{-# LANGUAGE TemplateHaskell, CPP, NamedFieldPuns #-}
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)
makeAcidic :: Name -> [Name] -> Q [Dec]
makeAcidic :: Name -> [Name] -> Q [Dec]
makeAcidic = SerialiserSpec -> Name -> [Name] -> Q [Dec]
makeAcidicWithSerialiser SerialiserSpec
safeCopySerialiserSpec
data SerialiserSpec =
SerialiserSpec
{ SerialiserSpec -> Name
serialisationClassName :: Name
, SerialiserSpec -> Name
methodSerialiserName :: Name
, SerialiserSpec -> Name -> Type -> DecQ
makeEventSerialiser :: Name -> Type -> DecQ
}
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
}
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
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
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))
eventCxts :: Type
-> [TyVarBndr]
-> Name
-> Type
-> [Pred]
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
eventTyVars :: [Name]
eventTyVars = Type -> [Name]
findTyVars Type
stateType
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)
(Type -> Type -> Cxt -> Cxt
renameState Type
stateType Type
targetStateType Cxt
cxt)
where
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
#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 :: 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) =
[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
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'
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
#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
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
]
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
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
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
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
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
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
}
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
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'
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
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 _ = []
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
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