module Eventful.TH.Projection
( mkProjection
) where
import Data.Char (toLower)
import Language.Haskell.TH
import SumTypes.TH
import Eventful.Projection
mkProjection :: Name -> Name -> [Name] -> Q [Dec]
mkProjection stateName stateDefault events = do
let eventTypeName = nameBase stateName ++ "Event"
sumTypeDecls <- constructSumType eventTypeName defaultSumTypeOptions events
let handleFuncName = mkName $ "handle" ++ eventTypeName
handleFuncType <- [t| $(conT stateName) -> $(conT $ mkName eventTypeName) -> $(conT stateName) |]
handleFuncBodies <- mapM (handleFuncBody stateName) events
let
handleTypeDecls =
[ SigD handleFuncName handleFuncType
, FunD handleFuncName handleFuncBodies
]
projectionType <- [t| Projection $(conT stateName) $(conT $ mkName eventTypeName) |]
let
projectionTypeName = mkName $ nameBase stateName ++ "Projection"
projectionTypeDecl = TySynD projectionTypeName [] projectionType
projectionFuncExpr <- [e| Projection $(varE stateDefault) $(varE handleFuncName) |]
let
projectionFuncName = mkName $ firstCharToLower (nameBase stateName) ++ "Projection"
projectionFuncClause = Clause [] (NormalB projectionFuncExpr) []
projectionDecls =
[ SigD projectionFuncName (ConT projectionTypeName)
, FunD projectionFuncName [projectionFuncClause]
]
return $ sumTypeDecls ++ handleTypeDecls ++ [projectionTypeDecl] ++ projectionDecls
handleFuncBody :: Name -> Name -> Q Clause
handleFuncBody stateName event = do
let
statePattern = VarP (mkName "state")
eventPattern = ConP (mkName $ nameBase stateName ++ nameBase event) [VarP (mkName "event")]
handleFuncName = mkName $ "handle" ++ nameBase event
constructor <- [e| $(varE handleFuncName) $(varE $ mkName "state") $(varE $ mkName "event") |]
return $ Clause [statePattern, eventPattern] (NormalB constructor) []
firstCharToLower :: String -> String
firstCharToLower [] = []
firstCharToLower (x:xs) = toLower x : xs