{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Derive.Show
-- Copyright   :  (c) 2010-2011 Patrick Bahr
-- License     :  BSD3
-- Maintainer  :  Patrick Bahr <paba@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- Automatically derive instances of @ShowF@.
--
--------------------------------------------------------------------------------

module Data.Comp.Derive.Show
    (
     ShowF(..),
     makeShowF,
     ShowConstr(..),
     makeShowConstr
    ) where

import Data.Comp.Derive.Utils
import Language.Haskell.TH

{-| Signature printing. An instance @ShowF f@ gives rise to an instance
  @Show (Term f)@. -}
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
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
con String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

{-| Derive an instance of 'ShowF' for a type constructor of any first-order kind
  taking at least one argument. -}
makeShowF :: Name -> Q [Dec]
makeShowF :: Name -> Q [Dec]
makeShowF Name
fname = do
  Just (DataInfo Cxt
_cxt Name
name [TyVarBndr]
args [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ (Q Info -> Q (Maybe DataInfo)) -> Q Info -> Q (Maybe DataInfo)
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
  let fArg :: Type
fArg = Name -> Type
VarT (Name -> Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
tyVarBndrName (TyVarBndr -> Type) -> TyVarBndr -> Type
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> TyVarBndr
forall a. [a] -> a
last [TyVarBndr]
args
      argNames :: Cxt
argNames = (TyVarBndr -> Type) -> [TyVarBndr] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
tyVarBndrName) ([TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
init [TyVarBndr]
args)
      complType :: Type
complType = (Type -> Type -> Type) -> Type -> Cxt -> Type
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 = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Cxt -> Type
mkClassP ''Show (Cxt -> Type) -> (Type -> Cxt) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Cxt -> Cxt
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' <- (Con -> Q (Name, Cxt, Maybe Type))
-> [Con] -> Q [(Name, Cxt, Maybe Type)]
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 <- Name -> [ClauseQ] -> DecQ
funD 'showF (Type -> [(Name, Cxt, Maybe Type)] -> [ClauseQ]
showFClauses Type
fArg [(Name, Cxt, Maybe Type)]
constrs')
  [Dec] -> Q [Dec]
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)] -> [ClauseQ]
showFClauses Type
fArg = ((Name, Cxt, Maybe Type) -> ClauseQ)
-> [(Name, Cxt, Maybe Type)] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> (Name, Cxt, Maybe Type) -> ClauseQ
genShowFClause Type
fArg)
            filterFarg :: a -> a -> Name -> (Bool, ExpQ)
filterFarg a
fArg a
ty Name
x = (a
fArg a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
ty, Name -> ExpQ
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) -> ClauseQ
genShowFClause Type
fArg (Name
constr, Cxt
args, Maybe Type
gadtTy) = do
              let n :: Int
n = Cxt -> Int
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 -> [Pat] -> Pat
ConP Name
constr ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNs
                  allVars :: [(Bool, ExpQ)]
allVars = (Type -> Name -> (Bool, ExpQ)) -> Cxt -> [Name] -> [(Bool, ExpQ)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Type -> Type -> Name -> (Bool, ExpQ)
forall a. Eq a => a -> a -> Name -> (Bool, ExpQ)
filterFarg (Type -> Maybe Type -> Type
getUnaryFArg Type
fArg Maybe Type
gadtTy)) Cxt
args [Name]
varNs
                  shows :: ExpQ
shows = [ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ((Bool, ExpQ) -> ExpQ) -> [(Bool, ExpQ)] -> [ExpQ]
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|]
              Clause -> ClauseQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> ClauseQ) -> Clause -> ClauseQ
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) []

{-| Constructor printing. -}
class ShowConstr f where
    showConstr :: f a -> String

showCon' :: String -> [String] -> String
showCon' :: String -> [String] -> String
showCon' String
con [String]
args = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
con String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
args

{-| Derive an instance of 'showConstr' for a type constructor of any first-order kind
  taking at least one argument. -}
makeShowConstr :: Name -> Q [Dec]
makeShowConstr :: Name -> Q [Dec]
makeShowConstr Name
fname = do
  Just (DataInfo Cxt
_cxt Name
name [TyVarBndr]
args [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ (Q Info -> Q (Maybe DataInfo)) -> Q Info -> Q (Maybe DataInfo)
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
  let fArg :: Type
fArg = Name -> Type
VarT (Name -> Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
tyVarBndrName (TyVarBndr -> Type) -> TyVarBndr -> Type
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> TyVarBndr
forall a. [a] -> a
last [TyVarBndr]
args
      argNames :: Cxt
argNames = (TyVarBndr -> Type) -> [TyVarBndr] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
tyVarBndrName) ([TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
init [TyVarBndr]
args)
      complType :: Type
complType = (Type -> Type -> Type) -> Type -> Cxt -> Type
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 = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Cxt -> Type
mkClassP ''Show (Cxt -> Type) -> (Type -> Cxt) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Cxt -> Cxt
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' <- (Con -> Q (Name, Cxt, Maybe Type))
-> [Con] -> Q [(Name, Cxt, Maybe Type)]
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 <- Name -> [ClauseQ] -> DecQ
funD 'showConstr (Type -> [(Name, Cxt, Maybe Type)] -> [ClauseQ]
showConstrClauses Type
fArg [(Name, Cxt, Maybe Type)]
constrs')
  [Dec] -> Q [Dec]
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)] -> [ClauseQ]
showConstrClauses Type
fArg = ((Name, Cxt, Maybe Type) -> ClauseQ)
-> [(Name, Cxt, Maybe Type)] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> (Name, Cxt, Maybe Type) -> ClauseQ
genShowConstrClause Type
fArg)
            filterFarg :: a -> a -> Name -> (Bool, ExpQ)
filterFarg a
fArg a
ty Name
x = (a
fArg a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
ty, Name -> ExpQ
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) -> ClauseQ
genShowConstrClause Type
fArg (Name
constr, Cxt
args, Maybe Type
gadtTy) = do
              let n :: Int
n = Cxt -> Int
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 -> [Pat] -> Pat
ConP Name
constr ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNs
                  allVars :: [(Bool, ExpQ)]
allVars = (Type -> Name -> (Bool, ExpQ)) -> Cxt -> [Name] -> [(Bool, ExpQ)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Type -> Type -> Name -> (Bool, ExpQ)
forall a. Eq a => a -> a -> Name -> (Bool, ExpQ)
filterFarg (Type -> Maybe Type -> Type
getUnaryFArg Type
fArg Maybe Type
gadtTy)) Cxt
args [Name]
varNs
                  shows :: ExpQ
shows = [ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ((Bool, ExpQ) -> ExpQ) -> [(Bool, ExpQ)] -> [ExpQ]
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|]
              Clause -> ClauseQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> ClauseQ) -> Clause -> ClauseQ
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) []