{-# 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
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#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 Info
stateInfo <- Name -> Q Info
reify Name
stateName
         case Info
stateInfo of
           TyConI Dec
tycon
             ->case Dec
tycon of
#if MIN_VERSION_template_haskell(2,11,0)
                 DataD Cxt
_cxt Name
_name [TyVarBndr ()]
tyvars Maybe Type
_kind [Con]
constructors [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 Name
_name [TyVarBndr ()]
tyvars Maybe Type
_kind Con
constructor [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 [TyVarBndr ()]
tyvars Type
_ty
                   -> SerialiserSpec
-> [Name] -> Name -> [TyVarBndr ()] -> [Con] -> Q [Dec]
makeAcidic' SerialiserSpec
ss [Name]
eventNames Name
stateName [TyVarBndr ()]
tyvars []
                 Dec
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Data.Acid.TemplateHaskell: Unsupported state type. Only 'data', 'newtype' and 'type' are supported."
           Info
_ -> 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 -> [TyVarBndr ()] -> [Con] -> Q [Dec]
makeAcidic' SerialiserSpec
ss [Name]
eventNames Name
stateName [TyVarBndr ()]
tyvars [Con]
constructors
    = do [[Dec]]
events <- 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 <- forall {p}.
SerialiserSpec -> [Name] -> Name -> [TyVarBndr ()] -> p -> DecQ
makeIsAcidic SerialiserSpec
ss [Name]
eventNames Name
stateName [TyVarBndr ()]
tyvars [Con]
constructors
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Dec
acidic forall a. a -> [a] -> [a]
: 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 SerialiserSpec
ss Name
eventName
    = do Bool
exists <- forall a. Q a -> Q a -> Q a
recover (forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (Name -> Q Info
reify (Name -> Name
toStructName Name
eventName) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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
                   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
                   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 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 Type
eventType Maybe Dec
_decl
#else
           VarI _name eventType _decl _fixity
#endif
             -> Type -> Q Type
expandSyns Type
eventType
           Info
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Data.Acid.TemplateHaskell: Events must be functions: " forall a. [a] -> [a] -> [a]
++ 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 SerialiserSpec
ss [Name]
eventNames Name
stateName [TyVarBndr ()]
tyvars p
constructors
    = do Cxt
types <- 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 = forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''IsAcidic) Q Type
stateType
             handlers :: [ExpQ]
handlers = 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 = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ 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' <- forall {m :: * -> *} {a}.
Quote m =>
[Name] -> [TyVarBndr a] -> Cxt -> m Cxt
mkCxtFromTyVars [Name]
preds [TyVarBndr ()]
tyvars Cxt
cxtFromEvents
         forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
cxts') Q Type
ty
                   [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP 'acidEvents) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [ExpQ]
handlers)) []
                   ]
    where stateType :: Q Type
stateType = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
stateName) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Type
varT (forall a. [TyVarBndr a] -> [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
          -> [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 -> [TyVarBndr ()] -> Name -> Type -> Cxt
eventCxts Type
targetStateType [TyVarBndr ()]
targetTyVars Name
eventName 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       = forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
eventTyVars (forall a b. (a -> b) -> [a] -> [b]
map forall a. TyVarBndr a -> Name
tyVarBndrName [TyVarBndr ()]
targetTyVars)
    in 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 [(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
#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 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 (forall a b. (a -> b) -> [a] -> [b]
map forall a. TyVarBndr a -> TyVarBndr a
renameTyVar [TyVarBndr Specificity]
tyvarbndrs) (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)    = 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) = 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 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 forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Name)]
table of
            Maybe Name
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
"Data.Acid.TemplateHaskell: "
                                       , [Char]
""
                                       , forall a. Show a => a -> [Char]
show 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]
""
                                       , forall a. Ppr a => a -> [Char]
pprint Type
pred
                                       , [Char]
""
                                       , [Char]
"contains a type variable which is not found in the state 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 = 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 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 Type
n | Type
n 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
         [Name]
vars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
args) (forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"arg")
         let lamClause :: Q Pat
lamClause = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
eventStructName [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
var | Name
var <- [Name]
vars ]
         forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
constr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat
lamClause] (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
eventName) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
vars))
                     forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
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 = forall a b. (a -> b) -> [a] -> [b]
map forall a. TyVarBndr a -> Name
tyVarBndrName [TyVarBndr ()]
tyvars
          assertTyVarsOk :: Q ()
assertTyVarsOk =
              case [Name]
