    {-# LANGUAGE TemplateHaskell, CPP, NamedFieldPuns #-}

    {- Holy crap this code is messy. -}
    module Data.Acid.TemplateHaskell where

    import Language.Haskell.TH
    import Language.Haskell.TH.Ppr
    import Language.Haskell.TH.ExpandSyns

    import Data.Acid.Core
    import Data.Acid.Common

    import Data.List ((\\), nub, delete)
    import Data.SafeCopy
    import Data.Typeable
    import Data.Char
    #if !MIN_VERSION_base(4,11,0)
    import Data.Monoid ((<>))
    #endif
    import Control.Monad
    import Control.Monad.State (MonadState)
    import Control.Monad.Reader (MonadReader)

    #if !MIN_VERSION_template_haskell(2,17,0)
    type TyVarBndrUnit = TyVarBndr
    #endif

    {-| Create the control structures required for acid states
        using Template Haskell.

    This code:

    @
    myUpdate :: Argument -> Update State Result
    myUpdate arg = ...

    myQuery :: Argument -> Query State Result
    myQuery arg = ...

    $(makeAcidic ''State ['myUpdate, 'myQuery])
    @

    will make @State@ an instance of 'IsAcidic' and provide the following
    events:

    @
    data MyUpdate = MyUpdate Argument
    data MyQuery  = MyQuery Argument
    @

    -}
    makeAcidic :: Name -> [Name] -> Q [Dec]
    makeAcidic :: Name -> [Name] -> Q [Dec]
    makeAcidic = SerialiserSpec -> Name -> [Name] -> Q [Dec]
    makeAcidicWithSerialiser SerialiserSpec
    safeCopySerialiserSpec

    -- | Specifies how to customise the 'IsAcidic' instance and event data
    -- type serialisation instances for a particular serialisation layer.
    data SerialiserSpec =
        SerialiserSpec
            { SerialiserSpec -> Name
    serialisationClassName :: Name
              -- ^ Class for serialisable types, e.g. @''Safecopy@.
            , SerialiserSpec -> Name
    methodSerialiserName :: Name
              -- ^ Name of the 'MethodSerialiser' to use in the list of
              -- events in the 'IsAcidic' instance.
            , SerialiserSpec -> Name -> Type -> DecQ
    makeEventSerialiser :: Name -> Type -> DecQ
              -- ^ Function to generate an instance of the class named by
              -- 'serialisationClassName', given the event name and its type.
            }

    -- | Default implementation of 'SerialiserSpec' that uses 'SafeCopy'
    -- for serialising events.
    safeCopySerialiserSpec :: SerialiserSpec
    safeCopySerialiserSpec :: SerialiserSpec
    safeCopySerialiserSpec =
        SerialiserSpec { serialisationClassName :: Name
    serialisationClassName = ''SafeCopy
                       , methodSerialiserName :: Name
    methodSerialiserName   = 'safeCopyMethodSerialiser
                       , makeEventSerialiser :: Name -> Type -> DecQ
    makeEventSerialiser    = Name -> Type -> DecQ
    makeSafeCopyInstance
                       }

    -- | A variant on 'makeAcidic' that makes it possible to explicitly choose the
    -- serialisation implementation to be used for methods.
    makeAcidicWithSerialiser :: SerialiserSpec -> Name -> [Name] -> Q [Dec]
    makeAcidicWithSerialiser :: SerialiserSpec -> Name -> [Name] -> Q [Dec]
    makeAcidicWithSerialiser SerialiserSpec
    ss Name
    stateName [Name]
    eventNames
        = do stateInfo <- Name -> Q Info
    reify Name
    stateName
             case stateInfo of
               TyConI Dec
    tycon
                 ->case Dec
    tycon of

                     DataD Cxt
    _cxt Name
    _name [TyVarBndr BndrVis]
    tyvars Maybe Type
    _kind [Con]
    constructors [DerivClause]
    _derivs
    #if MIN_VERSION_template_haskell(2,21,0)
                       -> SerialiserSpec
    -> [Name] -> Name -> [TyVarBndrUnit] -> [Con] -> Q [Dec]
    makeAcidic' SerialiserSpec
    ss [Name]
    eventNames Name
    stateName ((TyVarBndr BndrVis -> TyVarBndrUnit)
    -> [TyVarBndr BndrVis] -> [TyVarBndrUnit]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr BndrVis -> TyVarBndrUnit
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void [TyVarBndr BndrVis]
    tyvars) [Con]
    constructors
    #else
                       -> makeAcidic' ss eventNames stateName tyvars constructors
    #endif

                     NewtypeD Cxt
    _cxt Name
    _name [TyVarBndr BndrVis]
    tyvars Maybe Type
    _kind Con
    constructor [DerivClause]
    _derivs
    #if MIN_VERSION_template_haskell(2,21,0)
                       -> SerialiserSpec
    -> [Name] -> Name -> [TyVarBndrUnit] -> [Con] -> Q [Dec]
    makeAcidic' SerialiserSpec
    ss [Name]
    eventNames Name
    stateName ((TyVarBndr BndrVis -> TyVarBndrUnit)
    -> [TyVarBndr BndrVis] -> [TyVarBndrUnit]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr BndrVis -> TyVarBndrUnit
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void [TyVarBndr BndrVis]
    tyvars) [Con
    constructor]
    #else
                       -> makeAcidic' ss eventNames stateName tyvars [constructor]
    #endif

                     TySynD Name
    _name [TyVarBndr BndrVis]
    tyvars Type
    _ty
    #if MIN_VERSION_template_haskell(2,21,0)
                       -> SerialiserSpec
    -> [Name] -> Name -> [TyVarBndrUnit] -> [Con] -> Q [Dec]
    makeAcidic' SerialiserSpec
    ss [Name]
    eventNames Name
    stateName ((TyVarBndr BndrVis -> TyVarBndrUnit)
    -> [TyVarBndr BndrVis] -> [TyVarBndrUnit]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr BndrVis -> TyVarBndrUnit
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void [TyVarBndr BndrVis]
    tyvars) []
    #else
                       -> makeAcidic' ss eventNames stateName tyvars []
    #endif

                     Dec
    _ -> [Char] -> Q [Dec]
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Data.Acid.TemplateHaskell: Unsupported state type. Only 'data', 'newtype' and 'type' are supported."
               Info
    _ -> [Char] -> Q [Dec]
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Data.Acid.TemplateHaskell: Given state is not a type."

    makeAcidic' :: SerialiserSpec -> [Name] -> Name -> [TyVarBndrUnit] -> [Con] -> Q [Dec]
    makeAcidic' :: SerialiserSpec
    -> [Name] -> Name -> [TyVarBndrUnit] -> [Con] -> Q [Dec]
    makeAcidic' SerialiserSpec
    ss [Name]
    eventNames Name
    stateName [TyVarBndrUnit]
    tyvars [Con]
    constructors
        = do events <- [Q [Dec]] -> Q [[Dec]]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence [ SerialiserSpec -> Name -> Q [Dec]
    makeEvent SerialiserSpec
    ss Name
    eventName | Name
    eventName <- [Name]
    eventNames ]
             acidic <- makeIsAcidic ss eventNames stateName tyvars constructors
             return $ acidic : concat events

    -- | Given an event name (e.g. @'myUpdate@), produce a data type like
    --
    -- > data MyUpdate = MyUpdate Argument
    --
    -- along with the 'Method' class instance, 'Event' class instance and
    -- the instance of the appropriate serialisation class.
    --
    -- However, if the event data type already exists, this will generate
    -- the serialisation instance only.  This makes it possible to call
    -- 'makeAcidicWithSerialiser' multiple times on the same events but
    -- with different 'SerialiserSpec's, to support multiple serialisation
    -- backends.
    makeEvent :: SerialiserSpec -> Name -> Q [Dec]
    makeEvent :: SerialiserSpec -> Name -> Q [Dec]
    makeEvent SerialiserSpec
    ss Name
    eventName
        = do exists <- Q Bool -> Q Bool -> Q Bool
    forall a. Q a -> Q a -> Q a
    recover (Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False) (Name -> Q Info
    reify (Name -> Name
    toStructName Name
    eventName) Q Info -> Q Bool -> Q Bool
    forall a b. Q a -> Q b -> Q b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True)
             eventType <- getEventType eventName
             if exists
               then do b <- makeEventSerialiser ss eventName eventType
                       return [b]
               else do d <- makeEventDataType      eventName eventType
                       b <- makeEventSerialiser ss eventName eventType
                       i <- makeMethodInstance     eventName eventType
                       e <- makeEventInstance      eventName eventType
                       return [d,b,i,e]

    getEventType :: Name -> Q Type
    getEventType :: Name -> Q Type
    getEventType Name
    eventName
        = do eventInfo <- Name -> Q Info
    reify Name
    eventName
             case eventInfo of
               VarI Name
    _name Type
    eventType Maybe Dec
    _decl
                 -> Type -> Q Type
    expandSyns Type
    eventType
               Info
    _ -> [Char] -> Q Type
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> Q Type) -> [Char] -> Q Type
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Data.Acid.TemplateHaskell: Events must be functions: " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Name -> [Char]
    forall a. Show a => a -> [Char]
    show Name
    eventName

    --instance (SafeCopy key, Typeable key, SafeCopy val, Typeable val) => IsAcidic State where
    --  acidEvents = [ UpdateEvent (\(MyUpdateEvent arg1 arg2 -> myUpdateEvent arg1 arg2) ]
    makeIsAcidic :: SerialiserSpec -> [Name] -> Name -> [TyVarBndrUnit] -> p -> DecQ
    makeIsAcidic SerialiserSpec
    ss [Name]
    eventNames Name
    stateName [TyVarBndrUnit]
    tyvars p
    constructors
        = do types <- (Name -> Q Type) -> [Name] -> Q Cxt
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Name -> Q Type
    getEventType [Name]
    eventNames
             stateType' <- stateType
             let preds = [ SerialiserSpec -> Name
    serialisationClassName SerialiserSpec
    ss, ''Typeable ]
                 ty = Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    appT (Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT ''IsAcidic) Q Type
    stateType
                 handlers = (Name -> Type -> ExpQ) -> [Name] -> Cxt -> [ExpQ]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (SerialiserSpec -> Name -> Type -> ExpQ
    makeEventHandler SerialiserSpec
    ss) [Name]
    eventNames Cxt
    types
                 cxtFromEvents = Cxt -> Cxt
    forall a. Eq a => [a] -> [a]
    nub (Cxt -> Cxt) -> Cxt -> Cxt
    forall a b. (a -> b) -> a -> b
    $ [Cxt] -> Cxt
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([Cxt] -> Cxt) -> [Cxt] -> Cxt
    forall a b. (a -> b) -> a -> b
    $ (Name -> Type -> Cxt) -> [Name] -> Cxt -> [Cxt]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (Type -> [TyVarBndrUnit] -> Name -> Type -> Cxt
    eventCxts Type
    stateType' [TyVarBndrUnit]
    tyvars) [Name]
    eventNames Cxt
    types
             cxts' <- mkCxtFromTyVars preds tyvars cxtFromEvents
             instanceD (return cxts') ty
                       [ valD (varP 'acidEvents) (normalB (listE handlers)) []
                       ]
        where stateType :: Q Type
    stateType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    appT (Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT Name
    stateName) ((Name -> Q Type) -> [Name] -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    varT ([TyVarBndrUnit] -> [Name]
    forall a. [TyVarBndr a] -> [Name]
    allTyVarBndrNames [TyVarBndrUnit]
    tyvars))

    -- | This function analyses an event function and extracts any
    -- additional class contexts which need to be added to the IsAcidic
    -- instance.
    --
    -- For example, if we have:
    --
    -- > data State a = ...
    --
    -- > setState :: (Ord a) => a -> UpdateEvent (State a) ()
    --
    -- Then we need to generate an IsAcidic instance like:
    --
    -- > instance (SafeCopy a, Typeable a, Ord a) => IsAcidic (State a)
    --
    -- Note that we can only add constraints for type variables which
    -- appear in the State type. If we tried to do this:
    --
    -- > setState :: (Ord a, Ord b) => a -> b -> UpdateEvent (State a) ()
    --
    -- We will get an ambigious type variable when trying to create the
    -- 'IsAcidic' instance, because there is no way to figure out what
    -- type 'b' should be.
    --
    -- The tricky part of this code is that we need to unify the type
    -- variables.
    --
    -- Let's say the user writes their code using 'b' instead of 'a':
    --
    -- > setState :: (Ord b) => b -> UpdateEvent (State b) ()
    --
    -- In the 'IsAcidic' instance, we are still going to use 'a'. So we
    -- need to rename the variables in the context to match.
    --
    -- The contexts returned by this function will have the variables renamed.
    --
    -- Additionally, if the event uses MonadReader or MonadState it might look
    -- like this:
    --
    -- > setState :: (MonadState x m, IsFoo x) => m ()
    --
    -- In this case we have to rename 'x' to the actual state we're going to
    -- use. This is done by 'renameState'.
    eventCxts :: Type            -- ^ State type
              -> [TyVarBndrUnit] -- ^ type variables that will be used for the State type in the IsAcidic instance
              -> Name            -- ^ 'Name' of the event
              -> Type            -- ^ 'Type' of the event
              -> [Pred]          -- ^ extra context to add to 'IsAcidic' instance
    eventCxts :: Type -> [TyVarBndrUnit] -> Name -> Type -> Cxt
    eventCxts Type
    targetStateType [TyVarBndrUnit]
    targetTyVars Name
    eventName Type
    eventType =
        let TypeAnalysis { context :: TypeAnalysis -> Cxt
    context = Cxt
    cxt, Type
    stateType :: Type
    stateType :: TypeAnalysis -> Type
    stateType }
                        = Name -> Type -> TypeAnalysis
    analyseType Name
    eventName Type
    eventType
            -- find the type variable names that this event is using
            -- for the State type
            eventTyVars :: [Name]
    eventTyVars = Type -> [Name]
    findTyVars Type
    stateType
            -- create a lookup table
            table :: [(Name, Name)]
    table       = [Name] -> [Name] -> [(Name, Name)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Name]
    eventTyVars ((TyVarBndrUnit -> Name) -> [TyVarBndrUnit] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndrUnit -> Name
    forall a. TyVarBndr a -> Name
    tyVarBndrName [TyVarBndrUnit]
    targetTyVars)
        in (Type -> Type) -> Cxt -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map ([(Name, Name)] -> Type -> Type
    unify [(Name, Name)]
    table) -- rename the type variables
           (Type -> Type -> Cxt -> Cxt
    renameState Type
    stateType Type
    targetStateType Cxt
    cxt)
        where
          -- | rename the type variables in a Pred
          unify :: [(Name, Name)] -> Pred -> Pred
          unify :: [(Name, Name)] -> Type -> Type
    unify [(Name, Name)]
    table Type
    p = Type -> [(Name, Name)] -> Type -> Type
    rename Type
    p [(Name, Name)]
    table Type
    p -- in 2.10.0: type Pred = Type

          -- | rename the type variables in a Type
          rename :: Pred -> [(Name, Name)] -> Type -> Type
          rename :: Type -> [(Name, Name)] -> Type -> Type
    rename Type
    pred [(Name, Name)]
    table t :: Type
    t@(ForallT [TyVarBndr Specificity]
    tyvarbndrs Cxt
    cxt Type
    typ) = -- this is probably wrong? I don't think acid-state can really handle this type anyway..
              [TyVarBndr Specificity] -> Cxt -> Type -> Type
    ForallT ((TyVarBndr Specificity -> TyVarBndr Specificity)
    -> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr Specificity -> TyVarBndr Specificity
    forall a. TyVarBndr a -> TyVarBndr a
    renameTyVar [TyVarBndr Specificity]
    tyvarbndrs) ((Type -> Type) -> Cxt -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map ([(Name, Name)] -> Type -> Type
    unify [(Name, Name)]
    table) Cxt
    cxt) (Type -> [(Name, Name)] -> Type -> Type
    rename Type
    pred [(Name, Name)]
    table Type
    typ)
              where
    #if MIN_VERSION_template_haskell(2,17,0)
                renameTyVar :: TyVarBndr a -> TyVarBndr a
                renameTyVar :: forall a. TyVarBndr a -> TyVarBndr a
    renameTyVar (PlainTV Name
    name a
    ann)    = Name -> a -> TyVarBndr a
    forall flag. Name -> flag -> TyVarBndr flag
    PlainTV  (Type -> [(Name, Name)] -> Name -> Name
    renameName Type
    pred [(Name, Name)]
    table Name
    name) a
    ann
                renameTyVar (KindedTV Name
    name a
    k Type
    ann) = Name -> a -> Type -> TyVarBndr a
    forall flag. Name -> flag -> Type -> TyVarBndr flag
    KindedTV (Type -> [(Name, Name)] -> Name -> Name
    renameName Type
    pred [(Name, Name)]
    table Name
    name) a
    k Type
    ann
    #else
                renameTyVar :: TyVarBndr -> TyVarBndr
                renameTyVar (PlainTV name)    = PlainTV  (renameName pred table name)
                renameTyVar (KindedTV name k) = KindedTV (renameName pred table name) k
    #endif
          rename Type
    pred [(Name, Name)]
    table (VarT Name
    n)   = Name -> Type
    VarT (Name -> Type) -> Name -> Type
    forall a b. (a -> b) -> a -> b
    $ Type -> [(Name, Name)] -> Name -> Name
    renameName Type
    pred [(Name, Name)]
    table Name
    n
          rename Type
    pred [(Name, Name)]
    table (AppT Type
    a Type
    b) = Type -> Type -> Type
    AppT (Type -> [(Name, Name)] -> Type -> Type
    rename Type
    pred [(Name, Name)]
    table Type
    a) (Type -> [(Name, Name)] -> Type -> Type
    rename Type
    pred [(Name, Name)]
    table Type
    b)
          rename Type
    pred [(Name, Name)]
    table (SigT Type
    a Type
    k) = Type -> Type -> Type
    SigT (Type -> [(Name, Name)] -> Type -> Type
    rename Type
    pred [(Name, Name)]
    table Type
    a) Type
    k
          rename Type
    _    [(Name, Name)]
    _     Type
    typ        = Type
    typ

          -- | rename a 'Name'
          renameName :: Pred -> [(Name, Name)] -> Name -> Name
          renameName :: Type -> [(Name, Name)] -> Name -> Name
    renameName Type
    pred [(Name, Name)]
    table Name
    n =
              case Name -> [(Name, Name)] -> Maybe Name
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Name
    n [(Name, Name)]
    table of
                Maybe Name
    Nothing -> [Char] -> Name
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> Name) -> [Char] -> Name
    forall a b. (a -> b) -> a -> b
    $ [[Char]] -> [Char]
    unlines [ [Char]
    "Data.Acid.TemplateHaskell: "
                                           , [Char]
    ""
                                           , Doc -> [Char]
    forall a. Show a => a -> [Char]
    show (Doc -> [Char]) -> Doc -> [Char]
    forall a b. (a -> b) -> a -> b
    $ Name -> Type -> Doc
    ppr_sig Name
    eventName Type
    eventType
                                           , [Char]
    ""
                                           , [Char]
    "can not be used as an UpdateEvent because the class context: "
                                           , [Char]
    ""
                                           , Type -> [Char]
    forall a. Ppr a => a -> [Char]
    pprint Type
    pred
                                           , [Char]
    ""
                                           , [Char]
    "contains a type variable which is not found in the state type: "
                                           , [Char]
    ""
                                           , Type -> [Char]
    forall a. Ppr a => a -> [Char]
    pprint Type
    targetStateType
                                           , [Char]
    ""
                                           , [Char]
    "You may be able to fix this by providing a type signature that fixes these type variable(s)"
                                           ]
                (Just Name
    n') -> Name
    n'

    -- | See the end of comment for 'eventCxts'.
    renameState :: Type -> Type -> Cxt -> Cxt
    renameState :: Type -> Type -> Cxt -> Cxt
    renameState Type
    tfrom Type
    tto Cxt
    cxt = (Type -> Type) -> Cxt -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Type
    renamePred Cxt
    cxt
      where
        renamePred :: Type -> Type
    renamePred Type
    p = Type -> Type
    renameType Type
    p -- in 2.10.0: type Pred = Type
        renameType :: Type -> Type
    renameType Type
    n | Type
    n Type -> Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Type
    tfrom = Type
    tto
        renameType (AppT Type
    a Type
    b)     = Type -> Type -> Type
    AppT (Type -> Type
    renameType Type
    a) (Type -> Type
    renameType Type
    b)
        renameType (SigT Type
    a Type
    k)     = Type -> Type -> Type
    SigT (Type -> Type
    renameType Type
    a) Type
    k
        renameType Type
    typ            = Type
    typ

    -- UpdateEvent (\(MyUpdateEvent arg1 arg2) -> myUpdateEvent arg1 arg2) safeCopyMethodSerialiser
    makeEventHandler :: SerialiserSpec -> Name -> Type -> ExpQ
    makeEventHandler :: SerialiserSpec -> Name -> Type -> ExpQ
    makeEventHandler SerialiserSpec
    ss Name
    eventName Type
    eventType
        = do Q ()
    assertTyVarsOk
             vars <- Int -> Q Name -> Q [Name]
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
    replicateM (Cxt -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length Cxt
    args) ([Char] -> Q Name
    forall (m :: * -> *). Quote m => [Char] -> m Name
    newName [Char]
    "arg")
             let lamClause = Name -> [Q Pat] -> Q Pat
    forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
    conP Name
    eventStructName [Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    var | Name
    var <- [Name]
    vars ]
             conE constr `appE` lamE [lamClause] (foldl appE (varE eventName) (map varE vars))
                         `appE` varE (methodSerialiserName ss)
        where constr :: Name
    constr = if Bool
    isUpdate then 'UpdateEvent else 'QueryEvent
              TypeAnalysis { [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
    tyvars :: TypeAnalysis -> [TyVarBndrUnit]
    tyvars, argumentTypes :: TypeAnalysis -> Cxt
    argumentTypes = Cxt
    args, Type
    stateType :: TypeAnalysis -> Type
    stateType :: Type
    stateType, Bool
    isUpdate :: Bool
    isUpdate :: TypeAnalysis -> Bool
    isUpdate } = Name -> Type -> TypeAnalysis
    analyseType Name
    eventName Type
    eventType
              eventStructName :: Name
    eventStructName = Name -> Name
    toStructName Name
    eventName
              stateTypeTyVars :: [Name]
    stateTypeTyVars = Type -> [Name]
    findTyVars Type
    stateType
              tyVarNames :: [Name]
    tyVarNames = (TyVarBndrUnit -> Name) -> [TyVarBndrUnit] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndrUnit -> Name
    forall a. TyVarBndr a -> Name
    tyVarBndrName [TyVarBndrUnit]
    tyvars
              assertTyVarsOk :: Q ()
    assertTyVarsOk =
                  case [Name]
    tyVarNames [Name] -> [Name] -> [Name]
    forall a. Eq a => [a] -> [a] -> [a]
    \\ [Name]
    stateTypeTyVars of
                    [] -> () -> Q ()
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                    [Name]
    ns -> [Char] -> Q ()
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> Q ()) -> [Char] -> Q ()
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Data.Acid.TemplateHaskell: " [Char] -> [Char] -> [Char]
    forall a. Semigroup a => a -> a -> a
    <> [[Char]] -> [Char]
    unlines
                          [Doc -> [Char]
    forall a. Show a => a -> [Char]
    show (Doc -> [Char]) -> Doc -> [Char]
    forall a b. (a -> b) -> a -> b
    $ Name -> Type -> Doc
    ppr_sig Name
    eventName Type
    eventType
                          , [Char]
    ""
                          , [Char]
    "can not be used as an UpdateEvent because it contains the type variables: "
                          , [Char]
    ""
                          , [Name] -> [Char]
    forall a. Ppr a => a -> [Char]
    pprint [Name]
    ns
                          , [Char]
    ""
                          , [Char]
    "which do not appear in the state type:"
                          , [Char]
    ""
                          , Type -> [Char]
    forall a. Ppr a => a -> [Char]
    pprint Type
    stateType
                          ]

    -- data MyUpdateEvent = MyUpdateEvent Arg1 Arg2
    makeEventDataType :: Name -> Type -> DecQ
    makeEventDataType :: Name -> Type -> DecQ
    makeEventDataType Name
    eventName Type
    eventType
        = do let con :: Q Con
    con = Name -> [Q BangType] -> Q Con
    forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
    normalC Name
    eventStructName [ Q Strict -> Q Type -> Q BangType
    forall (m :: * -> *). Quote m => m Strict -> m Type -> m BangType
    strictType Q Strict
    forall (m :: * -> *). Quote m => m Strict
    notStrict (Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    arg) | Type
    arg <- Cxt
    args ]
                 cxt :: [a]
    cxt = []
             case Cxt
    args of
    #if MIN_VERSION_template_haskell(2,21,0)
              [Type
    _] -> Q Cxt
    -> Name
    -> [TyVarBndr BndrVis]
    -> Maybe Type
    -> Q Con
    -> [Q DerivClause]
    -> DecQ
    forall (m :: * -> *).
    Quote m =>
    m Cxt
    -> Name
    -> [TyVarBndr BndrVis]
    -> Maybe Type
    -> m Con
    -> [m DerivClause]
    -> m Dec
    newtypeD (Cxt -> Q Cxt
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []) Name
    eventStructName ((TyVarBndrUnit -> TyVarBndr BndrVis)
    -> [TyVarBndrUnit] -> [TyVarBndr BndrVis]
    forall a b. (a -> b) -> [a] -> [b]
    map (BndrVis
    BndrReq BndrVis -> TyVarBndrUnit -> TyVarBndr BndrVis
    forall a b. a -> TyVarBndr b -> TyVarBndr a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$) [TyVarBndrUnit]
    tyvars) Maybe Type
    forall a. Maybe a
    Nothing Q Con
    con [Q DerivClause]
    forall a. [a]
    cxt
              Cxt
    _   -> Q Cxt
    -> Name
    -> [TyVarBndr BndrVis]
    -> Maybe Type
    -> [Q Con]
    -> [Q DerivClause]
    -> DecQ
    forall (m :: * -> *).
    Quote m =>
    m Cxt
    -> Name
    -> [TyVarBndr BndrVis]
    -> Maybe Type
    -> [m Con]
    -> [m DerivClause]
    -> m Dec
    dataD (Cxt -> Q Cxt
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []) Name
    eventStructName ((TyVarBndrUnit -> TyVarBndr BndrVis)
    -> [TyVarBndrUnit] -> [TyVarBndr BndrVis]
    forall a b. (a -> b) -> [a] -> [b]
    map (BndrVis
    BndrReq BndrVis -> TyVarBndrUnit -> TyVarBndr BndrVis
    forall a b. a -> TyVarBndr b -> TyVarBndr a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$) [TyVarBndrUnit]
    tyvars) Maybe Type
    forall a. Maybe a
    Nothing [Q Con
    con] [Q DerivClause]
    forall a. [a]
    cxt
    #elif MIN_VERSION_template_haskell(2,11,0)
              [_] -> newtypeD (return []) eventStructName tyvars Nothing con cxt
              _   -> dataD (return []) eventStructName tyvars Nothing [con] cxt
    #else
              [_] -> newtypeD (return []) eventStructName tyvars con cxt
              _   -> dataD (return []) eventStructName tyvars [con] cxt
    #endif
        where TypeAnalysis { [TyVarBndrUnit]
    tyvars :: TypeAnalysis -> [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
    tyvars, argumentTypes :: TypeAnalysis -> Cxt
    argumentTypes = Cxt
    args } = Name -> Type -> TypeAnalysis
    analyseType Name
    eventName Type
    eventType
              eventStructName :: Name
    eventStructName = Name -> Name
    toStructName Name
    eventName

    -- instance (SafeCopy key, SafeCopy val) => SafeCopy (MyUpdateEvent key val) where
    --    put (MyUpdateEvent a b) = do put a; put b
    --    get = MyUpdateEvent <$> get <*> get
    makeSafeCopyInstance :: Name -> Type -> DecQ
    makeSafeCopyInstance :: Name -> Type -> DecQ
    makeSafeCopyInstance Name
    eventName Type
    eventType
        = do let preds :: [Name]
    preds = [ ''SafeCopy ]
                 ty :: Type
    ty = Type -> Type -> Type
    AppT (Name -> Type
    ConT ''SafeCopy) ((Type -> Type -> Type) -> Type -> Cxt -> Type
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    eventStructName) ((Name -> Type) -> [Name] -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT ([TyVarBndrUnit] -> [Name]
    forall a. [TyVarBndr a] -> [Name]
    allTyVarBndrNames [TyVarBndrUnit]
    tyvars)))

                 getBase :: ExpQ
    getBase = ExpQ -> ExpQ -> ExpQ
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE (Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'return) (Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    eventStructName)
                 getArgs :: ExpQ
    getArgs = (ExpQ -> Type -> ExpQ) -> ExpQ -> Cxt -> ExpQ
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl (\ExpQ
    a Type
    b -> Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
    forall (m :: * -> *).
    Quote m =>
    Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
    infixE (ExpQ -> Maybe ExpQ
    forall a. a -> Maybe a
    Just ExpQ
    a) (Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE '(<*>)) (ExpQ -> Maybe ExpQ
    forall a. a -> Maybe a
    Just (Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'safeGet))) ExpQ
    getBase Cxt
    args
                 contained :: m Exp -> m Exp
    contained m Exp
    val = Name -> m Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'contain m Exp -> m Exp -> m Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` m Exp
    val

             putVars <- Int -> Q Name -> Q [Name]
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
    replicateM (Cxt -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length Cxt
    args) ([Char] -> Q Name
    forall (m :: * -> *). Quote m => [Char] -> m Name
    newName [Char]
    "arg")
             let putClause = Name -> [Q Pat] -> Q Pat
    forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
    conP Name
    eventStructName [Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    var | Name
    var <- [Name]
    putVars ]
                 putExp    = [Q Stmt] -> ExpQ
    forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
    doE ([Q Stmt] -> ExpQ) -> [Q Stmt] -> ExpQ
    forall a b. (a -> b) -> a -> b
    $ [ ExpQ -> Q Stmt
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS (ExpQ -> Q Stmt) -> ExpQ -> Q Stmt
    forall a b. (a -> b) -> a -> b
    $ ExpQ -> ExpQ -> ExpQ
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE (Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'safePut) (Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    var) | Name
    var <- [Name]
    putVars ] [Q Stmt] -> [Q Stmt] -> [Q Stmt]
    forall a. [a] -> [a] -> [a]
    ++
                                   [ ExpQ -> Q Stmt
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS (ExpQ -> Q Stmt) -> ExpQ -> Q Stmt
    forall a b. (a -> b) -> a -> b
    $ ExpQ -> ExpQ -> ExpQ
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE (Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'return) ([ExpQ] -> ExpQ
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    tupE []) ]

             instanceD (mkCxtFromTyVars preds tyvars context)
                       (return ty)
                       [ funD 'putCopy [clause [putClause] (normalB (contained putExp)) []]
                       , valD (varP 'getCopy) (normalB (contained getArgs)) []
                       , funD 'errorTypeName [clause [wildP] (normalB (litE (stringL (pprint ty)))) []]
                       ]
        where TypeAnalysis { [TyVarBndrUnit]
    tyvars :: TypeAnalysis -> [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
    tyvars, Cxt
    context :: TypeAnalysis -> Cxt
    context :: Cxt
    context, argumentTypes :: TypeAnalysis -> Cxt
    argumentTypes = Cxt
    args } = Name -> Type -> TypeAnalysis
    analyseType Name
    eventName Type
    eventType
              eventStructName :: Name
    eventStructName = Name -> Name
    toStructName Name
    eventName

    mkCxtFromTyVars :: [Name] -> [TyVarBndr a] -> Cxt -> m Cxt
    mkCxtFromTyVars [Name]
    preds [TyVarBndr a]
    tyvars Cxt
    extraContext
        = [m Type] -> m Cxt
    forall (m :: * -> *). Quote m => [m Type] -> m Cxt
    cxt ([m Type] -> m Cxt) -> [m Type] -> m Cxt
    forall a b. (a -> b) -> a -> b
    $ [ Name -> [m Type] -> m Type
    forall (m :: * -> *). Quote m => Name -> [m Type] -> m Type
    classP Name
    classPred [Name -> m Type
    forall (m :: * -> *). Quote m => Name -> m Type
    varT Name
    tyvar] | Name
    tyvar <- [TyVarBndr a] -> [Name]
    forall a. [TyVarBndr a] -> [Name]
    allTyVarBndrNames [TyVarBndr a]
    tyvars, Name
    classPred <- [Name]
    preds ] [m Type] -> [m Type] -> [m Type]
    forall a. [a] -> [a] -> [a]
    ++
                (Type -> m Type) -> Cxt -> [m Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> m Type
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    extraContext

    {-
    instance (Typeable key, Typeable val) => Method (MyUpdateEvent key val) where
      type MethodResult (MyUpdateEvent key val) = Return
      type MethodState (MyUpdateEvent key val) = State key val
    -}
    makeMethodInstance :: Name -> Type -> DecQ
    makeMethodInstance :: Name -> Type -> DecQ
    makeMethodInstance Name
    eventName Type
    eventType = do
        let preds :: [Name]
    preds =
                [ ''Typeable ]
            ty :: Type
    ty =
                Type -> Type -> Type
    AppT (Name -> Type
    ConT ''Method) ((Type -> Type -> Type) -> Type -> Cxt -> Type
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    eventStructName) ((Name -> Type) -> [Name] -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT ([TyVarBndrUnit] -> [Name]
    forall a. [TyVarBndr a] -> [Name]
    allTyVarBndrNames [TyVarBndrUnit]
    tyvars)))
            structType :: Q Type
    structType =
                (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    appT (Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT Name
    eventStructName) ((Name -> Q Type) -> [Name] -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    varT ([TyVarBndrUnit] -> [Name]
    forall a. [TyVarBndr a] -> [Name]
    allTyVarBndrNames [TyVarBndrUnit]
    tyvars))
            instanceContext :: Q Cxt
    instanceContext  =
                [Q Type] -> Q Cxt
    forall (m :: * -> *). Quote m => [m Type] -> m Cxt
    cxt ([Q Type] -> Q Cxt) -> [Q Type] -> Q Cxt
    forall a b. (a -> b) -> a -> b
    $
                    [ Name -> [Q Type] -> Q Type
    forall (m :: * -> *). Quote m => Name -> [m Type] -> m Type
    classP Name
    classPred [Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    varT Name
    tyvar]
                    | Name
    tyvar <- [TyVarBndrUnit] -> [Name]
    forall a. [TyVarBndr a] -> [Name]
    allTyVarBndrNames [TyVarBndrUnit]
    tyvars
                    , Name
    classPred <- [Name]
    preds
                    ]
                    [Q Type] -> [Q Type] -> [Q Type]
    forall a. [a] -> [a] -> [a]
    ++ (Type -> Q Type) -> Cxt -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    context
        Q Cxt -> Q Type -> [DecQ] -> DecQ
    forall (m :: * -> *).
    Quote m =>
    m Cxt -> m Type -> [m Dec] -> m Dec
    instanceD
            Q Cxt
    instanceContext
            (Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    ty)
    #if MIN_VERSION_template_haskell(2,15,0)
            [ Q TySynEqn -> DecQ
    forall (m :: * -> *). Quote m => m TySynEqn -> m Dec
    tySynInstD (Q TySynEqn -> DecQ) -> Q TySynEqn -> DecQ
    forall a b. (a -> b) -> a -> b
    $ Maybe [TyVarBndrUnit] -> Q Type -> Q Type -> Q TySynEqn
    forall (m :: * -> *).
    Quote m =>
    Maybe [TyVarBndrUnit] -> m Type -> m Type -> m TySynEqn
    tySynEqn Maybe [TyVarBndrUnit]
    forall a. Maybe a
    Nothing (Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT ''MethodResult Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Q Type
    structType) (Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    resultType)
            , Q TySynEqn -> DecQ
    forall (m :: * -> *). Quote m => m TySynEqn -> m Dec
    tySynInstD (Q TySynEqn -> DecQ) -> Q TySynEqn -> DecQ
    forall a b. (a -> b) -> a -> b
    $ Maybe [TyVarBndrUnit] -> Q Type -> Q Type -> Q TySynEqn
    forall (m :: * -> *).
    Quote m =>
    Maybe [TyVarBndrUnit] -> m Type -> m Type -> m TySynEqn
    tySynEqn Maybe [TyVarBndrUnit]
    forall a. Maybe a
    Nothing (Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT ''MethodState Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Q Type
    structType) (Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    stateType)
    #elif __GLASGOW_HASKELL__ >= 707
            [ tySynInstD ''MethodResult (tySynEqn [structType] (return resultType))
            , tySynInstD ''MethodState  (tySynEqn [structType] (return stateType))
    #else
            [ tySynInstD ''MethodResult [structType] (return resultType)
            , tySynInstD ''MethodState  [structType] (return stateType)
    #endif
            ]
        where TypeAnalysis { [TyVarBndrUnit]
    tyvars :: TypeAnalysis -> [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
    tyvars, Cxt
    context :: TypeAnalysis -> Cxt
    context :: Cxt
    context, Type
    stateType :: TypeAnalysis -> Type
    stateType :: Type
    stateType, Type
    resultType :: Type
    resultType :: TypeAnalysis -> Type
    resultType } = Name -> Type -> TypeAnalysis
    analyseType Name
    eventName Type
    eventType
              eventStructName :: Name
    eventStructName = Name -> Name
    toStructName Name
    eventName

    --instance (Typeable key, Typeable val) => UpdateEvent (MyUpdateEvent key val)
    makeEventInstance :: Name -> Type -> DecQ
    makeEventInstance :: Name -> Type -> DecQ
    makeEventInstance Name
    eventName Type
    eventType
        = do let preds :: [Name]
    preds = [ ''Typeable ]
                 eventClass :: Name
    eventClass = if Bool
    isUpdate then ''UpdateEvent else ''QueryEvent
                 ty :: Type
    ty = Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    eventClass) ((Type -> Type -> Type) -> Type -> Cxt -> Type
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    eventStructName) ((Name -> Type) -> [Name] -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT ([TyVarBndrUnit] -> [Name]
    forall a. [TyVarBndr a] -> [Name]
    allTyVarBndrNames [TyVarBndrUnit]
    tyvars)))
             Q Cxt -> Q Type -> [DecQ] -> DecQ
    forall (m :: * -> *).
    Quote m =>
    m Cxt -> m Type -> [m Dec] -> m Dec
    instanceD ([Q Type] -> Q Cxt
    forall (m :: * -> *). Quote m => [m Type] -> m Cxt
    cxt ([Q Type] -> Q Cxt) -> [Q Type] -> Q Cxt
    forall a b. (a -> b) -> a -> b
    $ [ Name -> [Q Type] -> Q Type
    forall (m :: * -> *). Quote m => Name -> [m Type] -> m Type
    classP Name
    classPred [Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    varT Name
    tyvar] | Name
    tyvar <- [TyVarBndrUnit] -> [Name]
    forall a. [TyVarBndr a] -> [Name]
    allTyVarBndrNames [TyVarBndrUnit]
    tyvars, Name
    classPred <- [Name]
    preds ] [Q Type] -> [Q Type] -> [Q Type]
    forall a. [a] -> [a] -> [a]
    ++ (Type -> Q Type) -> Cxt -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    context)
                       (Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    ty)
                       []
        where TypeAnalysis { [TyVarBndrUnit]
    tyvars :: TypeAnalysis -> [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
    tyvars, Cxt
    context :: TypeAnalysis -> Cxt
    context :: Cxt
    context, Bool
    isUpdate :: TypeAnalysis -> Bool
    isUpdate :: Bool
    isUpdate } = Name -> Type -> TypeAnalysis
    analyseType Name
    eventName Type
    eventType
              eventStructName :: Name
    eventStructName = Name -> Name
    toStructName Name
    eventName

    data TypeAnalysis = TypeAnalysis
        { TypeAnalysis -> [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
        , TypeAnalysis -> Cxt
    context :: Cxt
        , TypeAnalysis -> Cxt
    argumentTypes :: [Type]
        , TypeAnalysis -> Type
    stateType :: Type
        , TypeAnalysis -> Type
    resultType :: Type
        , TypeAnalysis -> Bool
    isUpdate :: Bool
        } deriving (TypeAnalysis -> TypeAnalysis -> Bool
    (TypeAnalysis -> TypeAnalysis -> Bool)
    -> (TypeAnalysis -> TypeAnalysis -> Bool) -> Eq TypeAnalysis
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: TypeAnalysis -> TypeAnalysis -> Bool
    == :: TypeAnalysis -> TypeAnalysis -> Bool
    $c/= :: TypeAnalysis -> TypeAnalysis -> Bool
    /= :: TypeAnalysis -> TypeAnalysis -> Bool
    Eq, Int -> TypeAnalysis -> [Char] -> [Char]
    [TypeAnalysis] -> [Char] -> [Char]
    TypeAnalysis -> [Char]
    (Int -> TypeAnalysis -> [Char] -> [Char])
    -> (TypeAnalysis -> [Char])
    -> ([TypeAnalysis] -> [Char] -> [Char])
    -> Show TypeAnalysis
    forall a.
    (Int -> a -> [Char] -> [Char])
    -> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
    $cshowsPrec :: Int -> TypeAnalysis -> [Char] -> [Char]
    showsPrec :: Int -> TypeAnalysis -> [Char] -> [Char]
    $cshow :: TypeAnalysis -> [Char]
    show :: TypeAnalysis -> [Char]
    $cshowList :: [TypeAnalysis] -> [Char] -> [Char]
    showList :: [TypeAnalysis] -> [Char] -> [Char]
    Show)

    analyseType :: Name -> Type -> TypeAnalysis
    analyseType :: Name -> Type -> TypeAnalysis
    analyseType Name
    eventName Type
    t = [TyVarBndrUnit] -> Cxt -> Cxt -> Type -> TypeAnalysis
    go [] [] [] Type
    t
      where
        getMonadReader :: Cxt -> Name -> [(Type, Type)]
        getMonadReader :: Cxt -> Name -> [(Type, Type)]
    getMonadReader Cxt
    cxt Name
    m = do
           constraint@(AppT (AppT (ConT c) x) m') <- Cxt
    cxt
           guard (c == ''MonadReader && m' == VarT m)
           return (constraint, x)

        getMonadState :: Cxt -> Name -> [(Type, Type)]
        getMonadState :: Cxt -> Name -> [(Type, Type)]
    getMonadState Cxt
    cxt Name
    m = do
           constraint@(AppT (AppT (ConT c) x) m') <- Cxt
    cxt
           guard (c == ''MonadState && m' == VarT m)
           return (constraint, x)

        -- a -> b
        go :: [TyVarBndrUnit] -> Cxt -> Cxt -> Type -> TypeAnalysis
    go [TyVarBndrUnit]
    tyvars Cxt
    cxt Cxt
    args (AppT (AppT Type
    ArrowT Type
    a) Type
    b)
            = [TyVarBndrUnit] -> Cxt -> Cxt -> Type -> TypeAnalysis
    go [TyVarBndrUnit]
    tyvars Cxt
    cxt (Cxt
    args Cxt -> Cxt -> Cxt
    forall a. [a] -> [a] -> [a]
    ++ [Type
    a]) Type
    b
        -- Update st res
        -- Query st res
        go [TyVarBndrUnit]
    tyvars Cxt
    context Cxt
    argumentTypes (AppT (AppT (ConT Name
    con) Type
    stateType) Type
    resultType)
            | Name
    con Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Update =
                TypeAnalysis
                    { [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
    tyvars, Cxt
    context :: Cxt
    context :: Cxt
    context, Cxt
    argumentTypes :: Cxt
    argumentTypes :: Cxt
    argumentTypes, Type
    stateType :: Type
    stateType :: Type
    stateType, Type
    resultType :: Type
    resultType :: Type
    resultType
                    , isUpdate :: Bool
    isUpdate = Bool
    True
                    }
            | Name
    con Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Query  =
                TypeAnalysis
                    { [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
    tyvars, Cxt
    context :: Cxt
    context :: Cxt
    context, Cxt
    argumentTypes :: Cxt
    argumentTypes :: Cxt
    argumentTypes, Type
    stateType :: Type
    stateType :: Type
    stateType, Type
    resultType :: Type
    resultType :: Type
    resultType
                    , isUpdate :: Bool
    isUpdate = Bool
    False
                    }
        -- (...) => a
        go [TyVarBndrUnit]
    tyvars Cxt
    cxt Cxt
    args (ForallT [TyVarBndr Specificity]
    tyvars2 Cxt
    cxt2 Type
    a)
    #if MIN_VERSION_template_haskell(2,17,0)
            = [TyVarBndrUnit] -> Cxt -> Cxt -> Type -> TypeAnalysis
    go ([TyVarBndrUnit]
    tyvars [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
    forall a. [a] -> [a] -> [a]
    ++ (TyVarBndr Specificity -> TyVarBndrUnit)
    -> [TyVarBndr Specificity] -> [TyVarBndrUnit]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap TyVarBndr Specificity -> TyVarBndrUnit
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void [TyVarBndr Specificity]
    tyvars2) (Cxt
    cxt Cxt -> Cxt -> Cxt
    forall a. [a] -> [a] -> [a]
    ++ Cxt
    cxt2) Cxt
    args Type
    a
    #else
            = go (tyvars ++ tyvars2)           (cxt ++ cxt2) args a
    #endif
        -- (MonadState state m) => ... -> m result
        -- (MonadReader state m) => ... -> m result
        go [TyVarBndrUnit]
    tyvars' Cxt
    cxt Cxt
    argumentTypes (AppT (VarT Name
    m) Type
    resultType)
            | [] <- [(Type, Type)]
    queries, [(Type
    cx, Type
    stateType)] <- [(Type, Type)]
    updates
                = TypeAnalysis
                    { [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
    tyvars,  Cxt
    argumentTypes :: Cxt
    argumentTypes :: Cxt
    argumentTypes , Type
    stateType :: Type
    stateType :: Type
    stateType, Type
    resultType :: Type
    resultType :: Type
    resultType
                    , isUpdate :: Bool
    isUpdate = Bool
    True
                    , context :: Cxt
    context = Type -> Cxt -> Cxt
    forall a. Eq a => a -> [a] -> [a]
    delete Type
    cx Cxt
    cxt
                    }

            | [(Type
    cx, Type
    stateType)] <- [(Type, Type)]
    queries, [] <- [(Type, Type)]
    updates
                = TypeAnalysis
                    { [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
    tyvars :: [TyVarBndrUnit]
    tyvars,  Cxt
    argumentTypes :: Cxt
    argumentTypes :: Cxt
    argumentTypes , Type
    stateType :: Type
    stateType :: Type
    stateType, Type
    resultType :: Type
    resultType :: Type
    resultType
                    , isUpdate :: Bool
    isUpdate = Bool
    False
                    , context :: Cxt
    context = Type -> Cxt -> Cxt
    forall a. Eq a => a -> [a] -> [a]
    delete Type
    cx Cxt
    cxt
                    }
          where
            queries :: [(Type, Type)]
    queries = Cxt -> Name -> [(Type, Type)]
    getMonadReader Cxt
    cxt Name
    m
            updates :: [(Type, Type)]
    updates = Cxt -> Name -> [(Type, Type)]
    getMonadState Cxt
    cxt Name
    m
            tyvars :: [TyVarBndrUnit]
    tyvars = (TyVarBndrUnit -> Bool) -> [TyVarBndrUnit] -> [TyVarBndrUnit]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Name
    m) (Name -> Bool) -> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TyVarBndrUnit -> Name
    forall a. TyVarBndr a -> Name
    tyVarBndrName) [TyVarBndrUnit]
    tyvars'
        -- otherwise, fail
        go [TyVarBndrUnit]
    _ Cxt
    _ Cxt
    _ Type
    _ = [Char] -> TypeAnalysis
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> TypeAnalysis) -> [Char] -> TypeAnalysis
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Data.Acid.TemplateHaskell: Event has an invalid type signature: Not an Update, Query, MonadState, or MonadReader: " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Name -> [Char]
    forall a. Show a => a -> [Char]
    show Name
    eventName

    -- | find the type variables
    -- | e.g. State a b  ==> [a,b]
    findTyVars :: Type -> [Name]
    findTyVars :: Type -> [Name]
    findTyVars (ForallT [TyVarBndr Specificity]
    _ Cxt
    _ Type
    a) = Type -> [Name]
    findTyVars Type
    a
    findTyVars (VarT Name
    n)   = [Name
    n]
    findTyVars (AppT Type
    a Type
    b) = Type -> [Name]
    findTyVars Type
    a [Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++ Type -> [Name]
    findTyVars Type
    b
    findTyVars (SigT Type
    a Type
    _) = Type -> [Name]
    findTyVars Type
    a
    findTyVars Type
    _          = []

    -- | extract the 'Name' from a 'TyVarBndr'
    #if MIN_VERSION_template_haskell(2,17,0)
    tyVarBndrName :: TyVarBndr a -> Name
    tyVarBndrName :: forall a. TyVarBndr a -> Name
    tyVarBndrName (PlainTV Name
    n a
    _)    = Name
    n
    tyVarBndrName (KindedTV Name
    n a
    _ Type
    _) = Name
    n

    allTyVarBndrNames :: [TyVarBndr a] -> [Name]
    allTyVarBndrNames :: forall a. [TyVarBndr a] -> [Name]
    allTyVarBndrNames [TyVarBndr a]
    tyvars = (TyVarBndr a -> Name) -> [TyVarBndr a] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr a -> Name
    forall a. TyVarBndr a -> Name
    tyVarBndrName [TyVarBndr a]
    tyvars
    #else
    tyVarBndrName :: TyVarBndr -> Name
    tyVarBndrName (PlainTV n)    = n
    tyVarBndrName (KindedTV n _) = n

    allTyVarBndrNames :: [TyVarBndr] -> [Name]
    allTyVarBndrNames tyvars = map tyVarBndrName tyvars
    #endif

    -- | Convert the 'Name' of the event function into the name of the
    -- corresponding data constructor.
    toStructName :: Name -> Name
    toStructName :: Name -> Name
    toStructName Name
    eventName = [Char] -> Name
    mkName ([Char] -> [Char]
    structName (Name -> [Char]
    nameBase Name
    eventName))
      where
        structName :: [Char] -> [Char]
    structName [] = []
        structName (Char
    x:[Char]
    xs) = Char -> Char
    toUpper Char
    x Char -> [Char] -> [Char]
    forall a. a -> [a] -> [a]
    : [Char]
    xs