module Eventful.TH.SumTypeSerializer
( mkSumTypeSerializer
) where
import Data.Char (toLower)
import Data.List (lookup)
import Language.Haskell.TH
mkSumTypeSerializer :: String -> Name -> Name -> Q [Dec]
mkSumTypeSerializer serializerName sourceType targetType = do
sourceConstructors <- typeConstructors sourceType
targetConstructors <- typeConstructors targetType
bothConstructors <- mapM (matchConstructor targetConstructors) sourceConstructors
let
serializeFuncName = mkName $ firstCharToLower (nameBase sourceType) ++ "To" ++ nameBase targetType
serializeFuncClauses = map mkSerializeFunc bothConstructors
serializeTypeDecl <- [t| $(conT sourceType) -> $(conT targetType) |]
let
deserializeFuncName = mkName $ firstCharToLower (nameBase targetType) ++ "To" ++ nameBase sourceType
wildcardDeserializeClause = Clause [WildP] (NormalB (ConE 'Nothing)) []
deserializeFuncClauses = map mkDeserializeFunc bothConstructors ++ [wildcardDeserializeClause]
deserializeTypeDecl <- [t| $(conT targetType) -> Maybe $(conT sourceType) |]
serializerTypeDecl <- [t| $(conT $ mkName "Serializer") $(conT sourceType) $(conT targetType) |]
serializerExp <- [e| $(varE $ mkName "simpleSerializer") $(varE serializeFuncName) $(varE deserializeFuncName) |]
let
serializerClause = Clause [] (NormalB serializerExp) []
return
[
SigD serializeFuncName serializeTypeDecl
, FunD serializeFuncName serializeFuncClauses
, SigD deserializeFuncName deserializeTypeDecl
, FunD deserializeFuncName deserializeFuncClauses
, SigD (mkName serializerName) serializerTypeDecl
, FunD (mkName serializerName) [serializerClause]
]
typeConstructors :: Name -> Q [(Type, Name)]
typeConstructors typeName = do
info <- reify typeName
case info of
(TyConI (DataD _ _ _ _ constructors _)) -> mapM go constructors
where
go (NormalC name []) = fail $ "Constructor " ++ nameBase name ++ " doesn't have any arguments"
go (NormalC name [(_, type')]) = return (type', name)
go (NormalC name _) = fail $ "Constructor " ++ nameBase name ++ " has more than one argument"
go _ = fail $ "Invalid constructor in " ++ nameBase typeName
_ -> fail $ nameBase typeName ++ " must be a sum type"
matchConstructor :: [(Type, Name)] -> (Type, Name) -> Q BothConstructors
matchConstructor targetConstructors (type', sourceConstructor) = do
targetConstructor <-
maybe
(fail $ "Can't find constructor in target type corresponding to " ++ nameBase sourceConstructor)
return
(lookup type' targetConstructors)
return $ BothConstructors type' sourceConstructor targetConstructor
data BothConstructors =
BothConstructors
{ eventType :: Type
, sourceConstructor :: Name
, targetConstructor :: Name
}
mkSerializeFunc :: BothConstructors -> Clause
mkSerializeFunc BothConstructors{..} =
let
patternMatch = ConP sourceConstructor [VarP (mkName "e")]
constructor = AppE (ConE targetConstructor) (VarE (mkName "e"))
in Clause [patternMatch] (NormalB constructor) []
mkDeserializeFunc :: BothConstructors -> Clause
mkDeserializeFunc BothConstructors{..} =
let
patternMatch = ConP targetConstructor [VarP (mkName "e")]
constructor = AppE (ConE 'Just) (AppE (ConE sourceConstructor) (VarE (mkName "e")))
in Clause [patternMatch] (NormalB constructor) []
firstCharToLower :: String -> String
firstCharToLower [] = []
firstCharToLower (x:xs) = toLower x : xs