tyVarNames forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
stateTypeTyVars of
                [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                [Name]
ns -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Data.Acid.TemplateHaskell: " forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
unlines
                      [forall a. Show a => a -> [Char]
show 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]
""
                      , forall a. Ppr a => a -> [Char]
pprint [Name]
ns
                      , [Char]
""
                      , [Char]
"which do not appear in the state 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 Name
eventName Type
eventType
    = do let con :: Q Con
con = forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC Name
eventStructName [ forall (m :: * -> *). Quote m => m Strict -> m Type -> m BangType
strictType forall (m :: * -> *). Quote m => m Strict
notStrict (forall (m :: * -> *) a. Monad m => a -> m a
return Type
arg) | Type
arg <- Cxt
args ]
#if MIN_VERSION_template_haskell(2,12,0)
             cxt :: [Q DerivClause]
cxt = [forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
derivClause forall a. Maybe a
Nothing [forall (m :: * -> *). Quote m => Name -> m 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)
          [Type
_] -> forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> m Con
-> [m DerivClause]
-> m Dec
newtypeD (forall (m :: * -> *) a. Monad m => a -> m a
return []) Name
eventStructName [TyVarBndr ()]
tyvars forall a. Maybe a
Nothing Q Con
con [Q DerivClause]
cxt
          Cxt
_   -> forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD (forall (m :: * -> *) a. Monad m => a -> m a
return []) Name
eventStructName [TyVarBndr ()]
tyvars forall a. Maybe a
Nothing [Q Con
con] [Q DerivClause]
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 Name
eventName Type
eventType
    = do let preds :: [Name]
preds = [ ''SafeCopy ]
             ty :: Type
ty = Type -> Type -> Type
AppT (Name -> Type
ConT ''SafeCopy) (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
eventStructName) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT (forall a. [TyVarBndr a] -> [Name]
allTyVarBndrNames [TyVarBndr ()]
tyvars)))

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

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

         forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall {m :: * -> *} {a}.
Quote m =>
[Name] -> [TyVarBndr a] -> Cxt -> m Cxt
mkCxtFromTyVars [Name]
preds [TyVarBndr ()]
tyvars Cxt
context)
                   (forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
                   [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'putCopy [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat
putClause] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall {m :: * -> *}. Quote m => m Exp -> m Exp
contained ExpQ
putExp)) []]
                   , forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP 'getCopy) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall {m :: * -> *}. Quote m => m Exp -> m Exp
contained ExpQ
getArgs)) []
                   , forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'errorTypeName [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => m Pat
wildP] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (m :: * -> *). Quote m => Lit -> m Exp
litE ([Char] -> Lit
stringL (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 a] -> Cxt -> m Cxt
mkCxtFromTyVars [Name]
preds [TyVarBndr a]
tyvars Cxt
extraContext
    = forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => Name -> [m Type] -> m Type
classP Name
classPred [forall (m :: * -> *). Quote m => Name -> m Type
varT Name
tyvar] | Name
tyvar <- forall a. [TyVarBndr a] -> [Name]
allTyVarBndrNames [TyVarBndr a]
tyvars, Name
classPred <- [Name]
preds ] forall a. [a] -> [a] -> [a]
++
            forall a b. (a -> b) -> [a] -> [b]
map 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) (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
eventStructName) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT (forall a. [TyVarBndr a] -> [Name]
allTyVarBndrNames [TyVarBndr ()]
tyvars)))
        structType :: Q Type
structType =
            forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
eventStructName) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Type
varT (forall a. [TyVarBndr a] -> [Name]
allTyVarBndrNames [TyVarBndr ()]
tyvars))
        instanceContext :: Q Cxt
instanceContext  =
            forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt forall a b. (a -> b) -> a -> b
$
                [ forall (m :: * -> *). Quote m => Name -> [m Type] -> m Type
classP Name
classPred [forall (m :: * -> *). Quote m => Name -> m Type
varT Name
tyvar]
                | Name
tyvar <- forall a. [TyVarBndr a] -> [Name]
allTyVarBndrNames [TyVarBndr ()]
tyvars
                , Name
classPred <- [Name]
preds
                ]
                forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
context
    forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        Q Cxt
