{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-|
Module:      Text.Show.Deriving.Internal
Copyright:   (C) 2015-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Portability: Template Haskell

Exports functions to mechanically derive 'Show', 'Show1', and 'Show2' instances.

Note: this is an internal module, and as such, the API presented here is not
guaranteed to be stable, even between minor releases of this library.
-}
module Text.Show.Deriving.Internal (
      -- * 'Show'

      deriveShow
    , deriveShowOptions
    , makeShowsPrec
    , makeShowsPrecOptions
    , makeShow
    , makeShowOptions
    , makeShowList
    , makeShowListOptions
      -- * 'Show1'

    , deriveShow1
    , deriveShow1Options
#if defined(NEW_FUNCTOR_CLASSES)
    , makeLiftShowsPrec
    , makeLiftShowsPrecOptions
    , makeLiftShowList
    , makeLiftShowListOptions
#endif
    , makeShowsPrec1
    , makeShowsPrec1Options
#if defined(NEW_FUNCTOR_CLASSES)
      -- * 'Show2'

    , deriveShow2
    , deriveShow2Options
    , makeLiftShowsPrec2
    , makeLiftShowsPrec2Options
    , makeLiftShowList2
    , makeLiftShowList2Options
    , makeShowsPrec2
    , makeShowsPrec2Options
#endif
      -- * 'ShowOptions'

    , 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

-- | Options that further configure how the functions in "Text.Show.Deriving"

-- should behave.

data ShowOptions = ShowOptions
  { ShowOptions -> Bool
ghc8ShowBehavior :: Bool
    -- ^ If 'True', the derived 'Show', 'Show1', or 'Show2' instance will not

    --   surround the output of showing fields of unlifted types with parentheses,

    --   and the output will be suffixed with hash signs (@#@).

  , ShowOptions -> Bool
showEmptyCaseBehavior :: Bool
    -- ^ If 'True', derived instances for empty data types (i.e., ones with

    --   no data constructors) will use the @EmptyCase@ language extension.

    --   If 'False', derived instances will simply use 'seq' instead.

    --   (This has no effect on GHCs before 7.8, since @EmptyCase@ is only

    --   available in 7.8 or later.)

  } 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)

-- | 'ShowOptions' that match the behavior of the most recent GHC release.

defaultShowOptions :: ShowOptions
defaultShowOptions :: ShowOptions
defaultShowOptions =
  ShowOptions { ghc8ShowBehavior :: Bool
ghc8ShowBehavior      = Bool
True
              , showEmptyCaseBehavior :: Bool
showEmptyCaseBehavior = Bool
False
              }

-- | 'ShowOptions' that match the behavior of the installed version of GHC.

legacyShowOptions :: ShowOptions
legacyShowOptions :: ShowOptions
legacyShowOptions = ShowOptions
  { ghc8ShowBehavior :: Bool
ghc8ShowBehavior =
#if __GLASGOW_HASKELL__ >= 711
                       Bool
True
#else
                       False
#endif
  , showEmptyCaseBehavior :: Bool
showEmptyCaseBehavior = Bool
False
  }

-- | Generates a 'Show' instance declaration for the given data type or data

-- family instance.

deriveShow :: Name -> Q [Dec]
deriveShow :: Name -> Q [Dec]
deriveShow = ShowOptions -> Name -> Q [Dec]
deriveShowOptions ShowOptions
defaultShowOptions

-- | Like 'deriveShow', but takes a 'ShowOptions' argument.

deriveShowOptions :: ShowOptions -> Name -> Q [Dec]
deriveShowOptions :: ShowOptions -> Name -> Q [Dec]
deriveShowOptions = ShowClass -> ShowOptions -> Name -> Q [Dec]
deriveShowClass ShowClass
Show

-- | Generates a lambda expression which behaves like 'show' (without

-- requiring a 'Show' instance).

makeShow :: Name -> Q Exp
makeShow :: Name -> Q Exp
makeShow = ShowOptions -> Name -> Q Exp
makeShowOptions ShowOptions
defaultShowOptions

-- | Like 'makeShow', but takes a 'ShowOptions' argument.

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
""

-- | Generates a lambda expression which behaves like 'showsPrec' (without

-- requiring a 'Show' instance).

makeShowsPrec :: Name -> Q Exp
makeShowsPrec :: Name -> Q Exp
makeShowsPrec = ShowOptions -> Name -> Q Exp
makeShowsPrecOptions ShowOptions
defaultShowOptions

-- | Like 'makeShowsPrec', but takes a 'ShowOptions' argument.

makeShowsPrecOptions :: ShowOptions -> Name -> Q Exp
makeShowsPrecOptions :: ShowOptions -> Name -> Q Exp
makeShowsPrecOptions = ShowClass -> ShowOptions -> Name -> Q Exp
makeShowsPrecClass ShowClass
Show

-- | Generates a lambda expression which behaves like 'showList' (without

-- requiring a 'Show' instance).

makeShowList :: Name -> Q Exp
makeShowList :: Name -> Q Exp
makeShowList = ShowOptions -> Name -> Q Exp
makeShowListOptions ShowOptions
defaultShowOptions

-- | Like 'makeShowList', but takes a 'ShowOptions' argument.

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)

