{-# 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 (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 (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)
mapM (Name -> Set Name -> ConstructorInfo -> WriterT [Type] Q Clause
gshowClause Name
typeName Set Name
paramVars) (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
typeInfo))

  [Dec] -> Q [Dec]
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)
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 (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 (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 (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_ Any -> Name) -> [TyVarBndr_ Any] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ Any -> Name
forall flag. TyVarBndr_ Any -> Name
tvName (ConstructorInfo -> [TyVarBndr_ Any]
constructorVars ConstructorInfo
con))

  Name
precName <- Q Name -> WriterT [Type] Q Name
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
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 (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
newName String
"x"

  [ExpQ]
argShowExprs <- [(Name, Type)]
-> ((Name, Type) -> WriterT [Type] Q ExpQ)
-> WriterT [Type] Q [ExpQ]
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 ExpQ)
 -> WriterT [Type] Q [ExpQ])
-> ((Name, Type) -> WriterT [Type] Q ExpQ)
-> WriterT [Type] Q [ExpQ]
forall a b. (a -> b) -> a -> b
$ \(Name
n,Type
t) -> do
    let useShow :: WriterT [Type] Q ExpQ
useShow = do
          [Dec]
u <- Q [Dec] -> WriterT [Type] Q [Dec]
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 (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]
          ExpQ -> WriterT [Type] Q ExpQ
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 ExpQ -> WriterT [Type] Q ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return [| gshowsPrec 11 $(varE n) |]
          else WriterT [Type] Q ExpQ
useShow
      Type
_ -> WriterT [Type] Q ExpQ
useShow

  let precPat :: PatQ
precPat = if [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
argNames
        then PatQ
wildP
        else Name -> PatQ
varP Name
precName

  Q Clause -> WriterT [Type] Q Clause
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
$ [PatQ] -> BodyQ -> [DecQ] -> Q Clause
clause [PatQ
precPat, Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
argNames)]
    (ExpQ -> BodyQ
normalB (ExpQ -> Name -> [ExpQ] -> ExpQ
gshowBody (Name -> ExpQ
varE Name
precName) Name
conName [ExpQ]
argShowExprs)) []

showsName :: Name -> ExpQ
showsName Name
name = [| showString $(litE . stringL $ nameBase name) |]

gshowBody :: Q Exp -> Name -> [Q Exp] -> Q Exp
gshowBody :: ExpQ -> Name -> [ExpQ] -> ExpQ
gshowBody ExpQ
prec Name
conName [] = Name -> ExpQ
showsName Name
conName
gshowBody ExpQ
prec Name
conName [ExpQ]
argShowExprs =
  let body :: ExpQ
body = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ExpQ
e ExpQ
es -> [| $e . $es |]) [| id |] ([ExpQ] -> ExpQ) -> ([ExpQ] -> [ExpQ]) -> [ExpQ] -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
intersperse [| showChar ' ' |] ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$
                 Name -> ExpQ
showsName Name
conName ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: [ExpQ]
argShowExprs
  in [| showParen ($prec > 10) $body |]