-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Singletons.Deriving.Show
-- Copyright   :  (C) 2017 Ryan Scott
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Ryan Scott
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Implements deriving of Show instances
--
----------------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Singletons.Deriving.Show (
    mkShowInstance
  , ShowMode(..)
  , mkShowSingContext
  ) where

import Language.Haskell.TH.Syntax hiding (showName)
import Language.Haskell.TH.Desugar
import Data.Singletons.Names
import Data.Singletons.TH.Options
import Data.Singletons.Util
import Data.Singletons.Syntax
import Data.Singletons.Deriving.Infer
import Data.Singletons.Deriving.Util
import Data.Maybe (fromMaybe)
import GHC.Lexeme (startsConSym, startsVarSym)
import GHC.Show (appPrec, appPrec1)

mkShowInstance :: OptionsMonad q => ShowMode -> DerivDesc q
mkShowInstance :: ShowMode -> DerivDesc q
mkShowInstance ShowMode
mode Maybe DCxt
mb_ctxt DType
ty (DataDecl Name
_ [DTyVarBndr]
_ [DCon]
cons) = do
  [DClause]
clauses <- ShowMode -> [DCon] -> q [DClause]
forall (q :: * -> *).
OptionsMonad q =>
ShowMode -> [DCon] -> q [DClause]
mk_showsPrec ShowMode
mode [DCon]
cons
  DCxt
constraints <- Maybe DCxt -> DType -> DType -> [DCon] -> q DCxt
forall (q :: * -> *).
DsMonad q =>
Maybe DCxt -> DType -> DType -> [DCon] -> q DCxt
inferConstraintsDef ((DCxt -> DCxt) -> Maybe DCxt -> Maybe DCxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowMode -> DCxt -> DCxt
mkShowSingContext ShowMode
mode) Maybe DCxt
mb_ctxt)
                                     (Name -> DType
DConT (ShowMode -> Name
mk_Show_name ShowMode
mode))
                                     DType
ty [DCon]
cons
  DType
ty' <- ShowMode -> DType -> q DType
forall (q :: * -> *).
OptionsMonad q =>
ShowMode -> DType -> q DType
mk_Show_inst_ty ShowMode
mode DType
ty
  UInstDecl -> q UInstDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (UInstDecl -> q UInstDecl) -> UInstDecl -> q UInstDecl
forall a b. (a -> b) -> a -> b
$ InstDecl :: forall (ann :: AnnotationFlag).
DCxt
-> Name
-> DCxt
-> OMap Name DType
-> [(Name, LetDecRHS ann)]
-> InstDecl ann
InstDecl { id_cxt :: DCxt
id_cxt = DCxt
constraints
                    , id_name :: Name
id_name = Name
showName
                    , id_arg_tys :: DCxt
id_arg_tys = [DType
ty']
                    , id_sigs :: OMap Name DType
id_sigs  = OMap Name DType
forall a. Monoid a => a
mempty
                    , id_meths :: [(Name, LetDecRHS Unannotated)]
id_meths = [ (Name
showsPrecName, [DClause] -> LetDecRHS Unannotated
UFunction [DClause]
clauses) ] }

mk_showsPrec :: OptionsMonad q => ShowMode -> [DCon] -> q [DClause]
mk_showsPrec :: ShowMode -> [DCon] -> q [DClause]
mk_showsPrec ShowMode
mode [DCon]
cons = do
    Name
p <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"p" -- The precedence argument (not always used)
    if [DCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DCon]
cons
       then do Name
v <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"v"
               [DClause] -> q [DClause]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[DPat] -> DExp -> DClause
DClause [DPat
DWildP, Name -> DPat
DVarP Name
v] (DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
v) [])]
       else (DCon -> q DClause) -> [DCon] -> q [DClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ShowMode -> Name -> DCon -> q DClause
forall (q :: * -> *).
OptionsMonad q =>
ShowMode -> Name -> DCon -> q DClause
mk_showsPrec_clause ShowMode
mode Name
p) [DCon]
cons

mk_showsPrec_clause :: forall q. OptionsMonad q
                    => ShowMode -> Name -> DCon
                    -> q DClause
mk_showsPrec_clause :: ShowMode -> Name -> DCon -> q DClause
mk_showsPrec_clause ShowMode
mode Name
p (DCon [DTyVarBndr]
_ DCxt
_ Name
con_name DConFields
con_fields DType
_) = DConFields -> q DClause
go DConFields
con_fields
  where
    go :: DConFields -> q DClause
    go :: DConFields -> q DClause
