module Data.ADT.Getters
( mkADTGetters
) where
import Language.Haskell.TH.Syntax
mkADTGetters :: Name -> Q [Dec]
mkADTGetters typeName = do
TyConI (DataD _ _ typeVars constructors _) <- reify typeName
return $ constructors >>= mkADTGetterFunc typeName typeVars
mkADTGetterFunc :: Name -> [Name] -> Con -> [Dec]
mkADTGetterFunc typeName typeVars constructor =
[ SigD resName
. ForallT typeVars []
. AppT (AppT ArrowT (foldl AppT (ConT typeName) (map VarT typeVars)))
. AppT (ConT (mkName "Maybe"))
$ case containedTypes of
[] -> TupleT 0
[x] -> x
xs -> foldl AppT (TupleT (length xs)) xs
, FunD resName
[ Clause [ConP name (map VarP varNames)] clauseJust []
, Clause [WildP] clauseNothing []
]
]
where
NormalC name params = constructor
containedTypes = map snd params
resName = mkName $ 'g' : nameBase name
varNames = map (mkName . ('x' :) . show) [0 .. length params 1]
clauseJust =
NormalB . AppE (ConE (mkName "Just"))
$ case varNames of
[] -> TupE []
[x] -> VarE x
xs -> TupE (map VarE xs)
clauseNothing = NormalB . ConE . mkName $ "Nothing"