[Git][ghc/ghc][wip/expand-do] trying out changes to heralds

Apoorv Ingle (@ani) gitlab at gitlab.haskell.org
Mon Jun 5 17:53:12 UTC 2023



Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC


Commits:
265cc4fd by Apoorv Ingle at 2023-06-05T12:53:04-05:00
trying out changes to heralds

- - - - -


9 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Rename/Expr.hs
- − compiler/GHC/Tc/Gen/.#Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- testsuite/tests/deSugar/should_compile/T3263-2.hs


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -463,7 +463,7 @@ data XXExprGhcRn
     {-# UNPACK #-} !(LHsExpr GhcRn)
   -- Placeholder for identifying generated source locations in GhcRn phase
   -- Should not presist post typechecking
-  -- Note [Desugaring Do with HsExpansion] in GHC.Tc.Gen.Match
+  -- Note [Expanding HsDo with HsExpansion] in GHC.Tc.Gen.Match
 
 -- | Wrap a located expression with a PopSrcExpr
 mkPopSrcSpanExpr :: LHsExpr GhcRn -> HsExpr GhcRn


=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -191,6 +191,25 @@ but several have a little bit of special treatment:
       in which an updated field has a higher-rank type.
       See Wrinkle [Using IdSig] in Note [Record Updates] in GHC.Tc.Gen.Expr.
 
+* HsDo: We expand HsDo statements in GHC.Tc.Expr
+        as we need to check for pattern irrefutability
+        which is dependent on the type constructor details available in TcM and not Rn monad
+
+    - For example, a user written code:
+
+                  do x <- e1
+                     g x
+                     return (f x)
+
+      is expanded to (roughly)
+
+                   (>>=) e1
+                        (\ x -> (>>) (g x)
+                                      (return (f x)))
+
+     See Note [Expanding HsDo with HsExpansion] in Ghc.Tc.Gen.Match for more details
+
+
 Note [Overloaded labels]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 For overloaded labels, note that we /only/ apply `fromLabel` to the


=====================================
compiler/GHC/Tc/Gen/.#Expr.hs deleted
=====================================
@@ -1 +0,0 @@
-aningle at CS-M030.71606
\ No newline at end of file


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -216,8 +216,7 @@ tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
                                     , text "expr:" <+> ppr expr
                                     , text "res_ty" <+> ppr res_ty
                                     ])
-        ; addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
-          tcExpr (unLoc expr) res_ty
+        ; tcExpr (unLoc expr) res_ty
         }
 
 
