[Git][ghc/ghc][wip/T23916] Wibbles

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T23916 at Glasgow Haskell Compiler / GHC


Commits:
2106cdc6 by Simon Peyton Jones at 2023-09-13T14:28:00+01:00
Wibbles

- - - - -


3 changed files:

- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Types/Origin.hs


Changes:

=====================================
compiler/GHC/Tc/Gen/Arrow.hs
=====================================
@@ -162,12 +162,10 @@ tc_cmd env (HsCmdLet x tkLet binds tkIn (L body_loc body)) res_ty
 
 tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
   = addErrCtxt (cmdCtxt in_cmd) $ do
-      (scrut', scrut_ty) <- tcInferRho scrut
-      hasFixedRuntimeRep_syntactic
-        (FRRArrow $ ArrowCmdCase)
-        scrut_ty
-      matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty)
-      return (HsCmdCase x scrut' matches')
+    do { (scrut', scrut_ty) <- tcInferRho scrut
+       ; hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowCmdCase) scrut_ty
+       ; matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty)
+       ; return (HsCmdCase x scrut' matches') }
 
 tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty    -- Ordinary 'if'
   = do  { pred' <- tcCheckMonoExpr pred boolTy
@@ -261,11 +259,13 @@ tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty)
 -- D;G |-a (\x.cmd) : (t,stk) --> res
 
 tc_cmd env cmd@(HsCmdLam x lam_variant match) cmd_ty
-  = addErrCtxt (cmdCtxt cmd)
-      do { let match_ctxt = ArrowLamAlt lam_variant
-         ; checkArgCounts (ArrowMatchCtxt match_ctxt) match
-         ; (wrap, match') <- tcCmdMatchLambda env match_ctxt match cmd_ty
-         ; return (mkHsCmdWrap wrap (HsCmdLam x lam_variant match')) }
+  = (case lam_variant of   -- Add context only for \case and \cases
+        LamSingle -> id    -- Avoids clutter in the vanilla-lambda form
+        _         -> addErrCtxt (cmdCtxt cmd)) $
+    do { let match_ctxt = ArrowLamAlt lam_variant
+       ; checkArgCounts (ArrowMatchCtxt match_ctxt) match
+       ; (wrap, match') <- tcCmdMatchLambda env match_ctxt match cmd_ty
+       ; return (mkHsCmdWrap wrap (HsCmdLam x lam_variant match')) }
 
 -------------------------------------------
 --              Do notation


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -269,11 +269,13 @@ tcMatch ctxt pat_tys rhs_ty match
                            , m_grhss = grhss' }) }
 
         -- For (\x -> e), tcExpr has already said "In the expression \x->e"
-        -- so we don't want to add "In the lambda abstraction \x->e"
+        --     so we don't want to add "In the lambda abstraction \x->e"
+        -- But for \cases with many alternatives, it is helpful to say
+        --     which particular alternative we are looking at
     add_match_ctxt match thing_inside
         = case mc_what ctxt of
-            LamAlt {} -> thing_inside
-            _         -> addErrCtxt (pprMatchInCtxt match) thing_inside
+            LamAlt LamSingle -> thing_inside
+            _                -> addErrCtxt (pprMatchInCtxt match) thing_inside
 
     -- We filter out type patterns because we have no use for them in HsToCore.
     -- Type variable bindings have already been converted to HsWrappers.


=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -1471,8 +1471,9 @@ pprExpectedFunTyHerald (ExpectedFunTyArg fun _)
         , text "is applied to" ]
 pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }))
   = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts
-pprExpectedFunTyHerald (ExpectedFunTyLam _ expr)
-  = sep [ text "The function" <+> quotes (pprSetDepth (PartWay 1) (ppr expr))
+pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr)
+  = sep [ text "The" <+> lamCaseKeyword lam_variant <+> text "expression"
+                     <+> quotes (pprSetDepth (PartWay 1) (ppr expr))
                -- The pprSetDepth makes the lambda abstraction print briefly
         , text "requires" ]
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2106cdc647a0daef846561d52d4380b537ecc481

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2106cdc647a0daef846561d52d4380b537ecc481
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230913/008ec5f0/attachment-0001.html>