Commit 9129210f authored by Matthew Pickering's avatar Matthew Pickering Committed by Marge Bot
Browse files

Overloaded Quotation Brackets (#246)

This patch implements overloaded quotation brackets which generalise the
desugaring of all quotation forms in terms of a new minimal interface.

The main change is that a quotation, for example, [e| 5 |], will now
have type `Quote m => m Exp` rather than `Q Exp`. The `Quote` typeclass
contains a single method for generating new names which is used when
desugaring binding structures.

The return type of functions from the `Lift` type class, `lift` and `liftTyped` have
been restricted to `forall m . Quote m => m Exp` rather than returning a
result in a Q monad.

More details about the feature can be read in the GHC proposal.

https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst
parent 49f83a0d
Pipeline #14483 failed with stages
in 332 minutes and 13 seconds
......@@ -926,8 +926,10 @@ cpeApp top_env expr
(_ : ss_rest, True) -> (topDmd, ss_rest)
(ss1 : ss_rest, False) -> (ss1, ss_rest)
([], _) -> (topDmd, [])
(arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
splitFunTy_maybe fun_ty
(arg_ty, res_ty) =
case splitFunTy_maybe fun_ty of
Just as -> as
Nothing -> pprPanic "cpeBody" (ppr fun_ty $$ ppr expr)
(fs, arg') <- cpeArg top_env ss1 arg arg_ty
rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest
CpeCast co ->
......
......@@ -451,6 +451,8 @@ data HsExpr p
| HsTcBracketOut
(XTcBracketOut p)
(Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument
-- to the quote.
(HsBracket GhcRn) -- Output of the type checker is the *original*
-- renamed expression, plus
[PendingTcSplice] -- _typechecked_ splices to be
......@@ -1006,8 +1008,8 @@ ppr_expr (HsSpliceE _ s) = pprSplice s
ppr_expr (HsBracket _ b) = pprHsBracket b
ppr_expr (HsRnBracketOut _ e []) = ppr e
ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
ppr_expr (HsTcBracketOut _ e []) = ppr e
ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
ppr_expr (HsTcBracketOut _ _wrap e []) = ppr e
ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
= hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
......
......@@ -1004,7 +1004,7 @@ instance ( a ~ GhcPass p
[ toHie b
, toHie p
]
HsTcBracketOut _ b p ->
HsTcBracketOut _ _wrap b p ->
[ toHie b
, toHie p
]
......
......@@ -709,7 +709,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
-- Template Haskell stuff
ds_expr _ (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut"
ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps
ds_expr _ (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps
ds_expr _ (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
-- Arrow notation extension
......
This diff is collapsed.
......@@ -224,6 +224,8 @@ import System.FilePath
import Control.Concurrent
import System.Process ( ProcessHandle )
import Control.DeepSeq
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class
-- -----------------------------------------------------------------------------
-- Compilation state
......@@ -2324,6 +2326,10 @@ class Monad m => MonadThings m where
lookupTyCon :: Name -> m TyCon
lookupTyCon = liftM tyThingTyCon . lookupThing
-- Instance used in DsMeta
instance MonadThings m => MonadThings (ReaderT s m) where
lookupThing = lift . lookupThing
{-
************************************************************************
* *
......
......@@ -146,18 +146,18 @@ templateHaskellNames = [
derivClauseName,
-- The type classes
liftClassName,
liftClassName, quoteClassName,
-- And the tycons
qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName,
varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
typeTyConName, tyVarBndrQTyConName, matchTyConName, clauseTyConName,
patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName,
overlapTyConName, derivClauseQTyConName, derivStrategyQTyConName,
qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchTyConName,
expQTyConName, fieldExpTyConName, predTyConName,
stmtTyConName, decsTyConName, conTyConName, bangTypeTyConName,
varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName,
typeTyConName, tyVarBndrTyConName, clauseTyConName,
patQTyConName, funDepTyConName, decsQTyConName,
ruleBndrTyConName, tySynEqnTyConName,
roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
overlapTyConName, derivClauseTyConName, derivStrategyTyConName,
-- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName]
......@@ -183,10 +183,13 @@ qqFun = mk_known_key_name OccName.varName qqLib
liftClassName :: Name
liftClassName = thCls (fsLit "Lift") liftClassKey
quoteClassName :: Name
quoteClassName = thCls (fsLit "Quote") quoteClassKey
qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
tExpTyConName, injAnnTyConName, overlapTyConName :: Name
tExpTyConName, injAnnTyConName, overlapTyConName, decsTyConName :: Name
qTyConName = thTc (fsLit "Q") qTyConKey
nameTyConName = thTc (fsLit "Name") nameTyConKey
fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
......@@ -194,6 +197,7 @@ patTyConName = thTc (fsLit "Pat") patTyConKey
fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
expTyConName = thTc (fsLit "Exp") expTyConKey
decTyConName = thTc (fsLit "Dec") decTyConKey
decsTyConName = libTc (fsLit "Decs") decsTyConKey
typeTyConName = thTc (fsLit "Type") typeTyConKey
matchTyConName = thTc (fsLit "Match") matchTyConKey
clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
......@@ -546,34 +550,30 @@ anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey
newtypeStrategyName = libFun (fsLit "newtypeStrategy") newtypeStrategyIdKey
viaStrategyName = libFun (fsLit "viaStrategy") viaStrategyIdKey
matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
decQTyConName, conQTyConName, bangTypeQTyConName,
varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,
patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName,
derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName,
derivStrategyQTyConName :: Name
matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
patQTyConName, expQTyConName, stmtTyConName,
conTyConName, bangTypeTyConName,
varBangTypeTyConName, typeQTyConName,
decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName,
derivClauseTyConName, kindTyConName, tyVarBndrTyConName,
derivStrategyTyConName :: Name
-- These are only used for the types of top-level splices
expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
decQTyConName = libTc (fsLit "DecQ") decQTyConKey
decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
conQTyConName = libTc (fsLit "ConQ") conQTyConKey
bangTypeQTyConName = libTc (fsLit "BangTypeQ") bangTypeQTyConKey
varBangTypeQTyConName = libTc (fsLit "VarBangTypeQ") varBangTypeQTyConKey
typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
patQTyConName = libTc (fsLit "PatQ") patQTyConKey
fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
predQTyConName = libTc (fsLit "PredQ") predQTyConKey
ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey
tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey
-- These are used in DsMeta but always wrapped in a type variable
stmtTyConName = thTc (fsLit "Stmt") stmtTyConKey
conTyConName = thTc (fsLit "Con") conTyConKey
bangTypeTyConName = thTc (fsLit "BangType") bangTypeTyConKey
varBangTypeTyConName = thTc (fsLit "VarBangType") varBangTypeTyConKey
ruleBndrTyConName = thTc (fsLit "RuleBndr") ruleBndrTyConKey
tySynEqnTyConName = thTc (fsLit "TySynEqn") tySynEqnTyConKey
roleTyConName = libTc (fsLit "Role") roleTyConKey
derivClauseQTyConName = libTc (fsLit "DerivClauseQ") derivClauseQTyConKey
kindQTyConName = libTc (fsLit "KindQ") kindQTyConKey
tyVarBndrQTyConName = libTc (fsLit "TyVarBndrQ") tyVarBndrQTyConKey
derivStrategyQTyConName = libTc (fsLit "DerivStrategyQ") derivStrategyQTyConKey
derivClauseTyConName = thTc (fsLit "DerivClause") derivClauseTyConKey
kindTyConName = thTc (fsLit "Kind") kindTyConKey
tyVarBndrTyConName = thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey
-- quasiquoting
quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
......@@ -621,6 +621,9 @@ incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey
liftClassKey :: Unique
liftClassKey = mkPreludeClassUnique 200
quoteClassKey :: Unique
quoteClassKey = mkPreludeClassUnique 201
{- *********************************************************************
* *
TyCon keys
......@@ -631,50 +634,47 @@ liftClassKey = mkPreludeClassUnique 200
-- Check in PrelNames if you want to change this
expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,
tyVarBndrQTyConKey, decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,
patTyConKey,
stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey,
tyVarBndrTyConKey, decTyConKey, bangTypeTyConKey, varBangTypeTyConKey,
fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
roleTyConKey, tExpTyConKey, injAnnTyConKey, kindQTyConKey,
overlapTyConKey, derivClauseQTyConKey, derivStrategyQTyConKey :: Unique
funDepTyConKey, predTyConKey,
predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey,
roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,
overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey
:: Unique
expTyConKey = mkPreludeTyConUnique 200
matchTyConKey = mkPreludeTyConUnique 201
clauseTyConKey = mkPreludeTyConUnique 202
qTyConKey = mkPreludeTyConUnique 203
expQTyConKey = mkPreludeTyConUnique 204
decQTyConKey = mkPreludeTyConUnique 205
patTyConKey = mkPreludeTyConUnique 206
matchQTyConKey = mkPreludeTyConUnique 207
clauseQTyConKey = mkPreludeTyConUnique 208
stmtQTyConKey = mkPreludeTyConUnique 209
conQTyConKey = mkPreludeTyConUnique 210
stmtTyConKey = mkPreludeTyConUnique 209
conTyConKey = mkPreludeTyConUnique 210
typeQTyConKey = mkPreludeTyConUnique 211
typeTyConKey = mkPreludeTyConUnique 212
decTyConKey = mkPreludeTyConUnique 213
bangTypeQTyConKey = mkPreludeTyConUnique 214
varBangTypeQTyConKey = mkPreludeTyConUnique 215
bangTypeTyConKey = mkPreludeTyConUnique 214
varBangTypeTyConKey = mkPreludeTyConUnique 215
fieldExpTyConKey = mkPreludeTyConUnique 216
fieldPatTyConKey = mkPreludeTyConUnique 217
nameTyConKey = mkPreludeTyConUnique 218
patQTyConKey = mkPreludeTyConUnique 219
fieldPatQTyConKey = mkPreludeTyConUnique 220
fieldExpQTyConKey = mkPreludeTyConUnique 221
funDepTyConKey = mkPreludeTyConUnique 222
predTyConKey = mkPreludeTyConUnique 223
predQTyConKey = mkPreludeTyConUnique 224
tyVarBndrQTyConKey = mkPreludeTyConUnique 225
tyVarBndrTyConKey = mkPreludeTyConUnique 225
decsQTyConKey = mkPreludeTyConUnique 226
ruleBndrQTyConKey = mkPreludeTyConUnique 227
tySynEqnQTyConKey = mkPreludeTyConUnique 228
ruleBndrTyConKey = mkPreludeTyConUnique 227
tySynEqnTyConKey = mkPreludeTyConUnique 228
roleTyConKey = mkPreludeTyConUnique 229
tExpTyConKey = mkPreludeTyConUnique 230
injAnnTyConKey = mkPreludeTyConUnique 231
kindQTyConKey = mkPreludeTyConUnique 232
kindTyConKey = mkPreludeTyConUnique 232
overlapTyConKey = mkPreludeTyConUnique 233
derivClauseQTyConKey = mkPreludeTyConUnique 234
derivStrategyQTyConKey = mkPreludeTyConUnique 235
derivClauseTyConKey = mkPreludeTyConUnique 234
derivStrategyTyConKey = mkPreludeTyConUnique 235
decsTyConKey = mkPreludeTyConUnique 236
{- *********************************************************************
* *
......
......@@ -830,7 +830,7 @@ tcMetaTy :: Name -> TcM Type
-- E.g. given the name "Expr" return the type "Expr"
tcMetaTy tc_name = do
t <- tcLookupTyCon tc_name
return (mkTyConApp t [])
return (mkTyConTy t)
isBrackStage :: ThStage -> Bool
isBrackStage (Brack {}) = True
......
......@@ -4,14 +4,14 @@
module TcEvidence (
-- HsWrapper
-- * HsWrapper
HsWrapper(..),
(<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams,
mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, collectHsWrapBinders,
mkWpFun, idHsWrapper, isIdHsWrapper, isErasableHsWrapper,
pprHsWrapper,
-- Evidence bindings
-- * Evidence bindings
TcEvBinds(..), EvBindsVar(..),
EvBindMap(..), emptyEvBindMap, extendEvBinds,
lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap,
......@@ -19,7 +19,7 @@ module TcEvidence (
EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,
evBindVar, isCoEvBindsVar,
-- EvTerm (already a CoreExpr)
-- * EvTerm (already a CoreExpr)
EvTerm(..), EvExpr,
evId, evCoercion, evCast, evDFunApp, evDataConApp, evSelector,
mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars,
......@@ -28,7 +28,7 @@ module TcEvidence (
EvCallStack(..),
EvTypeable(..),
-- TcCoercion
-- * TcCoercion
TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole,
TcMCoercion,
Role(..), LeftOrRight(..), pickLR,
......@@ -45,7 +45,10 @@ module TcEvidence (
mkTcCoVarCo,
isTcReflCo, isTcReflexiveCo, isTcGReflMCo, tcCoToMCo,
tcCoercionRole,
unwrapIP, wrapIP
unwrapIP, wrapIP,
-- * QuoteWrapper
QuoteWrapper(..), applyQuoteWrapper, quoteWrapperTyVarTy
) where
#include "HsVersions.h"
......@@ -1002,3 +1005,25 @@ unwrapIP ty =
-- dictionary. See 'unwrapIP'.
wrapIP :: Type -> CoercionR
wrapIP ty = mkSymCo (unwrapIP ty)
----------------------------------------------------------------------
-- A datatype used to pass information when desugaring quotations
----------------------------------------------------------------------
-- We have to pass a `EvVar` and `Type` into `dsBracket` so that the
-- correct evidence and types are applied to all the TH combinators.
-- This data type bundles them up together with some convenience methods.
--
-- The EvVar is evidence for `Quote m`
-- The Type is a metavariable for `m`
--
data QuoteWrapper = QuoteWrapper EvVar Type deriving Data.Data
quoteWrapperTyVarTy :: QuoteWrapper -> Type
quoteWrapperTyVarTy (QuoteWrapper _ t) = t
-- | Convert the QuoteWrapper into a normal HsWrapper which can be used to
-- apply its contents.
applyQuoteWrapper :: QuoteWrapper -> HsWrapper
applyQuoteWrapper (QuoteWrapper ev_var m_var)
= mkWpEvVarApps [ev_var] <.> mkWpTyApps [m_var]
......@@ -1978,7 +1978,7 @@ checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
-- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but
-- this code is applied to *typed* brackets.
checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var))
checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))
| isTopLevel top_lvl
= when (isExternalName id_name) (keepAlive id_name)
-- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice
......@@ -2015,7 +2015,8 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var))
-- Update the pending splices
; ps <- readMutVar ps_var
; let pending_splice = PendingTcSplice id_name
(nlHsApp (noLoc lift) (nlHsVar id))
(nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLoc lift))
(nlHsVar id))
; writeMutVar ps_var (pending_splice : ps)
; return () }
......
......@@ -798,12 +798,18 @@ zonkExpr env (HsAppType x e t)
zonkExpr _ e@(HsRnBracketOut _ _ _)
= pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
zonkExpr env (HsTcBracketOut x body bs)
= do bs' <- mapM zonk_b bs
return (HsTcBracketOut x body bs')
zonkExpr env (HsTcBracketOut x wrap body bs)
= do wrap' <- traverse zonkQuoteWrap wrap
bs' <- mapM (zonk_b env) bs
return (HsTcBracketOut x wrap' body bs')
where
zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
return (PendingTcSplice n e')
zonkQuoteWrap (QuoteWrapper ev ty) = do
let ev' = zonkIdOcc env ev
ty' <- zonkTcTypeToTypeX env ty
return (QuoteWrapper ev' ty')
zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
return (PendingTcSplice n e')
zonkExpr env (HsSpliceE _ (HsSplicedT s)) =
runTopSplice s >>= zonkExpr env
......
......@@ -17,6 +17,7 @@ module TcMType (
--------------------------------
-- Creating new mutable type variables
newFlexiTyVar,
newNamedFlexiTyVar,
newFlexiTyVarTy, -- Kind -> TcM TcType
newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType]
newOpenFlexiTyVarTy, newOpenTypeKind,
......@@ -730,15 +731,22 @@ And there no reason /not/ to clone the Name when making a
unification variable. So that's what we do.
-}
metaInfoToTyVarName :: MetaInfo -> FastString
metaInfoToTyVarName meta_info =
case meta_info of
TauTv -> fsLit "t"
FlatMetaTv -> fsLit "fmv"
FlatSkolTv -> fsLit "fsk"
TyVarTv -> fsLit "a"
newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi
newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TcTyVar
-- Make a new meta tyvar out of thin air
newAnonMetaTyVar meta_info kind
= do { let s = case meta_info of
TauTv -> fsLit "t"
FlatMetaTv -> fsLit "fmv"
FlatSkolTv -> fsLit "fsk"
TyVarTv -> fsLit "a"
; name <- newMetaTyVarName s
newNamedAnonMetaTyVar tyvar_name meta_info kind
= do { name <- newMetaTyVarName tyvar_name
; details <- newMetaDetails meta_info
; let tyvar = mkTcTyVar name kind details
; traceTc "newAnonMetaTyVar" (ppr tyvar)
......@@ -963,6 +971,10 @@ that can't ever appear in user code, so we're safe!
newFlexiTyVar :: Kind -> TcM TcTyVar
newFlexiTyVar kind = newAnonMetaTyVar TauTv kind
-- | Create a new flexi ty var with a specific name
newNamedFlexiTyVar :: FastString -> Kind -> TcM TcTyVar
newNamedFlexiTyVar fs kind = newNamedAnonMetaTyVar fs TauTv kind
newFlexiTyVarTy :: Kind -> TcM TcType
newFlexiTyVarTy kind = do
tc_tyvar <- newFlexiTyVar kind
......
......@@ -430,6 +430,7 @@ data CtOrigin
| HoleOrigin
| UnboundOccurrenceOf OccName
| ListOrigin -- An overloaded list
| BracketOrigin -- An overloaded quotation bracket
| StaticOrigin -- A static form
| FailablePattern (LPat GhcTcId) -- A failable pattern in do-notation for the
-- MonadFail Proposal (MFP). Obsolete when
......@@ -655,4 +656,5 @@ pprCtO AnnOrigin = text "an annotation"
pprCtO HoleOrigin = text "a use of" <+> quotes (text "_")
pprCtO ListOrigin = text "an overloaded list"
pprCtO StaticOrigin = text "a static form"
pprCtO BracketOrigin = text "a quotation bracket"
pprCtO _ = panic "pprCtOrigin"
......@@ -948,6 +948,13 @@ data PendingStuff
| TcPending -- Typechecking the inside of a typed bracket
(TcRef [PendingTcSplice]) -- Accumulate pending splices here
(TcRef WantedConstraints) -- and type constraints here
QuoteWrapper -- A type variable and evidence variable
-- for the overall monad of
-- the bracket. Splices are checked
-- against this monad. The evidence
-- variable is used for desugaring
-- `lift`.
topStage, topAnnStage, topSpliceStage :: ThStage
topStage = Comp
......
......@@ -15,6 +15,7 @@ TcSplice: Template Haskell splices
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module TcSplice(
......@@ -93,7 +94,7 @@ import CoAxiom
import PatSyn
import ConLike
import DataCon
import TcEvidence( TcEvBinds(..) )
import TcEvidence
import Id
import IdInfo
import DsExpr
......@@ -172,68 +173,132 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
-- should get thrown into the constraint set
-- from outside the bracket
-- Make a new type variable for the type of the overall quote
; m_var <- mkTyVarTy <$> mkMetaTyVar
-- Make sure the type variable satisfies Quote
; ev_var <- emitQuoteWanted m_var
-- Bundle them together so they can be used in DsMeta for desugaring
-- brackets.
; let wrapper = QuoteWrapper ev_var m_var
-- Typecheck expr to make sure it is valid,
-- Throw away the typechecked expression but return its type.
-- We'll typecheck it again when we splice it in somewhere
; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $
tcInferRhoNC expr
-- NC for no context; tcBracket does that
; let rep = getRuntimeRep expr_ty
; meta_ty <- tcTExpTy expr_ty
; meta_ty <- tcTExpTy m_var expr_ty
; ps' <- readMutVar ps_ref
; texpco <- tcLookupId unsafeTExpCoerceName
; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
rn_expr
(unLoc (mkHsApp (nlHsTyApp texpco [rep, expr_ty])
(noLoc (HsTcBracketOut noExtField brack ps'))))
(unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)
(nlHsTyApp texpco [rep, expr_ty]))
(noLoc (HsTcBracketOut noExtField (Just wrapper) brack ps'))))
meta_ty res_ty }
tcTypedBracket _ other_brack _
= pprPanic "tcTypedBracket" (ppr other_brack)
-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)
-- See Note [Typechecking Overloaded Quotes]
tcUntypedBracket rn_expr brack ps res_ty
= do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
; ps' <- mapM tcPendingSplice ps
; meta_ty <- tcBrackTy brack
; traceTc "tc_bracket done untyped" (ppr meta_ty)
; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket")
rn_expr (HsTcBracketOut noExtField brack ps') meta_ty res_ty }
-- Create the type m Exp for expression bracket, m Type for a type
-- bracket and so on. The brack_info is a Maybe because the
-- VarBracket ('a) isn't overloaded, but also shouldn't contain any
-- splices.
; (brack_info, expected_type) <- brackTy brack
-- Match the expected type with the type of all the internal
-- splices. They might have further constrained types and if they do
-- we want to reflect that in the overall type of the bracket.
; ps' <- case quoteWrapperTyVarTy <$> brack_info of
Just m_var -> mapM (tcPendingSplice m_var) ps
Nothing -> ASSERT(null ps) return []
; traceTc "tc_bracket done untyped" (ppr expected_type)
-- Unify the overall type of the bracket with the expected result
-- type
; tcWrapResultO BracketOrigin rn_expr
(HsTcBracketOut noExtField brack_info brack ps')
expected_type res_ty
}
-- | A type variable with kind * -> * named "m"
mkMetaTyVar :: TcM TyVar
mkMetaTyVar =
newNamedFlexiTyVar (fsLit "m") (mkVisFunTy liftedTypeKind liftedTypeKind)
-- | For a type 'm', emit the constraint 'Quote m'.
emitQuoteWanted :: Type -> TcM EvVar
emitQuoteWanted m_var = do
quote_con <- tcLookupTyCon quoteClassName
emitWantedEvVar BracketOrigin $
mkTyConApp quote_con [m_var]
---------------
tcBrackTy :: HsBracket GhcRn -> TcM TcType
tcBrackTy (VarBr {}) = tcMetaTy nameTyConName
-- Result type is Var (not Q-monadic)
tcBrackTy (ExpBr {}) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp)
tcBrackTy (TypBr {}) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
tcBrackTy (PatBr {}) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat)
tcBrackTy (DecBrL {}) = panic "tcBrackTy: Unexpected DecBrL"
tcBrackTy (TExpBr {}) = panic "tcUntypedBracket: Unexpected TExpBr"
tcBrackTy (XBracket nec) = noExtCon nec
-- | Compute the expected type of a quotation, and also the QuoteWrapper in
-- the case where it is an overloaded quotation. All quotation forms are
-- overloaded aprt from Variable quotations ('foo)
brackTy :: HsBracket GhcRn -> TcM (Maybe QuoteWrapper, Type)
brackTy b =
let mkTy n = do
-- New polymorphic type variable for the bracket
m_var <- mkTyVarTy <$> mkMetaTyVar
-- Emit a Quote constraint for the bracket
ev_var <- emitQuoteWanted m_var
-- Construct the final expected type of the quote, for example
-- m Exp or m Type
final_ty <- mkAppTy m_var <$> tcMetaTy n
-- Return the evidence variable and metavariable to be used during
-- desugaring.
let wrapper = QuoteWrapper ev_var m_var
return (Just wrapper, final_ty)
in
case b of
(VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName