Apoorv Ingle pushed to branch wip/ani/kill-popErrCtxt at Glasgow Haskell Compiler / GHC

Commits:

7 changed files:

Changes:

  • compiler/GHC/Hs/Expr.hs
    ... ... @@ -681,6 +681,7 @@ data SrcCodeOrigin
    681 681 
                    -- Does not presist post renaming phase
    682 682 
                    -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]
    683 683 
                    -- in `GHC.Tc.Gen.Do`
    684 
    +               -- INVARIANT: SHOULD NEVER APPEAR IN A ExpansionCodeCtxt in CodeSrcFlag ErrCtxt on stack
    684 685
    685 686 
     data XXExprGhcRn
    686 687 
       = ExpandedThingRn { xrn_orig     :: SrcCodeOrigin   -- The original source thing to be used for error messages

  • compiler/GHC/Tc/Gen/App.hs
    ... ... @@ -32,7 +32,7 @@ import GHC.Tc.Gen.HsType
    32 32 
     import GHC.Tc.Utils.Concrete  ( unifyConcrete, idConcreteTvs )
    33 33 
     import GHC.Tc.Utils.TcMType
    34 34 
     import GHC.Tc.Types.Evidence
    35 
    -import GHC.Tc.Types.ErrCtxt ( FunAppCtxtFunArg(..), ErrCtxt (..) )
    35 
    +import GHC.Tc.Types.ErrCtxt ( FunAppCtxtFunArg(..), ErrCtxt (..),  CodeSrcFlag (..))
    36 36 
     import GHC.Tc.Errors.Ppr (pprErrCtxtMsg)
    37 37 
     import GHC.Tc.Types.Origin
    38 38 
     import GHC.Tc.Utils.TcType as TcType
    ... ... @@ -951,28 +951,23 @@ addArgCtxt arg_no fun (L arg_loc arg) thing_inside
    951 951 
                                         , text "arg: " <+> ppr (arg, arg_no)
    952 952 
                                         , text "arg_loc:" <+> ppr arg_loc
    953 953 
                                         , text "fun:" <+> ppr fun
    954 
    -                                    -- , text "err_ctx" <+> vcat (fmap (\ (x, y) -> case x of
    955 
    -                                    --                                     UserCodeCtxt{} -> text "<USER>" <+> pprErrCtxtMsg y
    956 
    -                                    --                                     ExpansionCodeCtxt{} -> text "<EXPN>" <+> pprErrCtxtMsg y)
    957 
    -                                    --                            (take 4 (zip err_ctx err_ctx_msg)))
    954 
    +                                    , text "err_ctx" <+> vcat (fmap (\ (x, y) -> case x of
    955 
    +                                                                        MkErrCtxt (ExpansionCodeCtxt{}) _ -> text "<EXPN>" <+> pprErrCtxtMsg y
    956 
    +                                                                        _ -> text "<USER>" <+> pprErrCtxtMsg y)
    957 
    +                                                               (take 4 (zip err_ctx err_ctx_msg)))
    958 958 
                                         ])
    959 959 
            ; if in_generated_code
    960 
    -         then updCtxtForArg (locA arg_loc) arg $
    960 
    +         then updCtxtForArg (L arg_loc arg) $
    961 961 
                        thing_inside
    962 962 
              else do setSrcSpanA arg_loc                    $
    963 963 
                        addErrCtxt (FunAppCtxt (FunAppCtxtExpr fun arg) arg_no) $
    964 964 
                        thing_inside }
    965 965 
       where
    966 
    -    updCtxtForArg :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a
    967 
    -    updCtxtForArg l@(RealSrcSpan{}) e thing_inside = -- See 2.iii above
    968 
    -      do setSrcSpan l $
    969 
    -           addExprCtxt e $
    970 
    -           thing_inside
    971 
    -    -- updCtxtForArg (UnhelpfulSpan UnhelpfulGenerated) _ thing_inside = -- See 2.i above
    972 
    -    --   thing_inside
    973 
    -    updCtxtForArg (UnhelpfulSpan {}) _ thing_inside = -- See 2.ii above
    974 
    -      do -- setInUserCode $
    975 
    -           thing_inside
    966 
    +    updCtxtForArg :: LHsExpr GhcRn -> TcRn a -> TcRn a
    967 
    +    updCtxtForArg e@(L lspan _) thing_inside
    968 
    +      = do setSrcSpan (locA lspan) $
    969 
    +             addLExprCtxt e $ -- addLExpr is no op for non-user located exprs
    970 
    +             thing_inside
    976 971
    977 972
    978 973

  • compiler/GHC/Tc/Gen/Do.hs
    ... ... @@ -126,7 +126,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _))
    126 126 
     --      e ; stmts ~~> (>>) e stmts'
    127 127 
       do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
    128 128 
          let expansion = genHsExpApps then_op  -- (>>)
    129 
    -                     [ e -- Span is set because of statement loc
    129 
    +                     [ e
    130 130 
                          , expand_stmts_expr ]
    131 131 
          return $ L loc (mkExpandedStmt stmt doFlavour expansion)
    132 132

  • compiler/GHC/Tc/Gen/Expr.hs
    ... ... @@ -54,7 +54,6 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep
    54 54 
     import GHC.Tc.Utils.Instantiate
    55 55 
     import GHC.Tc.Utils.Env
    56 56 
     import GHC.Tc.Types.Origin
    57 
    -import GHC.Tc.Types.ErrCtxt ( srcCodeOriginErrCtxMsg )
    58 57 
     import GHC.Tc.Types.Evidence
    59 58 
     import GHC.Tc.Errors.Types hiding (HoleError)
    60 59
    ... ... @@ -125,7 +124,7 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
    125 124
    126 125 
     tcPolyLExpr (L loc expr) res_ty
    127 126 
       = setSrcSpanA loc  $  -- Set location /first/; see GHC.Tc.Utils.Monad
    128 
    -    addExprCtxt expr $  -- Note [Error contexts in generated code]
    127 
    +    addLExprCtxt (L loc expr) $  -- Note [Error contexts in generated code]
    129 128 
         do { expr' <- tcPolyExpr expr res_ty
    130 129 
            ; return (L loc expr') }
    131 130
    ... ... @@ -244,7 +243,7 @@ tcInferRhoNC = tcInferExprNC IIF_DeepRho
    244 243 
     tcInferExpr, tcInferExprNC :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
    245 244 
     tcInferExpr iif (L loc expr)
    246 245 
       = setSrcSpanA loc  $  -- Set location /first/; see GHC.Tc.Utils.Monad
    247 
    -    addExprCtxt expr $  -- Note [Error contexts in generated code]
    246 
    +    addLExprCtxt (L loc expr) $  -- Note [Error contexts in generated code]
    248 247 
         do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr)
    249 248 
            ; return (L loc expr', rho) }
    250 249
    ... ... @@ -271,7 +270,7 @@ tcMonoLExpr, tcMonoLExprNC
    271 270
    272 271 
     tcMonoLExpr (L loc expr) res_ty
    273 272 
       = setSrcSpanA loc   $  -- Set location /first/; see GHC.Tc.Utils.Monad
    274 
    -    addExprCtxt expr $  -- Note [Error contexts in generated code]
    273 
    +    addLExprCtxt (L loc expr) $  -- Note [Error contexts in generated code]
    275 274 
         do  { expr' <- tcExpr expr res_ty
    276 275 
             ; return (L loc expr') }
    277 276
    ... ... @@ -757,11 +756,8 @@ tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
    757 756
    758 757 
     tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
    759 758 
     tcXExpr (ExpandedThingRn o e) res_ty
    760 
    -   = addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $
    761 
    -     -- e is the expanded expression of o, so we need to set the error ctxt to generated
    762 
    -     -- see Note [Error Context Stack] in `GHC.Tc.Type.LclEnv`
    763 
    -        mkExpandedTc o <$> -- necessary for hpc ticks
    764 
    -          tcExpr e res_ty
    759 
    +   = mkExpandedTc o <$> -- necessary for hpc ticks
    760 
    +         tcExpr e res_ty
    765 761
    766 762 
     -- For record selection, same as HsVar case
    767 763 
     tcXExpr xe res_ty = tcApp (XExpr xe) res_ty

  • compiler/GHC/Tc/Gen/Head.hs
    ... ... @@ -26,7 +26,7 @@ module GHC.Tc.Gen.Head
    26 26 
            , nonBidirectionalErr
    27 27
    28 28 
            , pprArgInst
    29 
    -       , addExprCtxt, addFunResCtxt ) where
    29 
    +       , addExprCtxt, addLExprCtxt, addFunResCtxt ) where
    30 30
    31 31 
     import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig )
    32 32 
     import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody )
    ... ... @@ -1108,6 +1108,29 @@ addExprCtxt e thing_inside
    1108 1108 
        --    f x = _
    1109 1109 
        -- when we don't want to say "In the expression: _",
    1110 1110 
        -- because it is mentioned in the error message itself
    1111 
    -      XExpr{} -> thing_inside -- the err ctxt management done is done by setInGeneratedCode
    1112 
    -      HsPar{} -> thing_inside -- the err ctxt management done is done by setInGeneratedCode
    1111 
    +      HsPar{} -> thing_inside -- We don't want to say 'In the expression (e)', we just want to say 'In the expression, 'e'. which will be handeled by the recursive call in thing_inside
    1112 
    +      XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) thing_inside
    1113 1113 
           _ -> addErrCtxt (ExprCtxt e) thing_inside -- no op in generated code
    1114 
    +
    1115 
    +
    1116 
    +addLExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a
    1117 
    +addLExprCtxt (L lspan e) thing_inside
    1118 
    +  | (RealSrcSpan{}) <- locA lspan
    1119 
    +  = case e of
    1120 
    +      HsHole _
    1121 
    +   -- The HsHole special case addresses situations like
    1122 
    +   --    f x = _
    1123 
    +   -- when we don't want to say "In the expression: _",
    1124 
    +   -- because it is mentioned in the error message itself
    1125 
    +        -> thing_inside
    1126 
    +      HsPar{}
    1127 
    +      -- We don't want to say 'In the expression (e)',
    1128 
    +      -- we just want to say 'In the expression, 'e'.
    1129 
    +      -- which will be adeed by the recursive call in thing_inside
    1130 
    +        -> thing_inside
    1131 
    +      XExpr (ExpandedThingRn o _)
    1132 
    +        -> addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) thing_inside
    1133 
    +      _
    1134 
    +        -> addErrCtxt (ExprCtxt e) thing_inside -- no op in generated code
    1135 
    +  | otherwise
    1136 
    +  = thing_inside

  • compiler/GHC/Tc/Types/ErrCtxt.hs
    ... ... @@ -63,6 +63,7 @@ data ErrCtxt = MkErrCtxt CodeSrcFlag ErrCtxtMsgM
    63 63 
     data CodeSrcFlag = VanillaUserSrcCode
    64 64 
                      | LandmarkUserSrcCode
    65 65 
                      | ExpansionCodeCtxt SrcCodeOrigin
    66 
    +                   -- INVARIANT: SHOULD NEVER APPEAR IN A ExpansionCodeCtxt in CodeSrcFlag ErrCtxt on stack
    66 67
    67 68 
     --------------------------------------------------------------------------------
    68 69 
     -- Error message contexts

  • compiler/GHC/Tc/Types/LclEnv.hs
    ... ... @@ -196,10 +196,7 @@ setLclEnvErrCtxt :: ErrCtxtStack -> TcLclEnv -> TcLclEnv
    196 196 
     setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_err_ctxt = ctxt })
    197 197
    198 198 
     addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
    199 
    -addLclEnvErrCtxt ec@(MkErrCtxt (ExpansionCodeCtxt _) _) = setLclEnvSrcCodeOrigin ec
    200 
    -addLclEnvErrCtxt ec = modifyLclCtxt (\env -> if lclCtxtInGeneratedCode env
    201 
    -                                             then env -- no op if we are in generated code
    202 
    -                                             else env { tcl_err_ctxt =  ec : (tcl_err_ctxt env) })
    199 
    +addLclEnvErrCtxt ec = setLclEnvSrcCodeOrigin ec
    203 200
    204 201 
     getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe SrcCodeOrigin
    205 202 
     getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_err_ctxt . tcl_lcl_ctxt

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help