module Hails.MVC.Model.THFields where
import Data.Char
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Lib
protectedField :: String -> Q Type -> String -> String -> Q [Dec]
protectedField :: String -> Q Type -> String -> String -> Q [Dec]
protectedField String
fname Q Type
ftype String
pmodel String
event = [Q Dec] -> Q [Dec]
forall a. [Q a] -> Q [a]
sequenceQ
[ Name -> Q Type -> Q Dec
sigD Name
setterName Q Type
setterType
, Name -> [ClauseQ] -> Q Dec
funD Name
setterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"reSetter"))
(Name -> ExpQ
varE Name
fieldName)
)
)
[]
]
, Name -> Q Type -> Q Dec
sigD Name
getterName Q Type
getterType
, Name -> [ClauseQ] -> Q Dec
funD Name
getterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"reGetter"))
(Name -> ExpQ
varE Name
fieldName)
)
)
[]
]
, Name -> Q Type -> Q Dec
sigD Name
fieldName Q Type
fieldType
, Name -> [ClauseQ] -> Q Dec
funD Name
fieldName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(ExpQ -> BodyQ
normalB
(Name -> [Q (Name, Exp)] -> ExpQ
recConE (String -> Name
mkName String
"ReactiveElement")
[Name -> ExpQ -> Q (Name, Exp)
fieldExp
(String -> Name
mkName String
"reEvents")
([ExpQ] -> ExpQ
listE [Name -> ExpQ
conE (String -> Name
mkName
(String
"RM." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Changed"))
]
)
, Name -> ExpQ -> Q (Name, Exp)
fieldExp
(String -> Name
mkName String
"reSetter")
([PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP (String -> Name
mkName String
"pm")
, Name -> PatQ
varP (String -> Name
mkName String
"c")
]
(Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Name -> ExpQ
varE (String -> Name
mkName String
"pm")))
(Name -> ExpQ
varE (String -> Name
mkName String
"applyToReactiveModel"))
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE Maybe ExpQ
forall a. Maybe a
Nothing
(Name -> ExpQ
varE (String -> Name
mkName
(String
"RM." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"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
"c")))
)
)
)
)
, Name -> ExpQ -> Q (Name, Exp)
fieldExp (String -> Name
mkName String
"reGetter")
(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." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"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)
fieldName :: Name
fieldName = String -> Name
mkName (String
fnamelc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Field")
setterType :: Q Type
setterType = Q Type -> Q Type -> Q Type
appT Q Type
pmTo Q Type
typeToIO
getterType :: Q Type
getterType = Q Type -> Q Type -> Q Type
appT Q Type
pmTo Q Type
ioType
fieldType :: Q Type
fieldType = Q Type -> Q Type -> Q Type
appT
(Q Type -> Q Type -> Q Type
appT
(Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT (String -> Name
mkName String
"ReactiveElement"))
Q Type
ftype
)
(Name -> Q Type
conT (String -> Name
mkName String
pmodel))
)
(Name -> Q Type
conT (String -> Name
mkName String
event))
pmTo :: Q Type
pmTo = Q Type -> Q Type -> Q Type
appT Q Type
arrowT (Name -> Q Type
conT (String -> Name
mkName String
"ProtectedModel"))
typeToIO :: Q Type
typeToIO = Q Type -> Q Type -> Q Type
appT (Q Type -> Q Type -> Q Type
appT Q Type
arrowT Q Type
ftype) Q Type
ioNil
ioNil :: Q Type
ioNil = Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT (String -> Name
mkName String
"IO")) (Name -> Q Type
conT (String -> Name
mkName String
"()"))
ioType :: Q Type
ioType = Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT (String -> Name
mkName String
"IO")) Q Type
ftype
fnamelc :: String
fnamelc = String -> String
lcFst String
fname
reactiveField :: String -> Q Type -> Q [Dec]
reactiveField :: String -> Q Type -> Q [Dec]
reactiveField String
fname Q Type
ftype = [Q Dec] -> Q [Dec]
forall a. [Q a] -> Q [a]
sequenceQ
[ Name -> Q Type -> Q Dec
sigD Name
setterName Q Type
setterType
, Name -> [ClauseQ] -> Q Dec
funD Name
setterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"fieldSetter"))
(Name -> ExpQ
varE Name
fieldName)
)
)
[]
]
, Name -> Q Type -> Q Dec
sigD Name
getterName Q Type
getterType
, Name -> [ClauseQ] -> Q Dec
funD Name
getterName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"fieldGetter"))
(Name -> ExpQ
varE Name
fieldName)
)
)
[]
]
, Name -> Q Type -> Q Dec
sigD Name
fieldName Q Type
fieldType
, Name -> [ClauseQ] -> Q Dec
funD Name
fieldName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(ExpQ -> BodyQ
normalB
([ExpQ] -> ExpQ
tupE
[ Name -> ExpQ
varE (String -> Name
mkName String
fnamelc)
, Name -> ExpQ
varE (String -> Name
mkName String
"preTrue")
, [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP (String -> Name
mkName String
"v"), 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
"v"))
]
)
, Name -> ExpQ
conE (String -> Name
mkName (String
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Changed"))
]
)
)
[]
]
]
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)
fieldName :: Name
fieldName = String -> Name
mkName (String
fnamelc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Field")
setterType :: Q Type
setterType = Q Type -> Q Type -> Q Type
appT Q Type
rmTo Q Type
typeToRM
getterType :: Q Type
getterType = Q Type -> Q Type -> Q Type
appT Q Type
rmTo Q Type
ftype
fieldType :: Q Type
fieldType = Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT (String -> Name
mkName String
"Field")) Q Type
ftype
rmTo :: Q Type
rmTo = Q Type -> Q Type -> Q Type
appT Q Type
arrowT (Name -> Q Type
conT (String -> Name
mkName String
"ReactiveModel"))
typeToRM :: Q Type
typeToRM = Q Type -> Q Type -> Q Type
appT (Q Type -> Q Type -> Q Type
appT Q Type
arrowT Q Type
ftype)
(Name -> Q Type
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