summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2021-02-11 14:44:20 +0000
committerBen Gamari <ben@smart-cactus.org>2021-02-19 11:03:46 -0500
commit4196969c53c55191e644d9eb258c14c2bc8467da (patch)
treebb4608ff96e916c204b6837405690190b70c59db /compiler/GHC/Tc
parentf78f001c91736e31cdfb23959647226f9bd9fe6b (diff)
downloadhaskell-4196969c53c55191e644d9eb258c14c2bc8467da.tar.gz
Improve handling of overloaded labels, literals, lists etcwip/T19154
When implementing Quick Look I'd failed to remember that overloaded labels, like #foo, should be treated as a "head", so that they can be instantiated with Visible Type Application. This caused #19154. A very similar ticket covers overloaded literals: #19167. This patch fixes both problems, but (annoyingly, albeit temporarily) in two different ways. Overloaded labels I dealt with overloaded labels by buying fully into the Rebindable Syntax approach described in GHC.Hs.Expr Note [Rebindable syntax and HsExpansion]. There is a good overview in GHC.Rename.Expr Note [Handling overloaded and rebindable constructs]. That module contains much of the payload for this patch. Specifically: * Overloaded labels are expanded in the renamer, fixing #19154. See Note [Overloaded labels] in GHC.Rename.Expr. * Left and right sections used to have special code paths in the typechecker and desugarer. Now we just expand them in the renamer. This is harder than it sounds. See GHC.Rename.Expr Note [Left and right sections]. * Infix operator applications are expanded in the typechecker, specifically in GHC.Tc.Gen.App.splitHsApps. See Note [Desugar OpApp in the typechecker] in that module * ExplicitLists are expanded in the renamer, when (and only when) OverloadedLists is on. * HsIf is expanded in the renamer when (and only when) RebindableSyntax is on. Reason: the coverage checker treats HsIf specially. Maybe we could instead expand it unconditionally, and fix up the coverage checker, but I did not attempt that. Overloaded literals Overloaded literals, like numbers (3, 4.2) and strings with OverloadedStrings, were not working correctly with explicit type applications (see #19167). Ideally I'd also expand them in the renamer, like the stuff above, but I drew back on that because they can occur in HsPat as well, and I did not want to to do the HsExpanded thing for patterns. But they *can* now be the "head" of an application in the typechecker, and hence something like ("foo" @T) works now. See GHC.Tc.Gen.Head.tcInferOverLit. It's also done a bit more elegantly, rather than by constructing a new HsExpr and re-invoking the typechecker. There is some refactoring around tcShortCutLit. Ultimately there is more to do here, following the Rebindable Syntax story. There are a lot of knock-on effects: * HsOverLabel and ExplicitList no longer need funny (Maybe SyntaxExpr) fields to support rebindable syntax -- good! * HsOverLabel, OpApp, SectionL, SectionR all become impossible in the output of the typecheker, GhcTc; so we set their extension fields to Void. See GHC.Hs.Expr Note [Constructor cannot occur] * Template Haskell quotes for HsExpanded is a bit tricky. See Note [Quotation and rebindable syntax] in GHC.HsToCore.Quote. * In GHC.HsToCore.Match.viewLExprEq, which groups equal HsExprs for the purpose of pattern-match overlap checking, I found that dictionary evidence for the same type could have two different names. Easily fixed by comparing types not names. * I did quite a bit of annoying fiddling around in GHC.Tc.Gen.Head and GHC.Tc.Gen.App to get error message locations and contexts right, esp in splitHsApps, and the HsExprArg type. Tiresome and not very illuminating. But at least the tricky, higher order, Rebuilder function is gone. * Some refactoring in GHC.Tc.Utils.Monad around contexts and locations for rebindable syntax. * Incidentally fixes #19346, because we now print renamed, rather than typechecked, syntax in error mesages about applications. The commit removes the vestigial module GHC.Builtin.RebindableNames, and thus triggers a 2.4% metric decrease for test MultiLayerModules (#19293). Metric Decrease: MultiLayerModules T12545
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Gen/App.hs235
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs282
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs-boot6
-rw-r--r--compiler/GHC/Tc/Gen/Head.hs314
-rw-r--r--compiler/GHC/Tc/Module.hs2
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs2
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs4
-rw-r--r--compiler/GHC/Tc/Utils/Instantiate.hs64
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs70
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs85
10 files changed, 563 insertions, 501 deletions
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index 5b34952d65..29dc16ab07 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -17,10 +17,9 @@
module GHC.Tc.Gen.App
( tcApp
, tcInferSigma
- , tcValArg
, tcExprPrag ) where
-import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExprNC )
+import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr )
import GHC.Builtin.Types (multiplicityTy)
import GHC.Tc.Gen.Head
@@ -137,13 +136,13 @@ tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType
-- True <=> instantiate -- return a rho-type
-- False <=> don't instantiate -- return a sigma-type
tcInferSigma inst (L loc rn_expr)
- | (rn_fun, rn_args, _) <- splitHsApps rn_expr
+ | (fun@(rn_fun,_), rn_args) <- splitHsApps rn_expr
= addExprCtxt rn_expr $
setSrcSpan loc $
do { do_ql <- wantQuickLook rn_fun
- ; (tc_fun, fun_sigma) <- tcInferAppHead rn_fun rn_args Nothing
- ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst rn_fun fun_sigma rn_args
- ; _tc_args <- tcValArgs do_ql tc_fun inst_args
+ ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args Nothing
+ ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst fun fun_sigma rn_args
+ ; _tc_args <- tcValArgs do_ql inst_args
; return app_res_sigma }
{- *********************************************************************
@@ -168,6 +167,7 @@ app :: head
head ::= f -- HsVar: variables
| fld -- HsRecFld: record field selectors
| (expr :: ty) -- ExprWithTySig: expr with user type sig
+ | lit -- HsOverLit: overloaded literals
| other_expr -- Other expressions
When tcExpr sees something that starts an application chain (namely,
@@ -259,18 +259,33 @@ Some cases that /won't/ work:
we'll delegate back to tcExpr, which will instantiate f's type
and the type application to @Int will fail. Too bad!
+Note [Quick Look for particular Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We switch on Quick Look (regardless of -XImpredicativeTypes) for certain
+particular Ids:
+
+* ($): For a long time GHC has had a special typing rule for ($), that
+ allows it to type (runST $ foo), which requires impredicative instantiation
+ of ($), without language flags. It's a bit ad-hoc, but it's been that
+ way for ages. Using quickLookIds is the only special treatment ($) needs
+ now, which is a lot better.
+
+* leftSection, rightSection: these are introduced by the expansion step in
+ the renamer (Note [Handling overloaded and rebindable constructs] in
+ GHC.Rename.Expr), and we want them to be instantiated impredicatively
+ so that (f `op`), say, will work OK even if `f` is higher rank.
-}
tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- See Note [tcApp: typechecking applications]
tcApp rn_expr exp_res_ty
- | (rn_fun, rn_args, rebuild) <- splitHsApps rn_expr
- = do { (tc_fun, fun_sigma) <- tcInferAppHead rn_fun rn_args
+ | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr
+ = do { (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
(checkingExpType_maybe exp_res_ty)
-- Instantiate
; do_ql <- wantQuickLook rn_fun
- ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True rn_fun fun_sigma rn_args
+ ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args
-- Quick look at result
; quickLookResultType do_ql delta app_res_rho exp_res_ty
@@ -287,7 +302,7 @@ tcApp rn_expr exp_res_ty
, text "rn_expr:" <+> ppr rn_expr ]) }
-- Typecheck the value arguments
- ; tc_args <- tcValArgs do_ql tc_fun inst_args
+ ; tc_args <- tcValArgs do_ql inst_args
-- Zonk the result type, to ensure that we substitute out
-- any filled-in instantiation variable before calling tcWrapResultMono
@@ -300,21 +315,35 @@ tcApp rn_expr exp_res_ty
-- Special case for tagToEnum#
; if isTagToEnum rn_fun
- then tcTagToEnum rn_expr tc_fun tc_args app_res_rho exp_res_ty
+ then tcTagToEnum rn_expr tc_fun fun_ctxt tc_args app_res_rho exp_res_ty
else
do { -- Reconstruct
- ; let tc_expr = rebuild tc_fun tc_args
+ ; let tc_expr = rebuildHsApps tc_fun fun_ctxt tc_args
+
+ -- Set a context for the helpful
+ -- "Probably cause: f applied to too many args"
+ -- But not in generated code, where we don't want
+ -- to mention internal (rebindable syntax) function names
+ set_res_ctxt thing_inside
+ | insideExpansion tc_args
+ = thing_inside
+ | otherwise
+ = addFunResCtxt tc_fun tc_args app_res_rho exp_res_ty thing_inside
-- Wrap the result
- ; addFunResCtxt tc_fun tc_args app_res_rho exp_res_ty $
- tcWrapResultMono rn_expr tc_expr app_res_rho exp_res_ty } }
+ ; set_res_ctxt $ tcWrapResultMono rn_expr tc_expr app_res_rho exp_res_ty } }
--------------------
wantQuickLook :: HsExpr GhcRn -> TcM Bool
-- GHC switches on impredicativity all the time for ($)
-wantQuickLook (HsVar _ f) | unLoc f `hasKey` dollarIdKey = return True
-wantQuickLook _ = xoptM LangExt.ImpredicativeTypes
+wantQuickLook (HsVar _ (L _ f))
+ | getUnique f `elem` quickLookKeys = return True
+wantQuickLook _ = xoptM LangExt.ImpredicativeTypes
+
+quickLookKeys :: [Unique]
+-- See Note [Quick Look for particular Ids]
+quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey]
zonkQuickLook :: Bool -> TcType -> TcM TcType
-- After all Quick Look unifications are done, zonk to ensure that all
@@ -343,24 +372,18 @@ zonkArg arg = return arg
----------------
tcValArgs :: Bool -- Quick-look on?
- -> HsExpr GhcTc -- The function (for error messages)
-> [HsExprArg 'TcpInst] -- Actual argument
-> TcM [HsExprArg 'TcpTc] -- Resulting argument
-tcValArgs do_ql fun args
- = go 1 args
+tcValArgs do_ql args
+ = mapM tc_arg args
where
- go _ [] = return []
- go n (arg:args) = do { (n',arg') <- tc_arg n arg
- ; args' <- go n' args
- ; return (arg' : args') }
-
- tc_arg :: Int -> HsExprArg 'TcpInst -> TcM (Int, HsExprArg 'TcpTc)
- tc_arg n (EPar l) = return (n, EPar l)
- tc_arg n (EPrag l p) = return (n, EPrag l (tcExprPrag p))
- tc_arg n (EWrap wrap) = return (n, EWrap wrap)
- tc_arg n (ETypeArg l hs_ty ty) = return (n+1, ETypeArg l hs_ty ty)
-
- tc_arg n eva@(EValArg { eva_arg = arg, eva_arg_ty = Scaled mult arg_ty })
+ tc_arg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpTc)
+ tc_arg (EPrag l p) = return (EPrag l (tcExprPrag p))
+ tc_arg (EWrap w) = return (EWrap w)
+ tc_arg (ETypeArg l hs_ty ty) = return (ETypeArg l hs_ty ty)
+
+ tc_arg eva@(EValArg { eva_arg = arg, eva_arg_ty = Scaled mult arg_ty
+ , eva_ctxt = ctxt })
= do { -- Crucial step: expose QL results before checking arg_ty
-- So far as the paper is concerned, this step applies
-- the poly-substitution Theta, learned by QL, so that we
@@ -373,47 +396,34 @@ tcValArgs do_ql fun args
arg_ty <- zonkQuickLook do_ql arg_ty
-- Now check the argument
- ; arg' <- addErrCtxt (funAppCtxt fun (eValArgExpr arg) n) $
- tcScalingUsage mult $
+ ; arg' <- tcScalingUsage mult $
do { traceTc "tcEValArg" $
- vcat [ ppr n <+> text "of" <+> ppr fun
+ vcat [ ppr ctxt
, text "arg type:" <+> ppr arg_ty
, text "arg:" <+> ppr arg ]
- ; tcEValArg arg arg_ty }
+ ; tcEValArg ctxt arg arg_ty }
- ; return (n+1, eva { eva_arg = ValArg arg'
- , eva_arg_ty = Scaled mult arg_ty }) }
+ ; return (eva { eva_arg = ValArg arg'
+ , eva_arg_ty = Scaled mult arg_ty }) }
-tcEValArg :: EValArg 'TcpInst -> TcSigmaType -> TcM (LHsExpr GhcTc)
+tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaType -> TcM (LHsExpr GhcTc)
-- Typecheck one value argument of a function call
-tcEValArg (ValArg arg) exp_arg_sigma
- = tcCheckPolyExprNC arg exp_arg_sigma
-
-tcEValArg (ValArgQL { va_expr = L loc _, va_fun = fun, va_args = args
- , va_ty = app_res_rho, va_rebuild = rebuild }) exp_arg_sigma
- = setSrcSpan loc $
- do { traceTc "tcEValArg {" (vcat [ ppr fun <+> ppr args ])
- ; tc_args <- tcValArgs True fun args
- ; co <- unifyType Nothing app_res_rho exp_arg_sigma
+tcEValArg ctxt (ValArg larg@(L arg_loc arg)) exp_arg_sigma
+ = addArgCtxt ctxt larg $
+ do { arg' <- tcPolyExpr arg (mkCheckExpType exp_arg_sigma)
+ ; return (L arg_loc arg') }
+
+tcEValArg ctxt (ValArgQL { va_expr = larg@(L arg_loc _)
+ , va_fun = (inner_fun, fun_ctxt)
+ , va_args = inner_args
+ , va_ty = app_res_rho }) exp_arg_sigma
+ = addArgCtxt ctxt larg $
+ do { traceTc "tcEValArgQL {" (vcat [ ppr inner_fun <+> ppr inner_args ])
+ ; tc_args <- tcValArgs True inner_args
+ ; co <- unifyType Nothing app_res_rho exp_arg_sigma
; traceTc "tcEValArg }" empty
- ; return (L loc $ mkHsWrapCo co $ rebuild fun tc_args) }
-
-----------------
-tcValArg :: HsExpr GhcRn -- The function (for error messages)
- -> LHsExpr GhcRn -- Actual argument
- -> Scaled TcSigmaType -- expected arg type
- -> Int -- # of argument
- -> TcM (LHsExpr GhcTc) -- Resulting argument
--- tcValArg is called only from Gen.Expr, dealing with left and right sections
-tcValArg fun arg (Scaled mult arg_ty) arg_no
- = addErrCtxt (funAppCtxt fun arg arg_no) $
- tcScalingUsage mult $
- do { traceTc "tcValArg" $
- vcat [ ppr arg_no <+> text "of" <+> ppr fun
- , text "arg type:" <+> ppr arg_ty
- , text "arg:" <+> ppr arg ]
- ; tcCheckPolyExprNC arg arg_ty }
-
+ ; return (L arg_loc $ mkHsWrapCo co $
+ rebuildHsApps inner_fun fun_ctxt tc_args) }
{- *********************************************************************
* *
@@ -435,18 +445,33 @@ tcInstFun :: Bool -- True <=> Do quick-look
-- in tcInferSigma, which is used only to implement :type
-- Otherwise we do eager instantiation; in Fig 5 of the paper
-- |-inst returns a rho-type
- -> HsExpr GhcRn -> TcSigmaType -> [HsExprArg 'TcpRn]
+ -> (HsExpr GhcRn, AppCtxt) -- Error messages only
+ -> TcSigmaType -> [HsExprArg 'TcpRn]
-> TcM ( Delta
, [HsExprArg 'TcpInst]
, TcSigmaType )
-- This function implements the |-inst judgement in Fig 4, plus the
-- modification in Fig 5, of the QL paper:
-- "A quick look at impredicativity" (ICFP'20).
-tcInstFun do_ql inst_final rn_fun fun_sigma rn_args
- = do { traceTc "tcInstFun" (ppr rn_fun $$ ppr rn_args $$ text "do_ql" <+> ppr do_ql)
+tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
+ = do { traceTc "tcInstFun" (vcat [ ppr rn_fun, ppr fun_sigma
+ , text "args:" <+> ppr rn_args
+ , text "do_ql" <+> ppr do_ql ])
; go emptyVarSet [] [] fun_sigma rn_args }
where
- fun_orig = exprCtOrigin rn_fun
+ fun_loc = appCtxtLoc fun_ctxt
+ fun_orig = exprCtOrigin (case fun_ctxt of
+ VAExpansion e _ -> e
+ VACall e _ _ -> e)
+ set_fun_ctxt thing_inside
+ | not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
+ = thing_inside -- => context is already set
+ | otherwise
+ = setSrcSpan fun_loc $
+ case fun_ctxt of
+ VAExpansion orig _ -> addExprCtxt orig thing_inside
+ VACall {} -> thing_inside
+
herald = sep [ text "The function" <+> quotes (ppr rn_fun)
, text "is applied to"]
@@ -497,13 +522,14 @@ tcInstFun do_ql inst_final rn_fun fun_sigma rn_args
-- ('go' dealt with that case)
-- Rule IALL from Fig 4 of the QL paper
+ -- c.f. GHC.Tc.Utils.Instantiate.topInstantiate
go1 delta acc so_far fun_ty args
| (tvs, body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty
, (theta, body2) <- tcSplitPhiTy body1
, not (null tvs && null theta)
- = do { (inst_tvs, wrap, fun_rho) <- setSrcSpanFromArgs rn_args $
+ = do { (inst_tvs, wrap, fun_rho) <- set_fun_ctxt $
instantiateSigma fun_orig tvs theta body2
- -- setSrcSpanFromArgs: important for the class constraints
+ -- set_fun_ctxt: important for the class constraints
-- that may be emitted from instantiating fun_sigma
; go (delta `extendVarSetList` inst_tvs)
(addArgWrap wrap acc) so_far fun_rho args }
@@ -515,21 +541,21 @@ tcInstFun do_ql inst_final rn_fun fun_sigma rn_args
= do { traceTc "tcInstFun:ret" (ppr fun_ty)
; return (delta, reverse acc, fun_ty) }
- go1 delta acc so_far fun_ty (EPar sp : args)
- = go1 delta (EPar sp : acc) so_far fun_ty args
+ go1 delta acc so_far fun_ty (EWrap w : args)
+ = go1 delta (EWrap w : acc) so_far fun_ty args
go1 delta acc so_far fun_ty (EPrag sp prag : args)
= go1 delta (EPrag sp prag : acc) so_far fun_ty args
-- Rule ITYARG from Fig 4 of the QL paper
- go1 delta acc so_far fun_ty ( ETypeArg { eva_loc = loc, eva_hs_ty = hs_ty }
+ go1 delta acc so_far fun_ty ( ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty }
: rest_args )
| fun_is_out_of_scope -- See Note [VTA for out-of-scope functions]
= go delta acc so_far fun_ty rest_args
| otherwise
= do { (ty_arg, inst_ty) <- tcVTA fun_ty hs_ty
- ; let arg' = ETypeArg { eva_loc = loc, eva_hs_ty = hs_ty, eva_ty = ty_arg }
+ ; let arg' = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty, eva_ty = ty_arg }
; go delta (arg' : acc) so_far inst_ty rest_args }
-- Rule IVAR from Fig 4 of the QL paper:
@@ -573,15 +599,12 @@ tcInstFun do_ql inst_final rn_fun fun_sigma rn_args
-- Rule IARG from Fig 4 of the QL paper:
go1 delta acc so_far fun_ty
- (eva@(EValArg { eva_arg = ValArg arg }) : rest_args)
+ (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args)
= do { (wrap, arg_ty, res_ty) <- matchActualFunTySigma herald
(Just (ppr rn_fun))
(n_val_args, so_far) fun_ty
- ; let arg_no = 1 + count isVisibleArg acc
- -- We could cache this in a pair with acc; but
- -- it's only evaluated if there's a type error
; (delta', arg') <- if do_ql
- then addErrCtxt (funAppCtxt rn_fun arg arg_no) $
+ then addArgCtxt ctxt arg $
-- Context needed for constraints
-- generated by calls in arg
quickLookArg delta arg arg_ty
@@ -591,6 +614,21 @@ tcInstFun do_ql inst_final rn_fun fun_sigma rn_args
; go delta' acc' (arg_ty:so_far) res_ty rest_args }
+addArgCtxt :: AppCtxt -> LHsExpr GhcRn
+ -> TcM a -> TcM a
+-- Adds a "In the third argument of f, namely blah"
+-- context, unless we are in generated code, in which case
+-- use "In the expression: arg"
+---See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
+addArgCtxt (VACall fun arg_no _) (L arg_loc arg) thing_inside
+ = setSrcSpan arg_loc $
+ addErrCtxt (funAppCtxt fun arg arg_no) $
+ thing_inside
+
+addArgCtxt (VAExpansion {}) (L arg_loc arg) thing_inside
+ = setSrcSpan arg_loc $
+ addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
+ thing_inside
{- *********************************************************************
* *
@@ -756,7 +794,7 @@ quickLookArg delta larg (Scaled _ arg_ty)
| isEmptyVarSet delta = skipQuickLook delta larg
| otherwise = go arg_ty
where
- guarded = isGuardedTy arg_ty
+ guarded = isGuardedTy arg_ty
-- NB: guardedness is computed based on the original,
-- unzonked arg_ty, so we deliberately do not exploit
-- guardedness that emerges a result of QL on earlier args
@@ -785,9 +823,8 @@ isGuardedTy ty
quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaType
-> TcM (Delta, EValArg 'TcpInst)
-quickLookArg1 guarded delta larg@(L loc arg) arg_ty
- = setSrcSpan loc $
- do { let (rn_fun,rn_args,rebuild) = splitHsApps arg
+quickLookArg1 guarded delta larg@(L _ arg) arg_ty
+ = do { let (fun@(rn_fun, fun_ctxt), rn_args) = splitHsApps arg
; mb_fun_ty <- tcInferAppHead_maybe rn_fun rn_args (Just arg_ty)
; traceTc "quickLookArg 1" $
vcat [ text "arg:" <+> ppr arg
@@ -797,19 +834,20 @@ quickLookArg1 guarded delta larg@(L loc arg) arg_ty
; case mb_fun_ty of {
Nothing -> -- fun is too complicated
skipQuickLook delta larg ;
- Just (fun', fun_sigma) ->
+ Just (tc_fun, fun_sigma) ->
do { let no_free_kappas = findNoQuantVars fun_sigma rn_args
; traceTc "quickLookArg 2" $
vcat [ text "no_free_kappas:" <+> ppr no_free_kappas
- , text "guarded:" <+> ppr guarded ]
+ , text "guarded:" <+> ppr guarded
+ , text "tc_fun:" <+> ppr tc_fun
+ , text "fun_sigma:" <+> ppr fun_sigma ]
; if not (guarded || no_free_kappas)
then skipQuickLook delta larg
else
do { do_ql <- wantQuickLook rn_fun
- ; (delta_app, inst_args, app_res_rho)
- <- tcInstFun do_ql True rn_fun fun_sigma rn_args
- ; traceTc "quickLookArg" $
+ ; (delta_app, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args
+ ; traceTc "quickLookArg 3" $
vcat [ text "arg:" <+> ppr arg
, text "delta:" <+> ppr delta
, text "delta_app:" <+> ppr delta_app
@@ -821,10 +859,10 @@ quickLookArg1 guarded delta larg@(L loc arg) arg_ty
; let delta' = delta `unionVarSet` delta_app
; qlUnify delta' arg_ty app_res_rho
- ; let ql_arg = ValArgQL { va_expr = larg, va_fun = fun'
- , va_args = inst_args
- , va_ty = app_res_rho
- , va_rebuild = rebuild }
+ ; let ql_arg = ValArgQL { va_expr = larg
+ , va_fun = (tc_fun, fun_ctxt)
+ , va_args = inst_args
+ , va_ty = app_res_rho }
; return (delta', ql_arg) } } } }
skipQuickLook :: Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
@@ -1013,7 +1051,7 @@ findNoQuantVars fun_ty args
go bvs fun_ty [] = tyCoVarsOfType fun_ty `disjointVarSet` bvs
- go bvs fun_ty (EPar {} : args) = go bvs fun_ty args
+ go bvs fun_ty (EWrap {} : args) = go bvs fun_ty args
go bvs fun_ty (EPrag {} : args) = go bvs fun_ty args
go bvs fun_ty args@(ETypeArg {} : rest_args)
@@ -1071,12 +1109,13 @@ isTagToEnum :: HsExpr GhcRn -> Bool
isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey
isTagToEnum _ = False
-tcTagToEnum :: HsExpr GhcRn -> HsExpr GhcTc -> [HsExprArg 'TcpTc]
+tcTagToEnum :: HsExpr GhcRn
+ -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]
-> TcRhoType -> ExpRhoType
-> TcM (HsExpr GhcTc)
-- tagToEnum# :: forall a. Int# -> a
-- See Note [tagToEnum#] Urgh!
-tcTagToEnum expr fun args app_res_ty res_ty
+tcTagToEnum expr fun fun_ctxt args app_res_ty res_ty
| null val_args
= failWithTc (text "tagToEnum# must appear applied to one argument")
@@ -1101,7 +1140,7 @@ tcTagToEnum expr fun args app_res_ty res_ty
check_enumeration ty' rep_tc
; let rep_ty = mkTyConApp rep_tc rep_args
fun' = mkHsWrap (WpTyApp rep_ty) fun
- expr' = rebuildPrefixApps fun' val_args
+ expr' = rebuildHsApps fun' fun_ctxt val_args
df_wrap = mkWpCastR (mkTcSymCo coi)
; return (mkHsWrap df_wrap expr') }}}}}
@@ -1109,7 +1148,7 @@ tcTagToEnum expr fun args app_res_ty res_ty
val_args = dropWhile (not . isHsValArg) args
vanilla_result
- = do { let expr' = rebuildPrefixApps fun args
+ = do { let expr' = rebuildHsApps fun fun_ctxt args
; tcWrapResultMono expr expr' app_res_ty res_ty }
check_enumeration ty' tc
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 7d7b34e9d3..8ad1e59796 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -17,9 +17,10 @@
module GHC.Tc.Gen.Expr
( tcCheckPolyExpr, tcCheckPolyExprNC,
- tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC,
+ tcCheckMonoExpr, tcCheckMonoExprNC,
+ tcMonoExpr, tcMonoExprNC,
tcInferRho, tcInferRhoNC,
- tcExpr,
+ tcPolyExpr, tcExpr,
tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
tcCheckId,
addAmbiguousNameErr,
@@ -37,7 +38,6 @@ import GHC.Tc.Utils.Zonk
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Types.Basic
-import GHC.Types.SourceText
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Tc.Utils.Instantiate
@@ -81,7 +81,6 @@ import GHC.Data.FastString
import Control.Monad
import GHC.Core.Class(classTyCon)
import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )
-import qualified GHC.LanguageExtensions as LangExt
import Data.Function
import Data.List (partition, sortBy, groupBy, intersect)
@@ -105,34 +104,23 @@ tcCheckPolyExpr, tcCheckPolyExprNC
-- The NC version does not do so, usually because the caller wants
-- to do so themselves.
-tcCheckPolyExpr expr res_ty = tcPolyExpr expr (mkCheckExpType res_ty)
-tcCheckPolyExprNC expr res_ty = tcPolyExprNC expr (mkCheckExpType res_ty)
+tcCheckPolyExpr expr res_ty = tcPolyLExpr expr (mkCheckExpType res_ty)
+tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty)
-- These versions take an ExpType
-tcPolyExpr, tcPolyExprNC
- :: LHsExpr GhcRn -> ExpSigmaType
- -> TcM (LHsExpr GhcTc)
+tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
+ -> TcM (LHsExpr GhcTc)
-tcPolyExpr expr res_ty
- = addLExprCtxt expr $
- do { traceTc "tcPolyExpr" (ppr res_ty)
- ; tcPolyExprNC expr res_ty }
-
-tcPolyExprNC (L loc expr) res_ty
- = set_loc_and_ctxt loc expr $
- do { traceTc "tcPolyExprNC" (ppr res_ty)
- ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
- tcExpr expr res_ty
- ; return $ L loc (mkHsWrap wrap expr') }
+tcPolyLExpr (L loc expr) res_ty
+ = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
+ addExprCtxt expr $ -- Note [Error contexts in generated code]
+ do { expr' <- tcPolyExpr expr res_ty
+ ; return (L loc expr') }
- where -- See Note [Rebindable syntax and HsExpansion), which describes
- -- the logic behind this location/context tweaking.
- set_loc_and_ctxt l e m = do
- inGenCode <- inGeneratedCode
- if inGenCode && not (isGeneratedSrcSpan l)
- then setSrcSpan l $
- addExprCtxt e m
- else setSrcSpan l m
+tcPolyLExprNC (L loc expr) res_ty
+ = setSrcSpan loc $
+ do { expr' <- tcPolyExpr expr res_ty
+ ; return (L loc expr') }
---------------
tcCheckMonoExpr, tcCheckMonoExprNC
@@ -149,9 +137,11 @@ tcMonoExpr, tcMonoExprNC
-- Definitely no foralls at the top
-> TcM (LHsExpr GhcTc)
-tcMonoExpr expr res_ty
- = addLExprCtxt expr $
- tcMonoExprNC expr res_ty
+tcMonoExpr (L loc expr) res_ty
+ = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
+ addExprCtxt expr $ -- Note [Error contexts in generated code]
+ do { expr' <- tcExpr expr res_ty
+ ; return (L loc expr') }
tcMonoExprNC (L loc expr) res_ty
= setSrcSpan loc $
@@ -161,8 +151,11 @@ tcMonoExprNC (L loc expr) res_ty
---------------
tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
-- Infer a *rho*-type. The return type is always instantiated.
-tcInferRho le = addLExprCtxt le $
- tcInferRhoNC le
+tcInferRho (L loc expr)
+ = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
+ addExprCtxt expr $ -- Note [Error contexts in generated code]
+ do { (expr', rho) <- tcInfer (tcExpr expr)
+ ; return (L loc expr', rho) }
tcInferRhoNC (L loc expr)
= setSrcSpan loc $
@@ -176,22 +169,45 @@ tcInferRhoNC (L loc expr)
* *
********************************************************************* -}
+tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
+tcPolyExpr expr res_ty
+ = do { traceTc "tcPolyExpr" (ppr res_ty)
+ ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
+ tcExpr expr res_ty
+ ; return $ mkHsWrap wrap expr' }
+
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- Use tcApp to typecheck appplications, which are treated specially
-- by Quick Look. Specifically:
--- - HsApp: value applications
--- - HsTypeApp: type applications
--- - HsVar: lone variables, to ensure that they can get an
--- impredicative instantiation (via Quick Look
--- driven by res_ty (in checking mode).
--- - ExprWithTySig: (e :: type)
+-- - HsVar lone variables, to ensure that they can get an
+-- impredicative instantiation (via Quick Look
+-- driven by res_ty (in checking mode)).
+-- - HsApp value applications
+-- - HsAppType type applications
+-- - ExprWithTySig (e :: type)
+-- - HsRecFld overloaded record fields
+-- - HsExpanded renamer expansions
+-- - HsOpApp operator applications
+-- - HsOverLit overloaded literals
+-- These constructors are the union of
+-- - ones taken apart by GHC.Tc.Gen.Head.splitHsApps
+-- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
-tcExpr e@(HsVar {}) res_ty = tcApp e res_ty
-tcExpr e@(HsApp {}) res_ty = tcApp e res_ty
-tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty
-tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty
-tcExpr e@(HsRecFld {}) res_ty = tcApp e res_ty
+tcExpr e@(HsVar {}) res_ty = tcApp e res_ty
+tcExpr e@(HsApp {}) res_ty = tcApp e res_ty
+tcExpr e@(OpApp {}) res_ty = tcApp e res_ty
+tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty
+tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty
+tcExpr e@(HsRecFld {}) res_ty = tcApp e res_ty
+tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty
+
+tcExpr e@(HsOverLit _ lit) res_ty
+ = do { mb_res <- tcShortCutLit lit res_ty
+ -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.Zonk
+ ; case mb_res of
+ Just lit' -> return (HsOverLit noExtField lit')
+ Nothing -> tcApp e res_ty }
-- Typecheck an occurrence of an unbound Id
--
@@ -216,10 +232,6 @@ tcExpr (HsPragE x prag expr) res_ty
= do { expr' <- tcMonoExpr expr res_ty
; return (HsPragE x (tcExprPrag prag) expr') }
-tcExpr (HsOverLit x lit) res_ty
- = do { lit' <- newOverloadedLit lit res_ty
- ; return (HsOverLit x lit') }
-
tcExpr (NegApp x expr neg_expr) res_ty
= do { (expr', neg_expr')
<- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
@@ -245,31 +257,6 @@ tcExpr e@(HsIPVar _ x) res_ty
unwrapIP $ mkClassPred ipClass [x,ty]
origin = IPOccOrigin x
-tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty
- = do { -- See Note [Type-checking overloaded labels]
- loc <- getSrcSpanM
- ; case mb_fromLabel of
- Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty
- Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName
- ; alpha <- newFlexiTyVarTy liftedTypeKind
- ; let pred = mkClassPred isLabelClass [lbl, alpha]
- ; loc <- getSrcSpanM
- ; var <- emitWantedEvVar origin pred
- ; tcWrapResult e
- (fromDict pred (HsVar noExtField (L loc var)))
- alpha res_ty } }
- where
- -- Coerces a dictionary for `IsLabel "x" t` into `t`,
- -- or `HasField "x" r a into `r -> a`.
- fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred
- origin = OverLabelOrigin l
- lbl = mkStrLitTy l
-
- applyFromLabel loc fromLabel =
- HsAppType noExtField
- (L loc (HsVar noExtField (L loc fromLabel)))
- (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l))))
-
tcExpr (HsLam x match) res_ty
= do { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty
; return (mkHsWrap wrap (HsLam x match')) }
@@ -292,92 +279,26 @@ tcExpr e@(HsLamCase x matches) res_ty
, text "requires"]
match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
-{-
-Note [Type-checking overloaded labels]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Recall that we have
-
- module GHC.OverloadedLabels where
- class IsLabel (x :: Symbol) a where
- fromLabel :: a
-
-We translate `#foo` to `fromLabel @"foo"`, where we use
-
- * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not
- * `GHC.OverloadedLabels.fromLabel`.
-
-In the `RebindableSyntax` case, the renamer will have filled in the
-first field of `HsOverLabel` with the `fromLabel` function to use, and
-we simply apply it to the appropriate visible type argument.
-
-In the `OverloadedLabels` case, when we see an overloaded label like
-`#foo`, we generate a fresh variable `alpha` for the type and emit an
-`IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a
-single method, it is represented by a newtype, so we can coerce
-`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters).
-
--}
{-
************************************************************************
* *
- Infix operators and sections
+ Explicit lists
* *
************************************************************************
-
-Note [Left sections]
-~~~~~~~~~~~~~~~~~~~~
-Left sections, like (4 *), are equivalent to
- \ x -> (*) 4 x,
-or, if PostfixOperators is enabled, just
- (*) 4
-With PostfixOperators we don't actually require the function to take
-two arguments at all. For example, (x `not`) means (not x); you get
-postfix operators! Not Haskell 98, but it's less work and kind of
-useful.
-}
-tcExpr expr@(OpApp {}) res_ty
- = tcApp expr res_ty
-
--- Right sections, equivalent to \ x -> x `op` expr, or
--- \ x -> op x expr
-
-tcExpr expr@(SectionR x op arg2) res_ty
- = do { (op', op_ty) <- tcInferRhoNC op
- ; (wrap_fun, [Scaled arg1_mult arg1_ty, arg2_ty], op_res_ty)
- <- matchActualFunTysRho (mk_op_msg op) fn_orig
- (Just (ppr op)) 2 op_ty
- ; arg2' <- tcValArg (unLoc op) arg2 arg2_ty 2
- ; let expr' = SectionR x (mkLHsWrap wrap_fun op') arg2'
- act_res_ty = mkVisFunTy arg1_mult arg1_ty op_res_ty
- ; tcWrapResultMono expr expr' act_res_ty res_ty }
-
- where
- fn_orig = lexprCtOrigin op
- -- It's important to use the origin of 'op', so that call-stacks
- -- come out right; they are driven by the OccurrenceOf CtOrigin
- -- See #13285
-
-tcExpr expr@(SectionL x arg1 op) res_ty
- = do { (op', op_ty) <- tcInferRhoNC op
- ; dflags <- getDynFlags -- Note [Left sections]
- ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1
- | otherwise = 2
-
- ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
- <- matchActualFunTysRho (mk_op_msg op) fn_orig
- (Just (ppr op)) n_reqd_args op_ty
- ; arg1' <- tcValArg (unLoc op) arg1 arg1_ty 1
- ; let expr' = SectionL x arg1' (mkLHsWrap wrap_fn op')
- act_res_ty = mkVisFunTys arg_tys op_res_ty
- ; tcWrapResultMono expr expr' act_res_ty res_ty }
- where
- fn_orig = lexprCtOrigin op
- -- It's important to use the origin of 'op', so that call-stacks
- -- come out right; they are driven by the OccurrenceOf CtOrigin
- -- See #13285
+-- Explict lists [e1,e2,e3] have been expanded already in the renamer
+-- The expansion includes an ExplicitList, but it is always the built-in
+-- list type, so that's all we need concern ourselves with here. See
+-- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs]
+tcExpr (ExplicitList _ exprs) res_ty
+ = do { res_ty <- expTypeToType res_ty
+ ; (coi, elt_ty) <- matchExpectedListTy res_ty
+ ; let tc_elt expr = tcCheckPolyExpr expr elt_ty
+ ; exprs' <- mapM tc_elt exprs
+ ; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' }
tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty
| all tupArgPresent tup_args
@@ -427,32 +348,6 @@ tcExpr (ExplicitSum _ alt arity expr) res_ty
; expr' <- tcCheckPolyExpr expr (arg_tys' `getNth` (alt - 1))
; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }
--- This will see the empty list only when -XOverloadedLists.
--- See Note [Empty lists] in GHC.Hs.Expr.
-tcExpr (ExplicitList _ witness exprs) res_ty
- = case witness of
- Nothing -> do { res_ty <- expTypeToType res_ty
- ; (coi, elt_ty) <- matchExpectedListTy res_ty
- ; exprs' <- mapM (tc_elt elt_ty) exprs
- ; return $
- mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' }
-
- Just fln -> do { ((exprs', elt_ty), fln')
- <- tcSyntaxOp ListOrigin fln
- [synKnownType intTy, SynList] res_ty $
- \ [elt_ty] [_int_mul, list_mul] ->
- -- We ignore _int_mul because the integer (first
- -- argument of fromListN) is statically known: it
- -- is desugared to a literal. Therefore there is
- -- no variable of which to scale the usage in that
- -- first argument, and `_int_mul` is completely
- -- free in this expression.
- do { exprs' <-
- mapM (tcScalingUsage list_mul . tc_elt elt_ty) exprs
- ; return (exprs', elt_ty) }
-
- ; return $ ExplicitList elt_ty (Just fln') exprs' }
- where tc_elt elt_ty expr = tcCheckPolyExpr expr elt_ty
{-
************************************************************************
@@ -955,27 +850,18 @@ tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty
{-
************************************************************************
* *
- Rebindable syntax
-* *
-************************************************************************
--}
-
--- See Note [Rebindable syntax and HsExpansion].
-tcExpr (XExpr (HsExpanded a b)) t
- = fmap (XExpr . ExpansionExpr . HsExpanded a) $
- setSrcSpan generatedSrcSpan (tcExpr b t)
-
-{-
-************************************************************************
-* *
Catch-all
* *
************************************************************************
-}
-tcExpr other _ = pprPanic "tcExpr" (ppr other)
- -- Include ArrForm, ArrApp, which shouldn't appear at all
- -- Also HsTcBracketOut, HsQuasiQuoteE
+tcExpr (HsConLikeOut {}) ty = pprPanic "tcExpr:HsConLikeOut" (ppr ty)
+tcExpr (HsOverLabel {}) ty = pprPanic "tcExpr:HsOverLabel" (ppr ty)
+tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty)
+tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
+tcExpr (HsTcBracketOut {}) ty = pprPanic "tcExpr:HsTcBracketOut" (ppr ty)
+tcExpr (HsTick {}) ty = pprPanic "tcExpr:HsTick" (ppr ty)
+tcExpr (HsBinTick {}) ty = pprPanic "tcExpr:HsBinTick" (ppr ty)
{-
@@ -1076,9 +962,8 @@ tcSyntaxOpGen :: CtOrigin
-> ([TcSigmaType] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside
- = do { (expr, sigma) <- tcInferAppHead op [] Nothing
- -- Nothing here might be improved, but all this
- -- code is scheduled for demolition anyway
+ = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) [] Nothing
+ -- Ugh!! But all this code is scheduled for demolition anyway
; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)
; (result, expr_wrap, arg_wraps, res_wrap)
<- tcSynArgA orig sigma arg_tys res_ty $
@@ -1391,8 +1276,8 @@ For each binding field = value
3. Instantiate the field type (from the field label) using the type
envt from step 2.
-4 Type check the value using tcValArg, passing the field type as
- the expected argument type.
+4 Type check the value using tcCheckPolyExprNC (in tcRecordField),
+ passing the field type as the expected argument type.
This extends OK when the field types are universally quantified.
-}
@@ -1540,9 +1425,6 @@ fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt field_name
= text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
-mk_op_msg :: LHsExpr GhcRn -> SDoc
-mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"
-
badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
badFieldTypes prs
= hang (text "Record update for insufficiently polymorphic field"
diff --git a/compiler/GHC/Tc/Gen/Expr.hs-boot b/compiler/GHC/Tc/Gen/Expr.hs-boot
index b47b146118..22abe79491 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs-boot
+++ b/compiler/GHC/Tc/Gen/Expr.hs-boot
@@ -1,7 +1,8 @@
module GHC.Tc.Gen.Expr where
import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn
, SyntaxExprTc )
-import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType )
+import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType
+ , ExpType, ExpRhoType, ExpSigmaType )
import GHC.Tc.Types ( TcM )
import GHC.Tc.Types.Origin ( CtOrigin )
import GHC.Core.Type ( Mult )
@@ -21,7 +22,8 @@ tcCheckMonoExpr, tcCheckMonoExprNC ::
-> TcRhoType
-> TcM (LHsExpr GhcTc)
-tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
+tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcInferRho, tcInferRhoNC ::
LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 3d6d51ff22..7dc993d8cc 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -16,10 +16,10 @@
-}
module GHC.Tc.Gen.Head
- ( HsExprArg(..), EValArg(..), TcPass(..), Rebuilder
- , splitHsApps
- , addArgWrap, eValArgExpr, isHsValArg, setSrcSpanFromArgs
- , countLeadingValArgs, isVisibleArg, pprHsExprArgTc, rebuildPrefixApps
+ ( HsExprArg(..), EValArg(..), TcPass(..), AppCtxt(..), appCtxtLoc
+ , splitHsApps, rebuildHsApps
+ , addArgWrap, isHsValArg, insideExpansion
+ , countLeadingValArgs, isVisibleArg, pprHsExprArgTc
, tcInferAppHead, tcInferAppHead_maybe
, tcInferId, tcCheckId
@@ -27,7 +27,7 @@ module GHC.Tc.Gen.Head
, tyConOf, tyConOfET, lookupParents, fieldNotInType
, notSelector, nonBidirectionalErr
- , addExprCtxt, addLExprCtxt, addFunResCtxt ) where
+ , addExprCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )
@@ -47,6 +47,7 @@ import GHC.Rename.Env ( addUsedGRE )
import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr )
import GHC.Tc.Solver ( InferMode(..), simplifyInfer )
import GHC.Tc.Utils.Env
+import GHC.Tc.Utils.Zonk ( hsLitType )
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
@@ -134,20 +135,24 @@ Invariants:
under the conditions when quick-look should happen (eg the argument
type is guarded) -- see quickLookArg
-Note [splitHsApps and Rebuilder]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [splitHsApps]
+~~~~~~~~~~~~~~~~~~
The key function
- splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, [HsExprArg 'TcpRn], Rebuilder)
+ splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, HsExpr GhcRn, [HsExprArg 'TcpRn])
takes apart either an HsApp, or an infix OpApp, returning
-* The "head" of the application, an expression that is often a variable
+* The "head" of the application, an expression that is often a variable;
+ this is used for typechecking
-* A list of HsExprArg, the arguments
+* The "user head" or "error head" of the application, to be reported to the
+ user in case of an error. Example:
+ (`op` e)
+ expands (via HsExpanded) to
+ (rightSection op e)
+ but we don't want to see 'rightSection' in error messages. So we keep the
+ innermost un-expanded head as the "error head".
-* A Rebuilder function which reconstructs the original form, given the
- head and arguments. This allows us to reconstruct infix
- applications (OpApp) as well as prefix applications (HsApp),
- thereby retaining the structure of the original tree.
+* A list of HsExprArg, the arguments
-}
data TcPass = TcpRn -- Arguments decomposed
@@ -156,34 +161,52 @@ data TcPass = TcpRn -- Arguments decomposed
data HsExprArg (p :: TcPass)
= -- See Note [HsExprArg]
- EValArg { eva_loc :: SrcSpan -- Of the function
+ EValArg { eva_ctxt :: AppCtxt
, eva_arg :: EValArg p
, eva_arg_ty :: !(XEVAType p) }
- | ETypeArg { eva_loc :: SrcSpan -- Of the function
+ | ETypeArg { eva_ctxt :: AppCtxt
, eva_hs_ty :: LHsWcType GhcRn -- The type arg
, eva_ty :: !(XETAType p) } -- Kind-checked type arg
- | EPrag SrcSpan
+ | EPrag AppCtxt
(HsPragE (GhcPass (XPass p)))
- | EPar SrcSpan -- Of the nested expr
+ | EWrap EWrap
- | EWrap !(XEWrap p) -- Wrapper, after instantiation
+data EWrap = EPar AppCtxt
+ | EExpand (HsExpr GhcRn)
+ | EHsWrap HsWrapper
data EValArg (p :: TcPass) where -- See Note [EValArg]
ValArg :: LHsExpr (GhcPass (XPass p))
-> EValArg p
- ValArgQL :: { va_expr :: LHsExpr GhcRn -- Original expression
+
+ ValArgQL :: { va_expr :: LHsExpr GhcRn -- Original application
-- For location and error msgs
- , va_fun :: HsExpr GhcTc -- Function, typechecked
+ , va_fun :: (HsExpr GhcTc, AppCtxt) -- Function of the application,
+ -- typechecked, plus its context
, va_args :: [HsExprArg 'TcpInst] -- Args, instantiated
- , va_ty :: TcRhoType -- Result type
- , va_rebuild :: Rebuilder } -- How to reassemble
+ , va_ty :: TcRhoType } -- Result type
-> EValArg 'TcpInst -- Only exists in TcpInst phase
-type Rebuilder = HsExpr GhcTc -> [HsExprArg 'TcpTc]-> HsExpr GhcTc
--- See Note [splitHsApps and Rebuilder]
+data AppCtxt
+ = VAExpansion
+ (HsExpr GhcRn) -- Inside an expansion of this expression
+ SrcSpan -- The SrcSpan of the expression
+ -- noSrcSpan if outermost
+
+ | VACall
+ (HsExpr GhcRn) Int -- In the third argument of function f
+ SrcSpan -- The SrcSpan of the application (f e1 e2 e3)
+
+appCtxtLoc :: AppCtxt -> SrcSpan
+appCtxtLoc (VAExpansion _ l) = l
+appCtxtLoc (VACall _ _ l) = l
+
+instance Outputable AppCtxt where
+ ppr (VAExpansion e _) = text "VAExpansion" <+> ppr e
+ ppr (VACall f n _) = text "VACall" <+> int n <+> ppr f
type family XPass p where
XPass 'TcpRn = 'Renamed
@@ -198,80 +221,92 @@ type family XEVAType p where -- Value arguments
XEVAType 'TcpRn = NoExtField
XEVAType _ = Scaled Type
-type family XEWrap p where
- XEWrap 'TcpRn = NoExtCon
- XEWrap _ = HsWrapper
-
-mkEValArg :: SrcSpan -> LHsExpr GhcRn -> HsExprArg 'TcpRn
-mkEValArg l e = EValArg { eva_loc = l, eva_arg = ValArg e
- , eva_arg_ty = noExtField }
+mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn
+mkEValArg ctxt e = EValArg { eva_arg = ValArg e, eva_ctxt = ctxt
+ , eva_arg_ty = noExtField }
-mkETypeArg :: SrcSpan -> LHsWcType GhcRn -> HsExprArg 'TcpRn
-mkETypeArg l hs_ty = ETypeArg { eva_loc = l, eva_hs_ty = hs_ty
- , eva_ty = noExtField }
-
-eValArgExpr :: EValArg 'TcpInst -> LHsExpr GhcRn
-eValArgExpr (ValArg e) = e
-eValArgExpr (ValArgQL { va_expr = e }) = e
+mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn
+mkETypeArg ctxt hs_ty = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty
+ , eva_ty = noExtField }
addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
addArgWrap wrap args
| isIdHsWrapper wrap = args
- | otherwise = EWrap wrap : args
+ | otherwise = EWrap (EHsWrap wrap) : args
-splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, [HsExprArg 'TcpRn], Rebuilder)
--- See Note [splitHsApps and Rebuilder]
-splitHsApps e
- = go e []
+splitHsApps :: HsExpr GhcRn
+ -> ( (HsExpr GhcRn, AppCtxt) -- Head
+ , [HsExprArg 'TcpRn]) -- Args
+-- See Note [splitHsApps]
+splitHsApps e = go e (top_ctxt 0 e) []
where
- go (HsPar _ (L l fun)) args = go fun (EPar l : args)
- go (HsPragE _ p (L l fun)) args = go fun (EPrag l p : args)
- go (HsAppType _ (L l fun) hs_ty) args = go fun (mkETypeArg l hs_ty : args)
- go (HsApp _ (L l fun) arg) args = go fun (mkEValArg l arg : args)
-
- go (OpApp fix arg1 (L l op) arg2) args
- = (op, mkEValArg l arg1 : mkEValArg l arg2 : args, rebuild_infix fix)
-
- go e args = (e, args, rebuildPrefixApps)
-
- rebuild_infix :: Fixity -> Rebuilder
- rebuild_infix fix fun args
- = go fun args
- where
- go fun (EValArg { eva_arg = ValArg arg1, eva_loc = l } :
- EValArg { eva_arg = ValArg arg2 } : args)
- = rebuildPrefixApps (OpApp fix arg1 (L l fun) arg2) args
- go fun (EWrap wrap : args) = go (mkHsWrap wrap fun) args
- go fun args = rebuildPrefixApps fun args
- -- This last case fails to rebuild a OpApp, which is sad.
- -- It can happen if we have (e1 `op` e2),
- -- and op :: Int -> forall a. a -> Int, and e2 :: Bool
- -- Then we'll get [ e1, @Bool, e2 ]
- -- Could be fixed with WpFun, but extra complexity.
-
-rebuildPrefixApps :: Rebuilder
-rebuildPrefixApps fun args
- = go fun args
+ top_ctxt n (HsPar _ fun) = top_lctxt n fun
+ top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun
+ top_ctxt n (HsAppType _ fun _) = top_lctxt (n+1) fun
+ top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun
+ top_ctxt n (XExpr (HsExpanded orig _)) = VACall orig n noSrcSpan
+ top_ctxt n other_fun = VACall other_fun n noSrcSpan
+
+ top_lctxt n (L _ fun) = top_ctxt n fun
+
+ go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]
+ -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
+ go (HsPar _ (L l fun)) ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt) : args)
+ go (HsPragE _ p (L l fun)) ctxt args = go fun (set l ctxt) (EPrag ctxt p : args)
+ go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty : args)
+ go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args)
+
+ -- See Note [Looking through HsExpanded]
+ go (XExpr (HsExpanded orig fun)) ctxt args
+ = go fun (VAExpansion orig (appCtxtLoc ctxt)) (EWrap (EExpand orig) : args)
+
+ -- See Note [Desugar OpApp in the typechecker]
+ go e@(OpApp _ arg1 (L l op) arg2) _ args
+ = ( (op, VACall op 0 l)
+ , mkEValArg (VACall op 1 generatedSrcSpan) arg1
+ : mkEValArg (VACall op 2 generatedSrcSpan) arg2
+ : EWrap (EExpand e)
+ : args )
+
+ go e ctxt args = ((e,ctxt), args)
+
+ set :: SrcSpan -> AppCtxt -> AppCtxt
+ set l (VACall f n _) = VACall f n l
+ set _ ctxt@(VAExpansion {}) = ctxt
+
+ dec :: SrcSpan -> AppCtxt -> AppCtxt
+ dec l (VACall f n _) = VACall f (n-1) l
+ dec _ ctxt@(VAExpansion {}) = ctxt
+
+rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-> HsExpr GhcTc
+rebuildHsApps fun _ [] = fun
+rebuildHsApps fun ctxt (arg : args)
+ = case arg of
+ EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' }
+ -> rebuildHsApps (HsApp noExtField lfun arg) ctxt' args
+ ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' }
+ -> rebuildHsApps (HsAppType ty lfun hs_ty) ctxt' args
+ EPrag ctxt' p
+ -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args
+ EWrap (EPar ctxt')
+ -> rebuildHsApps (HsPar noExtField lfun) ctxt' args
+ EWrap (EExpand orig)
+ -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args
+ EWrap (EHsWrap wrap)
+ -> rebuildHsApps (mkHsWrap wrap fun) ctxt args
where
- go fun [] = fun
- go fun (EWrap wrap : args) = go (mkHsWrap wrap fun) args
- go fun (EValArg { eva_arg = ValArg arg
- , eva_loc = l } : args) = go (HsApp noExtField (L l fun) arg) args
- go fun (ETypeArg { eva_hs_ty = hs_ty
- , eva_ty = ty
- , eva_loc = l } : args) = go (HsAppType ty (L l fun) hs_ty) args
- go fun (EPar l : args) = go (HsPar noExtField (L l fun)) args
- go fun (EPrag l p : args) = go (HsPragE noExtField p (L l fun)) args
+ lfun = L (appCtxtLoc ctxt) fun
isHsValArg :: HsExprArg id -> Bool
isHsValArg (EValArg {}) = True
isHsValArg _ = False
countLeadingValArgs :: [HsExprArg id] -> Int
-countLeadingValArgs (EValArg {} : args) = 1 + countLeadingValArgs args
-countLeadingValArgs (EPar {} : args) = countLeadingValArgs args
-countLeadingValArgs (EPrag {} : args) = countLeadingValArgs args
-countLeadingValArgs _ = 0
+countLeadingValArgs [] = 0
+countLeadingValArgs (EValArg {} : args) = 1 + countLeadingValArgs args
+countLeadingValArgs (EWrap {} : args) = countLeadingValArgs args
+countLeadingValArgs (EPrag {} : args) = countLeadingValArgs args
+countLeadingValArgs (ETypeArg {} : _) = 0
isValArg :: HsExprArg id -> Bool
isValArg (EValArg {}) = True
@@ -282,27 +317,22 @@ isVisibleArg (EValArg {}) = True
isVisibleArg (ETypeArg {}) = True
isVisibleArg _ = False
-setSrcSpanFromArgs :: [HsExprArg 'TcpRn] -> TcM a -> TcM a
-setSrcSpanFromArgs [] thing_inside
- = thing_inside
-setSrcSpanFromArgs (arg:_) thing_inside
- = setSrcSpan (argFunLoc arg) thing_inside
-
-argFunLoc :: HsExprArg 'TcpRn -> SrcSpan
-argFunLoc (EValArg { eva_loc = l }) = l
-argFunLoc (ETypeArg { eva_loc = l}) = l
-argFunLoc (EPrag l _) = l
-argFunLoc (EPar l) = l
+insideExpansion :: [HsExprArg p] -> Bool
+insideExpansion args = any is_expansion args
+ where
+ is_expansion (EWrap (EExpand {})) = True
+ is_expansion _ = False
instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where
ppr (EValArg { eva_arg = arg }) = text "EValArg" <+> ppr arg
ppr (EPrag _ p) = text "EPrag" <+> ppr p
ppr (ETypeArg { eva_hs_ty = hs_ty }) = char '@' <> ppr hs_ty
- ppr (EPar _) = text "EPar"
- ppr (EWrap _) = text "EWrap"
- -- ToDo: to print the wrapper properly we'll need to work harder
- -- "Work harder" = replicate the ghcPass approach, but I didn't
- -- think it was worth the effort to do so.
+ ppr (EWrap wrap) = ppr wrap
+
+instance Outputable EWrap where
+ ppr (EPar _) = text "EPar"
+ ppr (EHsWrap w) = text "EHsWrap" <+> ppr w
+ ppr (EExpand orig) = text "EExpand" <+> ppr orig
instance OutputableBndrId (XPass p) => Outputable (EValArg p) where
ppr (ValArg e) = ppr e
@@ -315,6 +345,27 @@ pprHsExprArgTc (EValArg { eva_arg = tm, eva_arg_ty = ty })
= text "EValArg" <+> hang (ppr tm) 2 (dcolon <+> ppr ty)
pprHsExprArgTc arg = ppr arg
+{- Note [Desugar OpApp in the typechecker]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Operator sections are desugared in the renamer; see GHC.Rename.Expr
+Note [Handling overloaded and rebindable constructs].
+But for reasons explained there, we rename OpApp to OpApp. Then,
+here in the typechecker, we desugar it to a use of HsExpanded.
+That makes it possible to typecheck something like
+ e1 `f` e2
+where
+ f :: forall a. t1 -> forall b. t2 -> t3
+
+Note [Looking through HsExpanded]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When creating an application chain in splitHsApps, we must deal with
+ HsExpanded f1 (f `HsApp` e1) `HsApp` e2 `HsApp` e3
+
+as a single application chain `f e1 e2 e3`. Otherwise stuff like overloaded
+labels (#19154) won't work.
+
+It's easy to achieve this: `splitHsApps` unwraps `HsExpanded`.
+-}
{- *********************************************************************
* *
@@ -322,7 +373,7 @@ pprHsExprArgTc arg = ppr arg
* *
********************************************************************* -}
-tcInferAppHead :: HsExpr GhcRn
+tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn] -> Maybe TcRhoType
-- These two args are solely for tcInferRecSelId
-> TcM (HsExpr GhcTc, TcSigmaType)
@@ -347,8 +398,8 @@ tcInferAppHead :: HsExpr GhcRn
-- cases are dealt with by splitHsApps.
--
-- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App
-tcInferAppHead fun args mb_res_ty
- = setSrcSpanFromArgs args $
+tcInferAppHead (fun,ctxt) args mb_res_ty
+ = setSrcSpan (appCtxtLoc ctxt) $
do { mb_tc_fun <- tcInferAppHead_maybe fun args mb_res_ty
; case mb_tc_fun of
Just (fun', fun_sigma) -> return (fun', fun_sigma)
@@ -367,6 +418,7 @@ tcInferAppHead_maybe fun args mb_res_ty
HsRecFld _ f -> Just <$> tcInferRecSelId f args mb_res_ty
ExprWithTySig _ e hs_ty -> add_head_ctxt fun args $
Just <$> tcExprWithSig e hs_ty
+ HsOverLit _ lit -> Just <$> tcInferOverLit lit
_ -> return Nothing
add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
@@ -724,6 +776,45 @@ CLong, as it should.
{- *********************************************************************
* *
+ Overloaded literals
+* *
+********************************************************************* -}
+
+tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
+tcInferOverLit lit@(OverLit { ol_val = val
+ , ol_witness = HsVar _ (L loc from_name)
+ , ol_ext = rebindable })
+ = -- Desugar "3" to (fromInteger (3 :: Integer))
+ -- where fromInteger is gotten by looking up from_name, and
+ -- the (3 :: Integer) is returned by mkOverLit
+ -- Ditto the string literal "foo" to (fromString ("foo" :: String))
+ do { from_id <- tcLookupId from_name
+ ; (wrap1, from_ty) <- topInstantiate orig (idType from_id)
+
+ ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_doc
+ (1, []) from_ty
+ ; hs_lit <- mkOverLit val
+ ; co <- unifyType mb_doc (hsLitType hs_lit) (scaledThing sarg_ty)
+
+ ; let lit_expr = L loc $ mkHsWrapCo co $
+ HsLit noExtField hs_lit
+ from_expr = mkHsWrap (wrap2 <.> wrap1) $
+ HsVar noExtField (L loc from_id)
+ lit' = lit { ol_witness = HsApp noExtField (L loc from_expr) lit_expr
+ , ol_ext = OverLitTc rebindable res_ty }
+ ; return (HsOverLit noExtField lit', res_ty) }
+ where
+ orig = LiteralOrigin lit
+ mb_doc = Just (ppr from_name)
+ herald = sep [ text "The function" <+> quotes (ppr from_name)
+ , text "is applied to"]
+
+tcInferOverLit lit
+ = pprPanic "tcInferOverLit" (ppr lit)
+
+
+{- *********************************************************************
+* *
tcInferId, tcCheckId
* *
********************************************************************* -}
@@ -1093,12 +1184,12 @@ addFunResCtxt fun args fun_res_ty env_ty
= Outputable.empty
; return info }
- where
- not_fun ty -- ty is definitely not an arrow type,
- -- and cannot conceivably become one
- = case tcSplitTyConApp_maybe ty of
- Just (tc, _) -> isAlgTyCon tc
- Nothing -> False
+
+ not_fun ty -- ty is definitely not an arrow type,
+ -- and cannot conceivably become one
+ = case tcSplitTyConApp_maybe ty of
+ Just (tc, _) -> isAlgTyCon tc
+ Nothing -> False
{-
Note [Splitting nested sigma types in mismatched function types]
@@ -1145,9 +1236,6 @@ provided.
* *
********************************************************************* -}
-addLExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a
-addLExprCtxt (L _ e) thing_inside = addExprCtxt e thing_inside
-
addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 42f0a3fddc..f250a8e82d 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2453,7 +2453,7 @@ tcGhciStmts stmts
-- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $
- noLoc $ ExplicitList unitTy Nothing $
+ noLoc $ ExplicitList unitTy $
map mk_item ids
mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id)
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 2577de341e..69a0d2898c 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -1024,7 +1024,7 @@ tcPatToExpr name args pat = go pat
go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat
go1 p@(ListPat reb pats)
| Nothing <- reb = do { exprs <- mapM go pats
- ; return $ ExplicitList noExtField Nothing exprs }
+ ; return $ ExplicitList noExtField exprs }
| otherwise = notInvertibleListPat p
go1 (TuplePat _ pats box) = do { exprs <- mapM go pats
; return $ ExplicitTuple noExtField
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 91fac134bc..b0d970bb37 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -481,7 +481,8 @@ exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name
exprCtOrigin (HsUnboundVar {}) = Shouldn'tHappenOrigin "unbound variable"
exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut"
exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)
-exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l
+exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l
+exprCtOrigin (ExplicitList {}) = ListOrigin
exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip
exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit
exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal"
@@ -501,7 +502,6 @@ exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression"
exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs
exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e
exprCtOrigin (HsDo {}) = DoOrigin
-exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list"
exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction"
exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update"
exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index 80f3a477dd..84e28a75e8 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -12,7 +12,8 @@
module GHC.Tc.Utils.Instantiate (
topSkolemise,
- topInstantiate, instantiateSigma,
+ topInstantiate,
+ instantiateSigma,
instCall, instDFunType, instStupidTheta, instTyVarsWith,
newWanted, newWanteds,
@@ -189,25 +190,25 @@ topSkolemise ty
= return (wrap, tv_prs, ev_vars, substTy subst ty)
-- substTy is a quick no-op on an empty substitution
--- | Instantiate all outer type variables
--- and any context. Never looks through arrows.
-topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
--- if topInstantiate ty = (wrap, rho)
--- and e :: ty
--- then wrap e :: rho (that is, wrap :: ty "->" rho)
--- NB: always returns a rho-type, with no top-level forall or (=>)
-topInstantiate orig ty
- | (tvs, theta, body) <- tcSplitSigmaTy ty
+topInstantiate ::CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+-- Instantiate outer invisible binders (both Inferred and Specified)
+-- If top_instantiate ty = (wrap, inner_ty)
+-- then wrap :: inner_ty "->" ty
+-- NB: returns a type with no (=>),
+-- and no invisible forall at the top
+topInstantiate orig sigma
+ | (tvs, body1) <- tcSplitSomeForAllTyVars isInvisibleArgFlag sigma
+ , (theta, body2) <- tcSplitPhiTy body1
, not (null tvs && null theta)
- = do { (_, wrap1, body1) <- instantiateSigma orig tvs theta body
+ = do { (_, wrap1, body3) <- instantiateSigma orig tvs theta body2
-- Loop, to account for types like
-- forall a. Num a => forall b. Ord b => ...
- ; (wrap2, rho) <- topInstantiate orig body1
+ ; (wrap2, body4) <- topInstantiate orig body3
- ; return (wrap2 <.> wrap1, rho) }
+ ; return (wrap2 <.> wrap1, body4) }
- | otherwise = return (idHsWrapper, ty)
+ | otherwise = return (idHsWrapper, sigma)
instantiateSigma :: CtOrigin -> [TyVar] -> TcThetaType -> TcSigmaType
-> TcM ([TcTyVar], HsWrapper, TcSigmaType)
@@ -658,34 +659,18 @@ cases (the rest are caught in lookupInst).
newOverloadedLit :: HsOverLit GhcRn
-> ExpRhoType
-> TcM (HsOverLit GhcTc)
-newOverloadedLit
- lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty
- | not rebindable
- = do { res_ty <- expTypeToType res_ty
- ; dflags <- getDynFlags
- ; let platform = targetPlatform dflags
- ; case shortCutLit platform val res_ty of
- -- Do not generate a LitInst for rebindable syntax.
- -- Reason: If we do, tcSimplify will call lookupInst, which
- -- will call tcSyntaxName, which does unification,
- -- which tcSimplify doesn't like
- Just expr -> return (lit { ol_witness = expr
- , ol_ext = OverLitTc False res_ty })
- Nothing -> newNonTrivialOverloadedLit orig lit
- (mkCheckExpType res_ty) }
-
- | otherwise
- = newNonTrivialOverloadedLit orig lit res_ty
- where
- orig = LiteralOrigin lit
+newOverloadedLit lit res_ty
+ = do { mb_lit' <- tcShortCutLit lit res_ty
+ ; case mb_lit' of
+ Just lit' -> return lit'
+ Nothing -> newNonTrivialOverloadedLit lit res_ty }
-- Does not handle things that 'shortCutLit' can handle. See also
-- newOverloadedLit in GHC.Tc.Utils.Unify
-newNonTrivialOverloadedLit :: CtOrigin
- -> HsOverLit GhcRn
+newNonTrivialOverloadedLit :: HsOverLit GhcRn
-> ExpRhoType
-> TcM (HsOverLit GhcTc)
-newNonTrivialOverloadedLit orig
+newNonTrivialOverloadedLit
lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)
, ol_ext = rebindable }) res_ty
= do { hs_lit <- mkOverLit val
@@ -697,7 +682,10 @@ newNonTrivialOverloadedLit orig
; res_ty <- readExpType res_ty
; return (lit { ol_witness = witness
, ol_ext = OverLitTc rebindable res_ty }) }
-newNonTrivialOverloadedLit _ lit _
+ where
+ orig = LiteralOrigin lit
+
+newNonTrivialOverloadedLit lit _
= pprPanic "newNonTrivialOverloadedLit" (ppr lit)
------------
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 0c276d9e16..493602fea0 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -896,19 +896,23 @@ getSrcSpanM :: TcRn SrcSpan
-- Avoid clash with Name.getSrcLoc
getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) }
--- See Note [Rebindable syntax and HsExpansion].
+-- See Note [Error contexts in generated code]
inGeneratedCode :: TcRn Bool
inGeneratedCode = tcl_in_gen_code <$> getLclEnv
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
-setSrcSpan (RealSrcSpan loc _) thing_inside =
- updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False })
- thing_inside
+-- See Note [Error contexts in generated code]
+-- for the tcl_in_gen_code manipulation
+setSrcSpan (RealSrcSpan loc _) thing_inside
+ = updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False })
+ thing_inside
+
setSrcSpan loc@(UnhelpfulSpan _) thing_inside
- -- See Note [Rebindable syntax and HsExpansion].
- | isGeneratedSrcSpan loc =
- updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside
- | otherwise = thing_inside
+ | isGeneratedSrcSpan loc
+ = updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside
+
+ | otherwise
+ = thing_inside
addLocM :: (a -> TcM b) -> Located a -> TcM b
addLocM fn (L loc a) = setSrcSpan loc $ fn a
@@ -1101,7 +1105,20 @@ is applied to four arguments. See #18379 for a concrete example.
This reliance on delicate inlining and Called Arity is not good.
See #18202 for a more general approach. But meanwhile, these
ininings seem unobjectional, and they solve the immediate
-problem. -}
+problem.
+
+Note [Error contexts in generated code]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* setSrcSpan sets tc_in_gen_code to True if the SrcSpan is GeneratedSrcSpan,
+ and back to False when we get a useful SrcSpan
+
+* When tc_in_gen_code is True, addErrCtxt becomes a no-op.
+
+So typically it's better to do setSrcSpan /before/ addErrCtxt.
+
+See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for
+more discussion of this fancy footwork.
+-}
getErrCtxt :: TcM [ErrCtxt]
getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
@@ -1119,7 +1136,7 @@ addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
-- | Add a message to the error context. This message may do tidying.
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
{-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt]
-addErrCtxtM ctxt m = updCtxt (push_ctxt (False, ctxt)) m
+addErrCtxtM ctxt = pushCtxt (False, ctxt)
-- | Add a fixed landmark message to the error context. A landmark
-- message is always sure to be reported, even if there is a lot of
@@ -1133,24 +1150,25 @@ addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
-- and tidying.
addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
{-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt]
-addLandmarkErrCtxtM ctxt m = updCtxt (push_ctxt (True, ctxt)) m
-
-push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, SDoc))
- -> Bool -> [ErrCtxt] -> [ErrCtxt]
-push_ctxt ctxt in_gen ctxts
- | in_gen = ctxts
- | otherwise = ctxt : ctxts
-
-updCtxt :: (Bool -> [ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
-{-# INLINE updCtxt #-} -- Note [Inlining addErrCtxt]
--- Helper function for the above
--- The Bool is true if we are in generated code
-updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt
- , tcl_in_gen_code = in_gen }) ->
- env { tcl_ctxt = upd in_gen ctxt })
+addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt)
+
+pushCtxt :: ErrCtxt -> TcM a -> TcM a
+{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]
+pushCtxt ctxt = updLclEnv (updCtxt ctxt)
+
+updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
+-- Do not update the context if we are in generated code
+-- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
+updCtxt ctxt env@(TcLclEnv { tcl_ctxt = ctxts, tcl_in_gen_code = in_gen })
+ | in_gen = env
+ | otherwise = env { tcl_ctxt = ctxt : ctxts }
popErrCtxt :: TcM a -> TcM a
-popErrCtxt = updCtxt (\ _ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
+popErrCtxt = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
+ env { tcl_ctxt = pop ctxt })
+ where
+ pop [] = []
+ pop (_:msgs) = msgs
getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM origin t_or_k
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 4fb5286c70..aad5299bbf 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -20,7 +20,7 @@ module GHC.Tc.Utils.Zonk (
-- * Other HsSyn functions
mkHsDictLet, mkHsApp,
mkHsAppTy, mkHsCaseAlt,
- shortCutLit, hsOverLitName,
+ tcShortCutLit, shortCutLit, hsOverLitName,
conLikeResTy,
-- * re-exported from TcMonad
@@ -90,6 +90,7 @@ import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Unique.FM
import GHC.Types.TyThing
+import GHC.Driver.Session( getDynFlags, targetPlatform )
import GHC.Data.Maybe
import GHC.Data.Bag
@@ -151,28 +152,75 @@ hsLitType (HsRat _ _ ty) = ty
hsLitType (HsFloatPrim _ _) = floatPrimTy
hsLitType (HsDoublePrim _ _) = doublePrimTy
+{- *********************************************************************
+* *
+ Short-cuts for overloaded numeric literals
+* *
+********************************************************************* -}
+
-- Overloaded literals. Here mainly because it uses isIntTy etc
+{- Note [Short cut for overloaded literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A literal like "3" means (fromInteger @ty (dNum :: Num ty) (3::Integer)).
+But if we have a list like
+ [4,2,3,2,4,4,2]::[Int]
+we use a lot of compile time and space generating and solving all those Num
+constraints, and generating calls to fromInteger etc. Better just to cut to
+the chase, and cough up an Int literal. Large collections of literals like this
+sometimes appear in source files, so it's quite a worthwhile fix.
+
+So we try to take advantage of whatever nearby type information we have,
+to short-cut the process for built-in types. We can do this in two places;
+
+* In the typechecker, when we are about to typecheck the literal.
+* If that fails, in the desugarer, once we know the final type.
+-}
+
+tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))
+tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = rebindable }) exp_res_ty
+ | not rebindable
+ , Just res_ty <- checkingExpType_maybe exp_res_ty
+ = do { dflags <- getDynFlags
+ ; let platform = targetPlatform dflags
+ ; case shortCutLit platform val res_ty of
+ Just expr -> return $ Just $
+ lit { ol_witness = expr
+ , ol_ext = OverLitTc False res_ty }
+ Nothing -> return Nothing }
+ | otherwise
+ = return Nothing
+
shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc)
-shortCutLit platform (HsIntegral int@(IL src neg i)) ty
- | isIntTy ty && platformInIntRange platform i = Just (HsLit noExtField (HsInt noExtField int))
- | isWordTy ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i))
- | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty))
- | otherwise = shortCutLit platform (HsFractional (integralFractionalLit neg i)) ty
+shortCutLit platform val res_ty
+ = case val of
+ HsIntegral int_lit -> go_integral int_lit
+ HsFractional frac_lit -> go_fractional frac_lit
+ HsIsString s src -> go_string s src
+ where
+ go_integral int@(IL src neg i)
+ | isIntTy res_ty && platformInIntRange platform i
+ = Just (HsLit noExtField (HsInt noExtField int))
+ | isWordTy res_ty && platformInWordRange platform i
+ = Just (mkLit wordDataCon (HsWordPrim src i))
+ | isIntegerTy res_ty
+ = Just (HsLit noExtField (HsInteger src i res_ty))
+ | otherwise
+ = go_fractional (integralFractionalLit neg i)
-- The 'otherwise' case is important
-- Consider (3 :: Float). Syntactically it looks like an IntLit,
-- so we'll call shortCutIntLit, but of course it's a float
-- This can make a big difference for programs with a lot of
-- literals, compiled without -O
-shortCutLit _ (HsFractional f) ty
- | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f))
- | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f))
- | otherwise = Nothing
+ go_fractional f
+ | isFloatTy res_ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f))
+ | isDoubleTy res_ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f))
+ | otherwise = Nothing
-shortCutLit _ (HsIsString src s) ty
- | isStringTy ty = Just (HsLit noExtField (HsString src s))
- | otherwise = Nothing
+ go_string src s
+ | isStringTy res_ty = Just (HsLit noExtField (HsString src s))
+ | otherwise = Nothing
mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit)
@@ -881,13 +929,10 @@ zonkExpr env (HsDo ty do_or_lc (L l stmts))
new_ty <- zonkTcTypeToTypeX env ty
return (HsDo new_ty do_or_lc (L l new_stmts))
-zonkExpr env (ExplicitList ty wit exprs)
- = do (env1, new_wit) <- zonkWit env wit
- new_ty <- zonkTcTypeToTypeX env1 ty
- new_exprs <- zonkLExprs env1 exprs
- return (ExplicitList new_ty new_wit new_exprs)
- where zonkWit env Nothing = return (env, Nothing)
- zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
+zonkExpr env (ExplicitList ty exprs)
+ = do new_ty <- zonkTcTypeToTypeX env ty
+ new_exprs <- zonkLExprs env exprs
+ return (ExplicitList new_ty new_exprs)
zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds })
= do { new_con_expr <- zonkExpr env con_expr
View Lorry Controller Status