{-# 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 a. String -> [a] 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 b a. (b -> a -> b) -> b -> [a] -> b 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) forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> Q a 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) forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> WriterT [Type] Q a 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 a. String -> Q a 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 a b. Q a -> (a -> Q b) -> Q b 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_ () -> Name) -> [TyVarBndr_ ()] -> [Name] forall a b. (a -> b) -> [a] -> [b] map TyVarBndr_ () -> Name forall flag. TyVarBndr_ flag -> Name tvName (ConstructorInfo -> [TyVarBndr_ ()] constructorVars ConstructorInfo con)) Name precName <- Q Name -> WriterT [Type] Q Name forall (m :: * -> *) a. Monad m => m a -> WriterT [Type] m a 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 forall (m :: * -> *). Quote m => String -> m 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 (m :: * -> *) a. Monad m => m a -> WriterT [Type] m a 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 forall (m :: * -> *). Quote m => String -> m Name newName String "x" [Q Exp] argShowExprs <- [(Name, Type)] -> ((Name, Type) -> WriterT [Type] Q (Q Exp)) -> WriterT [Type] Q [Q Exp] 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 (Q Exp)) -> WriterT [Type] Q [Q Exp]) -> ((Name, Type) -> WriterT [Type] Q (Q Exp)) -> WriterT [Type] Q [Q Exp] forall a b. (a -> b) -> a -> b $ \(Name n,Type t) -> do let useShow :: WriterT [Type] Q (Q Exp) useShow = do [Dec] u <- Q [Dec] -> WriterT [Type] Q [Dec] forall (m :: * -> *) a. Monad m => m a -> WriterT [Type] m a 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 a. a -> WriterT [Type] Q a 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] Q Exp -> WriterT [Type] Q (Q Exp) forall a. a -> WriterT [Type] Q a forall (m :: * -> *) a. Monad m => a -> m a return [| showsPrec 11 $(Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp varE Name n) |] case Type t of AppT Type tyFun Type tyArg -> do if Type -> Type -> Bool isApplicationOf (Name -> Type ConT Name typeName) Type tyFun then Q Exp -> WriterT [Type] Q (Q Exp) forall a. a -> WriterT [Type] Q a forall (m :: * -> *) a. Monad m => a -> m a return [| gshowsPrec 11 $(Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp varE Name n) |] else WriterT [Type] Q (Q Exp) useShow Type _ -> WriterT [Type] Q (Q Exp) useShow let precPat :: Q Pat precPat = if [Name] -> Bool forall a. [a] -> 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 Clause -> WriterT [Type] Q Clause forall (m :: * -> *) a. Monad m => m a -> WriterT [Type] m a 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 $ [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 -> [Q Exp] -> Q Exp gshowBody (Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp varE Name precName) Name conName [Q Exp] argShowExprs)) [] showsName :: Name -> m Exp showsName Name name = [| showString $(Lit -> m Exp forall (m :: * -> *). Quote m => Lit -> m Exp litE (Lit -> m Exp) -> (String -> Lit) -> String -> m Exp forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Lit stringL (String -> m Exp) -> String -> m Exp forall a b. (a -> b) -> a -> b $ Name -> String nameBase Name name) |] gshowBody :: Q Exp -> Name -> [Q Exp] -> Q Exp gshowBody :: Q Exp -> Name -> [Q Exp] -> 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 [Q Exp] argShowExprs = let body :: Q Exp body = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp forall a b. (a -> b -> b) -> b -> [a] -> b forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (\Q Exp e Q Exp es -> [| $Q Exp e . $Q Exp es |]) [| id |] ([Q Exp] -> Q Exp) -> ([Q Exp] -> [Q Exp]) -> [Q Exp] -> Q Exp forall b c a. (b -> c) -> (a -> b) -> a -> c . Q Exp -> [Q Exp] -> [Q Exp] forall a. a -> [a] -> [a] intersperse [| showChar ' ' |] ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp forall a b. (a -> b) -> a -> b $ Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp showsName Name conName Q Exp -> [Q Exp] -> [Q Exp] forall a. a -> [a] -> [a] : [Q Exp] argShowExprs in [| showParen ($Q Exp prec > 10) $Q Exp body |]