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 fname ftype = sequenceQ
[ sigD setterName setterType
, funD setterName [clause [varP (mkName "pm"), varP (mkName "n")]
(normalB (appE (appE (varE (mkName "applyToReactiveModel"))
(varE (mkName "pm"))
)
(infixE Nothing
(varE (mkName ("RM.set" ++ fname)))
(Just (varE (mkName "n")))
)
)
)
[]
]
, sigD getterName getterType
, funD getterName [clause []
(normalB (infixE Nothing
(varE (mkName "onReactiveModel"))
(Just (varE (mkName ("RM.get" ++ fname))))
)
)
[]
]
]
where setterName = mkName ("set" ++ fname)
getterName = mkName ("get" ++ fname)
setterType = appT pmTo typeToIO
getterType = appT pmTo ioType
pmTo = appT arrowT (conT (mkName "ProtectedModel"))
typeToIO = appT (appT arrowT (conT (mkName ftype))) ioNil
ioNil = appT (conT (mkName "IO")) (conT (mkName "()"))
ioType = appT (conT (mkName "IO")) (conT (mkName ftype))
reactiveModelAccessors :: String -> String -> Q [Dec]
reactiveModelAccessors fname ftype = sequenceQ
[ sigD setterName setterType
, funD setterName
[clause
[varP (mkName "rm"), varP (mkName "n")]
(normalB (appE (appE (varE (mkName "triggerEvent"))
(varE (mkName "rm'"))
)
(varE (mkName "ev"))
)
)
[valD (varP (mkName "rm'"))
(normalB (infixE (Just (varE (mkName "rm")))
(varE (mkName "onBasicModel"))
(Just (lamE [varP (mkName "b")]
(recUpdE (varE (mkName "b"))
[fieldExp
(mkName fnamelc)
(varE (mkName "n"))
]
)
)
)
)
)
[]
, valD (varP (mkName "ev"))
(normalB (conE (mkName (fname ++ "Changed"))))
[]
]
]
, sigD getterName getterType
, funD getterName [clause []
(normalB (infixE (Just (varE (mkName fnamelc)))
(varE (mkName "."))
(Just (varE (mkName "basicModel")))
)
)
[]
]
]
where setterName = mkName ("set" ++ fname)
getterName = mkName ("get" ++ fname)
setterType = appT rmTo typeToRM
getterType = appT rmTo (conT (mkName ftype))
rmTo = appT arrowT (conT (mkName "ReactiveModel"))
typeToRM = appT (appT arrowT (conT (mkName ftype))) (conT (mkName "ReactiveModel"))
fnamelc = lcFst fname
nonReactiveModelAccessors :: String -> Q Type -> Q [Dec]
nonReactiveModelAccessors fname ftype = sequenceQ
[ sigD setterName setterType
, funD setterName
[clause
[varP (mkName "rm"), varP (mkName "n")]
(normalB (varE (mkName "rm'")))
[valD (varP (mkName "rm'"))
(normalB (infixE (Just (varE (mkName "rm")))
(varE (mkName "onBasicModel"))
(Just (lamE [varP (mkName "b")]
(recUpdE (varE (mkName "b"))
[fieldExp
(mkName fnamelc)
(varE (mkName "n"))
]
)
)
)
)
)
[]
]
]
, sigD getterName getterType
, funD getterName [clause []
(normalB (infixE (Just (varE (mkName fnamelc)))
(varE (mkName "."))
(Just (varE (mkName "basicModel")))
)
)
[]
]
]
where setterName = mkName ("set" ++ fname)
getterName = mkName ("get" ++ fname)
setterType = appT rmTo typeToRM
getterType = appT rmTo 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