    {-# 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
      typeInfo <- Name -> Q DatatypeInfo
    reifyDatatype Name
    typeName
      let instTypes = DatatypeInfo -> [Type]
    datatypeInstTypes DatatypeInfo
    typeInfo
          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' = 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 -> 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')
      (clauses, cxt) <- runWriterT (mapM (gshowClause typeName paramVars) (datatypeCons typeInfo))

      return [InstanceD Nothing (datatypeContext typeInfo ++ cxt) instanceHead [gshowFunction 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]
          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)
          return $ gshowFunction 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))

      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"
      argNames <- forM argTypes $ \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"

      argShowExprs <- forM (zip argNames argTypes) $ \(Name
    n,Type
    t) -> do
        let useShow :: WriterT [Type] Q (Q Exp)
    useShow = do
              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 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]
              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 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 = 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

      lift $ clause [precPat, conP conName (map varP argNames)]
        (normalB (gshowBody (varE precName) conName 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 |]