{-# 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 Data.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
(ShowOptions -> ShowOptions -> Bool)
-> (ShowOptions -> ShowOptions -> Bool) -> Eq ShowOptions
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
Eq ShowOptions =>
(ShowOptions -> ShowOptions -> Ordering)
-> (ShowOptions -> ShowOptions -> Bool)
-> (ShowOptions -> ShowOptions -> Bool)
-> (ShowOptions -> ShowOptions -> Bool)
-> (ShowOptions -> ShowOptions -> Bool)
-> (ShowOptions -> ShowOptions -> ShowOptions)
-> (ShowOptions -> ShowOptions -> ShowOptions)
-> Ord 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
$cp1Ord :: Eq ShowOptions
Ord, ReadPrec [ShowOptions]
ReadPrec ShowOptions
Int -> ReadS ShowOptions
ReadS [ShowOptions]
(Int -> ReadS ShowOptions)
-> ReadS [ShowOptions]
-> ReadPrec ShowOptions
-> ReadPrec [ShowOptions]
-> Read 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
(Int -> ShowOptions -> ShowS)
-> (ShowOptions -> String)
-> ([ShowOptions] -> ShowS)
-> Show ShowOptions
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 :: Bool -> Bool -> ShowOptions
ShowOptions { ghc8ShowBehavior :: Bool
ghc8ShowBehavior = Bool
True
, showEmptyCaseBehavior :: Bool
showEmptyCaseBehavior = Bool
False
}
legacyShowOptions :: ShowOptions
legacyShowOptions :: ShowOptions
legacyShowOptions = ShowOptions :: Bool -> Bool -> ShowOptions
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 opts :: ShowOptions
opts name :: Name
name = do
Name
x <- String -> Q Name
newName "x"
PatQ -> Q Exp -> Q Exp
lam1E (Name -> PatQ
varP Name
x) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ ShowOptions -> Name -> Q Exp
makeShowsPrecOptions ShowOptions
opts Name
name
Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE 0
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
x
Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE ""
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 opts :: ShowOptions
opts name :: Name
name =
Name -> Q Exp
varE Name
showListWithValName Q Exp -> Q Exp -> Q Exp
`appE` (ShowOptions -> Name -> Q Exp
makeShowsPrecOptions ShowOptions
opts Name
name Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE 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 opts :: ShowOptions
opts name :: Name
name = do
Name
sp' <- String -> Q Name
newName "sp'"
Name
sl' <- String -> Q Name
newName "sl'"
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
sp', Name -> PatQ
varP Name
sl'] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
showListWithValName Q Exp -> Q Exp -> Q Exp
`appE`
(ShowOptions -> Name -> Q Exp
makeLiftShowsPrecOptions ShowOptions
opts Name
name Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
sp' Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
sl'
Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE 0)
makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp
makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp
makeShowsPrec1Options opts :: ShowOptions
opts name :: Name
name = ShowOptions -> Name -> Q Exp
makeLiftShowsPrecOptions ShowOptions
opts Name
name
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
showsPrecValName
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q 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 opts :: ShowOptions
opts name :: Name
name = do
Name
sp1' <- String -> Q Name
newName "sp1'"
Name
sl1' <- String -> Q Name
newName "sl1'"
Name
sp2' <- String -> Q Name
newName "sp2'"
Name
sl2' <- String -> Q Name
newName "sl2'"
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
sp1', Name -> PatQ
varP Name
sl1', Name -> PatQ
varP Name
sp2', Name -> PatQ
varP Name
sl2'] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Name -> Q Exp
varE Name
showListWithValName Q Exp -> Q Exp -> Q Exp
`appE`
(ShowOptions -> Name -> Q Exp
makeLiftShowsPrec2Options ShowOptions
opts Name
name Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
sp1' Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
sl1'
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
sp2' Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
sl2'
Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE 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 opts :: ShowOptions
opts name :: Name
name = ShowOptions -> Name -> Q Exp
makeLiftShowsPrec2Options ShowOptions
opts Name
name
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
showsPrecValName
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
showListValName
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
showsPrecValName
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
showListValName
#endif
deriveShowClass :: ShowClass -> ShowOptions -> Name -> Q [Dec]
deriveShowClass :: ShowClass -> ShowOptions -> Name -> Q [Dec]
deriveShowClass sClass :: ShowClass
sClass opts :: ShowOptions
opts name :: 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
(instanceCxt :: Cxt
instanceCxt, instanceType :: Type
instanceType)
<- ShowClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance ShowClass
sClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
(Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(Type -> TypeQ
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 sClass :: ShowClass
sClass opts :: ShowOptions
opts instTypes :: Cxt
instTypes cons :: [ConstructorInfo]
cons =
[ Name -> [ClauseQ] -> Q Dec
funD (ShowClass -> Name
showsPrecName ShowClass
sClass)
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
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 sClass :: ShowClass
sClass opts :: ShowOptions
opts name :: 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
ShowClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance ShowClass
sClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
Q (Cxt, Type) -> Q Exp -> Q Exp
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 sClass :: ShowClass
sClass opts :: ShowOptions
opts instTypes :: Cxt
instTypes cons :: [ConstructorInfo]
cons = do
Name
p <- String -> Q Name
newName "p"
Name
value <- String -> Q Name
newName "value"
[Name]
sps <- String -> Int -> Q [Name]
newNameList "sp" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ ShowClass -> Int
forall a. ClassRep a => a -> Int
arity ShowClass
sClass
[Name]
sls <- String -> Int -> Q [Name]
newNameList "sl" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ ShowClass -> Int
forall a. ClassRep a => a -> Int
arity ShowClass
sClass
let spls :: [(Name, Name)]
spls = [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
sps [Name]
sls
_spsAndSls :: [Name]
_spsAndSls = [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
interleave [Name]
sps [Name]
sls
lastTyVars :: [Name]
lastTyVars = (Type -> Name) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName (Cxt -> [Name]) -> Cxt -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTypes Int -> Int -> Int
forall a. Num a => a -> a -> a
- ShowClass -> Int
forall a. Enum a => a -> Int
fromEnum ShowClass
sClass) Cxt
instTypes
splMap :: Map Name (OneOrTwoNames Two)
splMap = [(Name, OneOrTwoNames Two)] -> Map Name (OneOrTwoNames Two)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, OneOrTwoNames Two)] -> Map Name (OneOrTwoNames Two))
-> [(Name, OneOrTwoNames Two)] -> Map Name (OneOrTwoNames Two)
forall a b. (a -> b) -> a -> b
$ (Name -> (Name, Name) -> (Name, OneOrTwoNames Two))
-> [Name] -> [(Name, Name)] -> [(Name, OneOrTwoNames Two)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\x :: Name
x (y :: Name
y, z :: Name
z) -> (Name
x, Name -> Name -> OneOrTwoNames Two
TwoNames Name
y Name
z)) [Name]
lastTyVars [(Name, Name)]
spls
makeFun :: Q Exp
makeFun
| [ConstructorInfo] -> Bool
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
= Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value) []
| [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
= Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
seqValName) (Name -> Q Exp
varE Name
value) Q Exp -> Q Exp -> Q Exp
`appE`
Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
errorValName)
(String -> Q Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "Void " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (ShowClass -> Name
showsPrecName ShowClass
sClass))
| Bool
otherwise
= Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value)
((ConstructorInfo -> MatchQ) -> [ConstructorInfo] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name
-> ShowClass
-> ShowOptions
-> Map Name (OneOrTwoNames Two)
-> ConstructorInfo
-> MatchQ
makeShowForCon Name
p ShowClass
sClass ShowOptions
opts Map Name (OneOrTwoNames Two)
splMap) [ConstructorInfo]
cons)
[PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP ([Name] -> [PatQ]) -> [Name] -> [PatQ]
forall a b. (a -> b) -> a -> b
$
#if defined(NEW_FUNCTOR_CLASSES)
[Name]
_spsAndSls [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
#endif
[Name
p, Name
value])
(Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE
([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ ShowClass -> Name
showsPrecConstName ShowClass
sClass
, Q Exp
makeFun
]
#if defined(NEW_FUNCTOR_CLASSES)
[Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
_spsAndSls
#endif
[Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ [Name -> Q Exp
varE Name
p, Name -> Q Exp
varE Name
value]
makeShowForCon :: Name
-> ShowClass
-> ShowOptions
-> TyVarMap2
-> ConstructorInfo
-> Q Match
makeShowForCon :: Name
-> ShowClass
-> ShowOptions
-> Map Name (OneOrTwoNames Two)
-> ConstructorInfo
-> MatchQ
makeShowForCon _ _ _ _
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName, constructorFields :: ConstructorInfo -> Cxt
constructorFields = [] }) =
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match
(Name -> [PatQ] -> PatQ
conP Name
conName [])
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE (Name -> ShowS
parenInfixConName Name
conName ""))
[]
makeShowForCon p :: Name
p sClass :: ShowClass
sClass opts :: ShowOptions
opts tvMap :: Map Name (OneOrTwoNames Two)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = [argTy :: Type
argTy] }) = do
Type
argTy' <- Type -> TypeQ
resolveTypeSynonyms Type
argTy
Name
arg <- String -> Q Name
newName "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 = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE (Name -> ShowS
parenInfixConName Name
conName " "))
(Name -> Q Exp
varE Name
composeValName)
Q Exp
showArg
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match
(Name -> [PatQ] -> PatQ
conP Name
conName [Name -> PatQ
varP Name
arg])
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
showParenValName
Q Exp -> Q Exp -> Q Exp
`appE` Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
p) (Name -> Q Exp
varE Name
gtValName) (Int -> Q Exp
integerE Int
appPrec)
Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
namedArg)
[]
makeShowForCon p :: Name
p sClass :: ShowClass
sClass opts :: ShowOptions
opts tvMap :: 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' <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
argTys
[Name]
args <- String -> Int -> Q [Name]
newNameList "arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
argTys'
if Name -> Bool
isNonUnitTuple Name
conName
then do
let showArgs :: [Q Exp]
showArgs = (Type -> Name -> Q Exp) -> Cxt -> [Name] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int
-> ShowClass
-> ShowOptions
-> Name
-> Map Name (OneOrTwoNames Two)
-> Type
-> Name
-> Q Exp
makeShowForArg 0 ShowClass
sClass ShowOptions
opts Name
conName Map Name (OneOrTwoNames Two)
tvMap) Cxt
argTys' [Name]
args
parenCommaArgs :: [Q Exp]
parenCommaArgs = (Name -> Q Exp
varE Name
showCharValName Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE '(')
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
varE Name
showCharValName Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE ',') [Q Exp]
showArgs
mappendArgs :: Q Exp
mappendArgs = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Q Exp -> Q Exp -> Q Exp -> Q Exp
`infixApp` Name -> Q Exp
varE Name
composeValName)
(Name -> Q Exp
varE Name
showCharValName Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE ')')
[Q Exp]
parenCommaArgs
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
(Q Exp -> BodyQ
normalB Q Exp
mappendArgs)
[]
else do
let showArgs :: [Q Exp]
showArgs = (Type -> Name -> Q Exp) -> Cxt -> [Name] -> [Q Exp]
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 = (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\v :: Q Exp
v q :: Q Exp
q -> Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp Q Exp
v (Name -> Q Exp
varE Name
composeValName)
(Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
showSpaceValName)
(Name -> Q Exp
varE Name
composeValName)
Q Exp
q)) [Q Exp]
showArgs
namedArgs :: Q Exp
namedArgs = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE (Name -> ShowS
parenInfixConName Name
conName " "))
(Name -> Q Exp
varE Name
composeValName)
Q Exp
mappendArgs
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
showParenValName
Q Exp -> Q Exp -> Q Exp
`appE` Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
p) (Name -> Q Exp
varE Name
gtValName) (Int -> Q Exp
integerE Int
appPrec)
Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
namedArgs)
[]
makeShowForCon p :: Name
p sClass :: ShowClass
sClass opts :: ShowOptions
opts tvMap :: Map Name (OneOrTwoNames Two)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = RecordConstructor argNames :: [Name]
argNames
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
argTys }) = do
Cxt
argTys' <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
argTys
[Name]
args <- String -> Int -> Q [Name]
newNameList "arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
argTys'
let showArgs :: [Q Exp]
showArgs = ((Name, Type, Name) -> [Q Exp]) -> [(Name, Type, Name)] -> [Q Exp]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(argName :: Name
argName, argTy :: Type
argTy, arg :: 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) ""
in [ Name -> Q Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE (String
infixRec String -> ShowS
forall a. [a] -> [a] -> [a]
++ " = ")
, Int
-> ShowClass
-> ShowOptions
-> Name
-> Map Name (OneOrTwoNames Two)
-> Type
-> Name
-> Q Exp
makeShowForArg 0 ShowClass
sClass ShowOptions
opts Name
conName Map Name (OneOrTwoNames Two)
tvMap Type
argTy Name
arg
, Name -> Q Exp
varE Name
showCommaSpaceValName
]
)
([Name] -> Cxt -> [Name] -> [(Name, Type, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
argNames Cxt
argTys' [Name]
args)
braceCommaArgs :: [Q Exp]
braceCommaArgs = (Name -> Q Exp
varE Name
showCharValName Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE '{') Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: Int -> [Q Exp] -> [Q Exp]
forall a. Int -> [a] -> [a]
take ([Q Exp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Exp]
showArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) [Q Exp]
showArgs
mappendArgs :: Q Exp
mappendArgs = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Q Exp -> Q Exp -> Q Exp -> Q Exp
`infixApp` Name -> Q Exp
varE Name
composeValName)
(Name -> Q Exp
varE Name
showCharValName Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE '}')
[Q Exp]
braceCommaArgs
namedArgs :: Q Exp
namedArgs = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE (Name -> ShowS
parenInfixConName Name
conName " "))
(Name -> Q Exp
varE Name
composeValName)
Q Exp
mappendArgs
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match
(Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
showParenValName
Q Exp -> Q Exp -> Q Exp
`appE` Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
p) (Name -> Q Exp
varE Name
gtValName) (Int -> Q Exp
integerE Int
appPrec)
Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
namedArgs)
[]
makeShowForCon p :: Name
p sClass :: ShowClass
sClass opts :: ShowOptions
opts tvMap :: 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
[alTy :: Type
alTy, arTy :: Type
arTy] <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
argTys
Name
al <- String -> Q Name
newName "argL"
Name
ar <- String -> Q Name
newName "argR"
Fixity
fi <- Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity (Maybe Fixity -> Fixity) -> Q (Maybe Fixity) -> Q Fixity
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 prec :: Int
prec _ -> Int
prec
opName :: String
opName = Name -> String
nameBase Name
conName
infixOpE :: Q Exp
infixOpE = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
showStringValName) (Q Exp -> Q Exp) -> (String -> Q Exp) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$
if String -> Bool
isInfixDataCon String
opName
then " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
opName String -> ShowS
forall a. [a] -> [a] -> [a]
++ " "
else " `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
opName String -> ShowS
forall a. [a] -> [a] -> [a]
++ "` "
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match
(PatQ -> Name -> PatQ -> PatQ
infixP (Name -> PatQ
varP Name
al) Name
conName (Name -> PatQ
varP Name
ar))
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ (Name -> Q Exp
varE Name
showParenValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
p) (Name -> Q Exp
varE Name
gtValName) (Int -> Q Exp
integerE Int
conPrec))
Q Exp -> Q Exp -> Q Exp
`appE` (Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Int
-> ShowClass
-> ShowOptions
-> Name
-> Map Name (OneOrTwoNames Two)
-> Type
-> Name
-> Q Exp
makeShowForArg (Int
conPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) ShowClass
sClass ShowOptions
opts Name
conName Map Name (OneOrTwoNames Two)
tvMap Type
alTy Name
al)
(Name -> Q Exp
varE Name
composeValName)
(Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp Q Exp
infixOpE
(Name -> Q Exp
varE Name
composeValName)
(Int
-> ShowClass
-> ShowOptions
-> Name
-> Map Name (OneOrTwoNames Two)
-> Type
-> Name
-> Q Exp
makeShowForArg (Int
conPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 p :: Int
p _ opts :: ShowOptions
opts _ _ (ConT tyName :: Name
tyName) tyExpName :: Name
tyExpName =
Q Exp
showE
where
tyVarE :: Q Exp
tyVarE :: Q Exp
tyVarE = Name -> Q Exp
varE Name
tyExpName
showE :: Q Exp
showE :: Q Exp
showE =
case Name -> Map Name PrimShow -> Maybe PrimShow
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name PrimShow
primShowTbl of
Just ps :: PrimShow
ps -> PrimShow -> Q Exp
showPrimE PrimShow
ps
Nothing -> Name -> Q Exp
varE Name
showsPrecValName Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE Int
p Q Exp -> Q Exp -> Q 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 (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Int -> Q Exp
primE 0) (Name -> Q 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 prec :: Int
prec = Name -> Q Exp
varE Name
showsPrecValName Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE Int
prec
Q Exp -> Q Exp -> Q Exp
`appE` Q Exp -> Q Exp
primShowBoxer Q Exp
tyVarE
makeShowForArg p :: Int
p sClass :: ShowClass
sClass _ conName :: Name
conName tvMap :: Map Name (OneOrTwoNames Two)
tvMap ty :: Type
ty tyExpName :: 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 Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE Int
p Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q 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 _ _ tvMap :: Map Name (OneOrTwoNames Two)
tvMap sl :: Bool
sl (VarT tyName :: Name
tyName) =
Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ case Name -> Map Name (OneOrTwoNames Two) -> Maybe (OneOrTwoNames Two)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name (OneOrTwoNames Two)
tvMap of
Just (TwoNames spExp :: Name
spExp slExp :: Name
slExp) -> if Bool
sl then Name
slExp else Name
spExp
Nothing -> if Bool
sl then Name
showListValName else Name
showsPrecValName
#else
makeShowForType _ _ _ _ VarT{} = varE showsPrecValName
#endif
makeShowForType sClass :: ShowClass
sClass conName :: Name
conName tvMap :: Map Name (OneOrTwoNames Two)
tvMap sl :: Bool
sl (SigT ty :: 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
makeShowForType sClass :: ShowClass
sClass conName :: Name
conName tvMap :: Map Name (OneOrTwoNames Two)
tvMap sl :: Bool
sl (ForallT _ _ ty :: 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 sClass :: ShowClass
sClass conName :: Name
conName tvMap :: Map Name (OneOrTwoNames Two)
tvMap sl :: Bool
sl ty :: Type
ty = do
let tyCon :: Type
tyArgs :: [Type]
(tyCon :: Type
tyCon, tyArgs :: Cxt
tyArgs) = Type -> (Type, Cxt)
unapplyTy Type
ty
numLastArgs :: Int
numLastArgs :: Int
numLastArgs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (ShowClass -> Int
forall a. ClassRep a => a -> Int
arity ShowClass
sClass) (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs)
lhsArgs, rhsArgs :: [Type]
(lhsArgs :: Cxt
lhsArgs, rhsArgs :: Cxt
rhsArgs) = Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) Cxt
tyArgs
tyVarNames :: [Name]
tyVarNames :: [Name]
tyVarNames = Map Name (OneOrTwoNames Two) -> [Name]
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 (Type -> Bool) -> Cxt -> Bool
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
&& (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs
then ShowClass -> Name -> Q Exp
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError ShowClass
sClass Name
conName
else if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
then [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> (ShowClass -> Name) -> ShowClass -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowClass -> Name
showsPrecOrListName Bool
sl (ShowClass -> Q Exp) -> ShowClass -> Q Exp
forall a b. (a -> b) -> a -> b
$ Int -> ShowClass
forall a. Enum a => Int -> a
toEnum Int
numLastArgs]
[Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Bool -> Type -> Q Exp) -> [Bool] -> Cxt -> [Q Exp]
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)
([Bool] -> [Bool]
forall a. [a] -> [a]
cycle [Bool
False,Bool
True])
(Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
interleave Cxt
rhsArgs Cxt
rhsArgs)
else Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
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
ShowClass -> ShowClass -> Bounded 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]
(ShowClass -> ShowClass)
-> (ShowClass -> ShowClass)
-> (Int -> ShowClass)
-> (ShowClass -> Int)
-> (ShowClass -> [ShowClass])
-> (ShowClass -> ShowClass -> [ShowClass])
-> (ShowClass -> ShowClass -> [ShowClass])
-> (ShowClass -> ShowClass -> ShowClass -> [ShowClass])
-> Enum 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 = ShowClass -> Int
forall a. Enum a => a -> Int
fromEnum
allowExQuant :: ShowClass -> Bool
allowExQuant _ = Bool
True
fullClassName :: ShowClass -> Name
fullClassName Show = Name
showTypeName
fullClassName Show1 = Name
show1TypeName
#if defined(NEW_FUNCTOR_CLASSES)
fullClassName Show2 = Name
show2TypeName
#endif
classConstraint :: ShowClass -> Int -> Maybe Name
classConstraint sClass :: ShowClass
sClass i :: Int
i
| Int
sMin Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
sMax = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ ShowClass -> Name
forall a. ClassRep a => a -> Name
fullClassName (Int -> ShowClass
forall a. Enum a => Int -> a
toEnum Int
i :: ShowClass)
| Bool
otherwise = Maybe Name
forall a. Maybe a
Nothing
where
sMin, sMax :: Int
sMin :: Int
sMin = ShowClass -> Int
forall a. Enum a => a -> Int
fromEnum (ShowClass
forall a. Bounded a => a
minBound :: ShowClass)
sMax :: Int
sMax = ShowClass -> Int
forall a. Enum a => a -> Int
fromEnum ShowClass
sClass
showsPrecConstName :: ShowClass -> Name
showsPrecConstName :: ShowClass -> Name
showsPrecConstName Show = Name
showsPrecConstValName
#if defined(NEW_FUNCTOR_CLASSES)
showsPrecConstName Show1 = Name
liftShowsPrecConstValName
showsPrecConstName Show2 = Name
liftShowsPrec2ConstValName
#else
showsPrecConstName Show1 = showsPrec1ConstValName
#endif
showsPrecName :: ShowClass -> Name
showsPrecName :: ShowClass -> Name
showsPrecName Show = Name
showsPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
showsPrecName Show1 = Name
liftShowsPrecValName
showsPrecName Show2 = Name
liftShowsPrec2ValName
#else
showsPrecName Show1 = showsPrec1ValName
#endif
#if defined(NEW_FUNCTOR_CLASSES)
showListName :: ShowClass -> Name
showListName :: ShowClass -> Name
showListName Show = Name
showListValName
showListName Show1 = Name
liftShowListValName
showListName Show2 = Name
liftShowList2ValName
showsPrecOrListName :: Bool
-> ShowClass
-> Name
showsPrecOrListName :: Bool -> ShowClass -> Name
showsPrecOrListName False = ShowClass -> Name
showsPrecName
showsPrecOrListName True = ShowClass -> Name
showListName
#endif
parenInfixConName :: Name -> ShowS
parenInfixConName :: Name -> ShowS
parenInfixConName conName :: Name
conName =
let conNameBase :: String
conNameBase = Name -> String
nameBase Name
conName
in Bool -> ShowS -> ShowS
showParen (String -> Bool
isInfixDataCon String
conNameBase) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
conNameBase
charE :: Char -> Q Exp
charE :: Char -> Q Exp
charE = Lit -> Q Exp
litE (Lit -> Q Exp) -> (Char -> Lit) -> Char -> Q Exp
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 = [(Name, PrimShow)] -> Map Name PrimShow
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (Name
charHashTypeName, PrimShow :: (Q Exp -> Q Exp) -> Q Exp -> (Q Exp -> Q Exp) -> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE Name
cHashDataName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
oneHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = Q Exp -> Q Exp
forall a. a -> a
id
})
, (Name
doubleHashTypeName, PrimShow :: (Q Exp -> Q Exp) -> Q Exp -> (Q Exp -> Q Exp) -> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE Name
dHashDataName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
twoHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = Q Exp -> Q Exp
forall a. a -> a
id
})
, (Name
floatHashTypeName, PrimShow :: (Q Exp -> Q Exp) -> Q Exp -> (Q Exp -> Q Exp) -> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE Name
fHashDataName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
oneHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = Q Exp -> Q Exp
forall a. a -> a
id
})
, (Name
intHashTypeName, PrimShow :: (Q Exp -> Q Exp) -> Q Exp -> (Q Exp -> Q Exp) -> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE Name
iHashDataName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
oneHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = Q Exp -> Q Exp
forall a. a -> a
id
})
, (Name
wordHashTypeName, PrimShow :: (Q Exp -> Q Exp) -> Q Exp -> (Q Exp -> Q Exp) -> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE Name
wHashDataName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
twoHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = Q Exp -> Q Exp
forall a. a -> a
id
})
#if MIN_VERSION_base(4,13,0)
, (Name
int8HashTypeName, PrimShow :: (Q Exp -> Q Exp) -> Q Exp -> (Q Exp -> Q Exp) -> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE Name
iHashDataName) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
extendInt8HashValName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
oneHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = String -> Q Exp -> Q Exp
mkNarrowE "narrowInt8#"
})
, (Name
int16HashTypeName, PrimShow :: (Q Exp -> Q Exp) -> Q Exp -> (Q Exp -> Q Exp) -> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE Name
iHashDataName) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
extendInt16HashValName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
oneHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = String -> Q Exp -> Q Exp
mkNarrowE "narrowInt16#"
})
, (Name
word8HashTypeName, PrimShow :: (Q Exp -> Q Exp) -> Q Exp -> (Q Exp -> Q Exp) -> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE Name
wHashDataName) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
extendWord8HashValName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
twoHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = String -> Q Exp -> Q Exp
mkNarrowE "narrowWord8#"
})
, (Name
word16HashTypeName, PrimShow :: (Q Exp -> Q Exp) -> Q Exp -> (Q Exp -> Q Exp) -> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE Name
wHashDataName) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
extendWord16HashValName)
, primShowPostfixMod :: Q Exp
primShowPostfixMod = Q Exp
twoHashE
, primShowConv :: Q Exp -> Q Exp
primShowConv = String -> Q Exp -> Q Exp
mkNarrowE "narrowWord16#"
})
#endif
]
#if MIN_VERSION_base(4,13,0)
mkNarrowE :: String -> Q Exp -> Q Exp
mkNarrowE :: String -> Q Exp -> Q Exp
mkNarrowE narrowStr :: String
narrowStr e :: Q Exp
e =
(Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Q Exp -> Q Exp -> Q Exp -> Q Exp
`infixApp` Name -> Q Exp
varE Name
composeValName)
(Name -> Q Exp
varE Name
showCharValName Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE ')')
[ Name -> Q Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE ('('Char -> ShowS
forall a. a -> [a] -> [a]
:String
narrowStr String -> ShowS
forall a. [a] -> [a] -> [a]
++ " ")
, Q Exp
e
]
#endif
oneHashE, twoHashE :: Q Exp
oneHashE :: Q Exp
oneHashE = Name -> Q Exp
varE Name
showCharValName Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE '#'
twoHashE :: Q Exp
twoHashE = Name -> Q Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE "##"