{-# LANGUAGE CPP, TemplateHaskell #-} module Data.GADT.Show.TH ( DeriveGShow(..) ) where import Control.Applicative import Control.Monad import Data.Dependent.Sum import Data.Dependent.Sum.TH.Internal import Data.Functor.Identity import Data.GADT.Show import Data.Traversable (for) import Data.List import Language.Haskell.TH import Language.Haskell.TH.Extras class DeriveGShow t where deriveGShow :: t -> Q [Dec] instance DeriveGShow Name where deriveGShow :: Name -> Q [Dec] deriveGShow Name typeName = do Info typeInfo <- Name -> Q Info reify Name typeName case Info typeInfo of TyConI Dec dec -> Dec -> Q [Dec] forall t. DeriveGShow t => t -> Q [Dec] deriveGShow Dec dec Info _ -> String -> Q [Dec] forall (m :: * -> *) a. MonadFail m => String -> m a fail String "deriveGShow: the name of a type constructor is required" instance DeriveGShow Dec where deriveGShow :: Dec -> Q [Dec] deriveGShow = Name -> (Q Type -> Q Type) -> ([TyVarBndrSpec] -> [Con] -> Q Dec) -> Dec -> Q [Dec] deriveForDec ''GShow (\Q Type t -> [t| GShow $t |]) (([TyVarBndrSpec] -> [Con] -> Q Dec) -> Dec -> Q [Dec]) -> ([TyVarBndrSpec] -> [Con] -> Q Dec) -> Dec -> Q [Dec] forall a b. (a -> b) -> a -> b $ \[TyVarBndrSpec] _ -> [Con] -> Q Dec gshowFunction instance DeriveGShow t => DeriveGShow [t] where deriveGShow :: [t] -> Q [Dec] deriveGShow [t it] = t -> Q [Dec] forall t. DeriveGShow t => t -> Q [Dec] deriveGShow t it deriveGShow [t] _ = String -> Q [Dec] forall (m :: * -> *) a. MonadFail m => String -> m a fail String "deriveGShow: [] instance only applies to single-element lists" instance DeriveGShow t => DeriveGShow (Q t) where deriveGShow :: Q t -> Q [Dec] deriveGShow = (Q t -> (t -> Q [Dec]) -> Q [Dec] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= t -> Q [Dec] forall t. DeriveGShow t => t -> Q [Dec] deriveGShow) gshowFunction :: [Con] -> Q Dec gshowFunction = Name -> [Q Clause] -> Q Dec forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec funD 'gshowsPrec ([Q Clause] -> Q Dec) -> ([Con] -> [Q Clause]) -> [Con] -> Q Dec forall b c a. (b -> c) -> (a -> b) -> a -> c . (Con -> Q Clause) -> [Con] -> [Q Clause] forall a b. (a -> b) -> [a] -> [b] map Con -> Q Clause gshowClause gshowClause :: Con -> Q Clause gshowClause Con con = do let conName :: Name conName = Con -> Name nameOfCon Con con argTypes :: [Type] argTypes = Con -> [Type] argTypesOfCon Con con nArgs :: Int nArgs = [Type] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [Type] argTypes precName :: Name precName = String -> Name mkName String "p" [Name] argNames <- Int -> Q Name -> Q [Name] forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a] replicateM Int nArgs (String -> Q Name forall (m :: * -> *). Quote m => String -> m Name newName String "x") let precPat :: Q Pat precPat = if [Name] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Name] argNames then Q Pat forall (m :: * -> *). Quote m => m Pat wildP else Name -> Q Pat forall (m :: * -> *). Quote m => Name -> m Pat varP Name precName [Q Pat] -> Q Body -> [Q Dec] -> Q Clause forall (m :: * -> *). Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause clause [Q Pat precPat, Name -> [Q Pat] -> Q Pat forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat conP Name conName ((Name -> Q Pat) -> [Name] -> [Q Pat] forall a b. (a -> b) -> [a] -> [b] map Name -> Q Pat forall (m :: * -> *). Quote m => Name -> m Pat varP [Name] argNames)] (Q Exp -> Q Body forall (m :: * -> *). Quote m => m Exp -> m Body normalB (Q Exp -> Name -> [Name] -> Q Exp gshowBody (Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp varE Name precName) Name conName [Name] argNames)) [] showsName :: Name -> m Exp showsName Name name = [| showString $(litE . stringL $ nameBase name) |] gshowBody :: Q Exp -> Name -> [Name] -> Q Exp gshowBody Q Exp prec Name conName [] = Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp showsName Name conName gshowBody Q Exp prec Name conName [Name] argNames = [| showParen ($prec > 10) $( composeExprs $ intersperse [| showChar ' ' |] ( showsName conName : [ [| showsPrec 11 $arg |] | argName <- argNames, let arg = varE argName ] )) |]