instanceContext
        (forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
#if MIN_VERSION_template_haskell(2,15,0)
        [ forall (m :: * -> *). Quote m => m TySynEqn -> m Dec
tySynInstD forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
Maybe [TyVarBndr ()] -> m Type -> m Type -> m TySynEqn
tySynEqn forall a. Maybe a
Nothing (forall (m :: * -> *). Quote m => Name -> m Type
conT ''MethodResult forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
structType) (forall (m :: * -> *) a. Monad m => a -> m a
return Type
resultType)
        , forall (m :: * -> *). Quote m => m TySynEqn -> m Dec
tySynInstD forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
Maybe [TyVarBndr ()] -> m Type -> m Type -> m TySynEqn
tySynEqn forall a. Maybe a
Nothing (forall (m :: * -> *). Quote m => Name -> m Type
conT ''MethodState forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
structType) (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 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) (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
eventStructName) (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT (forall a. [TyVarBndr a] -> [Name]
allTyVarBndrNames [TyVarBndr ()]
tyvars)))
         forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => Name -> [m Type] -> m Type
classP Name
classPred [forall (m :: * -> *). Quote m => Name -> m Type
varT Name
tyvar] | Name
tyvar <- forall a. [TyVarBndr a] -> [Name]
allTyVarBndrNames [TyVarBndr ()]
tyvars, Name
classPred <- [Name]
preds ] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
context)
                   (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 :: [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
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 -> ShowS
[TypeAnalysis] -> ShowS
TypeAnalysis -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TypeAnalysis] -> ShowS
$cshowList :: [TypeAnalysis] -> ShowS
show :: TypeAnalysis -> [Char]
$cshow :: TypeAnalysis -> [Char]
showsPrec :: Int -> TypeAnalysis -> ShowS
$cshowsPrec :: Int -> TypeAnalysis -> ShowS
Show)

analyseType :: Name -> Type -> TypeAnalysis
analyseType :: Name -> Type -> TypeAnalysis
analyseType Name
eventName 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 Name
m = do
       constraint :: Type
constraint@(AppT (AppT (ConT Name
c) Type
x) Type
m') <- Cxt
cxt
       forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Name
c forall a. Eq a => a -> a -> Bool
== ''MonadReader Bool -> Bool -> Bool
&& Type
m' forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
m)
       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 Name
m = do
       constraint :: Type
constraint@(AppT (AppT (ConT Name
c) Type
x) Type
m') <- Cxt
cxt
       forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Name
c forall a. Eq a => a -> a -> Bool
== ''MonadState Bool -> Bool -> Bool
&& Type
m' forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
m)
       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 [TyVarBndr ()]
tyvars Cxt
cxt Cxt
args (AppT (AppT Type
ArrowT Type
a) Type
b)
        = [TyVarBndr ()] -> Cxt -> Cxt -> Type -> TypeAnalysis
go [TyVarBndr ()]
tyvars Cxt
cxt (Cxt
args forall a. [a] -> [a] -> [a]
++ [Type
a]) Type
b
    -- Update st res
    -- Query st res
    go [TyVarBndr ()]
tyvars Cxt
context Cxt
argumentTypes (AppT (AppT (ConT Name
con) Type
stateType) Type
resultType)
        | Name
con forall a. Eq a => a -> a -> Bool
== ''Update =
            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 forall a. Eq a => a -> a -> Bool
== ''Query  =
            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 [TyVarBndr ()]
tyvars Cxt
cxt Cxt
args (ForallT [TyVarBndr Specificity]
tyvars2 Cxt
cxt2 Type
a)
#if MIN_VERSION_template_haskell(2,17,0)
        = [TyVarBndr ()] -> Cxt -> Cxt -> Type -> TypeAnalysis
go ([TyVarBndr ()]
tyvars forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Functor f => f a -> f ()
void [TyVarBndr Specificity]
tyvars2) (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 [TyVarBndr ()]
tyvars' Cxt
cxt Cxt
argumentTypes (AppT (VarT Name
m) Type
resultType)
        | [] <- [(Type, Type)]
queries, [(Type
cx, Type
stateType)] <- [(Type, Type)]
updates
            = 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 = forall a. Eq a => a -> [a] -> [a]
delete Type
cx Cxt
cxt
                }

        | [(Type
cx, Type
stateType)] <- [(Type, Type)]
queries, [] <- [(Type, Type)]
updates
            = 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 = 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 = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= Name
m) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TyVarBndr a -> Name
tyVarBndrName) [TyVarBndr ()]
tyvars'
    -- otherwise, fail
    go [TyVarBndr ()]
_ Cxt
_ Cxt
_ Type
_ = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Data.Acid.TemplateHaskell: Event has an invalid type signature: Not an Update, Query, MonadState, or MonadReader: " forall a. [a] -> [a] -> [a]
++ 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 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 = forall a b. (a -> b) -> [a] -> [b]
map 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 (ShowS
structName (Name -> [Char]
nameBase Name
eventName))
  where
    structName :: ShowS
structName [] = []
    structName (Char
x:[Char]
xs) = Char -> Char
toUpper Char
x forall a. a -> [a] -> [a]
: [Char]
xs