{-# 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
    , makeLiftShowsPrec
    , makeLiftShowsPrecOptions
    , makeLiftShowList
    , makeLiftShowListOptions
    , makeShowsPrec1
    , makeShowsPrec1Options
      -- * 'Show2'
    , deriveShow2
    , deriveShow2Options
    , makeLiftShowsPrec2
    , makeLiftShowsPrec2Options
    , makeLiftShowList2
    , makeLiftShowList2Options
    , makeShowsPrec2
    , makeShowsPrec2Options
      -- * '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
(ShowOptions -> ShowOptions -> Bool)
-> (ShowOptions -> ShowOptions -> Bool) -> Eq ShowOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShowOptions -> ShowOptions -> Bool
== :: ShowOptions -> ShowOptions -> Bool
$c/= :: ShowOptions -> ShowOptions -> Bool
/= :: 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
$ccompare :: ShowOptions -> ShowOptions -> Ordering
compare :: ShowOptions -> ShowOptions -> Ordering
$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
>= :: ShowOptions -> ShowOptions -> Bool
$cmax :: ShowOptions -> ShowOptions -> ShowOptions
max :: ShowOptions -> ShowOptions -> ShowOptions
$cmin :: ShowOptions -> ShowOptions -> ShowOptions
min :: ShowOptions -> ShowOptions -> 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
$creadsPrec :: Int -> ReadS ShowOptions
readsPrec :: Int -> ReadS ShowOptions
$creadList :: ReadS [ShowOptions]
readList :: ReadS [ShowOptions]
$creadPrec :: ReadPrec ShowOptions
readPrec :: ReadPrec ShowOptions
$creadListPrec :: ReadPrec [ShowOptions]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> ShowOptions -> ShowS
showsPrec :: Int -> ShowOptions -> ShowS
$cshow :: ShowOptions -> String
show :: ShowOptions -> String
$cshowList :: [ShowOptions] -> ShowS
showList :: [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 = Bool
True
  , 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
    x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
    lam1E (varP x) $ makeShowsPrecOptions opts name
                     `appE` integerE 0
                     `appE` varE x
                     `appE` stringE ""

-- | 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 =
    Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showListWithValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (ShowOptions -> Name -> Q Exp
makeShowsPrecOptions ShowOptions
opts Name
name Q Exp -> Q Exp -> Q Exp
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

-- | 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
    sp' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"sp'"
    sl' <- newName "sl'"
    lamE [varP sp', varP sl'] $ varE showListWithValName `appE`
        (makeLiftShowsPrecOptions opts name `appE` varE sp' `appE` varE sl'
                                            `appE` integerE 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
                           Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showsPrecValName
                           Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showListValName

-- | 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
    sp1' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"sp1'"
    sl1' <- newName "sl1'"
    sp2' <- newName "sp2'"
    sl2' <- newName "sl2'"
    lamE [varP sp1', varP sl1', varP sp2', varP sl2'] $
        varE showListWithValName `appE`
            (makeLiftShowsPrec2Options opts name `appE` varE sp1' `appE` varE sl1'
                                                 `appE` varE sp2' `appE` varE sl2'
                                                 `appE` integerE 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
                           Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showsPrecValName
                           Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showListValName
                           Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showsPrecValName
                           Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showListValName

-------------------------------------------------------------------------------
-- 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
  info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case 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, 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
      (:[]) `fmap` instanceD (return instanceCxt)
                             (return instanceType)
                             (showsPrecDecs sClass opts instTypes 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 =
    [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (ShowClass -> Name
showsPrecName ShowClass
sClass)
           [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
                    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
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
  info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case 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.
      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 a b. Q a -> Q b -> Q b
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
    p     <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"p"
    value <- newName "value"
    sps   <- newNameList "sp" $ arity sClass
    sls   <- newNameList "sl" $ arity sClass
    let spls       = [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
sps [Name]
sls
        spsAndSls  = [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
interleave [Name]
sps [Name]
sls
        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 a. [a] -> 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     = [(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 (\Name
x (Name
y, Name
z) -> (Name
x, Name -> Name -> OneOrTwoNames Two
TwoNames Name
y Name
z)) [Name]
lastTyVars [(Name, Name)]
spls

        makeFun
          | [ConstructorInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons Bool -> Bool -> Bool
&& ShowOptions -> Bool
showEmptyCaseBehavior ShowOptions
opts
          = Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) []

          | [ConstructorInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
          = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
seqValName) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
            Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
errorValName)
                 (String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Void " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (ShowClass -> Name
showsPrecName ShowClass
sClass))

          | Bool
otherwise
          = Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value)
                  ((ConstructorInfo -> Q Match) -> [ConstructorInfo] -> [Q Match]
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)

    lamE (map varP $ spsAndSls ++ [p, value])
        . appsE
        $ [ varE $ showsPrecConstName sClass
          , makeFun
          ] ++ map varE spsAndSls
            ++ [varE p, varE 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 = [] }) =
    Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
      (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName [])
      (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
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
    argTy' <- Type -> Q Type
resolveTypeSynonyms Type
argTy
    arg <- newName "arg"

    let 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 -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> ShowS
parenInfixConName Name
conName String
" "))
                            (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
                            Q Exp
showArg

    match
      (conP conName [varP arg])
      (normalB $ varE showParenValName
                  `appE` infixApp (varE p) (varE gtValName) (integerE appPrec)
                  `appE` 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
    argTys' <- (Type -> Q Type) -> Cxt -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms Cxt
argTys
    args <- newNameList "arg" $ length argTys'

    if isNonUnitTuple conName
       then do
         let 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
0 ShowClass
sClass ShowOptions
opts Name
conName Map Name (OneOrTwoNames Two)
tvMap) Cxt
argTys' [Name]
args
             parenCommaArgs = (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCharValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
'(')
                              Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
List.intersperse (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCharValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
',') [Q Exp]
showArgs
             mappendArgs    = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
`infixApp` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
                                    (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCharValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
')')
                                    [Q Exp]
parenCommaArgs

         match (conP conName $ map varP args)
               (normalB mappendArgs)
               []
       else do
         let 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 -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Exp
v Q Exp
q -> Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
v (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
                                                    (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showSpaceValName)
                                                            (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
                                                            Q Exp
q)) [Q Exp]
showArgs
             namedArgs   = Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> ShowS
parenInfixConName Name
conName String
" "))
                                    (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
                                    Q Exp
mappendArgs

         match (conP conName $ map varP args)
               (normalB $ varE showParenValName
                            `appE` infixApp (varE p) (varE gtValName) (integerE appPrec)
                            `appE` 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
    argTys' <- (Type -> Q Type) -> Cxt -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms Cxt
argTys
    args <- newNameList "arg" $ length argTys'

    let showArgs       = ((Name, Type, Name) -> [Q Exp]) -> [(Name, Type, Name)] -> [Q Exp]
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 [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String
infixRec String -> ShowS
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
                                            , Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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 = (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCharValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
'{') 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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Exp]
showArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Q Exp]
showArgs
        mappendArgs    = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
`infixApp` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
                               (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCharValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
'}')
                               [Q Exp]
braceCommaArgs
        namedArgs      = Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> ShowS
parenInfixConName Name
conName String
" "))
                                  (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
                                  Q Exp
mappendArgs

    match
      (conP conName $ map varP args)
      (normalB $ varE showParenValName
                   `appE` infixApp (varE p) (varE gtValName) (integerE appPrec)
                   `appE` 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
    [alTy, arTy] <- (Type -> Q Type) -> Cxt -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms Cxt
argTys
    al   <- newName "argL"
    ar   <- newName "argR"
    fi <- fromMaybe defaultFixity `fmap` reifyFixityCompat conName
    let conPrec  = case Fixity
fi of Fixity Int
prec FixityDirection
_ -> Int
prec
        opName   = Name -> String
nameBase Name
conName
        infixOpE = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$
                     if String -> Bool
isInfixDataCon String
opName
                        then String
" "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
opName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" "
                        else String
" `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
opName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"` "

    match
      (infixP (varP al) conName (varP ar))
      (normalB $ (varE showParenValName `appE` infixApp (varE p) (varE gtValName) (integerE conPrec))
                   `appE` (infixApp (makeShowForArg (conPrec + 1) sClass opts conName tvMap alTy al)
                                    (varE composeValName)
                                    (infixApp infixOpE
                                              (varE composeValName)
                                              (makeShowForArg (conPrec + 1) sClass opts conName tvMap arTy 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 = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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 PrimShow
ps -> PrimShow -> Q Exp
showPrimE PrimShow
ps
        Maybe PrimShow
Nothing -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showsPrecValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
p Q Exp -> Q Exp -> Q Exp
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 :: Q Exp -> Q Exp
primShowBoxer :: PrimShow -> Q Exp -> Q Exp
primShowBoxer, Q Exp
primShowPostfixMod :: Q Exp
primShowPostfixMod :: PrimShow -> Q Exp
primShowPostfixMod, Q Exp -> Q Exp
primShowConv :: Q Exp -> Q Exp
primShowConv :: PrimShow -> 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 (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Int -> Q Exp
primE Int
0) (Name -> Q Exp
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 = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showsPrecValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
prec
                                           Q Exp -> Q Exp -> Q Exp
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 Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
p Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
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
makeShowForType :: ShowClass
-> Name -> Map Name (OneOrTwoNames Two) -> Bool -> Type -> Q Exp
makeShowForType ShowClass
_ Name
_ Map Name (OneOrTwoNames Two)
tvMap Bool
sl (VarT Name
tyName) =
    Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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 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
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
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 = 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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs)

        lhsArgs, rhsArgs :: [Type]
        (Cxt
lhsArgs, Cxt
rhsArgs) = Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt (Cxt -> Int
forall a. [a] -> 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

    itf <- [Name] -> Type -> Cxt -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
tyCon Cxt
tyArgs
    if any (`mentionsName` tyVarNames) lhsArgs
          || itf && any (`mentionsName` tyVarNames) tyArgs
       then outOfPlaceTyVarError sClass conName
       else if any (`mentionsName` tyVarNames) rhsArgs
               then appsE $ [ varE . showsPrecOrListName sl $ toEnum numLastArgs]
                            ++ zipWith (makeShowForType sClass conName tvMap)
                                       (cycle [False,True])
                                       (interleave rhsArgs rhsArgs)
               else varE $ if sl then showListValName else showsPrecValName

-------------------------------------------------------------------------------
-- Class-specific constants
-------------------------------------------------------------------------------

-- | A representation of which @Show@ variant is being derived.
data ShowClass = Show
               | Show1
               | Show2
  deriving (ShowClass
ShowClass -> ShowClass -> Bounded ShowClass
forall a. a -> a -> Bounded a
$cminBound :: ShowClass
minBound :: ShowClass
$cmaxBound :: ShowClass
maxBound :: 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
$csucc :: ShowClass -> ShowClass
succ :: ShowClass -> ShowClass
$cpred :: ShowClass -> ShowClass
pred :: ShowClass -> ShowClass
$ctoEnum :: Int -> ShowClass
toEnum :: Int -> ShowClass
$cfromEnum :: ShowClass -> Int
fromEnum :: ShowClass -> Int
$cenumFrom :: ShowClass -> [ShowClass]
enumFrom :: ShowClass -> [ShowClass]
$cenumFromThen :: ShowClass -> ShowClass -> [ShowClass]
enumFromThen :: ShowClass -> ShowClass -> [ShowClass]
$cenumFromTo :: ShowClass -> ShowClass -> [ShowClass]
enumFromTo :: ShowClass -> ShowClass -> [ShowClass]
$cenumFromThenTo :: ShowClass -> ShowClass -> ShowClass -> [ShowClass]
enumFromThenTo :: ShowClass -> ShowClass -> ShowClass -> [ShowClass]
Enum)

instance ClassRep ShowClass where
    arity :: ShowClass -> Int
arity = ShowClass -> Int
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
    fullClassName ShowClass
Show2 = Name
show2TypeName

    classConstraint :: ShowClass -> Int -> Maybe Name
classConstraint ShowClass
sClass 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 ShowClass
Show  = Name
showsPrecConstValName
showsPrecConstName ShowClass
Show1 = Name
liftShowsPrecConstValName
showsPrecConstName ShowClass
Show2 = Name
liftShowsPrec2ConstValName

showsPrecName :: ShowClass -> Name
showsPrecName :: ShowClass -> Name
showsPrecName ShowClass
Show  = Name
showsPrecValName
showsPrecName ShowClass
Show1 = Name
liftShowsPrecValName
showsPrecName ShowClass
Show2 = Name
liftShowsPrec2ValName

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

-------------------------------------------------------------------------------
-- 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) (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
forall (m :: * -> *). Quote m => Lit -> m 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
                             { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
                             { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
                             { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
                             { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
                             { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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,19,0)
    , (Name
int8HashTypeName,   PrimShow
                             { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
i8HashDataName)
                             , primShowPostfixMod :: Q Exp
primShowPostfixMod = String -> Q Exp
extendedLitE String
"Int8"
                             , primShowConv :: Q Exp -> Q Exp
primShowConv       = Q Exp -> Q Exp
forall a. a -> a
id
                             })
    , (Name
int16HashTypeName,  PrimShow
                             { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
i16HashDataName)
                             , primShowPostfixMod :: Q Exp
primShowPostfixMod = String -> Q Exp
extendedLitE String
"Int16"
                             , primShowConv :: Q Exp -> Q Exp
primShowConv       = Q Exp -> Q Exp
forall a. a -> a
id
                             })
    , (Name
int32HashTypeName,  PrimShow
                             { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
i32HashDataName)
                             , primShowPostfixMod :: Q Exp
primShowPostfixMod = String -> Q Exp
extendedLitE String
"Int32"
                             , primShowConv :: Q Exp -> Q Exp
primShowConv       = Q Exp -> Q Exp
forall a. a -> a
id
                             })
    , (Name
int64HashTypeName,  PrimShow
                             { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
i64HashDataName)
                             , primShowPostfixMod :: Q Exp
primShowPostfixMod = String -> Q Exp
extendedLitE String
"Int64"
                             , primShowConv :: Q Exp -> Q Exp
primShowConv       = Q Exp -> Q Exp
forall a. a -> a
id
                             })
    , (Name
word8HashTypeName,  PrimShow
                             { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
w8HashDataName)
                             , primShowPostfixMod :: Q Exp
primShowPostfixMod = String -> Q Exp
extendedLitE String
"Word8"
                             , primShowConv :: Q Exp -> Q Exp
primShowConv       = Q Exp -> Q Exp
forall a. a -> a
id
                             })
    , (Name
word16HashTypeName, PrimShow
                             { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
w16HashDataName)
                             , primShowPostfixMod :: Q Exp
primShowPostfixMod = String -> Q Exp
extendedLitE String
"Word16"
                             , primShowConv :: Q Exp -> Q Exp
primShowConv       = Q Exp -> Q Exp
forall a. a -> a
id
                             })
    , (Name
word32HashTypeName, PrimShow
                             { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
w32HashDataName)
                             , primShowPostfixMod :: Q Exp
primShowPostfixMod = String -> Q Exp
extendedLitE String
"Word32"
                             , primShowConv :: Q Exp -> Q Exp
primShowConv       = Q Exp -> Q Exp
forall a. a -> a
id
                             })
    , (Name
word64HashTypeName, PrimShow
                             { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
w64HashDataName)
                             , primShowPostfixMod :: Q Exp
primShowPostfixMod = String -> Q Exp
extendedLitE String
"Word64"
                             , primShowConv :: Q Exp -> Q Exp
primShowConv       = Q Exp -> Q Exp
forall a. a -> a
id
                             })
#else
# if MIN_VERSION_base(4,13,0)
    , (int8HashTypeName,   PrimShow
                             { primShowBoxer      = appE (conE iHashDataName) . appE (varE int8ToIntHashValName)
                             , primShowPostfixMod = oneHashE
                             , primShowConv       = mkNarrowE intToInt8HashValName
                             })
    , (int16HashTypeName,  PrimShow
                             { primShowBoxer      = appE (conE iHashDataName) . appE (varE int16ToIntHashValName)
                             , primShowPostfixMod = oneHashE
                             , primShowConv       = mkNarrowE intToInt16HashValName
                             })
    , (word8HashTypeName,  PrimShow
                             { primShowBoxer      = appE (conE wHashDataName) . appE (varE word8ToWordHashValName)
                             , primShowPostfixMod = twoHashE
                             , primShowConv       = mkNarrowE wordToWord8HashValName
                             })
    , (word16HashTypeName, PrimShow
                             { primShowBoxer      = appE (conE wHashDataName) . appE (varE word16ToWordHashValName)
                             , primShowPostfixMod = twoHashE
                             , primShowConv       = mkNarrowE wordToWord16HashValName
                             })
# endif
# if MIN_VERSION_base(4,16,0)
    , (int32HashTypeName,  PrimShow
                             { primShowBoxer      = appE (conE iHashDataName) . appE (varE int32ToIntHashValName)
                             , primShowPostfixMod = oneHashE
                             , primShowConv       = mkNarrowE intToInt32HashValName
                             })
    , (word32HashTypeName, PrimShow
                             { primShowBoxer      = appE (conE wHashDataName) . appE (varE word32ToWordHashValName)
                             , primShowPostfixMod = twoHashE
                             , primShowConv       = mkNarrowE wordToWord32HashValName
                             })
# endif
#endif
    ]

#if MIN_VERSION_base(4,13,0) && !(MIN_VERSION_base(4,19,0))
mkNarrowE :: Name -> Q Exp -> Q Exp
mkNarrowE narrowName e =
  foldr (`infixApp` varE composeValName)
        (varE showCharValName `appE` charE ')')
        [ varE showStringValName `appE` stringE ('(':nameBase narrowName ++ " ")
        , e
        ]
#endif

oneHashE, twoHashE :: Q Exp
oneHashE :: Q Exp
oneHashE = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showCharValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
'#'
twoHashE :: Q Exp
twoHashE = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE String
"##"

#if MIN_VERSION_base(4,19,0)
extendedLitE :: String -> Q Exp
extendedLitE :: String -> Q Exp
extendedLitE String
suffix = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
showStringValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String
"#" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
suffix)
#endif