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

Commits:

1 changed file:

Changes:

  • compiler/GHC/Tc/Gen/App.hs
    ... ... @@ -188,11 +188,8 @@ tcExprSigma :: Bool -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
    188 188
     tcExprSigma inst rn_expr
    
    189 189
       = do { (fun@(rn_fun,fun_lspan), rn_args) <- splitHsApps rn_expr
    
    190 190
            ; (tc_fun, fun_sigma) <- tcInferAppHead fun
    
    191
    -       ; code_orig <- getSrcCodeOrigin
    
    192
    -       ; let fun_orig | not (isGeneratedSrcSpan fun_lspan)
    
    193
    -                      = exprCtOrigin rn_fun
    
    194
    -                      | otherwise
    
    195
    -                      = srcCodeOriginCtOrigin rn_fun code_orig
    
    191
    +       ; fun_orig <- mk_origin fun_lspan rn_fun rn_fun
    
    192
    +
    
    196 193
            ; traceTc "tcExprSigma" (vcat [ text "rn_expr:" <+> ppr rn_expr
    
    197 194
                                          , text "tc_fun" <+> ppr tc_fun ])
    
    198 195
            ; (inst_args, app_res_sigma) <- tcInstFun DoQL inst (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_args
    
    ... ... @@ -426,11 +423,7 @@ tcApp rn_expr exp_res_ty
    426 423
            -- If it is generated code location span, blame it on the
    
    427 424
            -- source code origin stored in the lclEnv.
    
    428 425
            -- See Note [Error contexts in generated code]
    
    429
    -       ; code_orig <- getSrcCodeOrigin
    
    430
    -       ; let fun_orig | not (isGeneratedSrcSpan fun_lspan)
    
    431
    -                      = exprCtOrigin rn_fun
    
    432
    -                      | otherwise
    
    433
    -                      = srcCodeOriginCtOrigin rn_fun code_orig
    
    426
    +       ; fun_orig <- mk_origin fun_lspan rn_fun rn_fun
    
    434 427
     
    
    435 428
            ; traceTc "tcApp:inferAppHead" $
    
    436 429
              vcat [ text "tc_fun:" <+> ppr tc_fun
    
    ... ... @@ -484,6 +477,7 @@ quickLookResultType _ _ = return ()
    484 477
     getDeepSubsumptionFlag_DataConHead :: HsExpr GhcTc -> TcM DeepSubsumptionFlag
    
    485 478
     getDeepSubsumptionFlag_DataConHead app_head =
    
    486 479
       do { user_ds <- xoptM LangExt.DeepSubsumption
    
    480
    +     ; traceTc "getDeepSubsumptionFlag_DataConHead" (ppr app_head)
    
    487 481
          ; return $
    
    488 482
              if | user_ds
    
    489 483
                 -> Deep DeepSub
    
    ... ... @@ -2026,11 +2020,9 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _
    2026 2020
            -- step 2: use |-inst to instantiate the head applied to the arguments
    
    2027 2021
         do { let arg_tc_head = (tc_fun_arg_head, fun_lspan_arg)
    
    2028 2022
            ; do_ql <- wantQuickLook rn_fun_arg
    
    2029
    -       ; code_orig <- getSrcCodeOrigin
    
    2030
    -       ; let arg_orig | not (isGeneratedSrcSpan fun_lspan_arg)
    
    2031
    -                      = exprCtOrigin rn_fun_arg
    
    2032
    -                      | otherwise
    
    2033
    -                      = srcCodeOriginCtOrigin fun code_orig
    
    2023
    +
    
    2024
    +       ; arg_orig <- mk_origin fun_lspan_arg rn_fun_arg fun
    
    2025
    +
    
    2034 2026
            ; ((inst_args, app_res_rho), wanted)
    
    2035 2027
                  <- captureConstraints $
    
    2036 2028
                     tcInstFun do_ql True (arg_orig, rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args
    
    ... ... @@ -2076,6 +2068,19 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _
    2076 2068
                                , eaql_encl     = arg_influences_enclosing_call
    
    2077 2069
                                , eaql_res_rho  = app_res_rho }) }}}
    
    2078 2070
     
    
    2071
    +mk_origin :: SrcSpan       -- SrcSpan of the argument
    
    2072
    +          -> HsExpr GhcRn  -- The head of the expression application chain
    
    2073
    +          -> HsExpr GhcRn  -- Fallback expression to appear in the error message
    
    2074
    +          -> TcM CtOrigin
    
    2075
    +mk_origin fun_lspan_arg rn_fun_arg rn_fun
    
    2076
    +  | not (isGeneratedSrcSpan fun_lspan_arg)
    
    2077
    +  = return $ exprCtOrigin rn_fun_arg
    
    2078
    +  | otherwise
    
    2079
    +  = do { code_orig <- getSrcCodeOrigin
    
    2080
    +       ; return $ srcCodeOriginCtOrigin rn_fun code_orig
    
    2081
    +       }
    
    2082
    +
    
    2083
    +
    
    2079 2084
     {- *********************************************************************
    
    2080 2085
     *                                                                      *
    
    2081 2086
                      Folding over instantiation variables