[Git][ghc/ghc][wip/expand-do] imporving error messages for applicative do
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Thu May 25 20:07:18 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
f8b82fcd by Apoorv Ingle at 2023-05-25T15:07:08-05:00
imporving error messages for applicative do
- - - - -
4 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -488,6 +488,12 @@ mkExpandedStmt
-> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
mkExpandedStmt a b = XExpr (ExpandedStmt (HsExpanded a b))
+mkExpandedStmtLExpr
+ :: ExprLStmt GhcRn -- ^ source statement
+ -> LHsExpr GhcRn -- ^ expanded expression
+ -> LHsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
+mkExpandedStmtLExpr a b = noLocA $ mkExpandedStmt a b
+
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
{-# UNPACK #-} !(HsWrap HsExpr)
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -864,6 +864,8 @@ warnUnusedBindValue fun arg@(L loc _) arg_ty
, text "loc" <+> ppr l
, text "locGen?" <+> ppr (isGeneratedSrcSpan l)
, text "noLoc?" <+> ppr (isNoSrcSpan l)
+ , text "arg" <+> ppr arg
+ , text "arg_loc" <+> ppr loc
])
putSrcSpanDs (locA loc) $ warnDiscardedDoBindings arg arg_ty
where
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -412,7 +412,8 @@ tcExpr (HsMultiIf _ alts) res_ty
tcExpr (XExpr (PopSrcSpan expr)) res_ty = popErrCtxt $ tcExpr (unLoc expr) res_ty
tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
- = do { traceTc "tcDoStmts stmt" (ppr expr)
+ = do { traceTc "tcDoStmts" (vcat [text "stmt" <+> ppr stmt
+ ,text "expr" <+> ppr expr])
; addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
tcExpr (unLoc expr) res_ty
}
@@ -421,20 +422,16 @@ tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty
= do { expand_expr <- expandDoStmts doFlav stmts
-- Do expansion on the fly
; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expand_expr)
- ; traceTc "tcDoStmts doExpr" (vcat [ text "original:" <+> ppr expanded_do_expr
- , text "expanded:" <+> ppr expand_expr
- ])
- ; addErrCtxt (text "In the" <+> matchDoContextErrString doFlav) $ popErrCtxt $ tcExpr expanded_do_expr res_ty
+ ; traceTc "tcDoStmts doExpr" (ppr expanded_do_expr)
+ ; tcExpr expanded_do_expr res_ty
}
tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) (L _ stmts)) res_ty
= do { expand_expr <- expandDoStmts doFlav stmts
-- Do expansion on the fly
; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expand_expr)
- ; traceTc "tcDoStmts mDoExpr" (vcat [ text "original:" <+> ppr expanded_do_expr
- , text "expanded:" <+> ppr expand_expr
- ])
- ; addErrCtxt (text "In the" <+> matchDoContextErrString doFlav) $ popErrCtxt $ tcExpr expanded_do_expr res_ty
+ ; traceTc "tcDoStmts mDoExpr" (ppr expanded_do_expr)
+ ; tcExpr expanded_do_expr res_ty
}
tcExpr (HsDo _ do_or_lc stmts) res_ty
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1189,21 +1189,30 @@ expandDoStmts = expand_do_stmts
-- ANI Questions: 1. What should be the location information in the expanded expression?
-- Currently the error is displayed on the expanded expr and not on the unexpanded expr
expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
+
expand_do_stmts ListComp _ = pprPanic "expand_do_stmts: impossible happened. ListComp" empty
+
expand_do_stmts _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
+expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) =
+ pprPanic "expand_do_stmts: TransStmt" $ ppr stmt
+
+expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
+-- See See Note [Monad Comprehensions]
+ pprPanic "expand_do_stmts: ParStmt" $ ppr stmt
+
expand_do_stmts _ [stmt@(L loc (LastStmt _ body _ ret_expr))]
-- last statement of a list comprehension, needs to explicitly return it
-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
| NoSyntaxExprRn <- ret_expr
-- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
- = return (noLocA (mkExpandedStmt stmt (genPopSrcSpanExpr body)))
+ = return (mkExpandedStmtLExpr stmt (genPopSrcSpanExpr body))
| SyntaxExprRn ret <- ret_expr
--
-- ------------------------------------------------
-- return e ~~> return e
-- to make T18324 work
- = return $ genPopSrcSpanExpr (noLocA (mkExpandedStmt stmt (genPopSrcSpanExpr (L loc $ genHsApp ret body))))
+ = return $ genPopSrcSpanExpr (mkExpandedStmtLExpr stmt (genPopSrcSpanExpr (L loc (genHsApp ret body))))
expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
@@ -1217,11 +1226,11 @@ expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
-- pat <- e ; stmts ~~> (>>=) e f
do expand_stmts <- expand_do_stmts do_or_lc lstmts
expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
- return $ noLocA (mkExpandedStmt stmt
+ return $ mkExpandedStmtLExpr stmt
(mkHsApps (wrapGenSpan bind_op) -- (>>=)
[ genPopSrcSpanExpr e
, genPopSrcSpanExpr expr
- ]))
+ ])
| otherwise = pprPanic "expand do: shouldn't happen" (text "stmt" <+> ppr stmt)
@@ -1230,10 +1239,10 @@ expand_do_stmts do_or_lc (stmt@(L _ (LetStmt _ bnds)) : lstmts) =
-- ------------------------------------------------
-- let x = e ; stmts ~~> let x = e in stmts'
do expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ noLocA (mkExpandedStmt stmt
+ return $ mkExpandedStmtLExpr stmt
(wrapGenSpan (HsLet noExtField
noHsTok bnds
- noHsTok (genPopSrcSpanExpr expand_stmts))))
+ noHsTok (genPopSrcSpanExpr expand_stmts)))
expand_do_stmts do_or_lc (stmt@(L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
@@ -1242,10 +1251,10 @@ expand_do_stmts do_or_lc (stmt@(L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts)
-- ----------------------------------------------
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ noLocA (mkExpandedStmt stmt
+ return $ mkExpandedStmtLExpr stmt
(mkHsApps (wrapGenSpan f) -- (>>)
[ genPopSrcSpanExpr e -- e
- , genPopSrcSpanExpr expand_stmts ])) -- stmts'
+ , genPopSrcSpanExpr expand_stmts ]) -- stmts'
expand_do_stmts do_or_lc
((L _ (RecStmt { recS_stmts = rec_stmts
@@ -1290,12 +1299,12 @@ expand_do_stmts do_or_lc
-- LazyPat becuase we do not want to eagerly evaluate the pattern
-- and potentially loop forever
-expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
+expand_do_stmts do_or_lc (stmt@(L _ (ApplicativeStmt _ args mb_join)): lstmts) =
-- See Note [Applicative BodyStmt]
--
-- stmts ~~> stmts'
-- -------------------------------------------------------------------------
--- [(<$>, e1), (<*>, e2)] ; stmts ~~> (\ x -> stmts') <$> e1 <*> e2 ...
+-- [(<$>, \ x -> e1), (<*>, e2)] ; stmts ~~> (\ x -> stmts') <$> e1 <*> e2 ...
--
-- Very similar to HsToCore.Expr.dsDo
@@ -1308,13 +1317,15 @@ expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
; body_with_fails <- foldrM match_args expr' pats_can_fail
-- builds (body <$> e1 <*> e2 ...)
- ; let expand_ado_expr = foldl mk_apps body_with_fails (zip (map fst args) rhss)
+ ; let expand_ado_expr = genPopSrcSpanExpr $ foldl mk_apps body_with_fails (zip (map fst args) rhss)
-- wrap the expanded expression with a `join` if needed
; case mb_join of
- Nothing -> return expand_ado_expr
- Just NoSyntaxExprRn -> return expand_ado_expr -- why can this happen?
- Just (SyntaxExprRn join_op) -> return $ mkHsApp (noLocA join_op) expand_ado_expr
+ Nothing -> return $ mkExpandedStmtLExpr stmt expand_ado_expr
+ Just NoSyntaxExprRn -> return $ mkExpandedStmtLExpr stmt expand_ado_expr -- why can this happen?
+ Just (SyntaxExprRn join_op) ->
+ return $ mkExpandedStmtLExpr stmt
+ ( mkHsApp (wrapGenSpan join_op) expand_ado_expr)
}
where
do_arg :: ApplicativeArg GhcRn -> TcM ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn)
@@ -1325,21 +1336,13 @@ expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
; return ((pat, Nothing), expr) }
match_args :: (LPat GhcRn, FailOperator GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
- match_args (pat, fail_op) body = mk_failable_lexpr_tcm pat body fail_op
+ match_args (pat, fail_op) body = genPopSrcSpanExpr <$> mk_failable_lexpr_tcm pat body fail_op
- mk_apps l (op, r) =
+ mk_apps l_expr (op, r_expr) =
case op of
- SyntaxExprRn op -> mkHsApps (noLocA op) [l, r]
+ SyntaxExprRn op -> mkHsApps (wrapGenSpan op) [genPopSrcSpanExpr l_expr, genPopSrcSpanExpr r_expr]
NoSyntaxExprRn -> pprPanic "expand_do_stmts op:" (ppr op)
-expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) =
- pprPanic "expand_do_stmts: TransStmt" $ ppr stmt
-
-expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
--- See See Note [Monad Comprehensions]
-
- pprPanic "expand_do_stmts: ParStmt" $ ppr stmt
-
expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
@@ -1413,4 +1416,27 @@ The points to consider are:
TODO expand using examples
+
+Applicative Do Expansion
+
+Consider (ado/ado003.hs)
+
+g :: IO ()
+g = do
+ x <- getChar
+ 'a' <- return (3::Int) -- type error
+ return ()
+
+this gets expanded to
+
+g = join ((<*>) (fmap (\ x -> / 'a' -> return ())
+ getChar
+ (return 3::Int) ))
+
+
+
+join (<*>) (\ x -> \ 'a' -> return ()
+ \ _ -> fail ..)
+ getChar
+ return (3 :: Int)
-}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8b82fcd1896998c3c5c63f34f67885dca0e6cc2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8b82fcd1896998c3c5c63f34f67885dca0e6cc2
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/20230525/5c45a5e1/attachment-0001.html>
More information about the ghc-commits
mailing list