-- | Generates a 'Show1' instance declaration for the given data type or data

-- family instance.

deriveShow1 :: Name -> Q [Dec]
deriveShow1 :: Name -> Q [Dec]
deriveShow1 = ShowOptions -> Name -> Q [Dec]
deriveShow1Options ShowOptions
defaultShowOptions

-- | Like 'deriveShow1', but takes a 'ShowOptions' argument.

deriveShow1Options :: ShowOptions -> Name -> Q [Dec]
deriveShow1Options :: ShowOptions -> Name -> Q [Dec]
deriveShow1Options = ShowClass -> ShowOptions -> Name -> Q [Dec]
deriveShowClass ShowClass
Show1

-- | Generates a lambda expression which behaves like 'showsPrec1' (without

-- requiring a 'Show1' instance).

makeShowsPrec1 :: Name -> Q Exp
makeShowsPrec1 :: Name -> Q Exp
makeShowsPrec1 = ShowOptions -> Name -> Q Exp
makeShowsPrec1Options ShowOptions
defaultShowOptions

#if defined(NEW_FUNCTOR_CLASSES)
-- | Generates a lambda expression which behaves like 'liftShowsPrec' (without

-- requiring a 'Show1' instance).

--

-- This function is not available with @transformers-0.4@.

makeLiftShowsPrec :: Name -> Q Exp
makeLiftShowsPrec :: Name -> Q Exp
makeLiftShowsPrec = ShowOptions -> Name -> Q Exp
makeLiftShowsPrecOptions ShowOptions
defaultShowOptions

-- | Like 'makeLiftShowsPrec', but takes a 'ShowOptions' argument.

--

-- This function is not available with @transformers-0.4@.

makeLiftShowsPrecOptions :: ShowOptions -> Name -> Q Exp
makeLiftShowsPrecOptions :: ShowOptions -> Name -> Q Exp
makeLiftShowsPrecOptions = ShowClass -> ShowOptions -> Name -> Q Exp
makeShowsPrecClass ShowClass
Show1

-- | Generates a lambda expression which behaves like 'liftShowList' (without

-- requiring a 'Show' instance).

--

-- This function is not available with @transformers-0.4@.

makeLiftShowList :: Name -> Q Exp
makeLiftShowList :: Name -> Q Exp
makeLiftShowList = ShowOptions -> Name -> Q Exp
makeLiftShowListOptions ShowOptions
defaultShowOptions

-- | Like 'makeLiftShowList', but takes a 'ShowOptions' argument.

--

-- This function is not available with @transformers-0.4@.

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)

-- | Like 'makeShowsPrec1', but takes a 'ShowOptions' argument.

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
-- | Like 'makeShowsPrec1', but takes a 'ShowOptions' argument.

makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp
makeShowsPrec1Options = makeShowsPrecClass Show1
#endif

#if defined(NEW_FUNCTOR_CLASSES)
-- | Generates a 'Show2' instance declaration for the given data type or data

-- family instance.

--

-- This function is not available with @transformers-0.4@.

deriveShow2 :: Name -> Q [Dec]
deriveShow2 :: Name -> Q [Dec]
deriveShow2 = ShowOptions -> Name -> Q [Dec]
deriveShow2Options ShowOptions
defaultShowOptions

-- | Like 'deriveShow2', but takes a 'ShowOptions' argument.

--

-- This function is not available with @transformers-0.4@.

deriveShow2Options :: ShowOptions -> Name -> Q [Dec]
deriveShow2Options :: ShowOptions -> Name -> Q [Dec]
deriveShow2Options = ShowClass -> ShowOptions -> Name -> Q [Dec]
deriveShowClass ShowClass
Show2

-- | Generates a lambda expression which behaves like 'liftShowsPrec2' (without

-- requiring a 'Show2' instance).

