    {-# LANGUAGE CPP #-}
    {-# LANGUAGE GADTs #-}
    {-|
    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.
    -}
    module Text.Show.Deriving.Internal (
          -- * 'Show'
          deriveShow
        , deriveShowOptions
        , makeShowsPrec
        , makeShowsPrecOptions
        , makeShow
        , makeShowOptions
        , makeShowList
        , makeShowListOptions
          -- * 'Show1'
        , deriveShow1
        , deriveShow1Options
    #if defined(NEW_FUNCTOR_CLASSES)
        , makeLiftShowsPrec
        , makeLiftShowsPrecOptions
        , makeLiftShowList
        , makeLiftShowListOptions
    #endif
        , makeShowsPrec1
        , makeShowsPrec1Options
    #if defined(NEW_FUNCTOR_CLASSES)
          -- * 'Show2'
        , deriveShow2
        , deriveShow2Options
        , makeLiftShowsPrec2
        , makeLiftShowsPrec2Options
        , makeLiftShowList2
        , makeLiftShowList2Options
        , makeShowsPrec2
        , makeShowsPrec2Options
    #endif
          -- * 'ShowOptions'
        , ShowOptions(..)
        , defaultShowOptions
        , legacyShowOptions
        ) where

    #if MIN_VERSION_template_haskell(2,11,0)
    import           Control.Monad ((<=<))
    import           Data.Maybe (fromMaybe, isJust)
    #endif

    import           Data.Deriving.Internal
    import           Data.List
    import qualified Data.Map as Map

    import           GHC.Show (appPrec, appPrec1)

    import           Language.Haskell.TH.Lib
    import           Language.Haskell.TH.Syntax

    -- | Options that further configure how the functions in "Text.Show.Deriving"
    -- should behave.
    newtype ShowOptions = ShowOptions
      { 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 (@#@).
      } deriving (Eq, Ord, Read, Show)

    -- | 'ShowOptions' that match the behavior of the most recent GHC release.
    defaultShowOptions :: ShowOptions
    defaultShowOptions = ShowOptions { ghc8ShowBehavior = True }

    -- | 'ShowOptions' that match the behavior of the installed version of GHC.
    legacyShowOptions :: ShowOptions
    legacyShowOptions = ShowOptions
      { ghc8ShowBehavior =
    #if __GLASGOW_HASKELL__ >= 711
                           True
    #else
                           False
    #endif
      }

    -- | Generates a 'Show' instance declaration for the given data type or data
    -- family instance.
    deriveShow :: Name -> Q [Dec]
    deriveShow = deriveShowOptions defaultShowOptions

    -- | Like 'deriveShow', but takes a 'ShowOptions' argument.
    deriveShowOptions :: ShowOptions -> Name -> Q [Dec]
    deriveShowOptions = deriveShowClass Show

    -- | Generates a lambda expression which behaves like 'show' (without
    -- requiring a 'Show' instance).
    makeShow :: Name -> Q Exp
    makeShow = makeShowOptions defaultShowOptions

    -- | Like 'makeShow', but takes a 'ShowOptions' argument.
    makeShowOptions :: ShowOptions -> Name -> Q Exp
    makeShowOptions opts name = do
        x <- newName "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 = makeShowsPrecOptions defaultShowOptions

    -- | Like 'makeShowsPrec', but takes a 'ShowOptions' argument.
    makeShowsPrecOptions :: ShowOptions -> Name -> Q Exp
    makeShowsPrecOptions = makeShowsPrecClass Show

    -- | Generates a lambda expression which behaves like 'showList' (without
    -- requiring a 'Show' instance).
    makeShowList :: Name -> Q Exp
    makeShowList = makeShowListOptions defaultShowOptions

    -- | Like 'makeShowList', but takes a 'ShowOptions' argument.
    makeShowListOptions :: ShowOptions -> Name -> Q Exp
    makeShowListOptions opts name =
        varE showListWithValName `appE` (makeShowsPrecOptions opts name `appE` integerE 0)

    -- | Generates a 'Show1' instance declaration for the given data type or data
    -- family instance.
    deriveShow1 :: Name -> Q [Dec]
    deriveShow1 = deriveShow1Options defaultShowOptions

    -- | Like 'deriveShow1', but takes a 'ShowOptions' argument.
    deriveShow1Options :: ShowOptions -> Name -> Q [Dec]
    deriveShow1Options = deriveShowClass Show1

    -- | Generates a lambda expression which behaves like 'showsPrec1' (without
    -- requiring a 'Show1' instance).
    makeShowsPrec1 :: Name -> Q Exp
    makeShowsPrec1 = makeShowsPrec1Options defaultShowOptions

    #if defined(NEW_FUNCTOR_CLASSES)
    -- | Generates a lambda expression which behaves like 'liftShowsPrec' (without
    -- requiring a 'Show1' instance).
    --
    -- This function is not available with @transformers-0.4@.
    makeLiftShowsPrec :: Name -> Q Exp
    makeLiftShowsPrec = makeLiftShowsPrecOptions defaultShowOptions

    -- | Like 'makeLiftShowsPrec', but takes a 'ShowOptions' argument.
    --
    -- This function is not available with @transformers-0.4@.
    makeLiftShowsPrecOptions :: ShowOptions -> Name -> Q Exp
    makeLiftShowsPrecOptions = makeShowsPrecClass 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 = makeLiftShowListOptions defaultShowOptions

    -- | Like 'makeLiftShowList', but takes a 'ShowOptions' argument.
    --
    -- This function is not available with @transformers-0.4@.
    makeLiftShowListOptions :: ShowOptions -> Name -> Q Exp
    makeLiftShowListOptions opts name = do
        sp' <- newName "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 opts name = makeLiftShowsPrecOptions opts name
                               `appE` varE showsPrecValName
                               `appE` varE showListValName
    #else
    -- | Like 'makeShowsPrec1', but takes a 'ShowOptions' argument.
    makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp
    makeShowsPrec1Options = makeShowsPrecClass Show1
    #endif

    #if defined(NEW_FUNCTOR_CLASSES)
    -- | Generates a 'Show2' instance declaration for the given data type or data
    -- family instance.
    --
    -- This function is not available with @transformers-0.4@.
    deriveShow2 :: Name -> Q [Dec]
    deriveShow2 = deriveShow2Options defaultShowOptions

    -- | Like 'deriveShow2', but takes a 'ShowOptions' argument.
    --
    -- This function is not available with @transformers-0.4@.
    deriveShow2Options :: ShowOptions -> Name -> Q [Dec]
    deriveShow2Options = deriveShowClass 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 = makeLiftShowsPrec2Options defaultShowOptions

    -- | Like 'makeLiftShowsPrec2', but takes a 'ShowOptions' argument.
    --
    -- This function is not available with @transformers-0.4@.
    makeLiftShowsPrec2Options :: ShowOptions -> Name -> Q Exp
    makeLiftShowsPrec2Options = makeShowsPrecClass 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 = makeLiftShowList2Options defaultShowOptions

    -- | Like 'makeLiftShowList2', but takes a 'ShowOptions' argument.
    --
    -- This function is not available with @transformers-0.4@.
    makeLiftShowList2Options :: ShowOptions -> Name -> Q Exp
    makeLiftShowList2Options opts name = do
        sp1' <- newName "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 = makeShowsPrec2Options defaultShowOptions

    -- | Like 'makeShowsPrec2', but takes a 'ShowOptions' argument.
    --
    -- This function is not available with @transformers-0.4@.
    makeShowsPrec2Options :: ShowOptions -> Name -> Q Exp
    makeShowsPrec2Options opts name = makeLiftShowsPrec2Options opts name
                               `appE` varE showsPrecValName
                               `appE` varE showListValName
                               `appE` varE showsPrecValName
                               `appE` varE showListValName
    #endif

    -------------------------------------------------------------------------------
    -- Code generation
    -------------------------------------------------------------------------------

    -- | Derive a Show(1)(2) instance declaration (depending on the ShowClass
    -- argument's value).
    deriveShowClass :: ShowClass -> ShowOptions -> Name -> Q [Dec]
    deriveShowClass sClass opts name = withType name fromCons
      where
        fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]
        fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do
            (instanceCxt, instanceType)
                <- buildTypeInstance sClass name' ctxt tvbs mbTys
            instanceD (return instanceCxt)
                      (return instanceType)
                      (showsPrecDecs sClass opts 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 -> [Con] -> [Q Dec]
    showsPrecDecs sClass opts cons =
        [ funD (showsPrecName sClass)
               [ clause []
                        (normalB $ makeShowForCons sClass opts 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 sClass opts name = withType name fromCons
      where
        fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp
        fromCons name' ctxt tvbs cons mbTys =
            -- 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.
            buildTypeInstance sClass name' ctxt tvbs mbTys
              `seq` makeShowForCons sClass opts cons

    -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for the
    -- given constructors. All constructors must be from the same type.
    makeShowForCons :: ShowClass -> ShowOptions -> [Con] -> Q Exp
    makeShowForCons _ _ [] = noConstructorsError
    makeShowForCons sClass opts cons = do
        p     <- newName "p"
        value <- newName "value"
        sps   <- newNameList "sp" $ arity sClass
        sls   <- newNameList "sl" $ arity sClass
        let spls       = zip sps sls
            _spsAndSls = interleave sps sls
        matches <- concatMapM (makeShowForCon p sClass opts spls) cons
        lamE (map varP $
    #if defined(NEW_FUNCTOR_CLASSES)
                         _spsAndSls ++
    #endif
                         [p, value])
            . appsE
            $ [ varE $ showsPrecConstName sClass
              , caseE (varE value) (map return matches)
              ]
    #if defined(NEW_FUNCTOR_CLASSES)
                ++ map varE _spsAndSls
    #endif
                ++ [varE p, varE value]

    -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a
    -- single constructor.
    makeShowForCon :: Name
                   -> ShowClass
                   -> ShowOptions
                   -> [(Name, Name)]
                   -> Con
                   -> Q [Match]
    makeShowForCon _ sClass _ spls (NormalC conName []) = do
        ([], _) <- reifyConTys2 sClass spls conName
        m <- match
               (conP conName [])
               (normalB $ varE showStringValName `appE` stringE (parenInfixConName conName ""))
               []
        return [m]
    makeShowForCon p sClass opts spls (NormalC conName [_]) = do
        ([argTy], tvMap) <- reifyConTys2 sClass spls conName
        arg <- newName "arg"

        let showArg  = makeShowForArg appPrec1 sClass opts conName tvMap argTy arg
            namedArg = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " "))
                                (varE composeValName)
                                showArg

        m <- match
               (conP conName [varP arg])
               (normalB $ varE showParenValName
                           `appE` infixApp (varE p) (varE gtValName) (integerE appPrec)
                           `appE` namedArg)
               []
        return [m]
    makeShowForCon p sClass opts spls (NormalC conName _) = do
        (argTys, tvMap) <- reifyConTys2 sClass spls conName
        args <- newNameList "arg" $ length argTys

        m <- if isNonUnitTuple conName
             then do
               let showArgs       = zipWith (makeShowForArg 0 sClass opts conName tvMap) argTys args
                   parenCommaArgs = (varE showCharValName `appE` charE '(')
                                    : intersperse (varE showCharValName `appE` charE ',') showArgs
                   mappendArgs    = foldr (`infixApp` varE composeValName)
                                          (varE showCharValName `appE` charE ')')
                                          parenCommaArgs

               match (conP conName $ map varP args)
                     (normalB mappendArgs)
                     []
             else do
               let showArgs    = zipWith (makeShowForArg appPrec1 sClass opts conName tvMap) argTys args
                   mappendArgs = foldr1 (\v q -> infixApp v (varE composeValName)
                                                          (infixApp (varE showSpaceValName)
                                                                  (varE composeValName)
                                                                  q)) showArgs
                   namedArgs   = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " "))
                                          (varE composeValName)
                                          mappendArgs

               match (conP conName $ map varP args)
                     (normalB $ varE showParenValName
                                  `appE` infixApp (varE p) (varE gtValName) (integerE appPrec)
                                  `appE` namedArgs)
                     []
        return [m]
    makeShowForCon p sClass opts spls (RecC conName []) =
        makeShowForCon p sClass opts spls $ NormalC conName []
    makeShowForCon p sClass opts spls (RecC conName ts) = do
        (argTys, tvMap) <- reifyConTys2 sClass spls conName
        args <- newNameList "arg" $ length argTys

        let showArgs       = concatMap (\((argName, _, _), argTy, arg)
                                          -> let argNameBase = nameBase argName
                                                 infixRec    = showParen (isSym argNameBase)
                                                                         (showString argNameBase) ""
                                             in [ varE showStringValName `appE` stringE (infixRec ++ " = ")
                                                , makeShowForArg 0 sClass opts conName tvMap argTy arg
                                                , varE showCommaSpaceValName
                                                ]
                                       )
                                       (zip3 ts argTys args)
            braceCommaArgs = (varE showCharValName `appE` charE '{') : take (length showArgs - 1) showArgs
            mappendArgs    = foldr (`infixApp` varE composeValName)
                                   (varE showCharValName `appE` charE '}')
                                   braceCommaArgs
            namedArgs      = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " "))
                                      (varE composeValName)
                                      mappendArgs

        m <- match
               (conP conName $ map varP args)
               (normalB $ varE showParenValName
                            `appE` infixApp (varE p) (varE gtValName) (integerE appPrec)
                            `appE` namedArgs)
               []
        return [m]
    makeShowForCon p sClass opts spls (InfixC _ conName _) = do
        ([alTy, arTy], tvMap) <- reifyConTys2 sClass spls conName
        al   <- newName "argL"
        ar   <- newName "argR"
        info <- reify conName

    #if MIN_VERSION_template_haskell(2,11,0)
        conPrec <- case info of
                            DataConI{} -> do
                                fi <- fromMaybe defaultFixity <$> reifyFixity conName
                                case fi of
                                     Fixity prec _ -> return prec
    #else
        let conPrec  = case info of
                            DataConI _ _ _ (Fixity prec _) -> prec
    #endif
                            _ -> error $ "Text.Show.Deriving.Internal.makeShowForCon: Unsupported type: " ++ show info

        let opName   = nameBase conName
            infixOpE = appE (varE showStringValName) . stringE $
                         if isInfixDataCon opName
                            then " "  ++ opName ++ " "
                            else " `" ++ opName ++ "` "

        m <- 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)))
               )
               []
        return [m]
    makeShowForCon p sClass opts spls (ForallC _ _ con) =
        makeShowForCon p sClass opts spls con
    #if MIN_VERSION_template_haskell(2,11,0)
    makeShowForCon p sClass opts spls (GadtC conNames ts _) =
        let con :: Name -> Q Con
            con conName = do
                mbFi <- reifyFixity conName
                return $ if isInfixDataCon (nameBase conName)
                            && length ts == 2
                            && isJust mbFi
                          then let [t1, t2] = ts in InfixC t1 conName t2
                          else NormalC conName ts

        in concatMapM (makeShowForCon p sClass opts spls <=< con) conNames
    makeShowForCon p sClass opts spls (RecGadtC conNames ts _) =
        concatMapM (makeShowForCon p sClass opts spls . flip RecC ts) conNames
    #endif

    -- | 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 p _ opts _ _ (ConT tyName) tyExpName =
        showE
      where
        tyVarE :: Q Exp
        tyVarE = varE tyExpName

        showE :: Q Exp
        showE | tyName == charHashTypeName   = showPrimE cHashDataName oneHashE
              | tyName == doubleHashTypeName = showPrimE dHashDataName twoHashE
              | tyName == floatHashTypeName  = showPrimE fHashDataName oneHashE
              | tyName == intHashTypeName    = showPrimE iHashDataName oneHashE
              | tyName == wordHashTypeName   = showPrimE wHashDataName twoHashE
              | otherwise = varE showsPrecValName `appE` integerE p `appE` tyVarE

        -- Starting with GHC 7.10, 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.
        showPrimE :: Name -> Q Exp -> Q Exp
        showPrimE con hashE
          | ghc8ShowBehavior opts
          = infixApp (varE showsPrecValName `appE` integerE 0 `appE` (conE con `appE` tyVarE))
                     (varE composeValName)
                     hashE
          | otherwise = varE showsPrecValName `appE` integerE p `appE` (conE con `appE` tyVarE)

        oneHashE, twoHashE :: Q Exp
        oneHashE = varE showCharValName `appE` charE '#'
        twoHashE = varE showStringValName `appE` stringE "##"
    makeShowForArg p sClass _ conName tvMap ty tyExpName =
        makeShowForType sClass conName tvMap False ty `appE` integerE p `appE` varE tyExpName

    -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a
    -- specific type. The generated expression depends on the number of type variables.
    --
    -- 1. If the type is of kind * (T), apply showsPrec.
    -- 2. If the type is of kind * -> * (T a), apply liftShowsPrec $(makeShowForType a)
    -- 3. If the type is of kind * -> * -> * (T a b), apply
    --    liftShowsPrec2 $(makeShowForType a) $(makeShowForType b)
    makeShowForType :: ShowClass
                    -> Name
                    -> TyVarMap2
                    -> Bool -- ^ True if we are using the function of type ([a] -> ShowS),
                            --   False if we are using the function of type (Int -> a -> ShowS).
                    -> Type
                    -> Q Exp
    #if defined(NEW_FUNCTOR_CLASSES)
    makeShowForType _ _ tvMap sl (VarT tyName) =
        varE $ case Map.lookup tyName tvMap of
          Just (TwoNames spExp slExp) -> if sl then slExp else spExp
          Nothing -> if sl then showListValName else showsPrecValName
    #else
    makeShowForType _ _ _ _ VarT{} = varE showsPrecValName
    #endif
    makeShowForType sClass conName tvMap sl (SigT ty _)      = makeShowForType sClass conName tvMap sl ty
    makeShowForType sClass conName tvMap sl (ForallT _ _ ty) = makeShowForType sClass conName tvMap sl ty
    #if defined(NEW_FUNCTOR_CLASSES)
    makeShowForType sClass conName tvMap sl ty = do
        let tyCon :: Type
            tyArgs :: [Type]
            tyCon:tyArgs = unapplyTy ty

            numLastArgs :: Int
            numLastArgs = min (arity sClass) (length tyArgs)

            lhsArgs, rhsArgs :: [Type]
            (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs

            tyVarNames :: [Name]
            tyVarNames = Map.keys tvMap

        itf <- isTyFamily tyCon
        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
    #else
    makeShowForType sClass conName tvMap _ ty = do
      let varNames = Map.keys tvMap

      p'     <- newName "p'"
      value' <- newName "value'"
      case varNames of
        [] -> varE showsPrecValName
        varName:_ ->
          if mentionsName ty varNames
             then lamE [varP p', varP value'] $ varE showsPrec1ValName
                    `appE` varE p'
                    `appE` (makeFmapApplyNeg sClass conName ty varName `appE` varE value')
             else varE showsPrecValName
    #endif

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

    -- | A representation of which @Show@ variant is being derived.
    data ShowClass = Show
                   | Show1
    #if defined(NEW_FUNCTOR_CLASSES)
                   | Show2
    #endif
      deriving (Bounded, Enum)

    instance ClassRep ShowClass where
        arity = fromEnum

        allowExQuant _ = True

        fullClassName Show  = showTypeName
        fullClassName Show1 = show1TypeName
    #if defined(NEW_FUNCTOR_CLASSES)
        fullClassName Show2 = show2TypeName
    #endif

        classConstraint sClass i
          | sMin <= i && i <= sMax = Just $ fullClassName (toEnum i :: ShowClass)
          | otherwise              = Nothing
          where
            sMin, sMax :: Int
            sMin = fromEnum (minBound :: ShowClass)
            sMax = fromEnum sClass

    showsPrecConstName :: ShowClass -> Name
    showsPrecConstName Show  = showsPrecConstValName
    #if defined(NEW_FUNCTOR_CLASSES)
    showsPrecConstName Show1 = liftShowsPrecConstValName
    showsPrecConstName Show2 = liftShowsPrec2ConstValName
    #else
    showsPrecConstName Show1 = showsPrec1ConstValName
    #endif

    showsPrecName :: ShowClass -> Name
    showsPrecName Show  = showsPrecValName
    #if defined(NEW_FUNCTOR_CLASSES)
    showsPrecName Show1 = liftShowsPrecValName
    showsPrecName Show2 = liftShowsPrec2ValName
    #else
    showsPrecName Show1 = showsPrec1ValName
    #endif

    #if defined(NEW_FUNCTOR_CLASSES)
    showListName :: ShowClass -> Name
    showListName Show  = showListValName
    showListName Show1 = liftShowListValName
    showListName Show2 = liftShowList2ValName

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

    -------------------------------------------------------------------------------
    -- Assorted utilities
    -------------------------------------------------------------------------------

    -- | Parenthesize an infix constructor name if it is being applied as a prefix
    -- function (e.g., data Amp a = (:&) a a)
    parenInfixConName :: Name -> ShowS
    parenInfixConName conName =
        let conNameBase = nameBase conName
         in showParen (isInfixDataCon conNameBase) $ showString conNameBase

    charE :: Char -> Q Exp
    charE = litE . charL