{-# 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 = forall a. Show a => a -> BuiltinString
show a
x forall a. a -> [a] -> [a]
: [BuiltinString]
ss

    {-# INLINEABLE show #-}
    show :: a -> BuiltinString
    show a
x = [BuiltinString] -> BuiltinString
concatBuiltinStrings (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]

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

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

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

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

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

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

{-# INLINEABLE concatBuiltinStrings #-}
concatBuiltinStrings :: [BuiltinString] -> BuiltinString
concatBuiltinStrings :: [BuiltinString] -> BuiltinString
concatBuiltinStrings = \case
    [] -> BuiltinString
""
    [BuiltinString
x] -> BuiltinString
x
    [BuiltinString]
xs ->
        let ([BuiltinString]
ys, [BuiltinString]
zs) = forall a. Integer -> [a] -> ([a], [a])
splitAt (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

-- | 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Name
varTToName 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) 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) forall a b. (a -> 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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
TH.instanceD (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
instanceCxt) (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 =
    [ 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
      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 = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [] Q Body
body []
    body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB 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 <- forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"_p" -- The precedence argument. It is not always used, hence the leading `_`.
    Name
value <- forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"_value" -- The value to be shown
    let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
p, forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
value]
        body :: Q Exp
body = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
TH.caseE (forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
value) (Name -> ConstructorInfo -> Q Match
deriveMatchForCon Name
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorInfo]
cons)
    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 = []
        } ->
            forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match
                (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
TH.conP Name
conName [])
                (forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB [| showString  $(TH.stringE (parenInfixConName 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 <-
                forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Integer
1 .. forall (t :: * -> *) a. Foldable t => t a -> Integer
length [Type]
argTys] forall a b. (a -> b) -> a -> b
$ \Integer
i ->
                   forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String
"arg" forall a. Semigroup a => a -> a -> a
<> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args
                parenCommaArgExps :: [Q Exp]
parenCommaArgExps =
                    (forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE String
"(") forall a. a -> [a] -> [a]
:
                    forall a. a -> [a] -> [a]
intersperse (forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE String
",") [Q Exp]
showArgExps
                mappendArgs :: Q Exp
mappendArgs =
                    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Haskell.foldr
                        (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
`TH.infixApp` forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE '(Haskell..))
                        (forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE String
")")
                        [Q Exp]
parenCommaArgExps
                pats :: Q Pat
pats = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
TH.conP Name
conName (forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
                body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB Q Exp
mappendArgs
            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 <-
                forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Integer
1 .. forall (t :: * -> *) a. Foldable t => t a -> Integer
length [Type]
argTys] forall a b. (a -> b) -> a -> b
$ \Integer
i ->
                   forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String
"arg" forall a. Semigroup a => a -> a -> a
<> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args

                mappendArgs, namedArgs :: TH.Q TH.Exp
                mappendArgs :: Q Exp
mappendArgs = 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 = [|$argExp . showSpace . $acc|]
                namedArgs :: Q Exp
namedArgs =
                    [|
                        showString
                            $(TH.stringE (parenInfixConName conName <> " "))
                            . $mappendArgs
                        |]
            let pats :: Q Pat
pats = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
TH.conP Name
conName (forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
                body :: Q Body
body =
                    forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB
                        [|
                            $(TH.varE 'showParen)
                                ( $(TH.varE p)
                                    `greaterThanInteger` $(TH.litE (TH.integerL appPrec))
                                )
                                $namedArgs
                            |]
            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 <-
                forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Haskell.traverse
                    (\Integer
i -> forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String
"arg" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
Haskell.show Integer
i))
                    [Integer
1 .. 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 = forall a. Int -> [a] -> [a]
dropEnd Int
1 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Haskell.foldMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Name -> [Q Exp]
f) (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 -> ShowS -> ShowS
Haskell.showParen
                                    (String -> Bool
isSym String
argNameBase)
                                    (String -> ShowS
Haskell.showString String
argNameBase)
                                    String
""
                         in [ forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE (String
infixRec forall a. Semigroup a => a -> a -> a
<> String
" = ")
                            , Integer -> Name -> Q Exp
deriveShowExpForArg Integer
0 Name
arg
                            , forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showCommaSpace
                            ]
                braceCommaArgExps :: [Q Exp]
braceCommaArgExps = (forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE String
"{") forall a. a -> [a] -> [a]
: [Q Exp]
showArgExps
                mappendArgs :: Q Exp
mappendArgs =
                    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Haskell.foldr
                        (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
`TH.infixApp` forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE '(Haskell..))
                        (forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE String
"}")
                        [Q Exp]
braceCommaArgExps
                namedArgs :: Q Exp
namedArgs =
                    [|
                        showString $(TH.stringE (parenInfixConName conName <> " "))
                            . $mappendArgs
                        |]
                pats :: Q Pat
pats = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
TH.conP Name
conName (forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
                body :: Q Body
body =
                    forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB
                        [|
                            showParen
                                ($(TH.varE p) `greaterThanInteger` $(TH.litE (TH.integerL appPrec)))
                                $namedArgs
                            |]
            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 <- forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"argL"
            Name
ar <- forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"argR"
            Fixity
fi <- forall a. a -> Maybe a -> a
fromMaybe Fixity
TH.defaultFixity 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
_ -> 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 =
                    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
TH.appE (forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'showString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE forall a b. (a -> b) -> a -> b
$
                        if String -> Bool
isInfixDataCon String
opName
                            then String
" " forall a. Semigroup a => a -> a -> a
<> String
opName forall a. Semigroup a => a -> a -> a
<> String
" "
                            else String
" `" forall a. Semigroup a => a -> a -> a
<> String
opName forall a. Semigroup a => a -> a -> a
<> String
"` "
                showArgLExp :: Q Exp
showArgLExp = Integer -> Name -> Q Exp
deriveShowExpForArg (Integer
conPrec forall a. Num a => a -> a -> a
+ Integer
1) Name
al
                showArgRExp :: Q Exp
showArgRExp = Integer -> Name -> Q Exp
deriveShowExpForArg (Integer
conPrec forall a. Num a => a -> a -> a
+ Integer
1) Name
ar
                pats :: Q Pat
pats = forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
TH.infixP (forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
al) Name
conName (forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
ar)
                body :: Q Body
body =
                    forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB
                        [|
                            showParen
                                ($(TH.varE p) `greaterThanInteger` $(TH.litE (TH.integerL conPrec)))
                                ($showArgLExp . $infixOpE . $showArgRExp)
                            |]
            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 $(TH.varE 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 -> ShowS -> ShowS
Haskell.showParen (String -> Bool
isInfixDataCon String
conNameBase) (String -> ShowS
Haskell.showString String
conNameBase) String
""