{-# 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)

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

makeAcidic' :: SerialiserSpec -> [Name] -> Name -> [TyVarBndrUnit] -> [Con] -> Q [Dec]
makeAcidic' :: SerialiserSpec -> [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]
makeAcidic' SerialiserSpec
ss [Name]
eventNames Name
stateName [TyVarBndr]
tyvars [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 SerialiserSpec
ss 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 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
_ -> [Char] -> Q Type
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q Type) -> [Char] -> Q Type
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.Acid.TemplateHaskell: Events must be functions: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
eventName

--instance (SafeCopy key, Typeable key, SafeCopy val, Typeable val) => IsAcidic State where
--  acidEvents = [ UpdateEvent (\(MyUpdateEvent arg1 arg2 -> myUpdateEvent arg1 arg2) ]
makeIsAcidic :: SerialiserSpec -> [Name] -> Name -> [TyVarBndr] -> p -> DecQ
makeIsAcidic SerialiserSpec
ss [Name]
eventNames Name
stateName [TyVarBndr]
tyvars 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
          -> [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       = [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 [(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]
tyvarbndrs Cxt
cxt 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
#if MIN_VERSION_template_haskell(2,17,0)
            renameTyVar :: TyVarBndr a -> TyVarBndr a
            renameTyVar (PlainTV name ann)    = PlainTV  (renameName pred table name) ann
            renameTyVar (KindedTV name k ann) = KindedTV (renameName pred table name) k ann
#else
            renameTyVar :: TyVarBndr -> TyVarBndr
            renameTyVar :: TyVarBndr -> TyVarBndr
renameTyVar (PlainTV Name
name)    = Name -> TyVarBndr
PlainTV  (Type -> [(Name, Name)] -> Name -> Name
renameName Type
pred [(Name, Name)]
table Name
name)
            renameTyVar (KindedTV Name
name Type
k) = Name -> Type -> TyVarBndr
KindedTV (Type -> [(Name, Name)] -> Name -> Name
renameName Type
pred [(Name, Name)]
table Name
name) Type
k
#endif
      rename Type
pred [(Name, Name)]
table (VarT Name
n)   = Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Type -> [(Name, Name)] -> Name -> Name
renameName Type
pred [(Name, Name)]
table Name
n
      rename Type
pred [(Name, Name)]
table (AppT Type
a Type
b) = Type -> Type -> Type
AppT (Type -> [(Name, Name)] -> Type -> Type
rename Type
pred [(Name, Name)]
table Type
a) (Type -> [(Name, Name)] -> Type -> Type
rename Type
pred [(Name, Name)]
table Type
b)
      rename Type
pred [(Name, Name)]
table (SigT Type
a Type
k) = Type -> Type -> Type
SigT (Type -> [(Name, Name)] -> Type -> Type
rename Type
pred [(Name, Name)]
table Type
a) Type
k
      rename Type
_    [(Name, Name)]
_     Type
typ        = Type
typ

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

-- | See the end of comment for 'eventCxts'.
renameState :: Type -> Type -> Cxt -> Cxt
renameState :: Type -> Type -> Cxt -> Cxt
renameState Type
tfrom Type
tto Cxt
cxt = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
renamePred Cxt
cxt
  where
#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 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tfrom = Type
tto
    renameType (AppT Type
a Type
b)     = Type -> Type -> Type
AppT (Type -> Type
renameType Type
a) (Type -> Type
renameType Type
b)
    renameType (SigT Type
a Type
k)     = Type -> Type -> Type
SigT (Type -> Type
renameType Type
a) Type
k
    renameType Type
typ            = Type
typ

-- UpdateEvent (\(MyUpdateEvent arg1 arg2) -> myUpdateEvent arg1 arg2) safeCopyMethodSerialiser
makeEventHandler :: SerialiserSpec -> Name -> Type -> ExpQ
makeEventHandler :: SerialiserSpec -> Name -> Type -> ExpQ
makeEventHandler SerialiserSpec
ss Name
eventName Type
eventType
    = do Q ()
assertTyVarsOk
         [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 [Char]
"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 ()
                [Name]
ns -> [Char] -> Q ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q ()) -> [Char] -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.Acid.TemplateHaskell: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
unlines
                      [Doc -> [Char]
forall a. Show a => a -> [Char]
show (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ Name -> Type -> Doc
ppr_sig Name
eventName Type
eventType
                      , [Char]
""
                      , [Char]
"can not be used as an UpdateEvent because it contains the type variables: "
                      , [Char]
""
                      , [Name] -> [Char]
forall a. Ppr a => a -> [Char]
pprint [Name]
ns
                      , [Char]
""
                      , [Char]
"which do not appear in the state type:"
                      , [Char]
""
                      , Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
stateType
                      ]

--data MyUpdateEvent = MyUpdateEvent Arg1 Arg2
--  deriving (Typeable)
makeEventDataType :: Name -> Type -> DecQ
makeEventDataType :: Name -> Type -> DecQ
makeEventDataType Name
eventName 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)
          [Type
_] -> 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
          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 Name
eventName Type
eventType
    = do let preds :: [Name]
preds = [ ''SafeCopy ]
             ty :: Type
ty = Type -> Type -> Type
AppT (Name -> Type
ConT ''SafeCopy) ((Type -> Type -> Type) -> Type -> Cxt -> Type
forall (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 (\ExpQ
a 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 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 [Char]
"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 [Name]
preds [TyVarBndr]
tyvars 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 Name
eventName Type
eventType = do
    let preds :: [Name]
preds =
            [ ''Typeable ]
        ty :: Type
ty =
            Type -> Type -> Type
AppT (Name -> Type
ConT ''Method) ((Type -> Type -> Type) -> Type -> Cxt -> Type
forall (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 Name
eventName Type
eventType
    = do let preds :: [Name]
preds = [ ''Typeable ]
             eventClass :: Name
eventClass = if Bool
isUpdate then ''UpdateEvent else ''QueryEvent
             ty :: Type
ty = Type -> Type -> Type
AppT (Name -> Type
ConT Name
eventClass) ((Type -> Type -> Type) -> Type -> Cxt -> Type
forall (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 :: [TyVarBndrUnit]
    , TypeAnalysis -> Cxt
context :: Cxt
    , TypeAnalysis -> Cxt
argumentTypes :: [Type]
    , TypeAnalysis -> Type
stateType :: Type
    , TypeAnalysis -> Type
resultType :: Type
    , TypeAnalysis -> Bool
isUpdate :: Bool
    } deriving (TypeAnalysis -> TypeAnalysis -> Bool
(TypeAnalysis -> TypeAnalysis -> Bool)
-> (TypeAnalysis -> TypeAnalysis -> Bool) -> Eq TypeAnalysis
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: 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 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
       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 Name
m = do
       constraint :: Type
constraint@(AppT (AppT (ConT Name
c) Type
x) 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 [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 Cxt -> Cxt -> Cxt
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 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 [TyVarBndr]
tyvars Cxt
cxt Cxt
args (ForallT [TyVarBndr]
tyvars2 Cxt
cxt2 Type
a)
#if MIN_VERSION_template_haskell(2,17,0)
        = go (tyvars ++ fmap void tyvars2) (cxt ++ cxt2) args a
#else
        = [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
#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] -> 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
                }

        | [(Type
cx, 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 [TyVarBndr]
_ Cxt
_ Cxt
_ Type
_ = [Char] -> TypeAnalysis
forall a. HasCallStack => [Char] -> a
error ([Char] -> TypeAnalysis) -> [Char] -> TypeAnalysis
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.Acid.TemplateHaskell: Event has an invalid type signature: Not an Update, Query, MonadState, or MonadReader: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
eventName

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

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

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

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

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