{-# 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
    Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
    Q Pat -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ ShowOptions -> Name -> Q Exp
makeShowsPrecOptions ShowOptions
opts Name
name
                     Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
0
                     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
x
                     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
""

-- | 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
    Name
sp' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"sp'"
    Name
sl' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"sl'"
    [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
sp', Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
sl'] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ 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
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
sp' 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
sl'
                                            Q Exp -> Q Exp -> Q Exp
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
                           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
    Name
sp1' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"sp1'"
    Name
sl1' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"sl1'"
    Name
sp2' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"sp2'"
    Name
sl2' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"sl2'"
    [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
sp1', Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
sl1', Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
sp2', Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
sl2'] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
        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
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
sp1' 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
sl1'
                                                 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
sp2' 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
sl2'
                                                 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 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
  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)
          <- ShowClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance ShowClass
sClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
      (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (Cxt -> Q Cxt
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
                             (Type -> Q Type
forall a. a -> Q a
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 =
    [ 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
  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.
      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
    Name
p     <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"p"
    Name
value <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"value"
    [Name]
sps   <- String -> Int -> Q [Name]
newNameList String
"sp" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ ShowClass -> Int
forall a. ClassRep a => a -> Int
arity ShowClass
sClass
    [Name]
sls   <- String -> Int -> Q [Name]
newNameList String
"sl" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ ShowClass -> Int
forall a. ClassRep a => a -> Int
arity ShowClass
sClass
    let spls :: [(Name, Name)]
spls       = [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
sps [Name]
sls
        spsAndSls :: [Name]
spsAndSls  = [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
interleave [Name]
sps [Name]
sls
        lastTyVars :: [Name]
lastTyVars = (Type -> Name) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName (Cxt -> [Name]) -> Cxt -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop (Cxt -> Int
forall 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 :: Map Name (OneOrTwoNames Two)
splMap     = [(Name, OneOrTwoNames Two)] -> Map Name (OneOrTwoNames Two)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, OneOrTwoNames Two)] -> Map Name (OneOrTwoNames Two))
-> [(Name, OneOrTwoNames Two)] -> Map Name (OneOrTwoNames Two)
forall a b. (a -> b) -> a -> b
$ (Name -> (Name, Name) -> (Name, OneOrTwoNames Two))
-> [Name] -> [(Name, Name)] -> [(Name, OneOrTwoNames Two)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\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
          | [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)

    [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP ([Name] -> [Q Pat]) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> a -> b
$ [Name]
spsAndSls [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
p, Name
value])
        (Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
        ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ ShowClass -> Name
showsPrecConstName ShowClass
sClass
          , Q Exp
makeFun
          ] [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
spsAndSls
            [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p, Name -> Q Exp
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 = [] }) =
    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
    Type
argTy' <- Type -> Q Type
resolveTypeSynonyms Type
argTy
    Name
arg <- String -> Q Name
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 = 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

    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 [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
arg])
      (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
showParenValName
                  Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` 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
p) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
gtValName) (Int -> Q Exp
integerE Int
appPrec)
                  Q Exp -> Q Exp -> Q Exp
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' <- (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
    [Name]
args <- String -> Int -> Q [Name]
newNameList String
"arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
argTys'

    if Name -> Bool
isNonUnitTuple Name
conName
       then do
         let showArgs :: [Q Exp]
showArgs       = (Type -> Name -> Q Exp) -> Cxt -> [Name] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int
-> ShowClass
-> ShowOptions
-> Name
-> Map Name (OneOrTwoNames Two)
-> Type
-> Name
-> Q Exp
makeShowForArg Int
0 ShowClass
sClass ShowOptions
opts Name
conName Map Name (OneOrTwoNames Two)
tvMap) Cxt
argTys' [Name]
args
             parenCommaArgs :: [Q Exp]
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
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

         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 Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
               (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
mappendArgs)
               []
       else do
         let showArgs :: [Q Exp]
showArgs    = (Type -> Name -> Q Exp) -> Cxt -> [Name] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int
-> ShowClass
-> ShowOptions
-> Name
-> Map Name (OneOrTwoNames Two)
-> Type
-> Name
-> Q Exp
makeShowForArg Int
appPrec1 ShowClass
sClass ShowOptions
opts Name
conName Map Name (OneOrTwoNames Two)
tvMap) Cxt
argTys' [Name]
args
             mappendArgs :: Q Exp
mappendArgs = (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall 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
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

         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 Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
               (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
showParenValName
                            Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` 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
p) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
gtValName) (Int -> Q Exp
integerE Int
appPrec)
                            Q Exp -> Q Exp -> Q Exp
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' <- (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
    [Name]
args <- String -> Int -> Q [Name]
newNameList String
"arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
argTys'

    let showArgs :: [Q Exp]
showArgs       = ((Name, Type, Name) -> [Q Exp]) -> [(Name, Type, Name)] -> [Q Exp]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(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 :: [Q Exp]
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
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
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

    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 Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
      (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
showParenValName
                   Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` 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
p) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
gtValName) (Int -> Q Exp
integerE Int
appPrec)
                   Q Exp -> Q Exp -> Q Exp
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] <- (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
    Name
al   <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"argL"
    Name
ar   <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"argR"
    Fixity
fi <- Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity (Maybe Fixity -> Fixity) -> Q (Maybe Fixity) -> Q Fixity
forall a b. (a -> b) -> Q a -> Q b
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 = 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
"` "

    Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
      (Q Pat -> Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
infixP (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
al) Name
conName (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
ar))
      (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
showParenValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` 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
p) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
gtValName) (Int -> Q Exp
integerE Int
conPrec))
                   Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Q Exp -> Q Exp -> Q Exp -> Q Exp
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ShowClass
sClass ShowOptions
opts Name
conName Map Name (OneOrTwoNames Two)
tvMap Type
alTy Name
al)
                                    (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 Q Exp
infixOpE
                                              (Name -> Q Exp
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 Int -> Int -> Int
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 = 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

    Bool
itf <- [Name] -> Type -> Cxt -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
tyCon Cxt
tyArgs
    if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
lhsArgs
          Bool -> Bool -> Bool
|| Bool
itf Bool -> Bool -> Bool
&& (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs
       then ShowClass -> Name -> Q Exp
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError ShowClass
sClass Name
conName
       else if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
               then [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (ShowClass -> Name) -> ShowClass -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowClass -> Name
showsPrecOrListName Bool
sl (ShowClass -> Q Exp) -> ShowClass -> Q Exp
forall a b. (a -> b) -> a -> b
$ Int -> ShowClass
forall a. Enum a => Int -> a
toEnum Int
numLastArgs]
                            [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Bool -> Type -> Q Exp) -> [Bool] -> Cxt -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ShowClass
-> Name -> Map Name (OneOrTwoNames Two) -> Bool -> Type -> Q Exp
makeShowForType ShowClass
sClass Name
conName Map Name (OneOrTwoNames Two)
tvMap)
                                       ([Bool] -> [Bool]
forall a. HasCallStack => [a] -> [a]
cycle [Bool
False,Bool
True])
                                       (Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
interleave Cxt
rhsArgs Cxt
rhsArgs)
               else Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ if Bool
sl then Name
showListValName else Name
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)
    , (int8HashTypeName,   PrimShow
                             { primShowBoxer      = appE (conE i8HashDataName)
                             , primShowPostfixMod = extendedLitE "Int8"
                             , primShowConv       = id
                             })
    , (int16HashTypeName,  PrimShow
                             { primShowBoxer      = appE (conE i16HashDataName)
                             , primShowPostfixMod = extendedLitE "Int16"
                             , primShowConv       = id
                             })
    , (int32HashTypeName,  PrimShow
                             { primShowBoxer      = appE (conE i32HashDataName)
                             , primShowPostfixMod = extendedLitE "Int32"
                             , primShowConv       = id
                             })
    , (int64HashTypeName,  PrimShow
                             { primShowBoxer      = appE (conE i64HashDataName)
                             , primShowPostfixMod = extendedLitE "Int64"
                             , primShowConv       = id
                             })
    , (word8HashTypeName,  PrimShow
                             { primShowBoxer      = appE (conE w8HashDataName)
                             , primShowPostfixMod = extendedLitE "Word8"
                             , primShowConv       = id
                             })
    , (word16HashTypeName, PrimShow
                             { primShowBoxer      = appE (conE w16HashDataName)
                             , primShowPostfixMod = extendedLitE "Word16"
                             , primShowConv       = id
                             })
    , (word32HashTypeName, PrimShow
                             { primShowBoxer      = appE (conE w32HashDataName)
                             , primShowPostfixMod = extendedLitE "Word32"
                             , primShowConv       = id
                             })
    , (word64HashTypeName, PrimShow
                             { primShowBoxer      = appE (conE w64HashDataName)
                             , primShowPostfixMod = extendedLitE "Word64"
                             , primShowConv       = id
                             })
#else
# if MIN_VERSION_base(4,13,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
iHashDataName) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
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      = 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) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
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      = 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) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
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      = 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) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
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      = 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) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
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      = 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) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
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
#endif
    ]

#if MIN_VERSION_base(4,13,0) && !(MIN_VERSION_base(4,19,0))
mkNarrowE :: Name -> Q Exp -> Q Exp
mkNarrowE :: Name -> Q Exp -> Q Exp
mkNarrowE Name
narrowName Q Exp
e =
  (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
')')
        [ 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 (Char
'('Char -> ShowS
forall a. a -> [a] -> [a]
:Name -> String
nameBase Name
narrowName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ")
        , Q Exp
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 suffix = varE showStringValName `appE` stringE ("#" ++ suffix)
#endif