singletons-2.6: src/Data/Singletons/Deriving/Show.hs
-----------------------------------------------------------------------------
-- |
-- 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 mode mb_ctxt ty (DataDecl _ _ cons) = do
clauses <- mk_showsPrec mode cons
constraints <- inferConstraintsDef (fmap (mkShowSingContext mode) mb_ctxt)
(DConT (mk_Show_name mode))
ty cons
ty' <- mk_Show_inst_ty mode ty
return $ InstDecl { id_cxt = constraints
, id_name = showName
, id_arg_tys = [ty']
, id_sigs = mempty
, id_meths = [ (showsPrecName, UFunction clauses) ] }
mk_showsPrec :: DsMonad q => ShowMode -> [DCon] -> q [DClause]
mk_showsPrec mode cons = do
p <- newUniqueName "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 mode p) cons
mk_showsPrec_clause :: forall q. DsMonad q
=> ShowMode -> Name -> DCon
-> q DClause
mk_showsPrec_clause mode p (DCon _ _ con_name con_fields _) = go con_fields
where
con_name' :: Name
con_name' = case mode of
ForPromotion -> con_name
ForShowSing{} -> singDataConName con_name
go :: DConFields -> q DClause
-- No fields: print just the constructor name, with no parentheses
go (DNormalC _ []) = return $
DClause [DWildP, DConP con_name' []] $
DVarE showStringName `DAppE` dStringE (parenInfixConName con_name' "")
-- Infix constructors have special Show treatment.
go (DNormalC True 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{} <- mode
, con_name == consName
= go (DNormalC False tys)
| otherwise
= do argL <- newUniqueName "argL"
argR <- newUniqueName "argR"
argTyL <- newUniqueName "argTyL"
argTyR <- newUniqueName "argTyR"
fi <- fromMaybe defaultFixity <$> reifyFixityWithLocals con_name'
let con_prec = case fi of Fixity prec _ -> prec
op_name = nameBase con_name'
infixOpE = DAppE (DVarE showStringName) . dStringE $
if isInfixDataCon op_name
then " " ++ op_name ++ " "
-- Make sure to handle infix data constructors
-- like (Int `Foo` Int)
else " `" ++ op_name ++ "` "
return $ DClause [ DVarP p
, DConP con_name' $
zipWith (mk_Show_arg_pat mode) [argL, argR] [argTyL, argTyR]
] $
mk_Show_rhs_sig mode [argTyL, argTyR] $
(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))
go (DNormalC _ tys) = do
args <- mapM (const $ newUniqueName "arg") tys
argTys <- mapM (const $ newUniqueName "argTy") tys
let show_args = map (showsPrecE appPrec1) args
composed_args = foldr1 (\v q -> DVarE composeName
`DAppE` v
`DAppE` (DVarE composeName
`DAppE` DVarE showSpaceName
`DAppE` q)) show_args
named_args = DVarE composeName
`DAppE` (DVarE showStringName
`DAppE` dStringE (parenInfixConName con_name' " "))
`DAppE` composed_args
return $ DClause [ DVarP p
, DConP con_name' $
zipWith (mk_Show_arg_pat mode) args argTys
] $
mk_Show_rhs_sig mode argTys $
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.
go (DRecC []) = go (DNormalC False [])
go (DRecC tys) = do
args <- mapM (const $ newUniqueName "arg") tys
argTys <- mapM (const $ newUniqueName "argTy") tys
let show_args =
concatMap (\((arg_name, _, _), arg) ->
let arg_name' = case mode of
ForPromotion -> arg_name
ForShowSing{} -> singValName arg_name
arg_nameBase = nameBase arg_name'
infix_rec = showParen (isSym arg_nameBase)
(showString arg_nameBase) ""
in [ DVarE showStringName `DAppE` dStringE (infix_rec ++ " = ")
, showsPrecE 0 arg
, DVarE showCommaSpaceName
])
(zip tys args)
brace_comma_args = (DVarE showCharName `DAppE` dCharE mode '{')
: take (length show_args - 1) show_args
composed_args = foldr (\x y -> DVarE composeName `DAppE` x `DAppE` y)
(DVarE showCharName `DAppE` dCharE mode '}')
brace_comma_args
named_args = DVarE composeName
`DAppE` (DVarE showStringName
`DAppE` dStringE (parenInfixConName con_name' " "))
`DAppE` composed_args
return $ DClause [ DVarP p
, DConP con_name' $
zipWith (mk_Show_arg_pat mode) args argTys
] $
mk_Show_rhs_sig mode argTys $
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 conName =
let conNameBase = nameBase conName
in showParen (isInfixDataCon conNameBase) $ showString conNameBase
showsPrecE :: Int -> Name -> DExp
showsPrecE prec n = DVarE showsPrecName `DAppE` dIntegerE prec `DAppE` DVarE n
dCharE :: ShowMode -> Char -> DExp
dCharE mode = DLitE . to_lit
where
to_lit :: Char -> Lit
to_lit c = case mode of
ForPromotion -> StringL [c] -- There aren't type-level characters yet,
-- so fake it with a string
ForShowSing{} -> CharL c
dStringE :: String -> DExp
dStringE = DLitE . StringL
dIntegerE :: Int -> DExp
dIntegerE = DLitE . IntegerL . fromIntegral
isSym :: String -> Bool
isSym "" = False
isSym (c : _) = startsVarSym c || startsConSym 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 ForPromotion = id
mkShowSingContext ForShowSing{} = map show_to_SingShow
where
show_to_SingShow :: DPred -> DPred
show_to_SingShow = modifyConNameDType $ \n ->
if n == showName
then showSingName
else n
mk_Show_name :: ShowMode -> Name
mk_Show_name ForPromotion = showName
mk_Show_name ForShowSing{} = 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 ForPromotion ty = pure ty
mk_Show_inst_ty (ForShowSing ty_tycon) ty = do
z <- qNewName "z"
pure $ DConT (singTyConName ty_tycon) `DAppT` (DVarT z `DSigT` 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 ForPromotion arg _ = DVarP arg
mk_Show_arg_pat ForShowSing{} arg arg_ty =
DSigP (DVarP arg) (DConT singFamilyName `DAppT` DVarT 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 ForPromotion _ e = e
mk_Show_rhs_sig ForShowSing{} arg_ty_names e =
e `DSigE` DForallT [] (map (DAppT (DConT showSing'Name) . DVarT) arg_ty_names)
(DConT showSName)