module SumTypes.TH
(
constructSumType
, SumTypeOptions
, defaultSumTypeOptions
, sumTypeOptionsTagOptions
, SumTypeTagOptions (..)
, sumTypeOptionsConstructorStrictness
, SumTypeConstructorStrictness (..)
, sumTypeConverter
, partialSumTypeConverter
) where
import Language.Haskell.TH
constructSumType :: String -> SumTypeOptions -> [Name] -> Q [Dec]
constructSumType typeName SumTypeOptions{..} types = do
let
strictness = constructorStrictness sumTypeOptionsConstructorStrictness
mkConstructor name =
NormalC
(constructorName sumTypeOptionsTagOptions typeName name)
[(Bang NoSourceUnpackedness strictness, ConT name)]
constructors = map mkConstructor types
return [DataD [] (mkName typeName) [] Nothing constructors []]
data SumTypeOptions
= SumTypeOptions
{ sumTypeOptionsTagOptions :: SumTypeTagOptions
, sumTypeOptionsConstructorStrictness :: SumTypeConstructorStrictness
}
defaultSumTypeOptions :: SumTypeOptions
defaultSumTypeOptions =
SumTypeOptions
{ sumTypeOptionsTagOptions = PrefixTagsWithTypeName
, sumTypeOptionsConstructorStrictness = LazySumTypeConstructors
}
data SumTypeTagOptions
= PrefixTagsWithTypeName
| AppendTypeNameToTags
| ConstructTagName (String -> String)
constructorName :: SumTypeTagOptions -> String -> Name -> Name
constructorName PrefixTagsWithTypeName typeName = mkName . (typeName ++) . nameBase
constructorName AppendTypeNameToTags typeName = mkName . (++ typeName) . nameBase
constructorName (ConstructTagName mkConstructor) _ = mkName . mkConstructor . nameBase
data SumTypeConstructorStrictness
= LazySumTypeConstructors
| StrictSumTypeConstructors
deriving (Show, Eq)
constructorStrictness :: SumTypeConstructorStrictness -> SourceStrictness
constructorStrictness LazySumTypeConstructors = NoSourceStrictness
constructorStrictness StrictSumTypeConstructors = SourceStrict
sumTypeConverter :: String -> Name -> Name -> Q [Dec]
sumTypeConverter functionName sourceType targetType = do
bothConstructors <- matchTypeConstructors sourceType targetType
let
funcName = mkName functionName
funcClauses <- mapM mkSerializeFunc bothConstructors
typeDecl <- [t| $(conT sourceType) -> $(conT targetType) |]
return
[ SigD funcName typeDecl
, FunD funcName funcClauses
]
partialSumTypeConverter :: String -> Name -> Name -> Q [Dec]
partialSumTypeConverter functionName sourceType targetType = do
bothConstructors <- matchTypeConstructors targetType sourceType
let
funcName = mkName functionName
wildcardClause = Clause [WildP] (NormalB (ConE 'Nothing)) []
funcClauses <- mapM mkDeserializeFunc bothConstructors
typeDecl <- [t| $(conT sourceType) -> Maybe $(conT targetType) |]
return
[ SigD funcName typeDecl
, FunD funcName (funcClauses ++ [wildcardClause])
]
matchTypeConstructors :: Name -> Name -> Q [BothConstructors]
matchTypeConstructors sourceType targetType = do
sourceConstructors <- typeConstructors sourceType
targetConstructors <- typeConstructors targetType
mapM (matchConstructor targetConstructors) sourceConstructors
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
{ innerType :: Type
, sourceConstructor :: Name
, targetConstructor :: Name
}
mkSerializeFunc :: BothConstructors -> Q Clause
mkSerializeFunc BothConstructors{..} = do
varName <- newName "value"
let
patternMatch = ConP sourceConstructor [VarP varName]
constructor = AppE (ConE targetConstructor) (VarE varName)
return $ Clause [patternMatch] (NormalB constructor) []
mkDeserializeFunc :: BothConstructors -> Q Clause
mkDeserializeFunc BothConstructors{..} = do
varName <- newName "value"
let
patternMatch = ConP targetConstructor [VarP varName]
constructor = AppE (ConE 'Just) (AppE (ConE sourceConstructor) (VarE varName))
return $ Clause [patternMatch] (NormalB constructor) []