module Text.GShow ( GShow(..), deriveShow, app_prec ) where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.List (nub, foldl1')
class GShow a where
gshow :: a -> String
gshowsPrec :: Int -> a -> ShowS
app_prec :: Int
app_prec = 10
data ADInfo = ADInfo [Name] [Con]
deriveShow :: Name -> Q [Dec]
deriveShow name = do
(ADInfo args cons) <- getInfo name
let targs = map VarT args
ctx = map (ClassP ''GShow) $ map (: []) (nub $ filterVars $ unrollApps $ mkContext cons)
typ = AppT (ConT ''GShow) (foldl1' AppT $ (ConT name):targs)
gs <- [d| gshow a = gshowsPrec 0 a "" |]
let clcons = map deriveShowCon cons
gsps <- funD (mkName "gshowsPrec") clcons
return [ InstanceD ctx typ (gsps:gs) ]
mkContext :: [Con] -> [Type]
mkContext [] = []
mkContext ((NormalC _ args) :cs) = (map snd args) ++ (mkContext cs)
mkContext ((InfixC argl _ argr) :cs) = (snd argl) : ((snd argr) : (mkContext cs))
mkContext _ = error "Error: the impossible happened in mkContext"
filterVars :: [Type] -> [Type]
filterVars [] = []
filterVars (v@(VarT _):vs) = v : filterVars vs
filterVars (_:vs) = filterVars vs
unrollApps :: [Type] -> [Type]
unrollApps [] = []
unrollApps (a@(AppT _ _):ts) = unrollApp a ++ unrollApps ts
unrollApps (other:ts) = other : unrollApps ts
unrollApp :: Type -> [Type]
unrollApp app = unrollApp' app []
where unrollApp' :: Type -> [Type] -> [Type]
unrollApp' (AppT sub@(AppT _ _) arg) args = unrollApp' sub (arg:args)
unrollApp' (AppT top arg) args = top:(arg:args)
unrollApp' _ _ = error "Error: the impossible happened in unrollApp"
deriveShowCon :: Con -> Q Clause
deriveShowCon (NormalC name types) = do
names <- mapM (const $ newName "x") types
let pat = conP name (map varP names)
shows = map ((appE fgshowp) . varE) names
clause [varP (mkName "d"), pat] (bdy shows) []
where
bdy s = normalB (appE (appE fshowParen cond) (str s))
fshowParen = varE $ mkName "showParen"
cond = infixE (Just $ varE $ mkName "d")
(varE $ mkName ">")
(Just $ varE $ mkName "app_prec")
str s = infixE (Just (appE (varE $ mkName "showString") cons))
(varE $ mkName ".") (Just $ conc s)
cons = litE $ StringL (nameBase name ++ " ")
fgshowp = appE (varE $ mkName "gshowsPrec") (varE $ mkName "app_prec")
conc [] = [| id |]
conc (s:[]) = [| $(s) |]
conc (s:rs) = [| $(s) . $(conc rs)|]
deriveShowCon (InfixC _ name _) = do
f <- getPrec name
clause [varP (mkName "d"), pat] (bdy f) []
where
l = mkName "l"
r = mkName "r"
pat = infixP (varP l) name (varP r)
bdy (f,fl,fr) = normalB (appE (appE fshowParen (cond f)) (str fl fr))
fshowParen = varE $ mkName "showParen"
cond f = infixE (Just $ varE $ mkName "d")
(varE $ mkName ">")
(Just [| f |])
fshowsPrec d n = appE (appE (varE $ mkName "gshowsPrec") [| d |]) n
strl fl = appE (appE (varE $ mkName ".") (fshowsPrec fl (varE l)))
(appE (varE $ mkName "showString")
(litE $ StringL (' ' : nameBase name ++ " ")))
str fl fr = appE (appE (varE $ mkName ".") (strl fl))
(fshowsPrec fr (varE r))
deriveShowCon _ = error "Error: the impossible happened in deriveShowCon"
getPrec :: Name -> Q (Int, Int, Int)
getPrec name = do
(DataConI _ _ _ (Fixity f fd)) <- reify name
return (f, (f + fLeft fd), (f + fRight fd))
where
fLeft InfixL = 0
fLeft InfixR = 1
fRight InfixR = 0
fRight InfixL = 1
getInfo :: Name -> Q ADInfo
getInfo name = do
info <- reify name
case info of
TyConI d -> case d of
(DataD _ _ args cs _) -> return $ ADInfo (map tyVarBndr2Name args) cs
(NewtypeD _ _ args c _) -> return $ ADInfo (map tyVarBndr2Name args) [c]
_ -> scopeError
_ -> scopeError
where scopeError = error $ "Can only be used on algebraic datatypes (which " ++ (show name) ++ " isn't)"
tyVarBndr2Name :: TyVarBndr -> Name
tyVarBndr2Name (PlainTV n) = n
tyVarBndr2Name (KindedTV n _) = n