go DConFields
con_fields' = do
      Options
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions

      let con_name' :: Name
          con_name' :: Name
con_name' = case ShowMode
mode of
                        ShowMode
ForPromotion  -> Name
con_name
                        ForShowSing{} -> Options -> Name -> Name
singledDataConName Options
opts Name
con_name

      case DConFields
con_fields' of

        -- No fields: print just the constructor name, with no parentheses
        DNormalC Bool
_ [] -> DClause -> q DClause
forall (m :: * -> *) a. Monad m => a -> m a
return (DClause -> q DClause) -> DClause -> q DClause
forall a b. (a -> b) -> a -> b
$
          [DPat] -> DExp -> DClause
DClause [DPat
DWildP, Name -> [DPat] -> DPat
DConP Name
con_name' []] (DExp -> DClause) -> DExp -> DClause
forall a b. (a -> b) -> a -> b
$
            Name -> DExp
DVarE Name
showStringName DExp -> DExp -> DExp
`DAppE` String -> DExp
dStringE (Name -> ShowS
parenInfixConName Name
con_name' String
"")

        -- Infix constructors have special Show treatment.
        DNormalC Bool
True tys :: [DBangType]
tys@[DBangType
_, DBangType
_]
            -- Although the (:) constructor is infix, its singled counterpart SCons
            -- is not, which matters if we're deriving a ShowSing instance.
            -- Unless we remove this special case (see #234), we will simply
            -- shunt it along as if we were dealing with a prefix constructor.
          |  ForShowSing{} <- ShowMode
mode
          ,  Name
con_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
consName
          -> DConFields -> q DClause
go (Bool -> [DBangType] -> DConFields
DNormalC Bool
False [DBangType]
tys)

          |  Bool
otherwise
          -> do Name
argL   <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"argL"
                Name
argR   <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"argR"
                Name
argTyL <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"argTyL"
                Name
argTyR <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"argTyR"
                Fixity
fi <- Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity (Maybe Fixity -> Fixity) -> q (Maybe Fixity) -> q Fixity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> q (Maybe Fixity)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Fixity)
reifyFixityWithLocals Name
con_name'
                let con_prec :: Int
con_prec = case Fixity
fi of Fixity Int
prec FixityDirection
_ -> Int
prec
                    op_name :: String
op_name  = Name -> String
nameBase Name
con_name'
                    infixOpE :: DExp
infixOpE = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE Name
showStringName) (DExp -> DExp) -> (String -> DExp) -> String -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DExp
dStringE (String -> DExp) -> String -> DExp
forall a b. (a -> b) -> a -> b
$
                                 if String -> Bool
isInfixDataCon String
op_name
                                    then String
" "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
op_name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" "
                                    -- Make sure to handle infix data constructors
                                    -- like (Int `Foo` Int)
                                    else String
" `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
op_name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"` "
                DClause -> q DClause
forall (m :: * -> *) a. Monad m => a -> m a
return (DClause -> q DClause) -> DClause -> q DClause
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause [ Name -> DPat
DVarP Name
p
                                 , Name -> [DPat] -> DPat
DConP Name
con_name' ([DPat] -> DPat) -> [DPat] -> DPat
forall a b. (a -> b) -> a -> b
$
                                   (Name -> Name -> DPat) -> [Name] -> [Name] -> [DPat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ShowMode -> Name -> Name -> DPat
mk_Show_arg_pat ShowMode
mode) [Name
argL, Name
argR] [Name
argTyL, Name
argTyR]
                                 ] (DExp -> DClause) -> DExp -> DClause
forall a b. (a -> b) -> a -> b
$
                  ShowMode -> [Name] -> DExp -> DExp
mk_Show_rhs_sig ShowMode
mode [Name
argTyL, Name
argTyR] (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$
                  (Name -> DExp
DVarE Name
showParenName DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
gtName DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
p
                                                             DExp -> DExp -> DExp
`DAppE` Int -> DExp
dIntegerE Int
con_prec))
                    DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
composeName
                               DExp -> DExp -> DExp
`DAppE` Int -> Name -> DExp
showsPrecE (Int
con_prec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Name
argL
                               DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
composeName
                                          DExp -> DExp -> DExp
`DAppE` DExp
infixOpE
                                          DExp -> DExp -> DExp
`DAppE` Int -> Name -> DExp
showsPrecE (Int
con_prec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Name
argR))

        DNormalC Bool
_ [DBangType]
tys -> do
          [Name]
