{-# LANGUAGE CPP, TemplateHaskell #-}
module Data.GADT.Show.TH
    ( DeriveGShow(..)
    ) where

import Control.Applicative
import Control.Monad
import Data.Dependent.Sum
import Data.Dependent.Sum.TH.Internal
import Data.Functor.Identity
import Data.GADT.Show
import Data.Traversable (for)
import Data.List
import Language.Haskell.TH
import Language.Haskell.TH.Extras

class DeriveGShow t where
    deriveGShow :: t -> Q [Dec]

instance DeriveGShow Name where
    deriveGShow :: Name -> Q [Dec]
deriveGShow Name
typeName = do
        Info
typeInfo <- Name -> Q Info
reify Name
typeName
        case Info
typeInfo of
            TyConI Dec
dec -> Dec -> Q [Dec]
forall t. DeriveGShow t => t -> Q [Dec]
deriveGShow Dec
dec
            Info
_ -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"deriveGShow: the name of a type constructor is required"

instance DeriveGShow Dec where
    deriveGShow :: Dec -> Q [Dec]
deriveGShow = Name
-> (Q Type -> Q Type)
-> ([TyVarBndrSpec] -> [Con] -> Q Dec)
-> Dec
-> Q [Dec]
deriveForDec ''GShow (\Q Type
t -> [t| GShow $t |]) (([TyVarBndrSpec] -> [Con] -> Q Dec) -> Dec -> Q [Dec])
-> ([TyVarBndrSpec] -> [Con] -> Q Dec) -> Dec -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \[TyVarBndrSpec]
_ -> [Con] -> Q Dec
gshowFunction

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 :: [Con] -> Q Dec
gshowFunction = Name -> [ClauseQ] -> Q Dec
funD 'gshowsPrec ([ClauseQ] -> Q Dec) -> ([Con] -> [ClauseQ]) -> [Con] -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Con -> ClauseQ) -> [Con] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map Con -> ClauseQ
gshowClause

gshowClause :: Con -> ClauseQ
gshowClause Con
con = do
    let conName :: Name
conName  = Con -> Name
nameOfCon Con
con
        argTypes :: [Type]
argTypes = Con -> [Type]
argTypesOfCon Con
con
        nArgs :: Int
nArgs    = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
argTypes

        precName :: Name
precName = String -> Name
mkName String
"p"

    [Name]
argNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
nArgs (String -> Q Name
newName String
"x")

    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

    [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
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 -> [Name] -> ExpQ
gshowBody (Name -> ExpQ
varE Name
precName) Name
conName [Name]
argNames)) []

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

gshowBody :: ExpQ -> Name -> [Name] -> ExpQ
gshowBody ExpQ
prec Name
conName [] = Name -> ExpQ
showsName Name
conName
gshowBody ExpQ
prec Name
conName [Name]
argNames =
    [| showParen ($prec > 10) $( composeExprs $ intersperse [| showChar ' ' |]
        ( showsName conName
        : [ [| showsPrec 11 $arg |]
          | argName <- argNames, let arg = varE argName
          ]
        ))
     |]