Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • compiler/GHC/Hs.hs
    ... ... @@ -38,8 +38,6 @@ module GHC.Hs (
    38 38 
             HsModule(..), AnnsModule(..),
    39 39 
             HsParsedModule(..), XModulePs(..),
    40 40
    41 
    -        SrcCodeCtxt(..), isUserCodeCtxt, isGeneratedCodeCtxt
    42 
    -
    43 41 
     ) where
    44 42
    45 43 
     -- friends:
    ... ... @@ -149,17 +147,3 @@ data HsParsedModule = HsParsedModule {
    149 147 
            -- the .hi file, so that we can force recompilation if any of
    150 148 
            -- them change (#3589)
    151 149 
       }
    152 
    -
    153 
    --- Used in TcLclCtxt.tcl_in_gen_code to mark if the current expression
    154 
    --- is a user generated code or a compiler generated expansion of some user written code
    155 
    -data SrcCodeCtxt
    156 
    -  = UserCode
    157 
    -  | GeneratedCode SrcCodeOrigin
    158 
    -
    159 
    -isUserCodeCtxt :: SrcCodeCtxt -> Bool
    160 
    -isUserCodeCtxt UserCode = True
    161 
    -isUserCodeCtxt _ = False
    162 
    -
    163 
    -isGeneratedCodeCtxt :: SrcCodeCtxt -> Bool
    164 
    -isGeneratedCodeCtxt UserCode = False
    165 
    -isGeneratedCodeCtxt _ = True

  • compiler/GHC/Tc/Gen/App.hs
    ... ... @@ -189,8 +189,8 @@ tcExprSigma inst rn_expr
    189 189 
       = do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr
    190 190 
            ; do_ql <- wantQuickLook rn_fun
    191 191 
            ; (tc_fun, fun_sigma) <- tcInferAppHead fun
    192 
    -       ; code_ctxt <- getSrcCodeCtxt
    193 
    -       ; let fun_orig = srcCodeCtxtCtOrigin rn_expr code_ctxt
    192 
    +       ; code_orig <- getSrcCodeOrigin
    193 
    +       ; let fun_orig = srcCodeOriginCtOrigin rn_expr code_orig
    194 194 
            ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args
    195 195 
            ; tc_args <- tcValArgs do_ql rn_fun inst_args
    196 196 
            ; let tc_expr = rebuildHsApps (tc_fun, fun_ctxt) tc_args
    ... ... @@ -417,8 +417,8 @@ tcApp rn_expr exp_res_ty
    417 417 
            ; let tc_head = (tc_fun, fun_loc)
    418 418 
            -- Step 3: Instantiate the function type (taking a quick look at args)
    419 419 
            ; do_ql <- wantQuickLook rn_fun
    420 
    -       ; code_ctxt <- getSrcCodeCtxt
    421 
    -       ; let fun_orig = srcCodeCtxtCtOrigin rn_fun code_ctxt
    420 
    +       ; code_orig <- getSrcCodeOrigin
    421 
    +       ; let fun_orig = srcCodeOriginCtOrigin rn_fun code_orig
    422 422 
            ; traceTc "tcApp:inferAppHead" $
    423 423 
              vcat [ text "tc_fun:" <+> ppr tc_fun
    424 424 
                   , text "fun_sigma:" <+> ppr fun_sigma
    ... ... @@ -857,8 +857,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args
    857 857 
         -- Rule IARG from Fig 4 of the QL paper:
    858 858 
         go1 pos acc fun_ty
    859 859 
             (EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args)
    860 
    -      = do { let herald | DoStmtOrigin <- fun_orig = ExpectedFunTySyntaxOp fun_orig tc_fun -- cf. RepPolyDoBind.hs
    861 
    -                        | otherwise = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
    860 
    +      = do { let herald = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
    862 861 
                ; (wrap, arg_ty, res_ty) <-
    863 862 
                     -- NB: matchActualFunTy does the rep-poly check.
    864 863 
                     -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int

  • compiler/GHC/Tc/Types/LclEnv.hs
    ... ... @@ -21,13 +21,14 @@ module GHC.Tc.Types.LclEnv (
    21 21 
       , setLclEnvTypeEnv
    22 22 
       , modifyLclEnvTcLevel
    23 23
    24 
    -  , getLclEnvSrcCodeCtxt
    25 
    -  , setLclEnvSrcCodeCtxt
    26 
    -  , setLclCtxtSrcCodeCtxt
    24 
    +  , getLclEnvSrcCodeOrigin
    25 
    +  , setLclEnvSrcCodeOrigin
    26 
    +  , setLclCtxtSrcCodeOrigin
    27 27 
       , lclEnvInGeneratedCode
    28 28
    29 29 
       , addLclEnvErrCtxt
    30 30
    31 
    +  , ErrCtxtStack (..)
    31 32 
       , ArrowCtxt(..)
    32 33 
       , ThBindEnv
    33 34 
       , TcTypeEnv
    ... ... @@ -35,7 +36,7 @@ module GHC.Tc.Types.LclEnv (
    35 36
    36 37 
     import GHC.Prelude
    37 38
    38 
    -import GHC.Hs ( SrcCodeCtxt (..), isGeneratedCodeCtxt )
    39 
    +import GHC.Hs ( SrcCodeOrigin )
    39 40 
     import GHC.Tc.Utils.TcType ( TcLevel )
    40 41 
     import GHC.Tc.Errors.Types ( TcRnMessage )
    41 42
    ... ... @@ -90,11 +91,29 @@ data TcLclEnv -- Changes as we move inside an expression
    90 91 
             tcl_errs :: TcRef (Messages TcRnMessage)     -- Place to accumulate diagnostics
    91 92 
         }
    92 93
    94 
    +
    95 
    +data ErrCtxtStack
    96 
    +  = UserCodeCtxt {err_ctxt :: [ErrCtxt]}
    97 
    +  | GeneratedCodeCtxt { src_code_origin :: SrcCodeOrigin
    98 
    +                      , err_ctxt ::  [ErrCtxt] }
    99 
    +
    100 
    +isGeneratedCodeCtxt :: ErrCtxtStack -> Bool
    101 
    +isGeneratedCodeCtxt UserCodeCtxt{} = False
    102 
    +isGeneratedCodeCtxt _ = True
    103 
    +
    104 
    +get_src_code_origin :: ErrCtxtStack -> Maybe SrcCodeOrigin
    105 
    +get_src_code_origin (UserCodeCtxt{}) = Nothing
    106 
    +get_src_code_origin es = Just $ src_code_origin es
    107 
    +
    108 
    +modify_err_ctxt_stack :: ([ErrCtxt] -> [ErrCtxt]) -> ErrCtxtStack -> ErrCtxtStack
    109 
    +modify_err_ctxt_stack f (UserCodeCtxt e) =  UserCodeCtxt (f e)
    110 
    +modify_err_ctxt_stack _ c = c -- any updates on the err context in generated context should be ignored
    111 
    +
    112 
    +
    93 113 
     data TcLclCtxt
    94 114 
       = TcLclCtxt {
    95 115 
             tcl_loc        :: RealSrcSpan,     -- Source span
    96 
    -        tcl_ctxt       :: [ErrCtxt],       -- Error context, innermost on top
    97 
    -        tcl_in_gen_code :: SrcCodeCtxt,
    116 
    +        tcl_ctxt       :: ErrCtxtStack,
    98 117 
             tcl_tclvl      :: TcLevel,
    99 118 
             tcl_bndrs      :: TcBinderStack,   -- Used for reporting relevant bindings,
    100 119 
                                                -- and for tidying type
    ... ... @@ -159,28 +178,28 @@ getLclEnvLoc :: TcLclEnv -> RealSrcSpan
    159 178 
     getLclEnvLoc = tcl_loc . tcl_lcl_ctxt
    160 179
    161 180 
     getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt]
    162 
    -getLclEnvErrCtxt = tcl_ctxt . tcl_lcl_ctxt
    181 
    +getLclEnvErrCtxt = err_ctxt . tcl_ctxt . tcl_lcl_ctxt
    163 182
    164 183 
     setLclEnvErrCtxt :: [ErrCtxt] -> TcLclEnv -> TcLclEnv
    165 
    -setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt })
    184 
    +setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ _ -> ctxt) (tcl_ctxt env) })
    166 185
    167 186 
     addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
    168 
    -addLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt : (tcl_ctxt env) })
    187 
    +addLclEnvErrCtxt ec = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ctxt -> ec : ctxt) (tcl_ctxt env) })
    169 188
    170 
    -getLclEnvSrcCodeCtxt :: TcLclEnv -> SrcCodeCtxt
    171 
    -getLclEnvSrcCodeCtxt = tcl_in_gen_code . tcl_lcl_ctxt
    189 
    +getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe SrcCodeOrigin
    190 
    +getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_ctxt . tcl_lcl_ctxt
    172 191
    173 
    -lclEnvInGeneratedCode :: TcLclEnv -> Bool
    174 
    -lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt
    192 
    +setLclEnvSrcCodeOrigin :: SrcCodeOrigin -> TcLclEnv -> TcLclEnv
    193 
    +setLclEnvSrcCodeOrigin o = modifyLclCtxt (setLclCtxtSrcCodeOrigin o)
    175 194
    176 
    -lclCtxtInGeneratedCode :: TcLclCtxt -> Bool
    177 
    -lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_in_gen_code
    195 
    +setLclCtxtSrcCodeOrigin :: SrcCodeOrigin -> TcLclCtxt -> TcLclCtxt
    196 
    +setLclCtxtSrcCodeOrigin o ctxt = ctxt { tcl_ctxt = GeneratedCodeCtxt o (err_ctxt $ tcl_ctxt ctxt) }
    178 197
    179 
    -setLclCtxtSrcCodeCtxt :: SrcCodeCtxt -> TcLclCtxt -> TcLclCtxt
    180 
    -setLclCtxtSrcCodeCtxt userOrGen env = env { tcl_in_gen_code = userOrGen }
    198 
    +lclCtxtInGeneratedCode :: TcLclCtxt -> Bool
    199 
    +lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_ctxt
    181 200
    182 
    -setLclEnvSrcCodeCtxt :: SrcCodeCtxt -> TcLclEnv -> TcLclEnv
    183 
    -setLclEnvSrcCodeCtxt userOrGen = modifyLclCtxt (\ctxt -> setLclCtxtSrcCodeCtxt userOrGen ctxt)
    201 
    +lclEnvInGeneratedCode :: TcLclEnv -> Bool
    202 
    +lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt
    184 203
    185 204 
     getLclEnvBinderStack :: TcLclEnv -> TcBinderStack
    186 205 
     getLclEnvBinderStack = tcl_bndrs . tcl_lcl_ctxt

  • compiler/GHC/Tc/Types/Origin.hs
    ... ... @@ -19,7 +19,7 @@ module GHC.Tc.Types.Origin (
    19 19
    20 20 
       -- * CtOrigin
    21 21 
       CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
    22 
    -  srcCodeCtxtCtOrigin,
    22 
    +  srcCodeOriginCtOrigin,
    23 23 
       isVisibleOrigin, toInvisibleOrigin,
    24 24 
       pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin,
    25 25 
       isWantedSuperclassOrigin,
    ... ... @@ -653,6 +653,7 @@ data CtOrigin
    653 653 
           Type   -- the instantiated type of the method
    654 654 
       | AmbiguityCheckOrigin UserTypeCtxt
    655 655 
       | ImplicitLiftOrigin HsImplicitLiftSplice
    656 
    +  | ExpansionOrigin SrcCodeOrigin -- This is due to an expansion of the original thing given by SrcCodeOrigin
    656 657
    657 658 
     data NonLinearPatternReason
    658 659 
       = LazyPatternReason
    ... ... @@ -764,18 +765,13 @@ exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression"
    764 765 
     exprCtOrigin (HsForAll {})       = Shouldn'tHappenOrigin "forall telescope"    -- See Note [Types in terms]
    765 766 
     exprCtOrigin (HsQual {})         = Shouldn'tHappenOrigin "constraint context"  -- See Note [Types in terms]
    766 767 
     exprCtOrigin (HsFunArr {})       = Shouldn'tHappenOrigin "function arrow"      -- See Note [Types in terms]
    767 
    -exprCtOrigin (XExpr (ExpandedThingRn o _)) = srcCodeOriginCtOrigin o
    768 
    +exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o
    768 769 
     exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e
    769 770 
     exprCtOrigin (XExpr (HsRecSelRn f))  = OccurrenceOfRecSel (foExt f)
    770 771
    771 
    -srcCodeOriginCtOrigin :: SrcCodeOrigin -> CtOrigin
    772 
    -srcCodeOriginCtOrigin (OrigExpr e) = exprCtOrigin e
    773 
    -srcCodeOriginCtOrigin (OrigStmt{}) = DoStmtOrigin
    774 
    -srcCodeOriginCtOrigin (OrigPat p) = DoPatOrigin p
    775 
    -
    776 
    -srcCodeCtxtCtOrigin :: HsExpr GhcRn -> SrcCodeCtxt -> CtOrigin
    777 
    -srcCodeCtxtCtOrigin e UserCode = exprCtOrigin e
    778 
    -srcCodeCtxtCtOrigin _ (GeneratedCode e) = srcCodeOriginCtOrigin e
    772 
    +srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe SrcCodeOrigin -> CtOrigin
    773 
    +srcCodeOriginCtOrigin e Nothing = exprCtOrigin e
    774 
    +srcCodeOriginCtOrigin _ (Just e) = ExpansionOrigin e
    779 775
    780 776 
     -- | Extract a suitable CtOrigin from a MatchGroup
    781 777 
     matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
    ... ... @@ -801,6 +797,14 @@ pprCtOrigin :: CtOrigin -> SDoc
    801 797 
     pprCtOrigin (GivenOrigin sk)
    802 798 
       = ctoHerald <+> ppr sk
    803 799
    800 
    +pprCtOrigin (ExpansionOrigin o)
    801 
    +  = ctoHerald <+> what
    802 
    +    where what :: SDoc
    803 
    +          what = case o of
    804 
    +                   OrigStmt{} -> text "a do statement"
    805 
    +                   OrigExpr e -> text "an expression" <+> ppr e
    806 
    +                   OrigPat p -> text "a pattern" <+> ppr p
    807 
    +
    804 808 
     pprCtOrigin (GivenSCOrigin sk d blk)
    805 809 
       = vcat [ ctoHerald <+> pprSkolInfo sk
    806 810 
              , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ]
    ... ... @@ -984,6 +988,10 @@ pprCtO (InstanceSigOrigin {}) = text "a type signature in an instance"
    984 988 
     pprCtO (AmbiguityCheckOrigin {})    = text "a type ambiguity check"
    985 989 
     pprCtO (ImpedanceMatching {})       = text "combining required constraints"
    986 990 
     pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)]
    991 
    +pprCtO (ExpansionOrigin (OrigPat p)) = hsep [text "a pattern" <+> quotes (ppr p)]
    992 
    +pprCtO (ExpansionOrigin (OrigStmt{})) = text "a do statement"
    993 
    +pprCtO (ExpansionOrigin (OrigExpr{})) = text "an expression"
    994 
    +
    987 995
    988 996 
     pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc
    989 997 
     pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear")

  • compiler/GHC/Tc/Utils/Monad.hs
    ... ... @@ -58,7 +58,7 @@ module GHC.Tc.Utils.Monad(
    58 58 
       addDependentFiles,
    59 59
    60 60 
       -- * Error management
    61 
    -  getSrcCodeCtxt,
    61 
    +  getSrcCodeOrigin,
    62 62 
       getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM,
    63 63 
       inGeneratedCode, setInGeneratedCode,
    64 64 
       wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
    ... ... @@ -400,8 +400,7 @@ initTcWithGbl hsc_env gbl_env loc do_this
    400 400 
                     tcl_lcl_ctxt   = TcLclCtxt {
    401 401 
                     tcl_loc        = loc,
    402 402 
                     -- tcl_loc should be over-ridden very soon!
    403 
    -                tcl_in_gen_code = UserCode,
    404 
    -                tcl_ctxt       = [],
    403 
    +                tcl_ctxt       = UserCodeCtxt [],
    405 404 
                     tcl_rdr        = emptyLocalRdrEnv,
    406 405 
                     tcl_th_ctxt    = topLevel,
    407 406 
                     tcl_th_bndrs   = emptyNameEnv,
    ... ... @@ -978,21 +977,21 @@ setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
    978 977 
     -- See Note [Error contexts in generated code]
    979 978 
     -- for the tcl_in_gen_code manipulation
    980 979 
     setSrcSpan (RealSrcSpan loc _) thing_inside
    981 
    -  = updLclCtxt (\env -> env { tcl_loc = loc, tcl_in_gen_code = UserCode })
    980 
    +  = updLclCtxt (\env -> env { tcl_loc = loc, tcl_ctxt = UserCodeCtxt (err_ctxt $ tcl_ctxt env)})
    982 981 
                   thing_inside
    983 982
    984 983 
     setSrcSpan (UnhelpfulSpan _) thing_inside
    985 984 
       = thing_inside
    986 985
    987 
    -getSrcCodeCtxt :: TcRn SrcCodeCtxt
    988 
    -getSrcCodeCtxt = getLclEnvSrcCodeCtxt <$> getLclEnv
    986 
    +getSrcCodeOrigin :: TcRn (Maybe SrcCodeOrigin)
    987 
    +getSrcCodeOrigin = getLclEnvSrcCodeOrigin <$> getLclEnv
    989 988
    990 989 
     -- | Mark the inner computation as being done inside generated code.
    991 990 
     --
    992 991 
     -- See Note [Error contexts in generated code]
    993 992 
     setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a
    994 
    -setInGeneratedCode scOrig thing_inside =
    995 
    -  updLclCtxt (setLclCtxtSrcCodeCtxt (GeneratedCode scOrig)) thing_inside
    993 
    +setInGeneratedCode sco thing_inside =
    994 
    +  updLclCtxt (setLclCtxtSrcCodeOrigin sco) thing_inside
    996 995
    997 996 
     setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a
    998 997 
     setSrcSpanA l = setSrcSpan (locA l)

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