module Cgm.Data.Structured.Derive (
deriveStructured
) where
import Language.Haskell.TH
import Control.Monad
deriveStructured :: Name -> Q [Dec]
deriveStructured typName =
do (TyConI d) <- reify typName
(type_name,tvars,_,constructors) <- typeInfo (return d)
appliedType <- appsT $ conT' type_name : map (varT . fromTyVar) tvars
let structureType = tySynInstD (mkName "Structure") [return appliedType] $
nestedEitherT $ map (nestedTupT . map (return . snd) . snd) constructors
structureFun = do clauses <- mapM structureClause constructors
return $ FunD (mkName "structure") $ addETags clauses
structureClause (conName, components) =
do vars <- newNames "a" components
clause [conP conName $ map varP vars] (normalB $ nestedTupE $ map varE vars) []
fromStructureFun =
do clauses <- mapM fromStructureClause constructors
return $ FunD (mkName "fromStructure") $ addPTags clauses
fromStructureClause (conName, components) =
do vars <- newNames "s" components
clause [nestedTupP $ map varP vars] (normalB (appsE (conE conName : map varE vars))) []
in sequence [instanceD (cxt []) (appT (conT $ mkName "Structured") (return appliedType))
[structureType, structureFun, fromStructureFun]]
conT' name = if nameBase name == "[]" then listT else conT name
nested :: b -> (a -> b) -> (a -> b -> b) -> [a] -> b
nested empty single pair [] = empty
nested empty single pair (x:[]) = single x
nested empty single pair (x:xs) = pair x $ nested empty single pair xs
nestedTupE = nested (tupE []) id (\a b -> tupE [a, b])
nestedTupT = nested (tupT []) id (\a b -> tupT [a, b])
nestedTupP = nested (tupP []) id (\a b -> tupP [a, b])
nestedEitherT = nested (error "nestedEitherT []") id eitherT
addETags = nested [] return $ \c cs -> mapClauseBodyE leftETag c : map (mapClauseBodyE rightETag) cs
addPTags = nested [] return $ \c cs -> mapClausePat1 leftPTag c : map (mapClausePat1 rightPTag) cs
leftETag = AppE $ ConE $ mkName "Left"
rightETag = AppE $ ConE $ mkName "Right"
leftPTag p = ConP (mkName "Left") [p]
rightPTag p = ConP (mkName "Right") [p]
mapClauseBodyE f (Clause ps b ds) = Clause ps (mapBodyE f b) ds
mapClausePat1 f (Clause [p] b ds) = Clause [f p] b ds
mapBodyE f (GuardedB gs) = GuardedB $ map (\p -> (fst p, f $ snd p)) gs
mapBodyE f (NormalB e) = NormalB $ f e
appsT :: [TypeQ] -> TypeQ
appsT [] = error "appsT []"
appsT [x] = x
appsT (x:y:zs) = appsT $ appT x y : zs
tupT ts = appsT $ tupleT (length ts) : ts
eitherT ta tb = appsT [conT (mkName "Either"), ta, tb]
fromTyVar :: TyVarBndr -> Name
fromTyVar (PlainTV v) = v
fromTyVar (KindedTV v _) = v
newNames prefix = mapM $ const $ newName prefix
typeInfo :: DecQ -> Q (Name, [TyVarBndr], [(Name, Int)], [(Name, [(Maybe Name, Type)])])
typeInfo m =
do d <- m
case d of
d@DataD{} ->
return (simpleName $ name d, paramsA d, consA d, termsA d)
d@NewtypeD{} ->
return (simpleName $ name d, paramsA d, consA d, termsA d)
_ -> error ("derive: not a data type declaration: " ++ show d)
where
consA (DataD _ _ _ cs _) = map conA cs
consA (NewtypeD _ _ _ c _) = [ conA c ]
paramsA (DataD _ _ ps _ _) = ps
paramsA (NewtypeD _ _ ps _ _) = ps
termsA (DataD _ _ _ cs _) = map termA cs
termsA (NewtypeD _ _ _ c _) = [ termA c ]
termA (NormalC c xs) = (c, map (\x -> (Nothing, snd x)) xs)
termA (RecC c xs) = (c, map (\(n, _, t) -> (Just $ simpleName n, t)) xs)
termA (InfixC t1 c t2) = (c, [(Nothing, snd t1), (Nothing, snd t2)])
conA (NormalC c xs) = (simpleName c, length xs)
conA (RecC c xs) = (simpleName c, length xs)
conA (InfixC _ c _) = (simpleName c, 2)
name (DataD _ n _ _ _) = n
name (NewtypeD _ n _ _ _) = n
name d = error $ show d
simpleName :: Name -> Name
simpleName nm =
let s = nameBase nm
in case dropWhile (/=':') s of
[] -> mkName s
_:[] -> mkName s
_:t -> mkName t