{-# 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
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 [])
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
"(" 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 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) = 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
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
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
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]
,
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"
Name
value <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"_value"
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
deriveMatchForCon :: TH.Name -> TH.ConstructorInfo -> TH.Q TH.Match
deriveMatchForCon :: Name -> ConstructorInfo -> Q Match
deriveMatchForCon Name
p = \case
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
[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
[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 []
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]
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 []
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 []
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)|]
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
""