module Data.Comp.Derive.Show
(
ShowF(..),
makeShowF,
ShowConstr(..),
makeShowConstr
) where
import Data.Comp.Derive.Utils
import Language.Haskell.TH
class ShowF f where
showF :: f String -> String
showCon :: String -> [String] -> String
showCon con [] = con
showCon con args = "(" ++ con ++ " " ++ unwords args ++ ")"
makeShowF :: Name -> Q [Dec]
makeShowF fname = do
Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
let fArg = VarT . tyVarBndrName $ last args
argNames = map (VarT . tyVarBndrName) (init args)
complType = foldl AppT (ConT name) argNames
preCond = map (mkClassP ''Show . (: [])) argNames
classType = AppT (ConT ''ShowF) complType
constrs' <- mapM normalConExp constrs
showFDecl <- funD 'showF (showFClauses fArg constrs')
return [mkInstanceD preCond classType [showFDecl]]
where showFClauses fArg = map (genShowFClause fArg)
filterFarg fArg ty x = (fArg == ty, varE x)
mkShow :: (Bool, ExpQ) -> ExpQ
mkShow (isFArg, var)
| isFArg = var
| otherwise = [| show $var |]
genShowFClause fArg (constr, args, gadtTy) = do
let n = length args
varNs <- newNames n "x"
let pat = ConP constr $ map VarP varNs
allVars = zipWith (filterFarg (getUnaryFArg fArg gadtTy)) args varNs
shows = listE $ map mkShow allVars
conName = nameBase constr
body <- [|showCon conName $shows|]
return $ Clause [pat] (NormalB body) []
class ShowConstr f where
showConstr :: f a -> String
showCon' :: String -> [String] -> String
showCon' con args = unwords $ con : filter (not.null) args
makeShowConstr :: Name -> Q [Dec]
makeShowConstr fname = do
Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
let fArg = VarT . tyVarBndrName $ last args
argNames = map (VarT . tyVarBndrName) (init args)
complType = foldl AppT (ConT name) argNames
preCond = map (mkClassP ''Show . (: [])) argNames
classType = AppT (ConT ''ShowConstr) complType
constrs' <- mapM normalConExp constrs
showConstrDecl <- funD 'showConstr (showConstrClauses fArg constrs')
return [mkInstanceD preCond classType [showConstrDecl]]
where showConstrClauses fArg = map (genShowConstrClause fArg)
filterFarg fArg ty x = (fArg == ty, varE x)
mkShow :: (Bool, ExpQ) -> ExpQ
mkShow (isFArg, var)
| isFArg = [| "" |]
| otherwise = [| show $var |]
genShowConstrClause fArg (constr, args, gadtTy) = do
let n = length args
varNs <- newNames n "x"
let pat = ConP constr $ map VarP varNs
allVars = zipWith (filterFarg (getUnaryFArg fArg gadtTy)) args varNs
shows = listE $ map mkShow allVars
conName = nameBase constr
body <- [|showCon' conName $shows|]
return $ Clause [pat] (NormalB body) []