{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
module Text.Show.Deriving.Internal (
deriveShow
, deriveShowOptions
, makeShowsPrec
, makeShowsPrecOptions
, makeShow
, makeShowOptions
, makeShowList
, makeShowListOptions
, deriveShow1
, deriveShow1Options
#if defined(NEW_FUNCTOR_CLASSES)
, makeLiftShowsPrec
, makeLiftShowsPrecOptions
, makeLiftShowList
, makeLiftShowListOptions
#endif
, makeShowsPrec1
, makeShowsPrec1Options
#if defined(NEW_FUNCTOR_CLASSES)
, deriveShow2
, deriveShow2Options
, makeLiftShowsPrec2
, makeLiftShowsPrec2Options
, makeLiftShowList2
, makeLiftShowList2Options
, makeShowsPrec2
, makeShowsPrec2Options
#endif
, ShowOptions(..)
, defaultShowOptions
, legacyShowOptions
) where
import Data.Deriving.Internal
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import GHC.Show (appPrec, appPrec1)
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
data ShowOptions = ShowOptions
{ ShowOptions -> Bool
ghc8ShowBehavior :: Bool
, ShowOptions -> Bool
showEmptyCaseBehavior :: Bool
} deriving (ShowOptions -> ShowOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShowOptions -> ShowOptions -> Bool
$c/= :: ShowOptions -> ShowOptions -> Bool
== :: ShowOptions -> ShowOptions -> Bool
$c== :: ShowOptions -> ShowOptions -> Bool
Eq, Eq ShowOptions
ShowOptions -> ShowOptions -> Bool
ShowOptions -> ShowOptions -> Ordering
ShowOptions -> ShowOptions -> ShowOptions
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ShowOptions -> ShowOptions -> ShowOptions
$cmin :: ShowOptions -> ShowOptions -> ShowOptions
max :: ShowOptions -> ShowOptions -> ShowOptions
$cmax :: ShowOptions -> ShowOptions -> ShowOptions
>= :: ShowOptions -> ShowOptions -> Bool
$c>= :: ShowOptions -> ShowOptions -> Bool
> :: ShowOptions -> ShowOptions -> Bool
$c> :: ShowOptions -> ShowOptions -> Bool
<= :: ShowOptions -> ShowOptions -> Bool
$c<= :: ShowOptions -> ShowOptions -> Bool
< :: ShowOptions -> ShowOptions -> Bool
$c< :: ShowOptions -> ShowOptions -> Bool
compare :: ShowOptions -> ShowOptions -> Ordering
$ccompare :: ShowOptions -> ShowOptions -> Ordering
Ord, ReadPrec [ShowOptions]
ReadPrec ShowOptions
Int -> ReadS ShowOptions
ReadS [ShowOptions]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ShowOptions]
$creadListPrec :: ReadPrec [ShowOptions]
readPrec :: ReadPrec ShowOptions
$creadPrec :: ReadPrec ShowOptions
readList :: ReadS [ShowOptions]
$creadList :: ReadS [ShowOptions]
readsPrec :: Int -> ReadS ShowOptions
$creadsPrec :: Int -> ReadS ShowOptions
Read, Int -> ShowOptions -> ShowS
[ShowOptions] -> ShowS
ShowOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShowOptions] -> ShowS
$cshowList :: [ShowOptions] -> ShowS
show :: ShowOptions -> String
$cshow :: ShowOptions -> String
showsPrec :: Int -> ShowOptions -> ShowS
$cshowsPrec :: Int -> ShowOptions -> ShowS
Show)
defaultShowOptions :: ShowOptions
defaultShowOptions :: ShowOptions
defaultShowOptions =
ShowOptions { ghc8ShowBehavior :: Bool
ghc8ShowBehavior = Bool
True
, showEmptyCaseBehavior :: Bool
showEmptyCaseBehavior = Bool
False
}
legacyShowOptions :: ShowOptions
legacyShowOptions :: ShowOptions
legacyShowOptions = ShowOptions
{ ghc8ShowBehavior :: Bool
ghc8ShowBehavior =
#if __GLASGOW_HASKELL__ >= 711
Bool
True
#else
False
#endif
, showEmptyCaseBehavior :: Bool
showEmptyCaseBehavior = Bool
False
}
deriveShow :: Name -> Q [Dec]
deriveShow :: Name -> Q [Dec]
deriveShow = ShowOptions -> Name -> Q [Dec]
deriveShowOptions ShowOptions
defaultShowOptions
deriveShowOptions :: ShowOptions -> Name -> Q [Dec]
deriveShowOptions :: ShowOptions -> Name -> Q [Dec]
deriveShowOptions = ShowClass -> ShowOptions -> Name -> Q [Dec]
deriveShowClass ShowClass
Show
makeShow :: Name -> Q Exp
makeShow :: Name -> Q Exp
makeShow = ShowOptions -> Name -> Q Exp
makeShowOptions ShowOptions
defaultShowOptions
makeShowOptions :: ShowOptions -> Name -> Q Exp
makeShowOptions :: ShowOptions -> Name -> Q Exp
makeShowOptions ShowOptions
opts Name
name = do
Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x) forall a b. (a -> b) -> a -> b
$ ShowOptions -> Name -> Q Exp
makeShowsPrecOptions ShowOptions
opts Name
name
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
0
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE String
""
makeShowsPrec :: Name -> Q Exp
makeShowsPrec :: Name -> Q Exp
makeShowsPrec = ShowOptions -> Name -> Q Exp
makeShowsPrecOptions ShowOptions
defaultShowOptions
makeShowsPrecOptions :: ShowOptions -> Name -> Q Exp
makeShowsPrecOptions :: ShowOptions -> Name -> Q Exp
makeShowsPrecOptions = ShowClass -> ShowOptions -> Name -> Q Exp
makeShowsPrecClass ShowClass
Show
makeShowList :: Name -> Q Exp
makeShowList :: Name -> Q Exp
makeShowList = ShowOptions -> Name -> Q Exp
makeShowListOptions ShowOptions
defaultShowOptions
makeShowListOptions :: ShowOptions -> Name -> Q Exp
makeShowListOptions :: ShowOptions -> Name -> Q Exp
makeShowListOptions ShowOptions
opts Name
name =
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showListWithValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (ShowOptions -> Name -> Q Exp
makeShowsPrecOptions ShowOptions
opts Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
0)
deriveShow1 :: Name -> Q [Dec]
deriveShow1 :: Name -> Q [Dec]
deriveShow1 = ShowOptions -> Name -> Q [Dec]
deriveShow1Options ShowOptions
defaultShowOptions
deriveShow1Options :: ShowOptions -> Name -> Q [Dec]
deriveShow1Options :: ShowOptions -> Name -> Q [Dec]
deriveShow1Options = ShowClass -> ShowOptions -> Name -> Q [Dec]
deriveShowClass ShowClass
Show1
makeShowsPrec1 :: Name -> Q Exp
makeShowsPrec1 :: Name -> Q Exp
makeShowsPrec1 = ShowOptions -> Name -> Q Exp
makeShowsPrec1Options ShowOptions
defaultShowOptions
#if defined(NEW_FUNCTOR_CLASSES)
makeLiftShowsPrec :: Name -> Q Exp
makeLiftShowsPrec :: Name -> Q Exp
makeLiftShowsPrec = ShowOptions -> Name -> Q Exp
makeLiftShowsPrecOptions ShowOptions
defaultShowOptions
makeLiftShowsPrecOptions :: ShowOptions -> Name -> Q Exp
makeLiftShowsPrecOptions :: ShowOptions -> Name -> Q Exp
makeLiftShowsPrecOptions = ShowClass -> ShowOptions -> Name -> Q Exp
makeShowsPrecClass ShowClass
Show1
makeLiftShowList :: Name -> Q Exp
makeLiftShowList :: Name -> Q Exp
makeLiftShowList = ShowOptions -> Name -> Q Exp
makeLiftShowListOptions ShowOptions
defaultShowOptions
makeLiftShowListOptions :: ShowOptions -> Name -> Q Exp
makeLiftShowListOptions :: ShowOptions -> Name -> Q Exp
makeLiftShowListOptions ShowOptions
opts Name
name = do
Name
sp' <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"sp'"
Name
sl' <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"sl'"
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
sp', forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
sl'] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showListWithValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
(ShowOptions -> Name -> Q Exp
makeLiftShowsPrecOptions ShowOptions
opts Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
sp' forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
sl'
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
0)
makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp
makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp
makeShowsPrec1Options ShowOptions
opts Name
name = ShowOptions -> Name -> Q Exp
makeLiftShowsPrecOptions ShowOptions
opts Name
name
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showsPrecValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showListValName
#else
makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp
makeShowsPrec1Options = makeShowsPrecClass Show1
#endif
#if defined(NEW_FUNCTOR_CLASSES)
deriveShow2 :: Name -> Q [Dec]
deriveShow2 :: Name -> Q [Dec]
deriveShow2 = ShowOptions -> Name -> Q [Dec]
deriveShow2Options ShowOptions
defaultShowOptions
deriveShow2Options :: ShowOptions -> Name -> Q [Dec]
deriveShow2Options :: ShowOptions -> Name -> Q [Dec]
deriveShow2Options = ShowClass -> ShowOptions -> Name -> Q [Dec]
deriveShowClass ShowClass
Show2
makeLiftShowsPrec2 :: Name -> Q Exp
makeLiftShowsPrec2 :: Name -> Q Exp
makeLiftShowsPrec2 = ShowOptions -> Name -> Q Exp
makeLiftShowsPrec2Options ShowOptions
defaultShowOptions
makeLiftShowsPrec2Options :: ShowOptions -> Name -> Q Exp
makeLiftShowsPrec2Options :: ShowOptions -> Name -> Q Exp
makeLiftShowsPrec2Options = ShowClass -> ShowOptions -> Name -> Q Exp
makeShowsPrecClass ShowClass
Show2
makeLiftShowList2 :: Name -> Q Exp
makeLiftShowList2 :: Name -> Q Exp
makeLiftShowList2 = ShowOptions -> Name -> Q Exp
makeLiftShowList2Options ShowOptions
defaultShowOptions
makeLiftShowList2Options :: ShowOptions -> Name -> Q Exp
makeLiftShowList2Options :: ShowOptions -> Name -> Q Exp
makeLiftShowList2Options ShowOptions
opts Name
name = do
Name
sp1' <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"sp1'"
Name
sl1' <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"sl1'"
Name
sp2' <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"sp2'"
Name
sl2' <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"sl2'"
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
sp1', forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
sl1', forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
sp2', forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
sl2'] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showListWithValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
(ShowOptions -> Name -> Q Exp
makeLiftShowsPrec2Options ShowOptions
opts Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
sp1' forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
sl1'
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
sp2' forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
sl2'
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
0)
makeShowsPrec2 :: Name -> Q Exp
makeShowsPrec2 :: Name -> Q Exp
makeShowsPrec2 = ShowOptions -> Name -> Q Exp
makeShowsPrec2Options ShowOptions
defaultShowOptions
makeShowsPrec2Options :: ShowOptions -> Name -> Q Exp
makeShowsPrec2Options :: ShowOptions -> Name -> Q Exp
makeShowsPrec2Options ShowOptions
opts Name
name = ShowOptions -> Name -> Q Exp
makeLiftShowsPrec2Options ShowOptions
opts Name
name
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showsPrecValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showListValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showsPrecValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showListValName
#endif
deriveShowClass :: ShowClass -> ShowOptions -> Name -> Q [Dec]
deriveShowClass :: ShowClass -> ShowOptions -> Name -> Q [Dec]
deriveShowClass ShowClass
sClass ShowOptions
opts Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
(Cxt
instanceCxt, Type
instanceType)
<- forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance ShowClass
sClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
(forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
(ShowClass -> ShowOptions -> Cxt -> [ConstructorInfo] -> [Q Dec]
showsPrecDecs ShowClass
sClass ShowOptions
opts Cxt
instTypes [ConstructorInfo]
cons)
showsPrecDecs :: ShowClass -> ShowOptions -> [Type] -> [ConstructorInfo] -> [Q Dec]
showsPrecDecs :: ShowClass -> ShowOptions -> Cxt -> [ConstructorInfo] -> [Q Dec]
showsPrecDecs ShowClass
sClass ShowOptions
opts Cxt
instTypes [ConstructorInfo]
cons =
[ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (ShowClass -> Name
showsPrecName ShowClass
sClass)
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ ShowClass -> ShowOptions -> Cxt -> [ConstructorInfo] -> Q Exp
makeShowForCons ShowClass
sClass ShowOptions
opts Cxt
instTypes [ConstructorInfo]
cons)
[]
]
]
makeShowsPrecClass :: ShowClass -> ShowOptions -> Name -> Q Exp
makeShowsPrecClass :: ShowClass -> ShowOptions -> Name -> Q Exp
makeShowsPrecClass ShowClass
sClass ShowOptions
opts Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance ShowClass
sClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ShowClass -> ShowOptions -> Cxt -> [ConstructorInfo] -> Q Exp
makeShowForCons ShowClass
sClass ShowOptions
opts Cxt
instTypes [ConstructorInfo]
cons
makeShowForCons :: ShowClass -> ShowOptions -> [Type] -> [ConstructorInfo] -> Q Exp
makeShowForCons :: ShowClass -> ShowOptions -> Cxt -> [ConstructorInfo] -> Q Exp
makeShowForCons ShowClass
sClass ShowOptions
opts Cxt
instTypes [ConstructorInfo]
cons = do
Name
p <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"p"
Name
value <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"value"
[Name]
sps <- String -> Int -> Q [Name]
newNameList String
"sp" forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Int
arity ShowClass
sClass
[Name]
sls <- String -> Int -> Q [Name]
newNameList String
"sl" forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Int
arity ShowClass
sClass
let spls :: [(Name, Name)]
spls = forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
sps [Name]
sls
_spsAndSls :: [Name]
_spsAndSls = forall a. [a] -> [a] -> [a]
interleave [Name]
sps [Name]
sls
lastTyVars :: [Name]
lastTyVars = forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTypes forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum ShowClass
sClass) Cxt
instTypes
splMap :: Map Name (OneOrTwoNames Two)
splMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
x (Name
y, Name
z) -> (Name
x, Name -> Name -> OneOrTwoNames Two
TwoNames Name
y Name
z)) [Name]
lastTyVars [(Name, Name)]
spls
makeFun :: Q Exp
makeFun
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons Bool -> Bool -> Bool
&& ShowOptions -> Bool
showEmptyCaseBehavior ShowOptions
opts Bool -> Bool -> Bool
&& Bool
ghc7'8OrLater
= forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) []
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
= forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
seqValName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
errorValName)
(forall (m :: * -> *). Quote m => String -> m Exp
stringE forall a b. (a -> b) -> a -> b
$ String
"Void " forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (ShowClass -> Name
showsPrecName ShowClass
sClass))
| Bool
otherwise
= forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value)
(forall a b. (a -> b) -> [a] -> [b]
map (Name
-> ShowClass
-> ShowOptions
-> Map Name (OneOrTwoNames Two)
-> ConstructorInfo
-> Q Match
makeShowForCon Name
p ShowClass
sClass ShowOptions
opts Map Name (OneOrTwoNames Two)
splMap) [ConstructorInfo]
cons)
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$
#if defined(NEW_FUNCTOR_CLASSES)
[Name]
_spsAndSls forall a. [a] -> [a] -> [a]
++
#endif
[Name
p, Name
value])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ ShowClass -> Name
showsPrecConstName ShowClass
sClass
, Q Exp
makeFun
]
#if defined(NEW_FUNCTOR_CLASSES)
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
_spsAndSls
#endif
forall a. [a] -> [a] -> [a]
++ [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value]
makeShowForCon :: Name
-> ShowClass
-> ShowOptions
-> TyVarMap2
-> ConstructorInfo
-> Q Match
makeShowForCon :: Name
-> ShowClass
-> ShowOptions
-> Map Name (OneOrTwoNames Two)
-> ConstructorInfo
-> Q Match
makeShowForCon Name
_ ShowClass
_ ShowOptions
_ Map Name (OneOrTwoNames Two)
_
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName, constructorFields :: ConstructorInfo -> Cxt
constructorFields = [] }) =
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
(forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName [])
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> ShowS
parenInfixConName Name
conName String
""))
[]
makeShowForCon Name
p ShowClass
sClass ShowOptions
opts Map Name (OneOrTwoNames Two)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = [Type
argTy] }) = do
Type
argTy' <- Type -> Q Type
resolveTypeSynonyms Type
argTy
Name
arg <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"arg"
let showArg :: Q Exp
showArg = Int
-> ShowClass
-> ShowOptions
-> Name
-> Map Name (OneOrTwoNames Two)
-> Type
-> Name
-> Q Exp
makeShowForArg Int
appPrec1 ShowClass
sClass ShowOptions
opts Name
conName Map Name (OneOrTwoNames Two)
tvMap Type
argTy' Name
arg
namedArg :: Q Exp
namedArg = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> ShowS
parenInfixConName Name
conName String
" "))
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
Q Exp
showArg
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
(forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
arg])
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showParenValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
gtValName) (Int -> Q Exp
integerE Int
appPrec)
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
namedArg)
[]
makeShowForCon Name
p ShowClass
sClass ShowOptions
opts Map Name (OneOrTwoNames Two)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
argTys }) = do
Cxt
argTys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms Cxt
argTys
[Name]
args <- String -> Int -> Q [Name]
newNameList String
"arg" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
argTys'
if Name -> Bool
isNonUnitTuple Name
conName
then do
let showArgs :: [Q Exp]
showArgs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int
-> ShowClass
-> ShowOptions
-> Name
-> Map Name (OneOrTwoNames Two)
-> Type
-> Name
-> Q Exp
makeShowForArg Int
0 ShowClass
sClass ShowOptions
opts Name
conName Map Name (OneOrTwoNames Two)
tvMap) Cxt
argTys' [Name]
args
parenCommaArgs :: [Q Exp]
parenCommaArgs = (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCharValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
'(')
forall a. a -> [a] -> [a]
: forall a. a -> [a] -> [a]
List.intersperse (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCharValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
',') [Q Exp]
showArgs
mappendArgs :: Q Exp
mappendArgs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
`infixApp` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCharValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
')')
[Q Exp]
parenCommaArgs
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
mappendArgs)
[]
else do
let showArgs :: [Q Exp]
showArgs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int
-> ShowClass
-> ShowOptions
-> Name
-> Map Name (OneOrTwoNames Two)
-> Type
-> Name
-> Q Exp
makeShowForArg Int
appPrec1 ShowClass
sClass ShowOptions
opts Name
conName Map Name (OneOrTwoNames Two)
tvMap) Cxt
argTys' [Name]
args
mappendArgs :: Q Exp
mappendArgs = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Exp
v Q Exp
q -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
v (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
(forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showSpaceValName)
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
Q Exp
q)) [Q Exp]
showArgs
namedArgs :: Q Exp
namedArgs = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> ShowS
parenInfixConName Name
conName String
" "))
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
Q Exp
mappendArgs
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showParenValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
gtValName) (Int -> Q Exp
integerE Int
appPrec)
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
namedArgs)
[]
makeShowForCon Name
p ShowClass
sClass ShowOptions
opts Map Name (OneOrTwoNames Two)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = RecordConstructor [Name]
argNames
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
argTys }) = do
Cxt
argTys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms Cxt
argTys
[Name]
args <- String -> Int -> Q [Name]
newNameList String
"arg" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
argTys'
let showArgs :: [Q Exp]
showArgs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Name
argName, Type
argTy, Name
arg)
-> let argNameBase :: String
argNameBase = Name -> String
nameBase Name
argName
infixRec :: String
infixRec = Bool -> ShowS -> ShowS
showParen (String -> Bool
isSym String
argNameBase)
(String -> ShowS
showString String
argNameBase) String
""
in [ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE (String
infixRec forall a. [a] -> [a] -> [a]
++ String
" = ")
, Int
-> ShowClass
-> ShowOptions
-> Name
-> Map Name (OneOrTwoNames Two)
-> Type
-> Name
-> Q Exp
makeShowForArg Int
0 ShowClass
sClass ShowOptions
opts Name
conName Map Name (OneOrTwoNames Two)
tvMap Type
argTy Name
arg
, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCommaSpaceValName
]
)
(forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
argNames Cxt
argTys' [Name]
args)
braceCommaArgs :: [Q Exp]
braceCommaArgs = (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCharValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
'{') forall a. a -> [a] -> [a]
: forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Exp]
showArgs forall a. Num a => a -> a -> a
- Int
1) [Q Exp]
showArgs
mappendArgs :: Q Exp
mappendArgs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
`infixApp` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCharValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
'}')
[Q Exp]
braceCommaArgs
namedArgs :: Q Exp
namedArgs = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> ShowS
parenInfixConName Name
conName String
" "))
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
Q Exp
mappendArgs
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
(forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showParenValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
gtValName) (Int -> Q Exp
integerE Int
appPrec)
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
namedArgs)
[]
makeShowForCon Name
p ShowClass
sClass ShowOptions
opts Map Name (OneOrTwoNames Two)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
InfixConstructor
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
argTys }) = do
[Type
alTy, Type
arTy] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms Cxt
argTys
Name
al <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"argL"
Name
ar <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"argR"
Fixity
fi <- forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q (Maybe Fixity)
reifyFixityCompat Name
conName
let conPrec :: Int
conPrec = case Fixity
fi of Fixity Int
prec FixityDirection
_ -> Int
prec
opName :: String
opName = Name -> String
nameBase Name
conName
infixOpE :: Q Exp
infixOpE = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => String -> m Exp
stringE forall a b. (a -> b) -> a -> b
$
if String -> Bool
isInfixDataCon String
opName
then String
" " forall a. [a] -> [a] -> [a]
++ String
opName forall a. [a] -> [a] -> [a]
++ String
" "
else String
" `" forall a. [a] -> [a] -> [a]
++ String
opName forall a. [a] -> [a] -> [a]
++ String
"` "
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
(forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
infixP (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
al) Name
conName (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
ar))
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showParenValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
gtValName) (Int -> Q Exp
integerE Int
conPrec))
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Int
-> ShowClass
-> ShowOptions
-> Name
-> Map Name (OneOrTwoNames Two)
-> Type
-> Name
-> Q Exp
makeShowForArg (Int
conPrec forall a. Num a => a -> a -> a
+ Int
1) ShowClass
sClass ShowOptions
opts Name
conName Map Name (OneOrTwoNames Two)
tvMap Type
alTy Name
al)
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
(forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
infixOpE
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
(Int
-> ShowClass
-> ShowOptions
-> Name
-> Map Name (OneOrTwoNames Two)
-> Type
-> Name
-> Q Exp
makeShowForArg (Int
conPrec forall a. Num a => a -> a -> a
+ Int
1) ShowClass
sClass ShowOptions
opts Name
conName Map Name (OneOrTwoNames Two)
tvMap Type
arTy Name
ar)))
)
[]
makeShowForArg :: Int
-> ShowClass
-> ShowOptions
-> Name
-> TyVarMap2
-> Type
-> Name
-> Q Exp
makeShowForArg :: Int
-> ShowClass
-> ShowOptions
-> Name
-> Map Name (OneOrTwoNames Two)
-> Type
-> Name
-> Q Exp
makeShowForArg Int
p ShowClass
_ ShowOptions
opts Name
_ Map Name (OneOrTwoNames Two)
_ (ConT Name
tyName) Name
tyExpName =
Q Exp
showE
where
tyVarE :: Q Exp
tyVarE :: Q Exp
tyVarE = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tyExpName
showE :: Q Exp
showE :: Q Exp
showE =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name PrimShow
primShowTbl of
Just PrimShow
ps -> PrimShow -> Q Exp
showPrimE PrimShow
ps
Maybe PrimShow
Nothing -> forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showsPrecValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
p forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
tyVarE
showPrimE :: PrimShow -> Q Exp
showPrimE :: PrimShow -> Q Exp
showPrimE PrimShow{Q Exp -> Q Exp
primShowBoxer :: PrimShow -> Q Exp -> Q Exp
primShowBoxer :: Q Exp -> Q Exp
primShowBoxer, Q Exp
primShowPostfixMod :: PrimShow -> Q Exp
primShowPostfixMod :: Q Exp
primShowPostfixMod, Q Exp -> Q Exp
primShowConv :: PrimShow -> Q Exp -> Q Exp
primShowConv :: Q Exp -> Q Exp
primShowConv}
| ShowOptions -> Bool
ghc8ShowBehavior ShowOptions
opts
= Q Exp -> Q Exp
primShowConv forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Int -> Q Exp
primE Int
0) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName) Q Exp
primShowPostfixMod
| Bool
otherwise
= Int -> Q Exp
primE Int
p
where
primE :: Int -> Q Exp
primE :: Int -> Q Exp
primE Int
prec = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showsPrecValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
prec
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp -> Q Exp
primShowBoxer Q Exp
tyVarE
makeShowForArg Int
p ShowClass
sClass ShowOptions
_ Name
conName Map Name (OneOrTwoNames Two)
tvMap Type
ty Name
tyExpName =
ShowClass
-> Name -> Map Name (OneOrTwoNames Two) -> Bool -> Type -> Q Exp
makeShowForType ShowClass
sClass Name
conName Map Name (OneOrTwoNames Two)
tvMap Bool
False Type
ty forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
p forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tyExpName
makeShowForType :: ShowClass
-> Name
-> TyVarMap2
-> Bool
-> Type
-> Q Exp
#if defined(NEW_FUNCTOR_CLASSES)
makeShowForType :: ShowClass
-> Name -> Map Name (OneOrTwoNames Two) -> Bool -> Type -> Q Exp
makeShowForType ShowClass
_ Name
_ Map Name (OneOrTwoNames Two)
tvMap Bool
sl (VarT Name
tyName) =
forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name (OneOrTwoNames Two)
tvMap of
Just (TwoNames Name
spExp Name
slExp) -> if Bool
sl then Name
slExp else Name
spExp
Maybe (OneOrTwoNames Two)
Nothing -> if Bool
sl then Name
showListValName else Name
showsPrecValName
#else
makeShowForType _ _ _ _ VarT{} = varE showsPrecValName
#endif
makeShowForType ShowClass
sClass Name
conName Map Name (OneOrTwoNames Two)
tvMap Bool
sl (SigT Type
ty Type
_) = ShowClass
-> Name -> Map Name (OneOrTwoNames Two) -> Bool -> Type -> Q Exp
makeShowForType ShowClass
sClass Name
conName Map Name (OneOrTwoNames Two)
tvMap Bool
sl Type
ty
makeShowForType ShowClass
sClass Name
conName Map Name (OneOrTwoNames Two)
tvMap Bool
sl (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
ty) = ShowClass
-> Name -> Map Name (OneOrTwoNames Two) -> Bool -> Type -> Q Exp
makeShowForType ShowClass
sClass Name
conName Map Name (OneOrTwoNames Two)
tvMap Bool
sl Type
ty
#if defined(NEW_FUNCTOR_CLASSES)
makeShowForType ShowClass
sClass Name
conName Map Name (OneOrTwoNames Two)
tvMap Bool
sl Type
ty = do
let tyCon :: Type
tyArgs :: [Type]
(Type
tyCon, Cxt
tyArgs) = Type -> (Type, Cxt)
unapplyTy Type
ty
numLastArgs :: Int
numLastArgs :: Int
numLastArgs = forall a. Ord a => a -> a -> a
min (forall a. ClassRep a => a -> Int
arity ShowClass
sClass) (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs)
lhsArgs, rhsArgs :: [Type]
(Cxt
lhsArgs, Cxt
rhsArgs) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs forall a. Num a => a -> a -> a
- Int
numLastArgs) Cxt
tyArgs
tyVarNames :: [Name]
tyVarNames :: [Name]
tyVarNames = forall k a. Map k a -> [k]
Map.keys Map Name (OneOrTwoNames Two)
tvMap
Bool
itf <- [Name] -> Type -> Cxt -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
tyCon Cxt
tyArgs
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
lhsArgs
Bool -> Bool -> Bool
|| Bool
itf Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs
then forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError ShowClass
sClass Name
conName
else if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
then forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => Name -> m Exp
varE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowClass -> Name
showsPrecOrListName Bool
sl forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum Int
numLastArgs]
forall a. [a] -> [a] -> [a]
++ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ShowClass
-> Name -> Map Name (OneOrTwoNames Two) -> Bool -> Type -> Q Exp
makeShowForType ShowClass
sClass Name
conName Map Name (OneOrTwoNames Two)
tvMap)
(forall a. [a] -> [a]
cycle [Bool
False,Bool
True])
(forall a. [a] -> [a] -> [a]
interleave Cxt
rhsArgs Cxt
rhsArgs)
else forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ if Bool
sl then Name
showListValName else Name
showsPrecValName
#else
makeShowForType sClass conName tvMap _ ty = do
let varNames = Map.keys tvMap
p' <- newName "p'"
value' <- newName "value'"
case varNames of
[] -> varE showsPrecValName
varName:_ ->
if mentionsName ty varNames
then lamE [varP p', varP value'] $ varE showsPrec1ValName
`appE` varE p'
`appE` (makeFmapApplyNeg sClass conName ty varName `appE` varE value')
else varE showsPrecValName
#endif
data ShowClass = Show
| Show1
#if defined(NEW_FUNCTOR_CLASSES)
| Show2
#endif
deriving (ShowClass
forall a. a -> a -> Bounded a
maxBound :: ShowClass
$cmaxBound :: ShowClass
minBound :: ShowClass
$cminBound :: ShowClass
Bounded, Int -> ShowClass
ShowClass -> Int
ShowClass -> [ShowClass]
ShowClass -> ShowClass
ShowClass -> ShowClass -> [ShowClass]
ShowClass -> ShowClass -> ShowClass -> [ShowClass]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ShowClass -> ShowClass -> ShowClass -> [ShowClass]
$cenumFromThenTo :: ShowClass -> ShowClass -> ShowClass -> [ShowClass]
enumFromTo :: ShowClass -> ShowClass -> [ShowClass]
$cenumFromTo :: ShowClass -> ShowClass -> [ShowClass]
enumFromThen :: ShowClass -> ShowClass -> [ShowClass]
$cenumFromThen :: ShowClass -> ShowClass -> [ShowClass]
enumFrom :: ShowClass -> [ShowClass]
$cenumFrom :: ShowClass -> [ShowClass]
fromEnum :: ShowClass -> Int
$cfromEnum :: ShowClass -> Int
toEnum :: Int -> ShowClass
$ctoEnum :: Int -> ShowClass
pred :: ShowClass -> ShowClass
$cpred :: ShowClass -> ShowClass
succ :: ShowClass -> ShowClass
$csucc :: ShowClass -> ShowClass
Enum)
instance ClassRep ShowClass where
arity :: ShowClass -> Int
arity = forall a. Enum a => a -> Int
fromEnum
allowExQuant :: ShowClass -> Bool
allowExQuant ShowClass
_ = Bool
True
fullClassName :: ShowClass -> Name
fullClassName ShowClass
Show = Name
showTypeName
fullClassName ShowClass
Show1 = Name
show1TypeName
#if defined(NEW_FUNCTOR_CLASSES)
fullClassName ShowClass
Show2 = Name
show2TypeName
#endif
classConstraint :: ShowClass -> Int -> Maybe Name
classConstraint ShowClass
sClass Int
i
| Int
sMin forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
<= Int
sMax = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Name
fullClassName (forall a. Enum a => Int -> a
toEnum Int
i :: ShowClass)
| Bool
otherwise = forall a. Maybe a
Nothing
where
sMin, sMax :: Int
sMin :: Int
sMin = forall a. Enum a => a -> Int
fromEnum (forall a. Bounded a => a
minBound :: ShowClass)
sMax :: Int
sMax = forall a. Enum a => a -> Int
fromEnum ShowClass
sClass
showsPrecConstName :: ShowClass -> Name
showsPrecConstName :: ShowClass -> Name
showsPrecConstName ShowClass
Show = Name
showsPrecConstValName
#if defined(NEW_FUNCTOR_CLASSES)
showsPrecConstName ShowClass
Show1 = Name
liftShowsPrecConstValName
showsPrecConstName ShowClass
Show2 = Name
liftShowsPrec2ConstValName
#else
showsPrecConstName Show1 = showsPrec1ConstValName
#endif
showsPrecName :: ShowClass -> Name
showsPrecName :: ShowClass -> Name
showsPrecName ShowClass
Show = Name
showsPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
showsPrecName ShowClass
Show1 = Name
liftShowsPrecValName
showsPrecName ShowClass
Show2 = Name
liftShowsPrec2ValName
#else
showsPrecName Show1 = showsPrec1ValName
#endif
#if defined(NEW_FUNCTOR_CLASSES)
showListName :: ShowClass -> Name
showListName :: ShowClass -> Name
showListName ShowClass
Show = Name
showListValName
showListName ShowClass
Show1 = Name
liftShowListValName
showListName ShowClass
Show2 = Name
liftShowList2ValName
showsPrecOrListName :: Bool
-> ShowClass
-> Name
showsPrecOrListName :: Bool -> ShowClass -> Name
showsPrecOrListName Bool
False = ShowClass -> Name
showsPrecName
showsPrecOrListName Bool
True = ShowClass -> Name
showListName
#endif
parenInfixConName :: Name -> ShowS
parenInfixConName :: Name -> ShowS
parenInfixConName Name
conName =
let conNameBase :: String
conNameBase = Name -> String
nameBase Name
conName
in Bool -> ShowS -> ShowS
showParen (String -> Bool
isInfixDataCon String
conNameBase) forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
conNameBase
charE :: Char -> Q Exp
charE :: Char -> Q Exp
charE = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Lit
charL
data PrimShow = PrimShow
{ PrimShow -> Q Exp -> Q Exp
primShowBoxer :: Q Exp -> Q Exp
, PrimShow -> Q Exp
primShowPostfixMod :: Q Exp
, PrimShow -> Q Exp -> Q Exp
primShowConv :: Q Exp -> Q Exp
}
primShowTbl :: Map Name PrimShow
primShowTbl :: Map Name PrimShow
primShowTbl = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (Name
charHashTypeName, PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cHashDataName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
oneHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = forall a. a -> a
id
})
, (Name
doubleHashTypeName, PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
dHashDataName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
twoHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = forall a. a -> a
id
})
, (Name
floatHashTypeName, PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
fHashDataName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
oneHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = forall a. a -> a
id
})
, (Name
intHashTypeName, PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
iHashDataName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
oneHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = forall a. a -> a
id
})
, (Name
wordHashTypeName, PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
wHashDataName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
twoHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = forall a. a -> a
id
})
#if MIN_VERSION_base(4,13,0)
, (Name
int8HashTypeName, PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
iHashDataName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
int8ToIntHashValName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
oneHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = Name -> Q Exp -> Q Exp
mkNarrowE Name
intToInt8HashValName
})
, (Name
int16HashTypeName, PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
iHashDataName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
int16ToIntHashValName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
oneHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = Name -> Q Exp -> Q Exp
mkNarrowE Name
intToInt16HashValName
})
, (Name
word8HashTypeName, PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
wHashDataName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
word8ToWordHashValName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
twoHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = Name -> Q Exp -> Q Exp
mkNarrowE Name
wordToWord8HashValName
})
, (Name
word16HashTypeName, PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
wHashDataName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
word16ToWordHashValName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
twoHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = Name -> Q Exp -> Q Exp
mkNarrowE Name
wordToWord16HashValName
})
#endif
#if MIN_VERSION_base(4,16,0)
, (Name
int32HashTypeName, PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
iHashDataName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
int32ToIntHashValName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
oneHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = Name -> Q Exp -> Q Exp
mkNarrowE Name
intToInt32HashValName
})
, (Name
word32HashTypeName, PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
wHashDataName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
word32ToWordHashValName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
twoHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = Name -> Q Exp -> Q Exp
mkNarrowE Name
wordToWord32HashValName
})
#endif
]
#if MIN_VERSION_base(4,13,0)
mkNarrowE :: Name -> Q Exp -> Q Exp
mkNarrowE :: Name -> Q Exp -> Q Exp
mkNarrowE Name
narrowName Q Exp
e =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
`infixApp` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCharValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
')')
[ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE (Char
'('forall a. a -> [a] -> [a]
:Name -> String
nameBase Name
narrowName forall a. [a] -> [a] -> [a]
++ String
" ")
, Q Exp
e
]
#endif
oneHashE, twoHashE :: Q Exp
oneHashE :: Q Exp
oneHashE = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCharValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
'#'
twoHashE :: Q Exp
twoHashE = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE String
"##"