[Git][ghc/ghc][wip/expand-do] trying out changes to heralds
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Jun 5 17:23:12 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
7bcf73a6 by Apoorv Ingle at 2023-06-05T12:22:57-05:00
trying out changes to heralds
- - - - -
8 changed files:
- 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/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/7bcf73a6ad424964d811dbc20684f03bd147b344
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7bcf73a6ad424964d811dbc20684f03bd147b344
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/ca72ff79/attachment-0001.html>
More information about the ghc-commits
mailing list