summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
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