--

-- This function is not available with @transformers-0.4@.

makeLiftShowsPrec2 :: Name -> Q Exp
makeLiftShowsPrec2 :: Name -> Q Exp
makeLiftShowsPrec2 = ShowOptions -> Name -> Q Exp
makeLiftShowsPrec2Options ShowOptions
defaultShowOptions

-- | Like 'makeLiftShowsPrec2', but takes a 'ShowOptions' argument.

--

-- This function is not available with @transformers-0.4@.

makeLiftShowsPrec2Options :: ShowOptions -> Name -> Q Exp
makeLiftShowsPrec2Options :: ShowOptions -> Name -> Q Exp
makeLiftShowsPrec2Options = ShowClass -> ShowOptions -> Name -> Q Exp
makeShowsPrecClass ShowClass
Show2

-- | Generates a lambda expression which behaves like 'liftShowList2' (without

-- requiring a 'Show' instance).

--

-- This function is not available with @transformers-0.4@.

makeLiftShowList2 :: Name -> Q Exp
makeLiftShowList2 :: Name -> Q Exp
makeLiftShowList2 = ShowOptions -> Name -> Q Exp
makeLiftShowList2Options ShowOptions
defaultShowOptions

-- | Like 'makeLiftShowList2', but takes a 'ShowOptions' argument.

--

-- This function is not available with @transformers-0.4@.

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)

-- | Generates a lambda expression which behaves like 'showsPrec2' (without

-- requiring a 'Show2' instance).

--

-- This function is not available with @transformers-0.4@.

makeShowsPrec2 :: Name -> Q Exp
makeShowsPrec2 :: Name -> Q Exp
makeShowsPrec2 = ShowOptions -> Name -> Q Exp
makeShowsPrec2Options ShowOptions
defaultShowOptions

-- | Like 'makeShowsPrec2', but takes a 'ShowOptions' argument.

--

-- This function is not available with @transformers-0.4@.

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

-------------------------------------------------------------------------------

-- Code generation

-------------------------------------------------------------------------------


-- | Derive a Show(1)(2) instance declaration (depending on the ShowClass

-- argument's value).

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)

-- | Generates a declaration defining the primary function corresponding to a

-- particular class (showsPrec for Show, liftShowsPrec for Show1, and

-- liftShowsPrec2 for Show2).

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)
                    []
           ]
    ]

-- | Generates a lambda expression which behaves like showsPrec (for Show),

-- liftShowsPrec (for Show1), or liftShowsPrec2 (for Show2).

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
      -- We force buildTypeInstance here since it performs some checks for whether

      -- or not the provided datatype can actually have showsPrec/liftShowsPrec/etc.

      -- implemented for it, and produces errors if it can't.

      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

-- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for the

-- given constructors. All constructors must be from the same type.

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]

-- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a

-- single constructor.

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)))
      )
      []

-- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for an

-- argument of a constructor.

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}
        -- Starting with GHC 8.0, data types containing unlifted types with

        -- derived Show instances show hashed literals with actual hash signs,

        -- and negative hashed literals are not surrounded with parentheses.

      | 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

-- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a

-- specific type. The generated expression depends on the number of type variables.

--

-- 1. If the type is of kind * (T), apply showsPrec.

-- 2. If the type is of kind * -> * (T a), apply liftShowsPrec $(makeShowForType a)

-- 3. If the type is of kind * -> * -> * (T a b), apply

--    liftShowsPrec2 $(makeShowForType a) $(makeShowForType b)

makeShowForType :: ShowClass
                -> Name
                -> TyVarMap2
                -> Bool -- ^ True if we are using the function of type ([a] -> ShowS),

                        --   False if we are using the function of type (Int -> a -> ShowS).

                -> 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

-------------------------------------------------------------------------------

-- Class-specific constants

-------------------------------------------------------------------------------


-- | A representation of which @Show@ variant is being derived.

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 -- ^ showListName if True, showsPrecName if False

                    -> ShowClass
                    -> Name
showsPrecOrListName :: Bool -> ShowClass -> Name
showsPrecOrListName Bool
False = ShowClass -> Name
showsPrecName
showsPrecOrListName Bool
True  = ShowClass -> Name
showListName
#endif

-------------------------------------------------------------------------------

-- Assorted utilities

-------------------------------------------------------------------------------


-- | Parenthesize an infix constructor name if it is being applied as a prefix

-- function (e.g., data Amp a = (:&) a a)

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
"##"