{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}

module PlutusTx.Show.TH where

import PlutusTx.Base
import PlutusTx.Bool
import PlutusTx.Builtins
import PlutusTx.Foldable
import PlutusTx.List

import Data.Deriving.Internal (isInfixDataCon, isNonUnitTuple, isSym, varTToName)
import Data.List.Extra (dropEnd, foldl', intersperse)
import Data.Maybe
import Data.Traversable (for)
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Datatype qualified as TH
import Prelude (pure, (+), (<$>), (<>))
import Prelude qualified as Haskell

{- | Conversion of values to `BuiltinString`s. Unlike @GHC.Show.Show@, there is no
 @showList@ method, because there is no `Show` instance for `Data.String.String`.
-}
class Show a where
    {-# MINIMAL showsPrec | show #-}

    {-# INLINEABLE showsPrec #-}
    showsPrec :: Integer -> a -> ShowS
    showsPrec Integer
_ a
x [BuiltinString]
ss = a -> BuiltinString
forall a. Show a => a -> BuiltinString
show a
x BuiltinString -> ShowS
forall a. a -> [a] -> [a]
: [BuiltinString]
ss

    {-# INLINEABLE show #-}
    show :: a -> BuiltinString
    show a
x = [BuiltinString] -> BuiltinString
concatBuiltinStrings (Integer -> a -> ShowS
forall a. Show a => Integer -> a -> ShowS
showsPrec Integer
0 a
x [])

{- | Currently the only way to concatenate `BuiltinString`s is `appendString`, whose cost
 is linear in the total length of the two strings. A naive concatenation of multiple
 `BuiltinString`s costs @O(n^2)@ in the worst case, where @n@ is the total length. By
 collecting the `BuiltinString`s in a list and concatenating them in the end, the cost
 can be reduced to @O(n*logn)@. If we add a @concatStrings@ builtin function in the future,
 the cost can be further reduced to @O(n)@.

 Like `GHC.Show.ShowS`, the purpose of the function type here is to turn list concatenation
 into function composition.
-}
type ShowS = [BuiltinString] -> [BuiltinString]

showString :: BuiltinString -> ShowS
showString :: BuiltinString -> ShowS
showString = (:)
{-# INLINEABLE showString #-}

showSpace :: ShowS
showSpace :: ShowS
showSpace = BuiltinString -> ShowS
showString BuiltinString
" "
{-# INLINEABLE showSpace #-}

showCommaSpace :: ShowS
showCommaSpace :: ShowS
showCommaSpace = BuiltinString -> ShowS
showString BuiltinString
", "
{-# INLINEABLE showCommaSpace #-}

showParen :: Bool -> ShowS -> ShowS
showParen :: Bool -> ShowS -> ShowS
showParen Bool
b ShowS
p = if Bool
b then BuiltinString -> ShowS
showString BuiltinString
"(" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinString -> ShowS
showString BuiltinString
")" else ShowS
p
{-# INLINEABLE showParen #-}

appPrec :: Integer
appPrec :: Integer
appPrec = Integer
10
{-# INLINEABLE appPrec #-}

appPrec1 :: Integer
appPrec1 :: Integer
appPrec1 = Integer
11
{-# INLINEABLE appPrec1 #-}

concatBuiltinStrings :: [BuiltinString] -> BuiltinString
concatBuiltinStrings :: [BuiltinString] -> BuiltinString
concatBuiltinStrings = \case
    [] -> BuiltinString
""
    [BuiltinString
x] -> BuiltinString
x
    [BuiltinString]
xs ->
        let ([BuiltinString]
ys, [BuiltinString]
zs) = Integer -> [BuiltinString] -> ([BuiltinString], [BuiltinString])
forall a. Integer -> [a] -> ([a], [a])
splitAt ([BuiltinString] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length [BuiltinString]
xs Integer -> Integer -> Integer
`divideInteger` Integer
2) [BuiltinString]
xs
         in [BuiltinString] -> BuiltinString
concatBuiltinStrings [BuiltinString]
ys BuiltinString -> BuiltinString -> BuiltinString
`appendString` [BuiltinString] -> BuiltinString
concatBuiltinStrings [BuiltinString]
zs
{-# INLINEABLE concatBuiltinStrings #-}

-- | Derive `Show` instance. Adapted from @Text.Show.Deriving.deriveShow@.
deriveShow :: TH.Name -> TH.Q [TH.Dec]
deriveShow :: Name -> Q [Dec]
deriveShow Name
name = do
    TH.DatatypeInfo
        { datatypeName :: DatatypeInfo -> Name
TH.datatypeName = Name
tyConName
        , datatypeInstTypes :: DatatypeInfo -> [Type]
TH.datatypeInstTypes = [Type]
tyVars0
        , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
TH.datatypeCons = [ConstructorInfo]
cons
        } <-
        Name -> Q DatatypeInfo
TH.reifyDatatype Name
name
    let -- The purpose of the `TH.VarT . varTToName` roundtrip is to remove the kind
        -- signatures attached to the type variables in `tyVars0`. Otherwise, the
        -- `KindSignatures` extension would be needed whenever `length tyVars0 > 0`.
        tyVars :: [Type]
tyVars = Name -> Type
TH.VarT (Name -> Type) -> (Type -> Name) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Name
varTToName (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
tyVars0
        instanceCxt :: TH.Cxt
        instanceCxt :: [Type]
instanceCxt = Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT ''Show) (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
tyVars
        instanceType :: TH.Type
        instanceType :: Type
instanceType = Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT ''Show) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ (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
TH.AppT (Name -> Type
TH.ConT Name
tyConName) [Type]
tyVars
        showsPrecDecs :: [Q Dec]
showsPrecDecs = [ConstructorInfo] -> [Q Dec]
deriveShowsPrec [ConstructorInfo]
cons
    Dec -> [Dec]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
TH.instanceD ([Type] -> Q [Type]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
instanceCxt) (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
instanceType) [Q Dec]
showsPrecDecs

-- | Derive `showsPrec` definition for each data constructor.
deriveShowsPrec :: [TH.ConstructorInfo] -> [TH.Q TH.Dec]
deriveShowsPrec :: [ConstructorInfo] -> [Q Dec]
deriveShowsPrec [ConstructorInfo]
cons =
    [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
TH.funD 'showsPrec [Q Clause
clause]
    , -- `showsPrec` must be inlinable for the plugin to inline it
      Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
TH.pragInlD 'showsPrec Inline
TH.Inlinable RuleMatch
TH.FunLike Phases
TH.AllPhases
    ]
  where
    clause :: Q Clause
clause = [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [] Q Body
body []
    body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [ConstructorInfo] -> Q Exp
deriveShowsPrecBody [ConstructorInfo]
cons

deriveShowsPrecBody :: [TH.ConstructorInfo] -> TH.Q TH.Exp
deriveShowsPrecBody :: [ConstructorInfo] -> Q Exp
deriveShowsPrecBody [ConstructorInfo]
cons = do
    Name
p <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"_p" -- The precedence argument. It is not always used, hence the leading `_`.
    Name
value <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"_value" -- The value to be shown
    let pats :: [Q Pat]
pats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
p, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
value]
        body :: Q Exp
body = Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
TH.caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
value) (Name -> ConstructorInfo -> Q Match
deriveMatchForCon Name
p (ConstructorInfo -> Q Match) -> [ConstructorInfo] -> [Q Match]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorInfo]
cons)
    [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
TH.lamE [Q Pat]
pats Q Exp
body

-- | Derive `showsPrec` body for a single data constructor.
deriveMatchForCon :: TH.Name -> TH.ConstructorInfo -> TH.Q TH.Match
deriveMatchForCon :: Name -> ConstructorInfo -> Q Match
deriveMatchForCon Name
p = \case
    -- Need a special case for nullary constructors, because
    -- @showParen (_p `greaterThanInteger` 10)@ is not needed for nullary constructors.
    TH.ConstructorInfo
        { constructorName :: ConstructorInfo -> Name
TH.constructorName = Name
conName
        , constructorFields :: ConstructorInfo -> [Type]
TH.constructorFields = []
        } ->
            Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match
                (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
TH.conP Name
conName [])
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB [| showString  $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE (Name -> String
parenInfixConName Name
conName))|])
                []
    TH.ConstructorInfo
        { constructorName :: ConstructorInfo -> Name
TH.constructorName = Name
conName
        , constructorVariant :: ConstructorInfo -> ConstructorVariant
TH.constructorVariant = ConstructorVariant
TH.NormalConstructor
        , constructorFields :: ConstructorInfo -> [Type]
TH.constructorFields = argTys :: [Type]
argTys@(Type
_ : [Type]
_)
        } | Name -> Bool
isNonUnitTuple Name
conName -> do
            {- Derive `showsPrec` body for a tuple constructor.
               Example: (,,)
               Output:
                 case _value of (,,) arg1 arg2 arg3 ->
                   showString "("
                   . showsPrec 0 arg1 . showString ","
                   . showsPrec 0 arg2 . showString ","
                   . showsPrec 0 arg3 . showString ")"
            -}
            [Name]
args <-
                [Integer] -> (Integer -> Q Name) -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Integer
1 .. [Type] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length [Type]
argTys] ((Integer -> Q Name) -> Q [Name])
-> (Integer -> Q Name) -> Q [Name]
forall a b. (a -> b) -> a -> b
$ \Integer
i ->
                   String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String
"arg" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
Haskell.show Integer
i)

            let showArgExps :: [TH.Q TH.Exp]
                showArgExps :: [Q Exp]
showArgExps = Integer -> Name -> Q Exp
deriveShowExpForArg Integer
0 (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args
                parenCommaArgExps :: [Q Exp]
parenCommaArgExps =
                    (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE String
"(") Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:
                    Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
intersperse (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE String
",") [Q Exp]
showArgExps
                mappendArgs :: Q Exp
mappendArgs =
                    (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
Haskell.foldr
                        (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
`TH.infixApp` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE '(Haskell..))
                        (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE String
")")
                        [Q Exp]
parenCommaArgExps
                pats :: Q Pat
pats = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
TH.conP Name
conName (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP (Name -> Q Pat) -> [Name] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
                body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB Q Exp
mappendArgs
            Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match Q Pat
pats Q Body
body []
          | Bool
otherwise -> do
            {- Derive `showsPrec` body for a non-tuple constructor.
               Example: C a b
               Output:
                 case _value of C arg1 arg2 ->
                   showParen
                     (_p `greaterThanInteger` 10)
                     (showString "C " . showsPrec 11 arg1 . showSpace . showsPrec 11 arg2)
            -}
            [Name]
args <-
                [Integer] -> (Integer -> Q Name) -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Integer
1 .. [Type] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length [Type]
argTys] ((Integer -> Q Name) -> Q [Name])
-> (Integer -> Q Name) -> Q [Name]
forall a b. (a -> b) -> a -> b
$ \Integer
i ->
                   String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String
"arg" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
Haskell.show Integer
i)
            let showArgExps :: [TH.Q TH.Exp]
                showArgExps :: [Q Exp]
showArgExps = Integer -> Name -> Q Exp
deriveShowExpForArg Integer
appPrec1 (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args

                mappendArgs, namedArgs :: TH.Q TH.Exp
                mappendArgs :: Q Exp
mappendArgs = (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
Haskell.foldr1 Q Exp -> Q Exp -> Q Exp
alg [Q Exp]
showArgExps
                    where
                    alg :: TH.Q TH.Exp -> TH.Q TH.Exp -> TH.Q TH.Exp
                    alg :: Q Exp -> Q Exp -> Q Exp
alg Q Exp
argExp Q Exp
acc = [|$Q Exp
argExp . showSpace . $Q Exp
acc|]
                namedArgs :: Q Exp
namedArgs =
                    [|
                        showString
                            $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE (Name -> String
parenInfixConName Name
conName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" "))
                            . $Q Exp
mappendArgs
                        |]
            let pats :: Q Pat
pats = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
TH.conP Name
conName (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP (Name -> Q Pat) -> [Name] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
                body :: Q Body
body =
                    Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB
                        [|
                            $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showParen)
                                ( $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
p)
                                    `greaterThanInteger` $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
TH.litE (Integer -> Lit
TH.integerL Integer
appPrec))
                                )
                                $Q Exp
namedArgs
                            |]
            Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match Q Pat
pats Q Body
body []
    {- Derive `showsPrec` body for a tuple constructor.
       Example: C {c1 ;: a, c2 :: b}
       Output:
         case _value of C arg1 arg2 ->
           showParen
             (_p `greaterThanInteger` 10)
             (showString "C " . showString "{"
                . showString "c1 = " . showsPrec 0 arg1
                . showCommaSpace
                . showString "c2 = " . showsPrec 0 arg2
                . showString "}")
    -}
    TH.ConstructorInfo
        { constructorName :: ConstructorInfo -> Name
TH.constructorName = Name
conName
        , constructorVariant :: ConstructorInfo -> ConstructorVariant
TH.constructorVariant = TH.RecordConstructor [Name]
argNames
        , constructorFields :: ConstructorInfo -> [Type]
TH.constructorFields = argTys :: [Type]
argTys@(Type
_ : [Type]
_)
        } -> do
            [Name]
args <-
                (Integer -> Q Name) -> [Integer] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
Haskell.traverse
                    (\Integer
i -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String
"arg" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
Haskell.show Integer
i))
                    [Integer
1 .. [Type] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length [Type]
argTys]
            let showArgExps :: [TH.Q TH.Exp]
                -- The `dropEnd` drops the last comma
                showArgExps :: [Q Exp]
showArgExps = Int -> [Q Exp] -> [Q Exp]
forall a. Int -> [a] -> [a]
dropEnd Int
1 ([Q Exp] -> [Q Exp]) -> [Q Exp] -> [Q Exp]
forall a b. (a -> b) -> a -> b
$ ((Name, Name) -> [Q Exp]) -> [(Name, Name)] -> [Q Exp]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Haskell.foldMap ((Name -> Name -> [Q Exp]) -> (Name, Name) -> [Q Exp]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Name -> [Q Exp]
f) ([Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
Haskell.zip [Name]
argNames [Name]
args)
                  where
                    f :: TH.Name -> TH.Name -> [TH.Q TH.Exp]
                    f :: Name -> Name -> [Q Exp]
f Name
argName Name
arg =
                        let argNameBase :: String
argNameBase = Name -> String
TH.nameBase Name
argName
                            infixRec :: String
infixRec =
                                Bool -> (String -> String) -> String -> String
Haskell.showParen
                                    (String -> Bool
isSym String
argNameBase)
                                    (String -> String -> String
Haskell.showString String
argNameBase)
                                    String
""
                         in [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE (String
infixRec String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = ")
                            , Integer -> Name -> Q Exp
deriveShowExpForArg Integer
0 Name
arg
                            , Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showCommaSpace
                            ]
                braceCommaArgExps :: [Q Exp]
braceCommaArgExps = (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE String
"{") Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
showArgExps
                mappendArgs :: Q Exp
mappendArgs =
                    (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
Haskell.foldr
                        (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
`TH.infixApp` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE '(Haskell..))
                        (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE String
"}")
                        [Q Exp]
braceCommaArgExps
                namedArgs :: Q Exp
namedArgs =
                    [|
                        showString $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE (Name -> String
parenInfixConName Name
conName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" "))
                            . $Q Exp
mappendArgs
                        |]
                pats :: Q Pat
pats = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
TH.conP Name
conName (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP (Name -> Q Pat) -> [Name] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
                body :: Q Body
body =
                    Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB
                        [|
                            showParen
                                ($(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
p) `greaterThanInteger` $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
TH.litE (Integer -> Lit
TH.integerL Integer
appPrec)))
                                $Q Exp
namedArgs
                            |]
            Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match Q Pat
pats Q Body
body []
    {- Derive `showsPrec` body for an infix constructor.
       Example: a :+: b, where (:+:) has fixity 9
       Output:
         case _value of argL :+: argR ->
           showParen
             (_p `greaterThanInteger` 9)
             (showsPrec 10 argL . showString " :+: " . showsPrec 10 argR)
    -}
    TH.ConstructorInfo
        { constructorName :: ConstructorInfo -> Name
TH.constructorName = Name
conName
        , constructorVariant :: ConstructorInfo -> ConstructorVariant
TH.constructorVariant = ConstructorVariant
TH.InfixConstructor
        } -> do
            Name
al <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"argL"
            Name
ar <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"argR"
            Fixity
fi <- Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
TH.defaultFixity (Maybe Fixity -> Fixity) -> Q (Maybe Fixity) -> Q Fixity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q (Maybe Fixity)
TH.reifyFixityCompat Name
conName
            let conPrec :: Integer
conPrec = case Fixity
fi of TH.Fixity Int
prec FixityDirection
_ -> Int -> Integer
forall a b. (Integral a, Num b) => a -> b
Haskell.fromIntegral Int
prec
                opName :: String
opName = Name -> String
TH.nameBase Name
conName
                infixOpE :: Q Exp
infixOpE =
                    Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
TH.appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString) (Q Exp -> Q Exp) -> (String -> Q Exp) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$
                        if String -> Bool
isInfixDataCon String
opName
                            then String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
opName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" "
                            else String
" `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
opName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"` "
                showArgLExp :: Q Exp
showArgLExp = Integer -> Name -> Q Exp
deriveShowExpForArg (Integer
conPrec Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Name
al
                showArgRExp :: Q Exp
showArgRExp = Integer -> Name -> Q Exp
deriveShowExpForArg (Integer
conPrec Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Name
ar
                pats :: Q Pat
pats = Q Pat -> Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
TH.infixP (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
al) Name
conName (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
ar)
                body :: Q Body
body =
                    Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB
                        [|
                            showParen
                                ($(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
p) `greaterThanInteger` $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
TH.litE (Integer -> Lit
TH.integerL Integer
conPrec)))
                                ($Q Exp
showArgLExp . $Q Exp
infixOpE . $Q Exp
showArgRExp)
                            |]
            Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match Q Pat
pats Q Body
body []

-- | Derive the `showsPrec` expression for showing a single constructor argument.
deriveShowExpForArg :: Integer -> TH.Name -> TH.Q TH.Exp
deriveShowExpForArg :: Integer -> Name -> Q Exp
deriveShowExpForArg Integer
p Name
tyExpName =
    [| showsPrec p $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
tyExpName)|]

-- | Add parens if it is an infix data constructor.
parenInfixConName :: TH.Name -> Haskell.String
parenInfixConName :: Name -> String
parenInfixConName Name
conName =
    let conNameBase :: String
conNameBase = Name -> String
TH.nameBase Name
conName
     in Bool -> (String -> String) -> String -> String
Haskell.showParen (String -> Bool
isInfixDataCon String
conNameBase) (String -> String -> String
Haskell.showString String
conNameBase) String
""