args   <- (DBangType -> q Name) -> [DBangType] -> q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (q Name -> DBangType -> q Name
forall a b. a -> b -> a
const (q Name -> DBangType -> q Name) -> q Name -> DBangType -> q Name
forall a b. (a -> b) -> a -> b
$ String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"arg")   [DBangType]
tys
          [Name]
argTys <- (DBangType -> q Name) -> [DBangType] -> q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (q Name -> DBangType -> q Name
forall a b. a -> b -> a
const (q Name -> DBangType -> q Name) -> q Name -> DBangType -> q Name
forall a b. (a -> b) -> a -> b
$ String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"argTy") [DBangType]
tys
          let show_args :: [DExp]
show_args     = (Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Name -> DExp
showsPrecE Int
appPrec1) [Name]
args
              composed_args :: DExp
composed_args = (DExp -> DExp -> DExp) -> [DExp] -> DExp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\DExp
v DExp
q -> Name -> DExp
DVarE Name
composeName
                                               DExp -> DExp -> DExp
`DAppE` DExp
v
                                               DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
composeName
                                                         DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
showSpaceName
                                                         DExp -> DExp -> DExp
`DAppE` DExp
q)) [DExp]
show_args
              named_args :: DExp
named_args = Name -> DExp
DVarE Name
composeName
                             DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
showStringName
                                       DExp -> DExp -> DExp
`DAppE` String -> DExp
dStringE (Name -> ShowS
parenInfixConName Name
con_name' String
" "))
                             DExp -> DExp -> DExp
`DAppE` DExp
composed_args
          DClause -> q DClause
forall (m :: * -> *) a. Monad m => a -> m a
return (DClause -> q DClause) -> DClause -> q DClause
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause [ Name -> DPat
DVarP Name
p
                           , Name -> [DPat] -> DPat
DConP Name
con_name' ([DPat] -> DPat) -> [DPat] -> DPat
forall a b. (a -> b) -> a -> b
$
                             (Name -> Name -> DPat) -> [Name] -> [Name] -> [DPat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ShowMode -> Name -> Name -> DPat
mk_Show_arg_pat ShowMode
mode) [Name]
args [Name]
argTys
                           ] (DExp -> DClause) -> DExp -> DClause
forall a b. (a -> b) -> a -> b
$
            ShowMode -> [Name] -> DExp -> DExp
mk_Show_rhs_sig ShowMode
mode [Name]
argTys (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$
            Name -> DExp
DVarE Name
showParenName
              DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
gtName DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
p DExp -> DExp -> DExp
`DAppE` Int -> DExp
dIntegerE Int
appPrec)
              DExp -> DExp -> DExp
`DAppE` DExp
named_args

        -- We show a record constructor with no fields the same way we'd show a
        -- normal constructor with no fields.
        DRecC [] -> DConFields -> q DClause
go (Bool -> [DBangType] -> DConFields
DNormalC Bool
False [])

        DRecC [DVarBangType]
tys -> do
          [Name]
args   <- (DVarBangType -> q Name) -> [DVarBangType] -> q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (q Name -> DVarBangType -> q Name
forall a b. a -> b -> a
const (q Name -> DVarBangType -> q Name)
-> q Name -> DVarBangType -> q Name
forall a b. (a -> b) -> a -> b
$ String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"arg")   [DVarBangType]
tys
          [Name]
argTys <- (DVarBangType -> q Name) -> [DVarBangType] -> q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (q Name -> DVarBangType -> q Name
forall a b. a -> b -> a
const (q Name -> DVarBangType -> q Name)
-> q Name -> DVarBangType -> q Name
forall a b. (a -> b) -> a -> b
$ String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"argTy") [DVarBangType]
tys
          let show_args :: [DExp]
show_args =
                ((DVarBangType, Name) -> [DExp])
-> [(DVarBangType, Name)] -> [DExp]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\((Name
arg_name, Bang
_, DType
_), Name
arg) ->
                            let arg_name' :: Name
arg_name'    = case ShowMode
mode of
                                                 ShowMode
ForPromotion  -> Name
arg_name
                                                 ForShowSing{} -> Options -> Name -> Name
singledValueName Options
opts Name
arg_name
                                arg_nameBase :: String
arg_nameBase = Name -> String
nameBase Name
arg_name'
                                infix_rec :: String
