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 fname ftype pmodel event = sequenceQ
[ sigD setterName setterType
, funD setterName [clause []
(normalB (appE (varE (mkName "reSetter"))
(varE fieldName)
)
)
[]
]
, sigD getterName getterType
, funD getterName [clause []
(normalB (appE (varE (mkName "reGetter"))
(varE fieldName)
)
)
[]
]
, sigD fieldName fieldType
, funD fieldName [clause []
(normalB
(recConE (mkName "ReactiveElement")
[fieldExp
(mkName "reEvents")
(listE [conE (mkName
("RM." ++ fname ++ "Changed"))
]
)
, fieldExp
(mkName "reSetter")
(lamE [varP (mkName "pm")
, varP (mkName "c")
]
(infixE
(Just (varE (mkName "pm")))
(varE (mkName "applyToReactiveModel"))
(Just (infixE Nothing
(varE (mkName
("RM." ++ "set" ++ fname)
)
)
(Just (varE (mkName "c")))
)
)
)
)
, fieldExp (mkName "reGetter")
(infixE
Nothing
(varE (mkName "onReactiveModel"))
(Just (varE (mkName
("RM." ++ "get" ++ fname)))
)
)
]
)
)
[]
]
]
where setterName = mkName ("set" ++ fname)
getterName = mkName ("get" ++ fname)
fieldName = mkName (fnamelc ++ "Field")
setterType = appT pmTo typeToIO
getterType = appT pmTo ioType
fieldType = appT
(appT
(appT (conT (mkName "ReactiveElement"))
ftype
)
(conT (mkName pmodel))
)
(conT (mkName event))
pmTo = appT arrowT (conT (mkName "ProtectedModel"))
typeToIO = appT (appT arrowT ftype) ioNil
ioNil = appT (conT (mkName "IO")) (conT (mkName "()"))
ioType = appT (conT (mkName "IO")) ftype
fnamelc = lcFst fname
reactiveField :: String -> Q Type -> Q [Dec]
reactiveField fname ftype = sequenceQ
[ sigD setterName setterType
, funD setterName [clause []
(normalB (appE (varE (mkName "fieldSetter"))
(varE fieldName)
)
)
[]
]
, sigD getterName getterType
, funD getterName [clause []
(normalB (appE (varE (mkName "fieldGetter"))
(varE fieldName)
)
)
[]
]
, sigD fieldName fieldType
, funD fieldName [clause []
(normalB
(tupE
[ varE (mkName fnamelc)
, varE (mkName "preTrue")
, lamE [varP (mkName "v"), varP (mkName "b")]
(recUpdE (varE (mkName "b"))
[fieldExp
(mkName fnamelc)
(varE (mkName "v"))
]
)
, conE (mkName (fname ++ "Changed"))
]
)
)
[]
]
]
where setterName = mkName ("set" ++ fname)
getterName = mkName ("get" ++ fname)
fieldName = mkName (fnamelc ++ "Field")
setterType = appT rmTo typeToRM
getterType = appT rmTo ftype
fieldType = appT (conT (mkName "Field")) ftype
rmTo = appT arrowT (conT (mkName "ReactiveModel"))
typeToRM = appT (appT arrowT ftype)
(conT (mkName "ReactiveModel"))
fnamelc = lcFst fname
lcFst :: String -> String
lcFst [] = []
lcFst (x:xs) = (toLower x) : xs