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

Commits:

9 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/Errors.hs
    ... ... @@ -26,10 +26,6 @@ import GHC.Driver.Config.Diagnostic
    26 26
    27 27 
     import GHC.Rename.Unbound
    28 28
    29 
    -import Language.Haskell.Syntax (DotFieldOcc (..))
    30 
    -import Language.Haskell.Syntax.Basic (FieldLabelString (..))
    31 
    -import GHC.Hs.Expr (SrcCodeOrigin (..), HsExpr (..))
    32 
    -
    33 29 
     import GHC.Tc.Types
    34 30 
     import GHC.Tc.Utils.Monad
    35 31 
     import GHC.Tc.Errors.Types
    ... ... @@ -2394,43 +2390,6 @@ mk_dict_err ctxt (item, (matches, pot_unifiers, unsafe_overlapped))
    2394 2390 
             in different_names && same_occ_names
    2395 2391 
           | otherwise = False
    2396 2392
    2397 
    -    -- See Note [Out-of-scope fields with -XOverloadedRecordDot]
    2398 
    -    record_field_suggestions :: ErrorItem -> TcM ([ImportError], [GhcHint])
    2399 
    -    record_field_suggestions item = flip (maybe $ return ([], noHints)) record_field $ \name ->
    2400 
    -       do { glb_env <- getGlobalRdrEnv
    2401 
    -          ; lcl_env <- getLocalRdrEnv
    2402 
    -          ; let field_name_hints = report_no_fieldnames item
    2403 
    -          ; (errs, hints) <- if occ_name_in_scope glb_env lcl_env name
    2404 
    -              then return ([], noHints)
    2405 
    -              else unknownNameSuggestions emptyLocalRdrEnv WL_RecField (mkRdrUnqual name)
    2406 
    -          ; pure (errs, hints ++ field_name_hints)
    2407 
    -          }
    2408 
    -
    2409 
    -    -- get type names from instance
    2410 
    -    -- resolve the type - if it's in scope is it a record?
    2411 
    -    -- if it's a record, report an error - the record name + the field that could not be found
    2412 
    -    report_no_fieldnames :: ErrorItem -> [GhcHint]
    2413 
    -    report_no_fieldnames item
    2414 
    -       | Just (EvVarDest evvar) <- ei_evdest item
    2415 
    -       -- we can assume that here we have a `HasField @Symbol x r a` instance
    2416 
    -       -- because of GetFieldOrigin in record_field
    2417 
    -       , Just (_, [_symbol, x, r, a]) <- tcSplitTyConApp_maybe (varType evvar)
    2418 
    -       , Just (r_tycon, _) <- tcSplitTyConApp_maybe r
    2419 
    -       , Just x_name <- isStrLitTy x
    2420 
    -       -- we check that this is a record type by checking whether it has any
    2421 
    -       -- fields (in scope)
    2422 
    -       , not . null $ tyConFieldLabels r_tycon
    2423 
    -       = [RemindRecordMissingField x_name r a]
    2424 
    -       | otherwise = []
    2425 
    -
    2426 
    -    occ_name_in_scope glb_env lcl_env occ_name = not $
    2427 
    -      null (lookupGRE glb_env (LookupOccName occ_name (RelevantGREsFOS WantNormal))) &&
    2428 
    -      isNothing (lookupLocalRdrOcc lcl_env occ_name)
    2429 
    -
    2430 
    -    record_field = case orig of
    2431 
    -      ExpansionOrigin (OrigExpr (HsGetField _ _ (L _ name))) -> Just (mkVarOccFS (field_label $ unLoc $ dfoLabel name))
    2432 
    -      _                   -> Nothing
    2433 
    -
    2434 2393 
     {- Note [Report candidate instances]
    2435 2394 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    2436 2395 
     If we have an unsolved (Num Int), where `Int` is not the Prelude Int,

  • 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,17 @@ 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
    1112 
    +      -- We don't want to say 'In the expression (e)',
    1113 
    +      -- we just want to say 'In the expression, 'e'
    1114 
    +      -- which will be handeled by the recursive call in thing_inside
    1115 
    +      XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) thing_inside
    1113 1116 
           _ -> addErrCtxt (ExprCtxt e) thing_inside -- no op in generated code
    1117 
    +
    1118 
    +
    1119 
    +addLExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a
    1120 
    +addLExprCtxt (L lspan e) thing_inside
    1121 
    +  | (RealSrcSpan{}) <- locA lspan
    1122 
    +  = addExprCtxt e thing_inside
    1123 
    +  | otherwise
    1124 
    +  = 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

  • compiler/GHC/Tc/Types/Origin.hs
    ... ... @@ -837,7 +837,7 @@ exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e)
    837 837 
     exprCtOrigin e@(RecordUpd{})      = ExpansionOrigin (OrigExpr e)
    838 838 
     exprCtOrigin e@(HsGetField{})     = ExpansionOrigin (OrigExpr e)
    839 839 
     exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o
    840 
    -exprCtOrigin (XExpr (HsRecSelRn f))  = OccurrenceOfRecSel (foExt f)
    840 
    +exprCtOrigin (XExpr (HsRecSelRn f))  = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f)
    841 841
    842 842 
     srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe SrcCodeOrigin -> CtOrigin
    843 843 
     srcCodeOriginCtOrigin e Nothing = exprCtOrigin e

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