infix_rec    = Bool -> ShowS -> ShowS
showParen (String -> Bool
isSym String
arg_nameBase)
                                                         (String -> ShowS
showString String
arg_nameBase) String
""
                            in [ Name -> DExp
DVarE Name
showStringName DExp -> DExp -> DExp
`DAppE` String -> DExp
dStringE (String
infix_rec String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = ")
                               , Int -> Name -> DExp
showsPrecE Int
0 Name
arg
                               , Name -> DExp
DVarE Name
showCommaSpaceName
                               ])
                          ([DVarBangType] -> [Name] -> [(DVarBangType, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DVarBangType]
tys [Name]
args)
              brace_comma_args :: [DExp]
brace_comma_args =   (Name -> DExp
DVarE Name
showCharName DExp -> DExp -> DExp
`DAppE` ShowMode -> Char -> DExp
dCharE ShowMode
mode Char
'{')
                                 DExp -> [DExp] -> [DExp]
forall a. a -> [a] -> [a]
: Int -> [DExp] -> [DExp]
forall a. Int -> [a] -> [a]
take ([DExp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
show_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [DExp]
show_args
              composed_args :: DExp
composed_args = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\DExp
x DExp
y -> Name -> DExp
DVarE Name
composeName DExp -> DExp -> DExp
`DAppE` DExp
x DExp -> DExp -> DExp
`DAppE` DExp
y)
                                    (Name -> DExp
DVarE Name
showCharName DExp -> DExp -> DExp
`DAppE` ShowMode -> Char -> DExp
dCharE ShowMode
mode Char
'}')
                                    [DExp]
brace_comma_args
              named_args :: DExp
named_args = Name -> DExp
DVarE Name
composeName
                             DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
showStringName
                                       DExp -> DExp -> DExp
`DAppE` String -> DExp
dStringE (Name -> ShowS
parenInfixConName Name
con_name' String
" "))
                             DExp -> DExp -> DExp
`DAppE` DExp
composed_args
          DClause -> q DClause
forall (m :: * -> *) a. Monad m => a -> m a
return (DClause -> q DClause) -> DClause -> q DClause
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause [ Name -> DPat
DVarP Name
p
                           , Name -> [DPat] -> DPat
DConP Name
con_name' ([DPat] -> DPat) -> [DPat] -> DPat
forall a b. (a -> b) -> a -> b
$
                             (Name -> Name -> DPat) -> [Name] -> [Name] -> [DPat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ShowMode -> Name -> Name -> DPat
mk_Show_arg_pat ShowMode
mode) [Name]
args [Name]
argTys
                           ] (DExp -> DClause) -> DExp -> DClause
forall a b. (a -> b) -> a -> b
$
            ShowMode -> [Name] -> DExp -> DExp
mk_Show_rhs_sig ShowMode
mode [Name]
argTys (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$
            Name -> DExp
DVarE Name
showParenName
              DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
gtName DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
p DExp -> DExp -> DExp
`DAppE` Int -> DExp
dIntegerE Int
appPrec)
              DExp -> DExp -> DExp
`DAppE` DExp
named_args

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

showsPrecE :: Int -> Name -> DExp
showsPrecE :: Int -> Name -> DExp
showsPrecE Int
prec Name
n = Name -> DExp
DVarE Name
showsPrecName DExp -> DExp -> DExp
`DAppE` Int -> DExp
dIntegerE Int
prec DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
n

dCharE :: ShowMode -> Char -> DExp
dCharE :: ShowMode -> Char -> DExp
dCharE ShowMode
mode = Lit -> DExp
DLitE (Lit -> DExp) -> (Char -> Lit) -> Char -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Lit
to_lit
  where
    to_lit :: Char -> Lit
    to_lit :: Char -> Lit
to_lit Char
c = case ShowMode
mode of
                 ShowMode
ForPromotion  -> String -> Lit
StringL [Char
c] -- There aren't type-level characters yet,
                                              -- so fake it with a string
                 ForShowSing{} -> Char -> Lit
CharL Char
c

dStringE :: String -> DExp
dStringE :: String -> DExp
dStringE = Lit -> DExp
DLitE (Lit -> DExp) -> (String -> Lit) -> String -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL

dIntegerE :: Int -> DExp
dIntegerE :: Int -> DExp
dIntegerE = Lit -> DExp
DLitE (Lit -> DExp) -> (Int -> Lit) -> Int -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Lit) -> (Int -> Integer) -> Int -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

isSym :: String -> Bool
isSym :: String -> Bool
isSym String
""      = Bool
False
isSym (Char
c : String
_) = Char -> Bool
startsVarSym Char
c Bool -> Bool -> Bool
|| Char -> Bool
startsConSym Char
c

