{-# 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 = 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 forall a. [a] -> [a] reverse [Type] instTypes of [] -> forall (m :: * -> *) a. MonadFail m => String -> m a fail String "deriveGEq: Not enough type parameters" (Type _:[Type] xs) -> forall a. [a] -> [a] reverse [Type] xs instanceHead :: Type instanceHead = Type -> Type -> Type AppT (Name -> Type ConT ''GShow) (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) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w) runWriterT (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)) forall (m :: * -> *) a. Monad m => a -> m a return [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec InstanceD forall a. Maybe a Nothing (DatatypeInfo -> [Type] datatypeContext DatatypeInfo typeInfo 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 forall a b. (a -> b) -> a -> b $ \DatatypeInfo typeInfo -> do let instTypes :: [Type] instTypes = DatatypeInfo -> [Type] datatypeInstTypes DatatypeInfo typeInfo paramVars :: Set Name paramVars = 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 <- 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) forall (m :: * -> *) a. Monad m => a -> m a return 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] = forall t. DeriveGShow t => t -> Q [Dec] deriveGShow t it deriveGShow [t] _ = 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 = (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= 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 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 = forall a. Ord a => [a] -> Set a Set.fromList (forall a b. (a -> b) -> [a] -> [b] map forall flag. TyVarBndr_ flag -> Name tvName (ConstructorInfo -> [TyVarBndrUnit] constructorVars ConstructorInfo con)) Name precName <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). Quote m => String -> m Name newName String "prec" [Name] argNames <- forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM [Type] argTypes forall a b. (a -> b) -> a -> b $ \Type _ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). Quote m => String -> m Name newName String "x" [Q Exp] argShowExprs <- forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM (forall a b. [a] -> [b] -> [(a, b)] zip [Name] argNames [Type] argTypes) forall a b. (a -> b) -> a -> b $ \(Name n,Type t) -> do let useShow :: WriterT [Type] Q (Q Exp) useShow = do [Dec] u <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift 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] _) -> forall (m :: * -> *) a. Monad m => a -> m a return () [Dec] _ -> forall w (m :: * -> *). MonadWriter w m => w -> m () tell [Type -> Type -> Type AppT (Name -> Type ConT ''Show) Type t] 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 forall (m :: * -> *) a. Monad m => a -> m a return [| gshowsPrec 11 $(varE n) |] else WriterT [Type] Q (Q Exp) useShow Type _ -> WriterT [Type] Q (Q Exp) useShow let precPat :: Q Pat precPat = if forall (t :: * -> *) a. Foldable t => t a -> Bool null [Name] argNames then forall (m :: * -> *). Quote m => m Pat wildP else forall (m :: * -> *). Quote m => Name -> m Pat varP Name precName forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause clause [Q Pat precPat, forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat conP Name conName (forall a b. (a -> b) -> [a] -> [b] map forall (m :: * -> *). Quote m => Name -> m Pat varP [Name] argNames)] (forall (m :: * -> *). Quote m => m Exp -> m Body normalB (Q Exp -> Name -> [Q Exp] -> Q Exp gshowBody (forall (m :: * -> *). Quote m => Name -> m Exp varE Name precName) Name conName [Q Exp] argShowExprs)) [] showsName :: Name -> m Exp showsName Name name = [| showString $(litE . stringL $ nameBase name) |] gshowBody :: Q Exp -> Name -> [Q Exp] -> Q Exp gshowBody :: Q Exp -> Name -> [Q Exp] -> Q Exp gshowBody Q Exp prec Name conName [] = forall (m :: * -> *). Quote m => Name -> m Exp showsName Name conName gshowBody Q Exp prec Name conName [Q Exp] argShowExprs = let body :: Q Exp body = forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (\Q Exp e Q Exp es -> [| $e . $es |]) [| id |] forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. a -> [a] -> [a] intersperse [| showChar ' ' |] forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). Quote m => Name -> m Exp showsName Name conName forall a. a -> [a] -> [a] : [Q Exp] argShowExprs in [| showParen ($prec > 10) $body |]