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