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

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 DataFlavor
_ Name
_ [DTyVarBndrVis]
_ [DCon]
cons) = do
  clauses <- [DCon] -> q [DClause]
forall (q :: * -> *). OptionsMonad q => [DCon] -> q [DClause]
mk_showsPrec [DCon]
cons
  constraints <- inferConstraintsDef mb_ctxt (DConT showName) ty cons
  return $ InstDecl { id_cxt = constraints
                    , id_name = showName
                    , id_arg_tys = [ty]
                    , id_sigs  = mempty
                    , id_meths = [ (showsPrecName, UFunction clauses) ] }

mk_showsPrec :: OptionsMonad q => [DCon] -> q [DClause]
mk_showsPrec :: forall (q :: * -> *). OptionsMonad q => [DCon] -> q [DClause]
mk_showsPrec [DCon]
cons = do
    p <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"p" -- The precedence argument (not always used)
    if null cons
       then do v <- newUniqueName "v"
               pure [DClause [DWildP, DVarP v] (dCaseE (DVarE v) [])]
       else mapM (mk_showsPrec_clause p) 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 a. a -> q a
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 -> DCxt -> [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
          argL   <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"argL"
          argR   <- newUniqueName "argR"
          fi <- fromMaybe defaultFixity <$> reifyFixityWithLocals con_name
          let con_prec = case Fixity
fi of Fixity Int
prec FixityDirection
_ -> Int
prec
              op_name  = Name -> String
nameBase Name
con_name
              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
"` "
          return $ DClause [DVarP p, DConP con_name [] [DVarP argL, DVarP argR]] $
            (DVarE showParenName `DAppE` (DVarE gtName `DAppE` DVarE p
                                                       `DAppE` dIntegerE con_prec))
              `DAppE` (DVarE composeName
                         `DAppE` showsPrecE (con_prec + 1) argL
                         `DAppE` (DVarE composeName
                                    `DAppE` infixOpE
                                    `DAppE` showsPrecE (con_prec + 1) argR))

        DNormalC Bool
_ [DBangType]
tys -> do
          args <- (DBangType -> q Name) -> [DBangType] -> q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (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     = (Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Name -> DExp
showsPrecE Int
appPrec1) [Name]
args
              composed_args = (DExp -> DExp -> DExp) -> [DExp] -> DExp
forall a. (a -> a -> a) -> [a] -> a
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 = 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
          return $ DClause [DVarP p, DConP con_name [] $ map DVarP args] $
            DVarE showParenName
              `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
              `DAppE` 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
          args <- (DVarBangType -> q Name) -> [DVarBangType] -> q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (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 =
                ((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 =   (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 a. [a] -> 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 -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall a b. (a -> b -> b) -> b -> [a] -> b
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 = 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
          return $ DClause [DVarP p, DConP con_name [] $ map DVarP args] $
            DVarE showParenName
              `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
              `DAppE` 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 = Lit -> DExp
DLitE (Lit -> DExp) -> (Char -> Lit) -> Char -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Lit
CharL

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