module Data.Comp.Derive.Show
(
ShowF(..),
makeShowF
) where
import Data.Comp.Derive.Utils
import Language.Haskell.TH
class ShowF f where
showF :: f String -> String
showConstr :: String -> [String] -> String
showConstr con [] = con
showConstr con args = "(" ++ con ++ " " ++ unwords args ++ ")"
makeShowF :: Name -> Q [Dec]
makeShowF fname = do
TyConI (DataD _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 (ClassP ''Show . (: [])) argNames
classType = AppT (ConT ''ShowF) complType
constrs' <- mapM normalConExp constrs
showFDecl <- funD 'showF (showFClauses fArg constrs')
return [InstanceD 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) = do
let n = length args
varNs <- newNames n "x"
let pat = ConP constr $ map VarP varNs
allVars = zipWith (filterFarg fArg) args varNs
shows = listE $ map mkShow allVars
conName = nameBase constr
body <- [|showConstr conName $shows|]
return $ Clause [pat] (NormalB body) []