-----------------------------------------------------------------------------
-- |
-- 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.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 :: DsMonad q => ShowMode -> DerivDesc q
mkShowInstance :: ShowMode -> DerivDesc q
mkShowInstance mode :: ShowMode
mode mb_ctxt :: Maybe DCxt
mb_ctxt ty :: DType
ty (DataDecl _ _ cons :: [DCon]
cons) = do
  [DClause]
clauses <- ShowMode -> [DCon] -> q [DClause]
forall (q :: * -> *).
DsMonad 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 :: * -> *). Quasi q => ShowMode -> DType -> q DType
mk_Show_inst_ty ShowMode
mode DType
ty
  InstDecl Unannotated -> q (InstDecl Unannotated)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstDecl Unannotated -> q (InstDecl Unannotated))
-> InstDecl Unannotated -> q (InstDecl Unannotated)
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 :: DsMonad q => ShowMode -> [DCon] -> q [DClause]
mk_showsPrec :: ShowMode -> [DCon] -> q [DClause]
mk_showsPrec mode :: ShowMode
mode cons :: [DCon]
cons = do
    Name
p <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "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 "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 :: * -> *).
DsMonad q =>
ShowMode -> Name -> DCon -> q DClause
mk_showsPrec_clause ShowMode
mode Name
p) [DCon]
cons

mk_showsPrec_clause :: forall q. DsMonad q
                    => ShowMode -> Name -> DCon
                    -> q DClause
mk_showsPrec_clause :: ShowMode -> Name -> DCon -> q DClause
mk_showsPrec_clause mode :: ShowMode
mode p :: Name
p (DCon _ _ con_name :: Name
con_name con_fields :: DConFields
con_fields _) = DConFields -> q DClause
go DConFields
con_fields
  where
    con_name' :: Name
    con_name' :: Name
con_name' = case ShowMode
mode of
                  ForPromotion  -> Name
con_name
                  ForShowSing{} -> Name -> Name
singDataConName Name
con_name

    go :: DConFields -> q DClause

    -- No fields: print just the constructor name, with no parentheses
    go :: DConFields -> q DClause
go (DNormalC _ []) = 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' "")

    -- Infix constructors have special Show treatment.
    go (DNormalC True tys :: [DBangType]
tys@[_, _])
        -- 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 "argL"
           Name
argR   <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "argR"
           Name
argTyL <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "argTyL"
           Name
argTyR <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "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 prec :: Int
prec _ -> 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
op_name String -> ShowS
forall a. [a] -> [a] -> [a]
++ " "
                               -- Make sure to handle infix data constructors
                               -- like (Int `Foo` Int)
                               else " `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
op_name String -> ShowS
forall a. [a] -> [a] -> [a]
++ "` "
           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
+ 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
+ 1) Name
argR))

    go (DNormalC _ tys :: [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 "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 "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 (\v :: DExp
v q :: 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' " "))
                         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.
    go (DRecC []) = DConFields -> q DClause
go (Bool -> [DBangType] -> DConFields
DNormalC Bool
False [])

    go (DRecC tys :: [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 "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 "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 (\((arg_name :: Name
arg_name, _, _), arg :: Name
arg) ->
                        let arg_name' :: Name
arg_name'    = case ShowMode
mode of
                                             ForPromotion  -> Name
arg_name
                                             ForShowSing{} -> Name -> Name
singValName 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) ""
                        in [ Name -> DExp
DVarE Name
showStringName DExp -> DExp -> DExp
`DAppE` String -> DExp
dStringE (String
infix_rec String -> ShowS
forall a. [a] -> [a] -> [a]
++ " = ")
                           , Int -> Name -> DExp
showsPrecE 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 '{')
                             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
- 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 (\x :: DExp
x y :: 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 '}')
                                [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' " "))
                         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 conName :: 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 prec :: Int
prec n :: 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 mode :: 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 c :: Char
c = case ShowMode
mode of
                 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 ""      = Bool
False
isSym (c :: Char
c : _) = 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 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
$ \n :: 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 ForPromotion  = Name
showName
mk_Show_name ForShowSing{} = Name
showSingName

-- If we're creating a 'Show' instance for a singleon 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 :: Quasi q => ShowMode -> DType -> q DType
mk_Show_inst_ty :: ShowMode -> DType -> q DType
mk_Show_inst_ty ForPromotion           ty :: DType
ty = DType -> q DType
forall (f :: * -> *) a. Applicative f => a -> f a
pure DType
ty
mk_Show_inst_ty (ForShowSing ty_tycon :: Name
ty_tycon) ty :: DType
ty = do
  Name
z <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
qNewName "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 (Name -> Name
singTyConName 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 ForPromotion  arg :: Name
arg _      = Name -> DPat
DVarP Name
arg
mk_Show_arg_pat ForShowSing{} arg :: Name
arg arg_ty :: 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 ForPromotion  _            e :: DExp
e = DExp
e
mk_Show_rhs_sig ForShowSing{} arg_ty_names :: [Name]
arg_ty_names e :: DExp
e =
  DExp
e DExp -> DType -> DExp
`DSigE` [DTyVarBndr] -> DCxt -> DType -> DType
DForallT [] ((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)