@@ -280,7 +279,7 @@ tcExpr (HsLam _ match) res_ty
   = do  { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty
         ; return (mkHsWrap wrap (HsLam noExtField match')) }
   where
-    match_ctxt = MC { mc_what = case mg_ext match of
+    match_ctxt = MC { mc_what = case mg_ext match of -- refactor this for a better place.
                                   Generated DoExpansion -> StmtCtxt (HsDoStmt (DoExpr Nothing))
                                   -- Either this lambda expr was generated by expanding a do block
                                   _ -> LambdaExpr


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -981,12 +981,13 @@ tcInferOverLit lit@(OverLit { ol_val = val
     --   the (3 :: Integer) is returned by mkOverLit
     -- Ditto the string literal "foo" to (fromString ("foo" :: String))
     do { hs_lit <- mkOverLit val
+       ; hs_lit_rn <- mkOverLitRn val
        ; from_id <- tcLookupId from_name
        ; (wrap1, from_ty) <- topInstantiate (LiteralOrigin lit) (idType from_id)
        ; let
            thing    = NameThing from_name
            mb_thing = Just thing
-           herald   = ExpectedFunTyArg thing (HsLit noAnn hs_lit)
+           herald   = ExpectedFunTyArg thing (HsLit noAnn hs_lit_rn)
        ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_thing
                                                            (1, []) from_ty
 
@@ -1469,6 +1470,7 @@ addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
 addExprCtxt e thing_inside
   = case e of
       HsUnboundVar {} -> thing_inside
+      XExpr (PopSrcSpan (L _ e)) -> addExprCtxt e thing_inside
       _ -> addErrCtxt (exprCtxt e) thing_inside
    -- The HsUnboundVar special case addresses situations like
    --    f x = _


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1405,34 +1405,34 @@ mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
 
 mk_fail_lexpr _ _ _ = pprPanic "mk_fail_lexpr: impossible happened" empty
 
-{- Note [Desugaring Do with HsExpansion]
+{- Note [Expanding HsDo with HsExpansion]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We expand do blocks before typechecking it rather than after type checking it using the
-HsExpansion mechanism similar to HsIf expansions for rebindable syntax.
+HsExpansions similar to HsIf expansions for rebindable syntax.
+The main reason to implement this is to make impredicatively typed expression statements typechec in do blocks.
+(#18324 and #23147).
+The challenge is to make sure we generate proper error messages with correct caret diagonstics
 
 Consider a do expression written in by the user
 
-f = {l0} do {l1} p <- {l1'}e1
-            {l2} g p
-            {l3} return {l3'}p
+    f = {l0} do {l1} p <- {l1'}e1
+                {l2} g p
+                {l3} return {l3'}p
 
 The {l1} etc are location/source span information stored in the AST,
 {g1} are compiler generated source spans
 
 The expanded version (performed by expand_do_stmts) looks as follows:
 
-f = {g1} (>>=) ({l1'} e1) (\ p ->
-               {g2} (>>) ({l2} g p)
-                         ({l3} return p)
-               )
+    f = {g1} (>>=) ({l1'} e1) (\ p ->
+                   {g2} (>>) ({l2} g p)
+                             ({l3} return p))
 
 The points to consider are:
 1. Generating appropriate type error messages that blame the correct source spans
 2. Generate appropriate warnings for discarded results, eg. say g p :: m Int
 3. Decorate an expression a fail block if the pattern match is irrefutable
 
-Things get a bit tricky with QuickLook involved that decomposes the applications
-to perform an impredicativity check.
 
 TODO expand using examples
 


=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -1332,12 +1332,10 @@ data ExpectedFunTyOrigin
   --
   -- Test cases for representation-polymorphism checks:
   --   RepPolyApp
-  | forall (p :: Pass)
-      . (OutputableBndrId p)
-      => ExpectedFunTyArg
+  | ExpectedFunTyArg
           !TypedThing
             -- ^ function
-          !(HsExpr (GhcPass p))
+          !(HsExpr GhcRn)
             -- ^ argument
 
   -- | Ensure that a function defined by equations indeed has a function type
@@ -1380,11 +1378,18 @@ pprExpectedFunTyOrigin funTy_origin i =
     ExpectedFunTyViewPat expr ->
       vcat [ the_arg_of <+> text "the view pattern"
            , nest 2 (ppr expr) ]
-    ExpectedFunTyArg fun arg ->
-      sep [ text "The argument"
-          , quotes (ppr arg)
-          , text "of"
-          , quotes (ppr fun) ]
+    ExpectedFunTyArg fun arg -> case arg of
+                                  XExpr (PopSrcSpan (L _ (XExpr (ExpandedStmt (HsExpanded {}))))) ->
+                                    vcat [ sep [ the_arg_of
+                                               , text "the rebindable syntax operator"
+                                               , quotes (ppr fun)
+                                               ]
+                                         , nest 2 (text "arising from a do stmt")
+                                         ]
+                                  _ -> sep [ text "The argument"
+                                           , quotes (ppr arg)
+                                           , text "of"
+                                           , quotes (ppr fun) ]
     ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })
       | null alts
       -> the_arg_of <+> quotes (ppr fun)


=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -25,7 +25,7 @@ module GHC.Tc.Utils.Instantiate (
 
      tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,
 
-     newOverloadedLit, mkOverLit,
+     newOverloadedLit, mkOverLit, mkOverLitRn,
 
      newClsInst, newFamInst,
      tcGetInsts, tcGetInstEnvs, getOverlapFlag,
@@ -698,6 +698,19 @@ mkOverLit (HsFractional r)
 
 mkOverLit (HsIsString src s) = return (HsString src s)
 
+mkOverLitRn ::OverLitVal -> TcM (HsLit GhcRn)
+mkOverLitRn (HsIntegral i)
+  = do  { integer_ty <- tcMetaTy integerTyConName
+        ; return (HsInteger (il_text i)
+                            (il_value i) integer_ty) }
+
+mkOverLitRn (HsFractional r)
+  = do  { rat_ty <- tcMetaTy rationalTyConName
+        ; return (HsRat noExtField r rat_ty) }
+
+mkOverLitRn (HsIsString src s) = return (HsString src s)
+
+
 {-
 ************************************************************************
 *                                                                      *


=====================================
testsuite/tests/deSugar/should_compile/T3263-2.hs
=====================================
@@ -31,7 +31,6 @@ t5 = do
   _ <- return (return 10 :: m Int)
   return 10
 
-
 -- Warning
 t6 :: forall m. MonadFix m => m Int
 t6 = mdo



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/265cc4fd5cab792f22121bdafdc047e13fb1f374

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/265cc4fd5cab792f22121bdafdc047e13fb1f374
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/20230605/8b0bd2ee/attachment-0001.html>


More information about the ghc-commits mailing list