-----
-- ShowMode
-----

-- | Is a 'Show' instance being generated to be promoted/singled, or is it
-- being generated to create a 'Show' instance for a singleton type?
data ShowMode = ForPromotion      -- ^ For promotion/singling
              | ForShowSing Name  -- ^ For a 'Show' instance.
                                  --   Bundles the 'Name' of the data type.

-- | Turn a context like @('Show' a, 'Show' b)@ into @('ShowSing' a, 'ShowSing' b)@.
-- This is necessary for 'Show' instances for singleton types.
mkShowSingContext :: ShowMode -> DCxt -> DCxt
mkShowSingContext :: ShowMode -> DCxt -> DCxt
mkShowSingContext ShowMode
ForPromotion  = DCxt -> DCxt
forall a. a -> a
id
mkShowSingContext ForShowSing{} = (DType -> DType) -> DCxt -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map DType -> DType
show_to_SingShow
  where
    show_to_SingShow :: DPred -> DPred
    show_to_SingShow :: DType -> DType
show_to_SingShow = (Name -> Name) -> DType -> DType
modifyConNameDType ((Name -> Name) -> DType -> DType)
-> (Name -> Name) -> DType -> DType
forall a b. (a -> b) -> a -> b
$ \Name
n ->
                         if Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
showName
                            then Name
showSingName
                            else Name
n

mk_Show_name :: ShowMode -> Name
mk_Show_name :: ShowMode -> Name
mk_Show_name ShowMode
ForPromotion  = Name
showName
mk_Show_name ForShowSing{} = Name
showSingName

-- If we're creating a 'Show' instance for a singleton type, decorate the type
-- appropriately (e.g., turn @Maybe a@ into @SMaybe (z :: Maybe a)@).
-- Otherwise, return the type (@Maybe a@) unchanged.
mk_Show_inst_ty :: OptionsMonad q => ShowMode -> DType -> q DType
mk_Show_inst_ty :: ShowMode -> DType -> q DType
mk_Show_inst_ty ShowMode
ForPromotion           DType
ty = DType -> q DType
forall (f :: * -> *) a. Applicative f => a -> f a
pure DType
ty
mk_Show_inst_ty (ForShowSing Name
ty_tycon) DType
ty = do
  Options
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
  Name
z <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
qNewName String
"z"
  DType -> q DType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT (Options -> Name -> Name
singledDataTypeName Options
opts Name
ty_tycon) DType -> DType -> DType
`DAppT` (Name -> DType
DVarT Name
z DType -> DType -> DType
`DSigT` DType
ty)

-- If we're creating a 'Show' instance for a singleton type, create a pattern
-- of the form @(sx :: Sing x)@. Otherwise, simply return the pattern @sx@.
mk_Show_arg_pat :: ShowMode -> Name -> Name -> DPat
mk_Show_arg_pat :: ShowMode -> Name -> Name -> DPat
mk_Show_arg_pat ShowMode
ForPromotion  Name
arg Name
_      = Name -> DPat
DVarP Name
arg
mk_Show_arg_pat ForShowSing{} Name
arg Name
arg_ty =
  DPat -> DType -> DPat
DSigP (Name -> DPat
DVarP Name
arg) (Name -> DType
DConT Name
singFamilyName DType -> DType -> DType
`DAppT` Name -> DType
DVarT Name
arg_ty)

-- If we're creating a 'Show' instance for a singleton type, decorate the
-- expression with an explicit signature of the form
-- @e :: (ShowSing' a_1, ..., ShowSing' a_n) => ShowS@. Otherwise, return
-- the expression (@e@) unchanged.
mk_Show_rhs_sig :: ShowMode -> [Name] -> DExp -> DExp
mk_Show_rhs_sig :: ShowMode -> [Name] -> DExp -> DExp
mk_Show_rhs_sig ShowMode
ForPromotion  [Name]
_            DExp
e = DExp
e
mk_Show_rhs_sig ForShowSing{} [Name]
arg_ty_names DExp
e =
  DExp
e DExp -> DType -> DExp
`DSigE` DCxt -> DType -> DType
DConstrainedT ((Name -> DType) -> [Name] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map (DType -> DType -> DType
DAppT (Name -> DType
DConT Name
showSing'Name) (DType -> DType) -> (Name -> DType) -> Name -> DType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DType
DVarT) [Name]
arg_ty_names)
                          (Name -> DType
DConT Name
showSName)