    {-# 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
    import Data.Monoid ((<>))
    import Control.Applicative
    import Control.Monad
    import Control.Monad.State (MonadState)
    import Control.Monad.Reader (MonadReader)

    {-| 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 :: Name -> Name -> (Name -> Type -> DecQ) -> SerialiserSpec
    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 ss :: SerialiserSpec
    ss stateName :: Name
    stateName eventNames :: [Name]
    eventNames
        = do Info
    stateInfo <- Name -> Q Info
    reify Name
    stateName
             case Info
    stateInfo of
               TyConI tycon :: Dec
    tycon
                 ->case Dec
    tycon of
    #if MIN_VERSION_template_haskell(2,11,0)
                     DataD _cxt :: Cxt
    _cxt _name :: Name
    _name tyvars :: [TyVarBndr]
    tyvars _kind :: Maybe Type
    _kind constructors :: [Con]
    constructors _derivs :: [DerivClause]
    _derivs
    #else
                     DataD _cxt _name tyvars constructors _derivs
    #endif
                       -> SerialiserSpec -> [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]
    makeAcidic' SerialiserSpec
    ss [Name]
    eventNames Name
    stateName [TyVarBndr]
    tyvars [Con]
    constructors
    #if MIN_VERSION_template_haskell(2,11,0)
                     NewtypeD _cxt :: Cxt
    _cxt _name :: Name
    _name tyvars :: [TyVarBndr]
    tyvars _kind :: Maybe Type
    _kind constructor :: Con
    constructor _derivs :: [DerivClause]
    _derivs
    #else
                     NewtypeD _cxt _name tyvars constructor _derivs
    #endif
                       -> SerialiserSpec -> [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]
    makeAcidic' SerialiserSpec
    ss [Name]
    eventNames Name
    stateName [TyVarBndr]
    tyvars [Con
    constructor]
                     TySynD _name :: Name
    _name tyvars :: [TyVarBndr]
    tyvars _ty :: Type
    _ty
                       -> SerialiserSpec -> [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]
    makeAcidic' SerialiserSpec
    ss [Name]
    eventNames Name
    stateName [TyVarBndr]
    tyvars []
                     _ -> [Char] -> Q [Dec]
    forall a. HasCallStack => [Char] -> a
    error "Data.Acid.TemplateHaskell: Unsupported state type. Only 'data', 'newtype' and 'type' are supported."
               _ -> [Char] -> Q [Dec]
    forall a. HasCallStack => [Char] -> a
    error "Data.Acid.TemplateHaskell: Given state is not a type."

    makeAcidic' :: SerialiserSpec -> [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]
    makeAcidic' :: SerialiserSpec -> [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]
    makeAcidic' ss :: SerialiserSpec
    ss eventNames :: [Name]
    eventNames stateName :: Name
    stateName tyvars :: [TyVarBndr]
    tyvars constructors :: [Con]
    constructors
        = do [[Dec]]
    events <- [Q [Dec]] -> Q [[Dec]]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [ SerialiserSpec -> Name -> Q [Dec]
    makeEvent SerialiserSpec
    ss Name
    eventName | Name
    eventName <- [Name]
    eventNames ]
             Dec
    acidic <- SerialiserSpec -> [Name] -> Name -> [TyVarBndr] -> [Con] -> DecQ
    forall p.
    SerialiserSpec -> [Name] -> Name -> [TyVarBndr] -> p -> DecQ
    makeIsAcidic SerialiserSpec
    ss [Name]
    eventNames Name
    stateName [TyVarBndr]
    tyvars [Con]
    constructors
             [Dec] -> Q [Dec]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ Dec
    acidic Dec -> [Dec] -> [Dec]
    forall a. a -> [a] -> [a]
    : [[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Dec]]
    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 ss :: SerialiserSpec
    ss eventName :: Name
    eventName
        = do Bool
    exists <- Q Bool -> Q Bool -> Q Bool
    forall a. Q a -> Q a -> Q a
    recover (Bool -> Q Bool
    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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Bool -> Q Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True)
             Type
    eventType <- Name -> Q Type
    getEventType Name
    eventName
             if Bool
    exists
               then do Dec
    b <- SerialiserSpec -> Name -> Type -> DecQ
    makeEventSerialiser SerialiserSpec
    ss Name
    eventName Type
    eventType
                       [Dec] -> Q [Dec]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Dec
    b]
               else do Dec
    d <- Name -> Type -> DecQ
    makeEventDataType      Name
    eventName Type
    eventType
                       Dec
    b <- SerialiserSpec -> Name -> Type -> DecQ
    makeEventSerialiser SerialiserSpec
    ss Name
    eventName Type
    eventType
                       Dec
    i <- Name -> Type -> DecQ
    makeMethodInstance     Name
    eventName Type
    eventType
                       Dec
    e <- Name -> Type -> DecQ
    makeEventInstance      Name
    eventName Type
    eventType
                       [Dec] -> Q [Dec]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Dec
    d,Dec
    b,Dec
    i,Dec
    e]

    getEventType :: Name -> Q Type
    getEventType :: Name -> Q Type
    getEventType eventName :: Name
    eventName
        = do Info
    eventInfo <- Name -> Q Info
    reify Name
    eventName
             case Info
    eventInfo of
    #if MIN_VERSION_template_haskell(2,11,0)
               VarI _name :: Name
    _name eventType :: Type
    eventType _decl :: Maybe Dec
    _decl
    #else
               VarI _name eventType _decl _fixity
    #endif
                 -> Type -> Q Type
    expandSyns Type
    eventType
               _ -> [Char] -> Q Type
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> Q Type) -> [Char] -> Q Type
    forall a b. (a -> b) -> a -> b
    $ "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 -> [TyVarBndr] -> p -> DecQ
    makeIsAcidic ss :: SerialiserSpec
    ss eventNames :: [Name]
    eventNames stateName :: Name
    stateName tyvars :: [TyVarBndr]
    tyvars constructors :: p
    constructors
        = do Cxt
    types <- (Name -> Q Type) -> [Name] -> Q Cxt
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM Name -> Q Type
    getEventType [Name]
    eventNames
             Type
    stateType' <- Q Type
    stateType
             let preds :: [Name]
    preds = [ SerialiserSpec -> Name
    serialisationClassName SerialiserSpec
    ss, ''Typeable ]
                 ty :: Q Type
    ty = Q Type -> Q Type -> Q Type
    appT (Name -> Q Type
    conT ''IsAcidic) Q Type
    stateType
                 handlers :: [ExpQ]
    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
    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 -> [TyVarBndr] -> Name -> Type -> Cxt
    eventCxts Type
    stateType' [TyVarBndr]
    tyvars) [Name]
    eventNames Cxt
    types
             Cxt
    cxts' <- [Name] -> [TyVarBndr] -> Cxt -> Q Cxt
    mkCxtFromTyVars [Name]
    preds [TyVarBndr]
    tyvars Cxt
    cxtFromEvents
             Q Cxt -> Q Type -> [DecQ] -> DecQ
    instanceD (Cxt -> Q Cxt
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    cxts') Q Type
    ty
                       [ PatQ -> BodyQ -> [DecQ] -> DecQ
    valD (Name -> PatQ
    varP 'acidEvents) (ExpQ -> BodyQ
    normalB ([ExpQ] -> ExpQ
    listE [ExpQ]
    handlers)) []
                       ]
        where stateType :: Q Type
    stateType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Q Type -> Q Type -> Q Type
    appT (Name -> Q Type
    conT Name
    stateName) ((Name -> Q Type) -> [Name] -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Type
    varT ([TyVarBndr] -> [Name]
    allTyVarBndrNames [TyVarBndr]
    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
              -> [TyVarBndr] -- ^ 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 -> [TyVarBndr] -> Name -> Type -> Cxt
    eventCxts targetStateType :: Type
    targetStateType targetTyVars :: [TyVarBndr]
    targetTyVars eventName :: Name
    eventName eventType :: Type
    eventType =
        let TypeAnalysis { context :: TypeAnalysis -> Cxt
    context = Cxt
    cxt, Type
    stateType :: TypeAnalysis -> Type
    stateType :: 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 ((TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr -> Name
    tyVarBndrName [TyVarBndr]
    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
    #if MIN_VERSION_template_haskell(2,10,0)
          unify :: [(Name, Name)] -> Type -> Type
    unify table :: [(Name, Name)]
    table p :: Type
    p = Type -> [(Name, Name)] -> Type -> Type
    rename Type
    p [(Name, Name)]
    table Type
    p -- in 2.10.0: type Pred = Type
    #else
          unify table p@(ClassP n tys) = ClassP n (map (rename p table) tys)
          unify table p@(EqualP a b)   = EqualP (rename p table a) (rename p table b)
    #endif

          -- | rename the type variables in a Type
          rename :: Pred -> [(Name, Name)] -> Type -> Type
          rename :: Type -> [(Name, Name)] -> Type -> Type
    rename pred :: Type
    pred table :: [(Name, Name)]
    table t :: Type
    t@(ForallT tyvarbndrs :: [TyVarBndr]
    tyvarbndrs cxt :: Cxt
    cxt typ :: Type
    typ) = -- this is probably wrong? I don't think acid-state can really handle this type anyway..
              [TyVarBndr] -> Cxt -> Type -> Type
    ForallT ((TyVarBndr -> TyVarBndr) -> [TyVarBndr] -> [TyVarBndr]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr -> TyVarBndr
    renameTyVar [TyVarBndr]
    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
                renameTyVar :: TyVarBndr -> TyVarBndr
    renameTyVar (PlainTV name :: Name
    name)    = Name -> TyVarBndr
    PlainTV  (Type -> [(Name, Name)] -> Name -> Name
    renameName Type
    pred [(Name, Name)]
    table Name
    name)
                renameTyVar (KindedTV name :: Name
    name k :: Type
    k) = Name -> Type -> TyVarBndr
    KindedTV (Type -> [(Name, Name)] -> Name -> Name
    renameName Type
    pred [(Name, Name)]
    table Name
    name) Type
    k
          rename pred :: Type
    pred table :: [(Name, Name)]
    table (VarT n :: 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 pred :: Type
    pred table :: [(Name, Name)]
    table (AppT a :: Type
    a b :: 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 pred :: Type
    pred table :: [(Name, Name)]
    table (SigT a :: Type
    a k :: Type
    k) = Type -> Type -> Type
    SigT (Type -> [(Name, Name)] -> Type -> Type
    rename Type
    pred [(Name, Name)]
    table Type
    a) Type
    k
          rename _    _     typ :: Type
    typ        = Type
    typ

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

    -- | See the end of comment for 'eventCxts'.
    renameState :: Type -> Type -> Cxt -> Cxt
    renameState :: Type -> Type -> Cxt -> Cxt
    renameState tfrom :: Type
    tfrom tto :: Type
    tto cxt :: Cxt
    cxt = (Type -> Type) -> Cxt -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Type
    renamePred Cxt
    cxt
      where
    #if MIN_VERSION_template_haskell(2,10,0)
        renamePred :: Type -> Type
    renamePred p :: Type
    p = Type -> Type
    renameType Type
    p -- in 2.10.0: type Pred = Type
    #else
        renamePred (ClassP n tys) = ClassP n (map renameType tys)
        renamePred (EqualP a b)   = EqualP (renameType a) (renameType b)
    #endif
        renameType :: Type -> Type
    renameType n :: Type
    n | Type
    n Type -> Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Type
    tfrom = Type
    tto
        renameType (AppT a :: Type
    a b :: Type
    b)     = Type -> Type -> Type
    AppT (Type -> Type
    renameType Type
    a) (Type -> Type
    renameType Type
    b)
        renameType (SigT a :: Type
    a k :: Type
    k)     = Type -> Type -> Type
    SigT (Type -> Type
    renameType Type
    a) Type
    k
        renameType typ :: Type
    typ            = Type
    typ

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

    --data MyUpdateEvent = MyUpdateEvent Arg1 Arg2
    --  deriving (Typeable)
    makeEventDataType :: Name -> Type -> DecQ
    makeEventDataType :: Name -> Type -> DecQ
    makeEventDataType eventName :: Name
    eventName eventType :: Type
    eventType
        = do let con :: ConQ
    con = Name -> [BangTypeQ] -> ConQ
    normalC Name
    eventStructName [ Q Strict -> Q Type -> BangTypeQ
    strictType Q Strict
    notStrict (Type -> Q Type
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    arg) | Type
    arg <- Cxt
    args ]
    #if MIN_VERSION_template_haskell(2,12,0)
                 cxt :: [DerivClauseQ]
    cxt = [Maybe DerivStrategy -> [Q Type] -> DerivClauseQ
    derivClause Maybe DerivStrategy
    forall a. Maybe a
    Nothing [Name -> Q Type
    conT ''Typeable]]
    #elif MIN_VERSION_template_haskell(2,11,0)
                 cxt = mapM conT [''Typeable]
    #else
                 cxt = [''Typeable]
    #endif
             case Cxt
    args of
    #if MIN_VERSION_template_haskell(2,11,0)
              [_] -> Q Cxt
    -> Name
    -> [TyVarBndr]
    -> Maybe Type
    -> ConQ
    -> [DerivClauseQ]
    -> DecQ
    newtypeD (Cxt -> Q Cxt
    forall (m :: * -> *) a. Monad m => a -> m a
    return []) Name
    eventStructName [TyVarBndr]
    tyvars Maybe Type
    forall a. Maybe a
    Nothing ConQ
    con [DerivClauseQ]
    cxt
              _   -> Q Cxt
    -> Name
    -> [TyVarBndr]
    -> Maybe Type
    -> [ConQ]
    -> [DerivClauseQ]
    -> DecQ
    dataD (Cxt -> Q Cxt
    forall (m :: * -> *) a. Monad m => a -> m a
    return []) Name
    eventStructName [TyVarBndr]
    tyvars Maybe Type
    forall a. Maybe a
    Nothing [ConQ
    con] [DerivClauseQ]
    cxt
    #else
              [_] -> newtypeD (return []) eventStructName tyvars con cxt
              _   -> dataD (return []) eventStructName tyvars [con] cxt
    #endif
        where TypeAnalysis { [TyVarBndr]
    tyvars :: [TyVarBndr]
    tyvars :: TypeAnalysis -> [TyVarBndr]
    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 eventName :: Name
    eventName eventType :: 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 (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 ([TyVarBndr] -> [Name]
    allTyVarBndrNames [TyVarBndr]
    tyvars)))

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

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

             Q Cxt -> Q Type -> [DecQ] -> DecQ
    instanceD ([Name] -> [TyVarBndr] -> Cxt -> Q Cxt
    mkCxtFromTyVars [Name]
    preds [TyVarBndr]
    tyvars Cxt
    context)
                       (Type -> Q Type
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    ty)
                       [ Name -> [ClauseQ] -> DecQ
    funD 'putCopy [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
    clause [PatQ
    putClause] (ExpQ -> BodyQ
    normalB (ExpQ -> ExpQ
    contained ExpQ
    putExp)) []]
                       , PatQ -> BodyQ -> [DecQ] -> DecQ
    valD (Name -> PatQ
    varP 'getCopy) (ExpQ -> BodyQ
    normalB (ExpQ -> ExpQ
    contained ExpQ
    getArgs)) []
                       , Name -> [ClauseQ] -> DecQ
    funD 'errorTypeName [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
    clause [PatQ
    wildP] (ExpQ -> BodyQ
    normalB (Lit -> ExpQ
    litE ([Char] -> Lit
    stringL (Type -> [Char]
    forall a. Ppr a => a -> [Char]
    pprint Type
    ty)))) []]
                       ]
        where TypeAnalysis { [TyVarBndr]
    tyvars :: [TyVarBndr]
    tyvars :: TypeAnalysis -> [TyVarBndr]
    tyvars, Cxt
    context :: Cxt
    context :: TypeAnalysis -> 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] -> Cxt -> Q Cxt
    mkCxtFromTyVars preds :: [Name]
    preds tyvars :: [TyVarBndr]
    tyvars extraContext :: Cxt
    extraContext
        = [Q Type] -> Q Cxt
    cxt ([Q Type] -> Q Cxt) -> [Q Type] -> Q Cxt
    forall a b. (a -> b) -> a -> b
    $ [ Name -> [Q Type] -> Q Type
    classP Name
    classPred [Name -> Q Type
    varT Name
    tyvar] | Name
    tyvar <- [TyVarBndr] -> [Name]
    allTyVarBndrNames [TyVarBndr]
    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 (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 eventName :: Name
    eventName eventType :: 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 (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 ([TyVarBndr] -> [Name]
    allTyVarBndrNames [TyVarBndr]
    tyvars)))
            structType :: Q Type
    structType =
                (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Q Type -> Q Type -> Q Type
    appT (Name -> Q Type
    conT Name
    eventStructName) ((Name -> Q Type) -> [Name] -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Type
    varT ([TyVarBndr] -> [Name]
    allTyVarBndrNames [TyVarBndr]
    tyvars))
            instanceContext :: Q Cxt
    instanceContext  =
                [Q Type] -> Q Cxt
    cxt ([Q Type] -> Q Cxt) -> [Q Type] -> Q Cxt
    forall a b. (a -> b) -> a -> b
    $
                    [ Name -> [Q Type] -> Q Type
    classP Name
    classPred [Name -> Q Type
    varT Name
    tyvar]
                    | Name
    tyvar <- [TyVarBndr] -> [Name]
    allTyVarBndrNames [TyVarBndr]
    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 (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    context
        Q Cxt -> Q Type -> [DecQ] -> DecQ
    instanceD
            Q Cxt
    instanceContext
            (Type -> Q Type
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    ty)
    #if MIN_VERSION_template_haskell(2,15,0)
            [ TySynEqnQ -> DecQ
    tySynInstD (TySynEqnQ -> DecQ) -> TySynEqnQ -> DecQ
    forall a b. (a -> b) -> a -> b
    $ Maybe [TyVarBndr] -> Q Type -> Q Type -> TySynEqnQ
    tySynEqn Maybe [TyVarBndr]
    forall a. Maybe a
    Nothing (Name -> Q Type
    conT ''MethodResult Q Type -> Q Type -> Q Type
    `appT` Q Type
    structType) (Type -> Q Type
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    resultType)
            , TySynEqnQ -> DecQ
    tySynInstD (TySynEqnQ -> DecQ) -> TySynEqnQ -> DecQ
    forall a b. (a -> b) -> a -> b
    $ Maybe [TyVarBndr] -> Q Type -> Q Type -> TySynEqnQ
    tySynEqn Maybe [TyVarBndr]
    forall a. Maybe a
    Nothing (Name -> Q Type
    conT ''MethodState Q Type -> Q Type -> Q Type
    `appT` Q Type
    structType) (Type -> Q Type
    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 { [TyVarBndr]
    tyvars :: [TyVarBndr]
    tyvars :: TypeAnalysis -> [TyVarBndr]
    tyvars, Cxt
    context :: Cxt
    context :: TypeAnalysis -> Cxt
    context, Type
    stateType :: Type
    stateType :: TypeAnalysis -> Type
    stateType, Type
    resultType :: TypeAnalysis -> Type
    resultType :: 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 eventName :: Name
    eventName eventType :: 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 (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 ([TyVarBndr] -> [Name]
    allTyVarBndrNames [TyVarBndr]
    tyvars)))
             Q Cxt -> Q Type -> [DecQ] -> DecQ
    instanceD ([Q Type] -> Q Cxt
    cxt ([Q Type] -> Q Cxt) -> [Q Type] -> Q Cxt
    forall a b. (a -> b) -> a -> b
    $ [ Name -> [Q Type] -> Q Type
    classP Name
    classPred [Name -> Q Type
    varT Name
    tyvar] | Name
    tyvar <- [TyVarBndr] -> [Name]
    allTyVarBndrNames [TyVarBndr]
    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 (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    context)
                       (Type -> Q Type
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    ty)
                       []
        where TypeAnalysis { [TyVarBndr]
    tyvars :: [TyVarBndr]
    tyvars :: TypeAnalysis -> [TyVarBndr]
    tyvars, Cxt
    context :: Cxt
    context :: TypeAnalysis -> Cxt
    context, Bool
    isUpdate :: Bool
    isUpdate :: TypeAnalysis -> Bool
    isUpdate } = Name -> Type -> TypeAnalysis
    analyseType Name
    eventName Type
    eventType
              eventStructName :: Name
    eventStructName = Name -> Name
    toStructName Name
    eventName

    data TypeAnalysis = TypeAnalysis
        { TypeAnalysis -> [TyVarBndr]
    tyvars :: [TyVarBndr]
        , 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
    /= :: TypeAnalysis -> TypeAnalysis -> Bool
    $c/= :: TypeAnalysis -> TypeAnalysis -> Bool
    == :: TypeAnalysis -> TypeAnalysis -> Bool
    $c== :: 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
    showList :: [TypeAnalysis] -> [Char] -> [Char]
    $cshowList :: [TypeAnalysis] -> [Char] -> [Char]
    show :: TypeAnalysis -> [Char]
    $cshow :: TypeAnalysis -> [Char]
    showsPrec :: Int -> TypeAnalysis -> [Char] -> [Char]
    $cshowsPrec :: Int -> TypeAnalysis -> [Char] -> [Char]
    Show)

    analyseType :: Name -> Type -> TypeAnalysis
    analyseType :: Name -> Type -> TypeAnalysis
    analyseType eventName :: Name
    eventName t :: Type
    t = [TyVarBndr] -> Cxt -> Cxt -> Type -> TypeAnalysis
    go [] [] [] Type
    t
      where
    #if MIN_VERSION_template_haskell(2,10,0)
        getMonadReader :: Cxt -> Name -> [(Type, Type)]
        getMonadReader :: Cxt -> Name -> [(Type, Type)]
    getMonadReader cxt :: Cxt
    cxt m :: Name
    m = do
           constraint :: Type
    constraint@(AppT (AppT (ConT c :: Name
    c) x :: Type
    x) m' :: Type
    m') <- Cxt
    cxt
           Bool -> [()]
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Name
    c Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''MonadReader Bool -> Bool -> Bool
    && Type
    m' Type -> Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name -> Type
    VarT Name
    m)
           (Type, Type) -> [(Type, Type)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type
    constraint, Type
    x)

        getMonadState :: Cxt -> Name -> [(Type, Type)]
        getMonadState :: Cxt -> Name -> [(Type, Type)]
    getMonadState cxt :: Cxt
    cxt m :: Name
    m = do
           constraint :: Type
    constraint@(AppT (AppT (ConT c :: Name
    c) x :: Type
    x) m' :: Type
    m') <- Cxt
    cxt
           Bool -> [()]
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Name
    c Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''MonadState Bool -> Bool -> Bool
    && Type
    m' Type -> Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name -> Type
    VarT Name
    m)
           (Type, Type) -> [(Type, Type)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type
    constraint, Type
    x)
    #else
        getMonadReader :: Cxt -> Name -> [(Pred, Type)]
        getMonadReader cxt m = do
           constraint@(ClassP c [x, m']) <- cxt
           guard (c == ''MonadReader && m' == VarT m)
           return (constraint, x)

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

        -- a -> b
        go :: [TyVarBndr] -> Cxt -> Cxt -> Type -> TypeAnalysis
    go tyvars :: [TyVarBndr]
    tyvars cxt :: Cxt
    cxt args :: Cxt
    args (AppT (AppT ArrowT a :: Type
    a) b :: Type
    b)
            = [TyVarBndr] -> Cxt -> Cxt -> Type -> TypeAnalysis
    go [TyVarBndr]
    tyvars Cxt
    cxt (Cxt
    args Cxt -> Cxt -> Cxt
    forall a. [a] -> [a] -> [a]
    ++ [Type
    a]) Type
    b
        -- Update st res
        -- Query st res
        go tyvars :: [TyVarBndr]
    tyvars context :: Cxt
    context argumentTypes :: Cxt
    argumentTypes (AppT (AppT (ConT con :: Name
    con) stateType :: Type
    stateType) resultType :: Type
    resultType)
            | Name
    con Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Update =
                TypeAnalysis :: [TyVarBndr] -> Cxt -> Cxt -> Type -> Type -> Bool -> TypeAnalysis
    TypeAnalysis
                    { [TyVarBndr]
    tyvars :: [TyVarBndr]
    tyvars :: [TyVarBndr]
    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 :: [TyVarBndr] -> Cxt -> Cxt -> Type -> Type -> Bool -> TypeAnalysis
    TypeAnalysis
                    { [TyVarBndr]
    tyvars :: [TyVarBndr]
    tyvars :: [TyVarBndr]
    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 tyvars :: [TyVarBndr]
    tyvars cxt :: Cxt
    cxt args :: Cxt
    args (ForallT tyvars2 :: [TyVarBndr]
    tyvars2 cxt2 :: Cxt
    cxt2 a :: Type
    a)
            = [TyVarBndr] -> Cxt -> Cxt -> Type -> TypeAnalysis
    go ([TyVarBndr]
    tyvars [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
    forall a. [a] -> [a] -> [a]
    ++ [TyVarBndr]
    tyvars2) (Cxt
    cxt Cxt -> Cxt -> Cxt
    forall a. [a] -> [a] -> [a]
    ++ Cxt
    cxt2) Cxt
    args Type
    a
        -- (MonadState state m) => ... -> m result
        -- (MonadReader state m) => ... -> m result
        go tyvars' :: [TyVarBndr]
    tyvars' cxt :: Cxt
    cxt argumentTypes :: Cxt
    argumentTypes (AppT (VarT m :: Name
    m) resultType :: Type
    resultType)
            | [] <- [(Type, Type)]
    queries, [(cx :: Type
    cx, stateType :: Type
    stateType)] <- [(Type, Type)]
    updates
                = TypeAnalysis :: [TyVarBndr] -> Cxt -> Cxt -> Type -> Type -> Bool -> TypeAnalysis
    TypeAnalysis
                    { [TyVarBndr]
    tyvars :: [TyVarBndr]
    tyvars :: [TyVarBndr]
    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
                    }

            | [(cx :: Type
    cx, stateType :: Type
    stateType)] <- [(Type, Type)]
    queries, [] <- [(Type, Type)]
    updates
                = TypeAnalysis :: [TyVarBndr] -> Cxt -> Cxt -> Type -> Type -> Bool -> TypeAnalysis
    TypeAnalysis
                    { [TyVarBndr]
    tyvars :: [TyVarBndr]
    tyvars :: [TyVarBndr]
    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 :: [TyVarBndr]
    tyvars = (TyVarBndr -> Bool) -> [TyVarBndr] -> [TyVarBndr]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Name
    m) (Name -> Bool) -> (TyVarBndr -> Name) -> TyVarBndr -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TyVarBndr -> Name
    tyVarBndrName) [TyVarBndr]
    tyvars'
        -- otherwise, fail
        go _ _ _ _ = [Char] -> TypeAnalysis
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> TypeAnalysis) -> [Char] -> TypeAnalysis
    forall a b. (a -> b) -> a -> b
    $ "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 _ _ a :: Type
    a) = Type -> [Name]
    findTyVars Type
    a
    findTyVars (VarT n :: Name
    n)   = [Name
    n]
    findTyVars (AppT a :: Type
    a b :: Type
    b) = Type -> [Name]
    findTyVars Type
    a [Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++ Type -> [Name]
    findTyVars Type
    b
    findTyVars (SigT a :: Type
    a _) = Type -> [Name]
    findTyVars Type
    a
    findTyVars _          = []

    -- | extract the 'Name' from a 'TyVarBndr'
    tyVarBndrName :: TyVarBndr -> Name
    tyVarBndrName :: TyVarBndr -> Name
    tyVarBndrName (PlainTV n :: Name
    n)    = Name
    n
    tyVarBndrName (KindedTV n :: Name
    n _) = Name
    n

    allTyVarBndrNames :: [TyVarBndr] -> [Name]
    allTyVarBndrNames :: [TyVarBndr] -> [Name]
    allTyVarBndrNames tyvars :: [TyVarBndr]
    tyvars = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr -> Name
    tyVarBndrName [TyVarBndr]
    tyvars

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