{-# 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 |]