{-# LANGUAGE CPP, TemplateHaskell #-} module Data.GADT.Show.TH ( DeriveGShow(..) ) where import Control.Applicative import Control.Monad import Control.Monad.Writer import Data.GADT.TH.Internal import Data.Functor.Identity import Data.GADT.Show import Data.Traversable (for) import Data.List import Data.Set (Set) import qualified Data.Set as Set import Language.Haskell.TH import Language.Haskell.TH.Datatype class DeriveGShow t where deriveGShow :: t -> Q [Dec] instance DeriveGShow Name where deriveGShow :: Name -> Q [Dec] deriveGShow Name typeName = do DatatypeInfo typeInfo <- Name -> Q DatatypeInfo reifyDatatype Name typeName let instTypes :: [Type] instTypes = DatatypeInfo -> [Type] datatypeInstTypes DatatypeInfo typeInfo paramVars :: Set Name paramVars = [Set Name] -> Set Name forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a Set.unions [Type -> Set Name freeTypeVariables Type t | Type t <- [Type] instTypes] instTypes' :: [Type] instTypes' = case [Type] -> [Type] forall a. [a] -> [a] reverse [Type] instTypes of [] -> String -> [Type] forall (m :: * -> *) a. MonadFail m => String -> m a fail String "deriveGEq: Not enough type parameters" (Type _:[Type] xs) -> [Type] -> [Type] forall a. [a] -> [a] reverse [Type] xs instanceHead :: Type instanceHead = Type -> Type -> Type AppT (Name -> Type ConT ''GShow) ((Type -> Type -> Type) -> Type -> [Type] -> Type forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl Type -> Type -> Type AppT (Name -> Type ConT Name typeName) [Type] instTypes') ([Clause] clauses, [Type] cxt) <- WriterT [Type] Q [Clause] -> Q ([Clause], [Type]) forall w (m :: * -> *) a. WriterT w m a -> m (a, w) runWriterT ((ConstructorInfo -> WriterT [Type] Q Clause) -> [ConstructorInfo] -> WriterT [Type] Q [Clause] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (Name -> Set Name -> ConstructorInfo -> WriterT [Type] Q Clause gshowClause Name typeName Set Name paramVars) (DatatypeInfo -> [ConstructorInfo] datatypeCons DatatypeInfo typeInfo)) [Dec] -> Q [Dec] forall (m :: * -> *) a. Monad m => a -> m a return [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec InstanceD Maybe Overlap forall a. Maybe a Nothing (DatatypeInfo -> [Type] datatypeContext DatatypeInfo typeInfo [Type] -> [Type] -> [Type] forall a. [a] -> [a] -> [a] ++ [Type] cxt) Type instanceHead [[Clause] -> Dec gshowFunction [Clause] clauses]] instance DeriveGShow Dec where deriveGShow :: Dec -> Q [Dec] deriveGShow = Name -> (DatatypeInfo -> WriterT [Type] Q Dec) -> Dec -> Q [Dec] deriveForDec ''GShow ((DatatypeInfo -> WriterT [Type] Q Dec) -> Dec -> Q [Dec]) -> (DatatypeInfo -> WriterT [Type] Q Dec) -> Dec -> Q [Dec] forall a b. (a -> b) -> a -> b $ \DatatypeInfo typeInfo -> do let instTypes :: [Type] instTypes = DatatypeInfo -> [Type] datatypeInstTypes DatatypeInfo typeInfo paramVars :: Set Name paramVars = [Set Name] -> Set Name forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a Set.unions [Type -> Set Name freeTypeVariables Type t | Type t <- [Type] instTypes] [Clause] clauses <- (ConstructorInfo -> WriterT [Type] Q Clause) -> [ConstructorInfo] -> WriterT [Type] Q [Clause] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (Name -> Set Name -> ConstructorInfo -> WriterT [Type] Q Clause gshowClause (DatatypeInfo -> Name datatypeName DatatypeInfo typeInfo) Set Name paramVars) (DatatypeInfo -> [ConstructorInfo] datatypeCons DatatypeInfo typeInfo) Dec -> WriterT [Type] Q Dec forall (m :: * -> *) a. Monad m => a -> m a return (Dec -> WriterT [Type] Q Dec) -> Dec -> WriterT [Type] Q Dec forall a b. (a -> b) -> a -> b $ [Clause] -> Dec gshowFunction [Clause] clauses 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 :: [Clause] -> Dec gshowFunction :: [Clause] -> Dec gshowFunction [Clause] clauses = Name -> [Clause] -> Dec FunD 'gshowsPrec [Clause] clauses isApplicationOf :: Type -> Type -> Bool isApplicationOf :: Type -> Type -> Bool isApplicationOf Type t Type t' = Type t Type -> Type -> Bool forall a. Eq a => a -> a -> Bool == Type t' Bool -> Bool -> Bool || case Type t' of AppT Type u Type _ -> Type -> Type -> Bool isApplicationOf Type t Type u Type _ -> Bool False gshowClause :: Name -> Set Name -> ConstructorInfo -> WriterT [Type] Q Clause gshowClause :: Name -> Set Name -> ConstructorInfo -> WriterT [Type] Q Clause gshowClause Name typeName Set Name paramVars ConstructorInfo con = do let conName :: Name conName = ConstructorInfo -> Name constructorName ConstructorInfo con argTypes :: [Type] argTypes = ConstructorInfo -> [Type] constructorFields ConstructorInfo con conTyVars :: Set Name conTyVars = [Name] -> Set Name forall a. Ord a => [a] -> Set a Set.fromList ((TyVarBndr_ Any -> Name) -> [TyVarBndr_ Any] -> [Name] forall a b. (a -> b) -> [a] -> [b] map TyVarBndr_ Any -> Name forall flag. TyVarBndr_ Any -> Name tvName (ConstructorInfo -> [TyVarBndr_ Any] constructorVars ConstructorInfo con)) Name precName <- Q Name -> WriterT [Type] Q Name forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (Q Name -> WriterT [Type] Q Name) -> Q Name -> WriterT [Type] Q Name forall a b. (a -> b) -> a -> b $ String -> Q Name newName String "prec" [Name] argNames <- [Type] -> (Type -> WriterT [Type] Q Name) -> WriterT [Type] Q [Name] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM [Type] argTypes ((Type -> WriterT [Type] Q Name) -> WriterT [Type] Q [Name]) -> (Type -> WriterT [Type] Q Name) -> WriterT [Type] Q [Name] forall a b. (a -> b) -> a -> b $ \Type _ -> Q Name -> WriterT [Type] Q Name forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (Q Name -> WriterT [Type] Q Name) -> Q Name -> WriterT [Type] Q Name forall a b. (a -> b) -> a -> b $ String -> Q Name newName String "x" [ExpQ] argShowExprs <- [(Name, Type)] -> ((Name, Type) -> WriterT [Type] Q ExpQ) -> WriterT [Type] Q [ExpQ] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM ([Name] -> [Type] -> [(Name, Type)] forall a b. [a] -> [b] -> [(a, b)] zip [Name] argNames [Type] argTypes) (((Name, Type) -> WriterT [Type] Q ExpQ) -> WriterT [Type] Q [ExpQ]) -> ((Name, Type) -> WriterT [Type] Q ExpQ) -> WriterT [Type] Q [ExpQ] forall a b. (a -> b) -> a -> b $ \(Name n,Type t) -> do let useShow :: WriterT [Type] Q ExpQ useShow = do [Dec] u <- Q [Dec] -> WriterT [Type] Q [Dec] forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (Q [Dec] -> WriterT [Type] Q [Dec]) -> Q [Dec] -> WriterT [Type] Q [Dec] forall a b. (a -> b) -> a -> b $ Set Name -> Name -> [Type] -> Q [Dec] reifyInstancesWithRigids Set Name paramVars ''Show [Type t] case [Dec] u of (Dec _:[Dec] _) -> () -> WriterT [Type] Q () forall (m :: * -> *) a. Monad m => a -> m a return () [Dec] _ -> [Type] -> WriterT [Type] Q () forall w (m :: * -> *). MonadWriter w m => w -> m () tell [Type -> Type -> Type AppT (Name -> Type ConT ''Show) Type t] ExpQ -> WriterT [Type] Q ExpQ forall (m :: * -> *) a. Monad m => a -> m a return [| showsPrec 11 $(varE n) |] case Type t of AppT Type tyFun Type tyArg -> do if Type -> Type -> Bool isApplicationOf (Name -> Type ConT Name typeName) Type tyFun then ExpQ -> WriterT [Type] Q ExpQ forall (m :: * -> *) a. Monad m => a -> m a return [| gshowsPrec 11 $(varE n) |] else WriterT [Type] Q ExpQ useShow Type _ -> WriterT [Type] Q ExpQ useShow let precPat :: PatQ precPat = if [Name] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Name] argNames then PatQ wildP else Name -> PatQ varP Name precName Q Clause -> WriterT [Type] Q Clause forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (Q Clause -> WriterT [Type] Q Clause) -> Q Clause -> WriterT [Type] Q Clause forall a b. (a -> b) -> a -> b $ [PatQ] -> BodyQ -> [DecQ] -> Q Clause clause [PatQ precPat, Name -> [PatQ] -> PatQ conP Name conName ((Name -> PatQ) -> [Name] -> [PatQ] forall a b. (a -> b) -> [a] -> [b] map Name -> PatQ varP [Name] argNames)] (ExpQ -> BodyQ normalB (ExpQ -> Name -> [ExpQ] -> ExpQ gshowBody (Name -> ExpQ varE Name precName) Name conName [ExpQ] argShowExprs)) [] showsName :: Name -> ExpQ showsName Name name = [| showString $(litE . stringL $ nameBase name) |] gshowBody :: Q Exp -> Name -> [Q Exp] -> Q Exp gshowBody :: ExpQ -> Name -> [ExpQ] -> ExpQ gshowBody ExpQ prec Name conName [] = Name -> ExpQ showsName Name conName gshowBody ExpQ prec Name conName [ExpQ] argShowExprs = let body :: ExpQ body = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (\ExpQ e ExpQ es -> [| $e . $es |]) [| id |] ([ExpQ] -> ExpQ) -> ([ExpQ] -> [ExpQ]) -> [ExpQ] -> ExpQ forall b c a. (b -> c) -> (a -> b) -> a -> c . ExpQ -> [ExpQ] -> [ExpQ] forall a. a -> [a] -> [a] intersperse [| showChar ' ' |] ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ forall a b. (a -> b) -> a -> b $ Name -> ExpQ showsName Name conName ExpQ -> [ExpQ] -> [ExpQ] forall a. a -> [a] -> [a] : [ExpQ] argShowExprs in [| showParen ($prec > 10) $body |]