-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Singletons.TH.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.TH.Deriving.Show (
    mkShowInstance
  , mkShowSingContext
  ) where

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

mkShowInstance :: OptionsMonad q => DerivDesc q
mkShowInstance :: forall (q :: * -> *). OptionsMonad q => DerivDesc q
mkShowInstance Maybe DCxt
mb_ctxt DType
ty (DataDecl Name
_ [DTyVarBndrUnit]
_ [DCon]
cons) = do
  [DClause]
clauses <- [DCon] -> q [DClause]
forall (q :: * -> *). OptionsMonad q => [DCon] -> q [DClause]
mk_showsPrec [DCon]
cons
  DCxt
constraints <- Maybe DCxt -> DType -> DType -> [DCon] -> q DCxt
forall (q :: * -> *).
DsMonad q =>
Maybe DCxt -> DType -> DType -> [DCon] -> q DCxt
inferConstraintsDef Maybe DCxt
mb_ctxt (Name -> DType
DConT Name
showName) DType
ty [DCon]
cons
  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 => [DCon] -> q [DClause]
mk_showsPrec :: forall (q :: * -> *). OptionsMonad q => [DCon] -> q [DClause]
mk_showsPrec [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 (Name -> DCon -> q DClause
forall (q :: * -> *). DsMonad q => Name -> DCon -> q DClause
mk_showsPrec_clause Name
p) [DCon]
cons

mk_showsPrec_clause :: forall q. DsMonad q
                    => Name -> DCon
                    -> q DClause
mk_showsPrec_clause :: forall (q :: * -> *). DsMonad q => Name -> DCon -> q DClause
mk_showsPrec_clause Name
p (DCon [DTyVarBndrSpec]
_ 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
      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 [DBangType
_, DBangType
_] -> 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"
          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 [Name -> DPat
DVarP Name
argL, Name -> DPat
DVarP Name
argR]] (DExp -> DClause) -> DExp -> DClause
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
          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 -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
args] (DExp -> DClause) -> DExp -> DClause
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
          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_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` Char -> DExp
dCharE 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` Char -> DExp
dCharE 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 -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
args] (DExp -> DClause) -> DExp -> DClause
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 :: Char -> DExp
dCharE :: Char -> DExp
dCharE Char
c = Lit -> DExp
DLitE (Lit -> DExp) -> Lit -> DExp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL [Char
c] -- There aren't type-level characters yet,
                               -- so fake it with a string

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

-- | Turn a context like @('Show' a, 'Show' b)@ into @('ShowSing' a, 'ShowSing' b)@.
-- This is necessary for standalone-derived 'Show' instances for singleton types.
mkShowSingContext :: DCxt -> DCxt
mkShowSingContext :: DCxt -> DCxt
mkShowSingContext = (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