{-# LANGUAGE TemplateHaskell #-}
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 :: String -> [String] -> String
showCon String
con [] = String
con
showCon String
con [String]
args = String
"(" forall a. [a] -> [a] -> [a]
++ String
con forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
args forall a. [a] -> [a] -> [a]
++ String
")"
makeShowF :: Name -> Q [Dec]
makeShowF :: Name -> Q [Dec]
makeShowF Name
fname = do
Just (DataInfo Cxt
_cxt Name
name [TyVarBndr flag]
args [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
let fArg :: Type
fArg = Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {flag}. TyVarBndr flag -> Name
tyVarBndrName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [TyVarBndr flag]
args
argNames :: Cxt
argNames = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {flag}. TyVarBndr flag -> Name
tyVarBndrName) (forall a. [a] -> [a]
init [TyVarBndr flag]
args)
complType :: Type
complType = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
argNames
preCond :: Cxt
preCond = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Cxt -> Type
mkClassP ''Show forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [])) Cxt
argNames
classType :: Type
classType = Type -> Type -> Type
AppT (Name -> Type
ConT ''ShowF) Type
complType
[(Name, Cxt, Maybe Type)]
constrs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q (Name, Cxt, Maybe Type)
normalConExp [Con]
constrs
Dec
showFDecl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'showF (Type -> [(Name, Cxt, Maybe Type)] -> [Q Clause]
showFClauses Type
fArg [(Name, Cxt, Maybe Type)]
constrs')
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Type -> [Dec] -> Dec
mkInstanceD Cxt
preCond Type
classType [Dec
showFDecl]]
where showFClauses :: Type -> [(Name, Cxt, Maybe Type)] -> [Q Clause]
showFClauses Type
fArg = forall a b. (a -> b) -> [a] -> [b]
map (Type -> (Name, Cxt, Maybe Type) -> Q Clause
genShowFClause Type
fArg)
filterFarg :: a -> a -> Name -> (Bool, m Exp)
filterFarg a
fArg a
ty Name
x = (a
fArg forall a. Eq a => a -> a -> Bool
== a
ty, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)
mkShow :: (Bool, ExpQ) -> ExpQ
mkShow :: (Bool, ExpQ) -> ExpQ
mkShow (Bool
isFArg, ExpQ
var)
| Bool
isFArg = ExpQ
var
| Bool
otherwise = [| show $var |]
genShowFClause :: Type -> (Name, Cxt, Maybe Type) -> Q Clause
genShowFClause Type
fArg (Name
constr, Cxt
args, Maybe Type
gadtTy) = do
let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
args
[Name]
varNs <- Int -> String -> Q [Name]
newNames Int
n String
"x"
let pat :: Pat
pat = Name -> Cxt -> [Pat] -> Pat
ConP Name
constr [] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNs
allVars :: [(Bool, ExpQ)]
allVars = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall {a} {m :: * -> *}.
(Eq a, Quote m) =>
a -> a -> Name -> (Bool, m Exp)
filterFarg (Type -> Maybe Type -> Type
getUnaryFArg Type
fArg Maybe Type
gadtTy)) Cxt
args [Name]
varNs
shows :: ExpQ
shows = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Bool, ExpQ) -> ExpQ
mkShow [(Bool, ExpQ)]
allVars
conName :: String
conName = Name -> String
nameBase Name
constr
Exp
body <- [|showCon conName $shows|]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) []
class ShowConstr f where
showConstr :: f a -> String
showCon' :: String -> [String] -> String
showCon' :: String -> [String] -> String
showCon' String
con [String]
args = [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ String
con forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
args
makeShowConstr :: Name -> Q [Dec]
makeShowConstr :: Name -> Q [Dec]
makeShowConstr Name
fname = do
Just (DataInfo Cxt
_cxt Name
name [TyVarBndr flag]
args [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
let fArg :: Type
fArg = Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {flag}. TyVarBndr flag -> Name
tyVarBndrName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [TyVarBndr flag]
args
argNames :: Cxt
argNames = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {flag}. TyVarBndr flag -> Name
tyVarBndrName) (forall a. [a] -> [a]
init [TyVarBndr flag]
args)
complType :: Type
complType = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
argNames
preCond :: Cxt
preCond = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Cxt -> Type
mkClassP ''Show forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [])) Cxt
argNames
classType :: Type
classType = Type -> Type -> Type
AppT (Name -> Type
ConT ''ShowConstr) Type
complType
[(Name, Cxt, Maybe Type)]
constrs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q (Name, Cxt, Maybe Type)
normalConExp [Con]
constrs
Dec
showConstrDecl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'showConstr (Type -> [(Name, Cxt, Maybe Type)] -> [Q Clause]
showConstrClauses Type
fArg [(Name, Cxt, Maybe Type)]
constrs')
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Type -> [Dec] -> Dec
mkInstanceD Cxt
preCond Type
classType [Dec
showConstrDecl]]
where showConstrClauses :: Type -> [(Name, Cxt, Maybe Type)] -> [Q Clause]
showConstrClauses Type
fArg = forall a b. (a -> b) -> [a] -> [b]
map (Type -> (Name, Cxt, Maybe Type) -> Q Clause
genShowConstrClause Type
fArg)
filterFarg :: a -> a -> Name -> (Bool, m Exp)
filterFarg a
fArg a
ty Name
x = (a
fArg forall a. Eq a => a -> a -> Bool
== a
ty, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)
mkShow :: (Bool, ExpQ) -> ExpQ
mkShow :: (Bool, ExpQ) -> ExpQ
mkShow (Bool
isFArg, ExpQ
var)
| Bool
isFArg = [| "" |]
| Bool
otherwise = [| show $var |]
genShowConstrClause :: Type -> (Name, Cxt, Maybe Type) -> Q Clause
genShowConstrClause Type
fArg (Name
constr, Cxt
args, Maybe Type
gadtTy) = do
let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
args
[Name]
varNs <- Int -> String -> Q [Name]
newNames Int
n String
"x"
let pat :: Pat
pat = Name -> Cxt -> [Pat] -> Pat
ConP Name
constr [] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNs
allVars :: [(Bool, ExpQ)]
allVars = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall {a} {m :: * -> *}.
(Eq a, Quote m) =>
a -> a -> Name -> (Bool, m Exp)
filterFarg (Type -> Maybe Type -> Type
getUnaryFArg Type
fArg Maybe Type
gadtTy)) Cxt
args [Name]
varNs
shows :: ExpQ
shows = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Bool, ExpQ) -> ExpQ
mkShow [(Bool, ExpQ)]
allVars
conName :: String
conName = Name -> String
nameBase Name
constr
Exp
body <- [|showCon' conName $shows|]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) []