module Hails.MVC.Model.THAccessors where
import Data.Char
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Lib
protectedModelAccessors :: String -> String -> Q [Dec]
protectedModelAccessors :: String -> String -> Q [Dec]
protectedModelAccessors String
fname String
ftype = [Q Dec] -> Q [Dec]
forall a. [Q a] -> Q [a]
sequenceQ
[ Name -> TypeQ -> Q Dec
sigD Name
setterName TypeQ
setterType
, Name -> [ClauseQ] -> Q Dec
funD Name
setterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP (String -> Name
mkName String
"pm"), Name -> PatQ
varP (String -> Name
mkName String
"n")]
(ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"applyToReactiveModel"))
(Name -> ExpQ
varE (String -> Name
mkName String
"pm"))
)
(Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE Maybe ExpQ
forall a. Maybe a
Nothing
(Name -> ExpQ
varE (String -> Name
mkName (String
"RM.set" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname)))
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
"n")))
)
)
)
[]
]
, Name -> TypeQ -> Q Dec
sigD Name
getterName TypeQ
getterType
, Name -> [ClauseQ] -> Q Dec
funD Name
getterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(ExpQ -> BodyQ
normalB (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE Maybe ExpQ
forall a. Maybe a
Nothing
(Name -> ExpQ
varE (String -> Name
mkName String
"onReactiveModel"))
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName (String
"RM.get" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname))))
)
)
[]
]
]
where setterName :: Name
setterName = String -> Name
mkName (String
"set" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname)
getterName :: Name
getterName = String -> Name
mkName (String
"get" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname)
setterType :: TypeQ
setterType = TypeQ -> TypeQ -> TypeQ
appT TypeQ
pmTo TypeQ
typeToIO
getterType :: TypeQ
getterType = TypeQ -> TypeQ -> TypeQ
appT TypeQ
pmTo TypeQ
ioType
pmTo :: TypeQ
pmTo = TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT (Name -> TypeQ
conT (String -> Name
mkName String
"ProtectedModel"))
typeToIO :: TypeQ
typeToIO = TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT (Name -> TypeQ
conT (String -> Name
mkName String
ftype))) TypeQ
ioNil
ioNil :: TypeQ
ioNil = TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (String -> Name
mkName String
"IO")) (Name -> TypeQ
conT (String -> Name
mkName String
"()"))
ioType :: TypeQ
ioType = TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (String -> Name
mkName String
"IO")) (Name -> TypeQ
conT (String -> Name
mkName String
ftype))
reactiveModelAccessors :: String -> String -> Q [Dec]
reactiveModelAccessors :: String -> String -> Q [Dec]
reactiveModelAccessors String
fname String
ftype = [Q Dec] -> Q [Dec]
forall a. [Q a] -> Q [a]
sequenceQ
[ Name -> TypeQ -> Q Dec
sigD Name
setterName TypeQ
setterType
, Name -> [ClauseQ] -> Q Dec
funD Name
setterName
[[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
[Name -> PatQ
varP (String -> Name
mkName String
"rm"), Name -> PatQ
varP (String -> Name
mkName String
"n")]
(ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"triggerEvent"))
(Name -> ExpQ
varE (String -> Name
mkName String
"rm'"))
)
(Name -> ExpQ
varE (String -> Name
mkName String
"ev"))
)
)
[PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP (String -> Name
mkName String
"rm'"))
(ExpQ -> BodyQ
normalB (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
"rm")))
(Name -> ExpQ
varE (String -> Name
mkName String
"onBasicModel"))
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ([PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP (String -> Name
mkName String
"b")]
(ExpQ -> [Q (Name, Exp)] -> ExpQ
recUpdE (Name -> ExpQ
varE (String -> Name
mkName String
"b"))
[Name -> ExpQ -> Q (Name, Exp)
fieldExp
(String -> Name
mkName String
fnamelc)
(Name -> ExpQ
varE (String -> Name
mkName String
"n"))
]
)
)
)
)
)
[]
, PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP (String -> Name
mkName String
"ev"))
(ExpQ -> BodyQ
normalB (Name -> ExpQ
conE (String -> Name
mkName (String
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Changed"))))
[]
]
]
, Name -> TypeQ -> Q Dec
sigD Name
getterName TypeQ
getterType
, Name -> [ClauseQ] -> Q Dec
funD Name
getterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(ExpQ -> BodyQ
normalB (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
fnamelc)))
(Name -> ExpQ
varE (String -> Name
mkName String
"."))
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
"basicModel")))
)
)
[]
]
]
where setterName :: Name
setterName = String -> Name
mkName (String
"set" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname)
getterName :: Name
getterName = String -> Name
mkName (String
"get" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname)
setterType :: TypeQ
setterType = TypeQ -> TypeQ -> TypeQ
appT TypeQ
rmTo TypeQ
typeToRM
getterType :: TypeQ
getterType = TypeQ -> TypeQ -> TypeQ
appT TypeQ
rmTo (Name -> TypeQ
conT (String -> Name
mkName String
ftype))
rmTo :: TypeQ
rmTo = TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT (Name -> TypeQ
conT (String -> Name
mkName String
"ReactiveModel"))
typeToRM :: TypeQ
typeToRM = TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT (Name -> TypeQ
conT (String -> Name
mkName String
ftype))) (Name -> TypeQ
conT (String -> Name
mkName String
"ReactiveModel"))
fnamelc :: String
fnamelc = String -> String
lcFst String
fname
nonReactiveModelAccessors :: String -> Q Type -> Q [Dec]
nonReactiveModelAccessors :: String -> TypeQ -> Q [Dec]
nonReactiveModelAccessors String
fname TypeQ
ftype = [Q Dec] -> Q [Dec]
forall a. [Q a] -> Q [a]
sequenceQ
[ Name -> TypeQ -> Q Dec
sigD Name
setterName TypeQ
setterType
, Name -> [ClauseQ] -> Q Dec
funD Name
setterName
[[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
[Name -> PatQ
varP (String -> Name
mkName String
"rm"), Name -> PatQ
varP (String -> Name
mkName String
"n")]
(ExpQ -> BodyQ
normalB (Name -> ExpQ
varE (String -> Name
mkName String
"rm'")))
[PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP (String -> Name
mkName String
"rm'"))
(ExpQ -> BodyQ
normalB (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
"rm")))
(Name -> ExpQ
varE (String -> Name
mkName String
"onBasicModel"))
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ([PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP (String -> Name
mkName String
"b")]
(ExpQ -> [Q (Name, Exp)] -> ExpQ
recUpdE (Name -> ExpQ
varE (String -> Name
mkName String
"b"))
[Name -> ExpQ -> Q (Name, Exp)
fieldExp
(String -> Name
mkName String
fnamelc)
(Name -> ExpQ
varE (String -> Name
mkName String
"n"))
]
)
)
)
)
)
[]
]
]
, Name -> TypeQ -> Q Dec
sigD Name
getterName TypeQ
getterType
, Name -> [ClauseQ] -> Q Dec
funD Name
getterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(ExpQ -> BodyQ
normalB (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
fnamelc)))
(Name -> ExpQ
varE (String -> Name
mkName String
"."))
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
"basicModel")))
)
)
[]
]
]
where setterName :: Name
setterName = String -> Name
mkName (String
"set" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname)
getterName :: Name
getterName = String -> Name
mkName (String
"get" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname)
setterType :: TypeQ
setterType = TypeQ -> TypeQ -> TypeQ
appT TypeQ
rmTo TypeQ
typeToRM
getterType :: TypeQ
getterType = TypeQ -> TypeQ -> TypeQ
appT TypeQ
rmTo TypeQ
ftype
rmTo :: TypeQ
rmTo = TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT (Name -> TypeQ
conT (String -> Name
mkName String
"ReactiveModel"))
typeToRM :: TypeQ
typeToRM = TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT TypeQ
ftype) (Name -> TypeQ
conT (String -> Name
mkName String
"ReactiveModel"))
fnamelc :: String
fnamelc = String -> String
lcFst String
fname
lcFst :: String -> String
lcFst :: String -> String
lcFst [] = []
lcFst (Char
x:String
xs) = (Char -> Char
toLower Char
x) Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs