Commit b8c29bc9 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Use the correct origin in SectionL and Section R

This fixes Trac #13285.

The CallStack stuff is all driven by a CtOrigin of (OccurenceOf f),
and we were instead using SectionOrigin.  Boo!

Easily fixed; and I did a little refactoring as usual.
parent 6bab649b
......@@ -148,7 +148,7 @@ tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
tcInferRhoNC expr
= do { (expr', sigma) <- tcInferSigmaNC expr
; (wrap, rho) <- topInstantiate (exprCtOrigin (unLoc expr)) sigma
; (wrap, rho) <- topInstantiate (lexprCtOrigin expr) sigma
; return (mkLHsWrap wrap expr', rho) }
......@@ -364,7 +364,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
; (arg1', arg1_ty) <- tcInferSigma arg1
; let doc = text "The first argument of ($) takes"
orig1 = exprCtOrigin (unLoc arg1)
orig1 = lexprCtOrigin arg1
; (wrap_arg1, [arg2_sigma], op_res_ty) <-
matchActualFunTys doc orig1 (Just arg1) 1 arg1_ty
......@@ -429,13 +429,18 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
tcExpr expr@(SectionR op arg2) res_ty
= do { (op', op_ty) <- tcInferFun op
; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) <-
matchActualFunTys (mk_op_msg op) SectionOrigin (Just op) 2 op_ty
; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)
<- matchActualFunTys (mk_op_msg op) fn_orig (Just op) 2 op_ty
; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
(mkFunTy arg1_ty op_res_ty) res_ty
; arg2' <- tcArg op arg2 arg2_ty 2
; return ( mkHsWrap wrap_res $
SectionR (mkLHsWrap wrap_fun op') arg2' ) }
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 Trac #13285
tcExpr expr@(SectionL arg1 op) res_ty
= do { (op', op_ty) <- tcInferFun op
......@@ -444,13 +449,18 @@ tcExpr expr@(SectionL arg1 op) res_ty
| otherwise = 2
; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
<- matchActualFunTys (mk_op_msg op) SectionOrigin (Just op)
<- matchActualFunTys (mk_op_msg op) fn_orig (Just op)
n_reqd_args op_ty
; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
(mkFunTys arg_tys op_res_ty) res_ty
; arg1' <- tcArg op arg1 arg1_ty 1
; return ( mkHsWrap wrap_res $
SectionL arg1' (mkLHsWrap wrap_fn op') ) }
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 Trac #13285
tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
| all tupArgPresent tup_args
......@@ -1152,7 +1162,7 @@ tcApp m_herald orig_fun orig_args res_ty
go fun args
= do { -- Type-check the function
; (fun1, fun_sigma) <- tcInferFun fun
; let orig = exprCtOrigin (unLoc fun)
; let orig = lexprCtOrigin fun
; (wrap_fun, args1, actual_res_ty)
<- tcArgs fun fun_sigma orig args
......
......@@ -408,7 +408,7 @@ tcGuardStmt _ (BodyStmt guard _ _ _) res_ty thing_inside
tcGuardStmt ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferSigmaNC rhs
-- Stmt has a context already
; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (exprCtOrigin (unLoc rhs))
; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
pat (mkCheckExpType rhs_ty) $
thing_inside res_ty
; return (mkTcBindStmt pat' rhs', thing) }
......
......@@ -378,7 +378,7 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
; (expr',expr'_inferred) <- tcInferSigma expr
-- expression must be a function
; let expr_orig = exprCtOrigin (unLoc expr)
; let expr_orig = lexprCtOrigin expr
herald = text "A view pattern expression expects"
; (expr_wrap1, [inf_arg_ty], inf_res_ty)
<- matchActualFunTys herald expr_orig (Just expr) 1 expr'_inferred
......
......@@ -2107,7 +2107,7 @@ tcRnExpr hsc_env mode rdr_expr
-- it might have a rank-2 type (e.g. :t runST)
uniq <- newUnique ;
let { fresh_it = itName uniq (getLoc rdr_expr)
; orig = exprCtOrigin (unLoc rn_expr) } ;
; orig = lexprCtOrigin rn_expr } ;
(tclvl, lie, res_ty)
<- pushLevelAndCaptureConstraints $
do { (_tc_expr, expr_ty) <- tcInferSigma rn_expr
......
......@@ -94,7 +94,7 @@ module TcRnTypes(
ctLocTypeOrKind_maybe,
ctLocDepth, bumpCtLocDepth,
setCtLocOrigin, setCtLocEnv, setCtLocSpan,
CtOrigin(..), exprCtOrigin, matchesCtOrigin, grhssCtOrigin,
CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
ErrorThing(..), mkErrorThing, errorThingNumArgs_maybe,
TypeOrKind(..), isTypeLevel, isKindLevel,
pprCtOrigin, pprCtLoc,
......@@ -3097,6 +3097,9 @@ ctoHerald :: SDoc
ctoHerald = text "arising from"
-- | Extract a suitable CtOrigin from a HsExpr
lexprCtOrigin :: LHsExpr Name -> CtOrigin
lexprCtOrigin (L _ e) = exprCtOrigin e
exprCtOrigin :: HsExpr Name -> CtOrigin
exprCtOrigin (HsVar (L _ name)) = OccurrenceOf name
exprCtOrigin (HsUnboundVar uv) = UnboundOccurrenceOf (unboundVarOcc uv)
......@@ -3108,12 +3111,12 @@ exprCtOrigin (HsOverLit lit) = LiteralOrigin lit
exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal"
exprCtOrigin (HsLam matches) = matchesCtOrigin matches
exprCtOrigin (HsLamCase ms) = matchesCtOrigin ms
exprCtOrigin (HsApp (L _ e1) _) = exprCtOrigin e1
exprCtOrigin (HsAppType (L _ e1) _) = exprCtOrigin e1
exprCtOrigin (HsAppTypeOut {}) = panic "exprCtOrigin HsAppTypeOut"
exprCtOrigin (OpApp _ (L _ op) _ _) = exprCtOrigin op
exprCtOrigin (NegApp (L _ e) _) = exprCtOrigin e
exprCtOrigin (HsPar (L _ e)) = exprCtOrigin e
exprCtOrigin (HsApp e1 _) = lexprCtOrigin e1
exprCtOrigin (HsAppType e1 _) = lexprCtOrigin e1
exprCtOrigin (HsAppTypeOut {}) = panic "exprCtOrigin HsAppTypeOut"
exprCtOrigin (OpApp _ op _ _) = lexprCtOrigin op
exprCtOrigin (NegApp e _) = lexprCtOrigin e
exprCtOrigin (HsPar e) = lexprCtOrigin e
exprCtOrigin (SectionL _ _) = SectionOrigin
exprCtOrigin (SectionR _ _) = SectionOrigin
exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"
......@@ -3122,7 +3125,7 @@ exprCtOrigin (HsCase _ matches) = matchesCtOrigin matches
exprCtOrigin (HsIf (Just syn) _ _ _) = exprCtOrigin (syn_expr syn)
exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression"
exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs
exprCtOrigin (HsLet _ (L _ e)) = exprCtOrigin e
exprCtOrigin (HsLet _ e) = lexprCtOrigin e
exprCtOrigin (HsDo _ _ _) = DoOrigin
exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list"
exprCtOrigin (ExplicitPArr {}) = Shouldn'tHappenOrigin "parallel array"
......@@ -3132,8 +3135,8 @@ exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin
exprCtOrigin (ExprWithTySigOut {}) = panic "exprCtOrigin ExprWithTySigOut"
exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence"
exprCtOrigin (PArrSeq {}) = Shouldn'tHappenOrigin "parallel array sequence"
exprCtOrigin (HsSCC _ _ (L _ e))= exprCtOrigin e
exprCtOrigin (HsCoreAnn _ _ (L _ e)) = exprCtOrigin e
exprCtOrigin (HsSCC _ _ e) = lexprCtOrigin e
exprCtOrigin (HsCoreAnn _ _ e) = lexprCtOrigin e
exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket"
exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut"
exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut"
......@@ -3142,9 +3145,9 @@ exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (HsArrApp {}) = panic "exprCtOrigin HsArrApp"
exprCtOrigin (HsArrForm {}) = panic "exprCtOrigin HsArrForm"
exprCtOrigin (HsTick _ (L _ e)) = exprCtOrigin e
exprCtOrigin (HsBinTick _ _ (L _ e)) = exprCtOrigin e
exprCtOrigin (HsTickPragma _ _ _ (L _ e)) = exprCtOrigin e
exprCtOrigin (HsTick _ e) = lexprCtOrigin e
exprCtOrigin (HsBinTick _ _ e) = lexprCtOrigin e
exprCtOrigin (HsTickPragma _ _ _ e) = lexprCtOrigin e
exprCtOrigin EWildPat = panic "exprCtOrigin EWildPat"
exprCtOrigin (EAsPat {}) = panic "exprCtOrigin EAsPat"
exprCtOrigin (EViewPat {}) = panic "exprCtOrigin EViewPat"
......
module Main where
-- Main.hs
import GHC.Stack
main :: IO ()
main = do
foo 23 42
(`foo` 23) 42
foo :: HasCallStack => Int -> Int -> IO ()
foo _ _ = print (length . getCallStack $ callStack)
......@@ -60,3 +60,4 @@ test('T11572', exit_code(1), compile_and_run, [''])
test('T11601', exit_code(1), compile_and_run, [''])
test('T11747', normal, compile_and_run, ['-dcore-lint'])
test('T12595', normal, compile_and_run, [''])
test('T13285', normal, compile_and_run, [''])
......@@ -13,7 +13,7 @@ T2245.hs:5:10: warning: [-Wmissing-methods (in -Wdefault)]
T2245.hs:7:27: warning: [-Wtype-defaults (in -Wall)]
• Defaulting the following constraints to type ‘T’
(Ord a0) arising from an operator section at T2245.hs:7:27-33
(Ord a0) arising from a use of ‘<’ at T2245.hs:7:27-33
(Fractional a0)
arising from the literal ‘1e400’ at T2245.hs:7:29-33
(Read a0) arising from a use of ‘read’ at T2245.hs:7:38-41
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment