[Git][ghc/ghc][wip/expand-do] more informative statement error context when rebindable syntax is turned on
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Jul 24 15:28:22 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
7280f48c by Apoorv Ingle at 2023-07-24T10:27:45-05:00
more informative statement error context when rebindable syntax is turned on
- - - - -
5 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Types/Basic.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -514,6 +514,17 @@ data XXExprGhcTc
(LHsExpr GhcTc) -- sub-expression
+
+-- | Build a 'HsExpansion' out of an extension constructor,
+-- and the two components of the expansion: original and
+-- expanded typechecked expressions.
+mkExpandedExprTc
+ :: HsExpr GhcRn -- ^ source expression
+ -> HsExpr GhcTc -- ^ expanded typechecked expression
+ -> HsExpr GhcTc -- ^ suitably wrapped 'HsExpansion'
+mkExpandedExprTc a b = XExpr (ExpansionExpr (HsExpanded a b))
+
+
{- *********************************************************************
* *
Pretty-printing expressions
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -480,39 +480,24 @@ tcExpr (HsMultiIf _ alts) res_ty
; return (HsMultiIf res_ty alts') }
where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
-tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) ss@(L loc stmts)) res_ty
+tcExpr hsDo@(HsDo _ do_or_lc@(DoExpr{}) ss@(L loc stmts)) res_ty
+-- In the case of vanilla do expression.
+-- We expand the statements into explicit application of binds, thens and lets
+-- This helps in infering the right types for bind expressions when impredicativity is turned on
+-- See Note [Expanding HsDo with HsExpansion] in GHC.Tc.Gen.Match.hs
= do { isApplicativeDo <- xoptM LangExt.ApplicativeDo
; if isApplicativeDo
- then tcDoStmts doFlav ss res_ty
- else do { (L _ expanded_expr) <- expandDoStmts doFlav stmts
+ then tcDoStmts do_or_lc ss res_ty -- Use tcSyntaxOp if ApplicativeDo is turned on for now
+ else do { (L _ expanded_expr) <- expandDoStmts do_or_lc stmts
-- Do expansion on the fly
- -- ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expanded_expr)
; traceTc "tcDoStmts hsDo" (vcat [ ppr hsDo
, text "expr:" <+> ppr expanded_expr
])
; setSrcSpanA loc $
- -- addExprCtxt (text "tcExpr") hsDo $
- (\ x -> XExpr (ExpansionExpr (HsExpanded hsDo x))) <$> (tcExpr expanded_expr res_ty)
+ mkExpandedExprTc hsDo <$> (tcExpr expanded_expr res_ty)
}
}
--- tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) ss@(L loc stmts)) res_ty
--- = do { isApplicativeDo <- xoptM LangExt.ApplicativeDo
--- ; is
--- ; if isApplicativeDo
--- then tcDoStmts doFlav ss res_ty
--- else do { (L _ expanded_expr) <- expandDoStmts doFlav stmts
--- -- Do expansion on the fly
--- -- ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expanded_expr)
--- ; traceTc "tcDoStmts hsDo" (vcat [ ppr hsDo
--- , text "expr:" <+> ppr expanded_expr
--- ])
--- ; setSrcSpanA loc $
--- -- addExprCtxt (text "tcExpr") hsDo $
--- (\ x -> XExpr (ExpansionExpr (HsExpanded hsDo x))) <$> (tcExpr expanded_expr res_ty)
--- }
--- }
-
tcExpr (HsDo _ do_or_lc stmts) res_ty
= tcDoStmts do_or_lc stmts res_ty
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -85,6 +85,8 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic.Plain
+import qualified GHC.LanguageExtensions as LangExt
+
import GHC.Data.Maybe
import Control.Monad
@@ -1538,20 +1540,28 @@ mis-match in the number of value arguments.
addStmtCtxt :: SDoc -> ExprLStmt GhcRn -> TcRn a -> TcRn a
addStmtCtxt doc stmt thing_inside
- = do let err = pprStmtInCtxt (HsDoStmt (DoExpr Nothing)) (unLoc stmt)
+ = do isRebindable <- xoptM LangExt.RebindableSyntax
+ let err = pprStmtInCtxt isRebindable (HsDoStmt (DoExpr Nothing)) (unLoc stmt)
traceTc "addStmtCtxt" (ppr $ doc <+> err)
addErrCtxt ({-doc <+>-} err) thing_inside
where
- pprStmtInCtxt :: HsStmtContext GhcRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
- pprStmtInCtxt ctxt stmt
- = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon)
- 2 (pprStmt stmt)
- -- maybeExpansionClause :: StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
- -- maybeExpansionClause stmt | BindStmt{} <- stmt = text "the expansion of"
- -- | otherwise = empty
-
-
+ pprStmtInCtxt :: Bool -> HsStmtContext GhcRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
+ pprStmtInCtxt isRebindable ctxt stmt
+ = vcat [ text "In" <+> optionalExpansionClause isRebindable stmt <+> text "a stmt of"
+ <+> pprAStmtContext ctxt <> colon
+ , nest 2 (pprStmt stmt)
+ , optionalNote isRebindable
+ ]
+ optionalExpansionClause :: Bool -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
+ optionalExpansionClause True stmt | BindStmt{} <- stmt = text "the expansion of"
+ | otherwise = empty
+ optionalExpansionClause _ _ = empty
+
+
+ optionalNote :: Bool -> SDoc
+ optionalNote True = text "NB: The language extension" <+> ppr LangExt.RebindableSyntax <+> text "is turned on"
+ optionalNote _ = empty
addExprCtxt :: SDoc -> HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt doc e thing_inside
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -84,7 +84,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Control.Arrow ( second )
import qualified Data.List.NonEmpty as NE
-import Data.List ((\\))
+
{-
************************************************************************
* *
@@ -1227,7 +1227,7 @@ expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
-- See See Note [Monad Comprehensions]
pprPanic "expand_do_stmts: ParStmt" $ ppr stmt
-expand_do_stmts _ (stmt@(L _ (ApplicativeStmt _ _ _)): _) =
+expand_do_stmts _ (stmt@(L _ (ApplicativeStmt{})): _) =
pprPanic "expand_do_stmts: Applicative Stmt" $ ppr stmt
expand_do_stmts _ [stmt@(L loc (LastStmt _ (L _ body) _ ret_expr))]
@@ -1260,7 +1260,7 @@ expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
, fail_op <- xbsrn_failOp xbsrn =
-- the pattern binding pat can fail
--- instead of making an internal name, the fail block is just an anonymous match block
+-- instead of making an internal name, the fail block is just an anonymous lambda
-- stmts ~~> stmt' f = / -> pat = stmts';
-- _ = fail "Pattern match failure .."
-- -------------------------------------------------------
@@ -1268,14 +1268,15 @@ expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
do -- isRebindableOn <- xoptM LangExt.RebindableSyntax
-- let spanWrap = if isRebindableOn then noLocA else wrapGenSpan
expand_stmts <- expand_do_stmts do_or_lc lstmts
- expr <- mk_failable_lexpr_tcm pat
+ expr <- mk_failable_expr_tcm pat
expand_stmts
fail_op
return $ wrapGenSpan (mkPopErrCtxtExpr $ (wrapGenSpan (mkExpandedStmt stmt (
(wrapGenSpan ((wrapGenSpan bind_op) -- (>>=)
`genHsApp` e))
`genHsApp` expr))))
- | otherwise = pprPanic "expand do: shouldn't happen" (text "stmt" <+> ppr stmt)
+ | otherwise
+ = pprPanic "expand_do_stmts: The impossible happened, missing bind operator" (text "stmt" <+> ppr stmt)
expand_do_stmts do_or_lc (stmt@(L _ (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
-- See Note [BodyStmt]
@@ -1314,7 +1315,7 @@ expand_do_stmts do_or_lc
return $ mkHsApps (wrapGenSpan bind_fun) -- (>>=)
[ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
, genHsLamDoExp [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
- ({-genPopSrcSpanExpr-} expand_stmts) -- stmts')
+ ( expand_stmts) -- stmts')
]
where
local_only_ids = local_ids \\ later_ids -- get unique local rec ids;
@@ -1332,20 +1333,14 @@ expand_do_stmts do_or_lc
do_block = L do_loc $ HsDo noExtField (DoExpr Nothing) $ do_stmts
mfix_expr :: LHsExpr GhcRn
mfix_expr = genHsLamDoExp [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ] $ do_block
- -- LazyPat becuase we do not want to eagerly evaluate the pattern
+ -- LazyPat because we do not want to eagerly evaluate the pattern
-- and potentially loop forever
expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
-
-
-mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
--- checks the pattern `pat` and decides if we need to decorate it with a fail block
--- Type checking the pattern is necessary to decide if we need to generate the fail block
--- The Renamer cannot always determine if a fail block is necessary, and its conservative behaviour would
--- generate a fail block even if it is not really needed. This would fail typechecking as
--- a monad fail instance for such datatypes maynot be defined. cf. GHC.Hs.isIrrefutableHsPat
-mk_failable_lexpr_tcm pat@(L loc _) lexpr fail_op =
+mk_failable_expr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
+-- checks the pattern `pat`for irrefutability which decides if we need to decorate it with a fail block
+mk_failable_expr_tcm pat@(L loc _) lexpr fail_op =
do { tc_env <- getGblEnv
; is_strict <- xoptM LangExt.Strict
; irrf_pat <- isIrrefutableHsPatRn' tc_env is_strict pat
@@ -1359,17 +1354,17 @@ mk_failable_lexpr_tcm pat@(L loc _) lexpr fail_op =
-- the pattern is irrefutable
then return $ let (L _ e) = genHsLamDoExp [pat] lexpr
in L loc e
- else mk_fail_lexpr pat lexpr fail_op
+ else mk_fail_block pat lexpr fail_op
}
-- makes the fail block
-- TODO: check the discussion around MonadFail.fail type signature.
-- Should we really say `mkHsString "fail pattern"`? if yes, maybe a better error message would help
-mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
-mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
+mk_fail_block :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
+mk_fail_block pat e (Just (SyntaxExprRn fail_op)) =
do dflags <- getDynFlags
- return $ wrapGenSpan (HsLam noExtField $ mkMatchGroup (Generated DoExpansion SkipPmc) -- \
- (wrapGenSpan [ genHsCaseAltDoExp pat lexpr -- pat -> expr
+ return $ wrapGenSpan (HsLam noExtField $ mkMatchGroup doExpansionOrigin -- \
+ (wrapGenSpan [ genHsCaseAltDoExp pat e -- pat -> expr
, genHsCaseAltDoExp (wrapGenSpan (WildPat noExtField)) -- _ -> fail "fail pattern"
$ wrapGenSpan (genHsApp (wrapGenSpan fail_op) (mk_fail_msg_expr dflags pat))
]))
@@ -1380,7 +1375,7 @@ mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
text "Pattern match failure in" <+> pprHsDoFlavour (DoExpr Nothing)
<+> text "at" <+> ppr (getLocA pat)
-mk_fail_lexpr _ _ _ = pprPanic "mk_fail_lexpr: impossible happened" empty
+mk_fail_block _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
genHsApp :: LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
@@ -1392,7 +1387,7 @@ genHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
-> LHsExpr (GhcPass p)
genHsLamDoExp pats body = mkHsPar (wrapGenSpan $ HsLam noExtField matches)
where
- matches = mkMatchGroup (Generated DoExpansion SkipPmc)
+ matches = mkMatchGroup doExpansionOrigin
(wrapGenSpan [genSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) pats' body])
pats' = map (parenthesizePat appPrec) pats
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -37,7 +37,7 @@ module GHC.Types.Basic (
RecFlag(..), isRec, isNonRec, boolToRecFlag,
Origin(..), isGenerated, DoPmc(..), requiresPMC,
- isDoExpansionGenerated, GenReason(..),
+ GenReason(..), isDoExpansionGenerated, doExpansionOrigin,
RuleName, pprRuleName,
@@ -610,6 +610,11 @@ isDoExpansionGenerated :: Origin -> Bool
isDoExpansionGenerated (Generated DoExpansion _) = True
isDoExpansionGenerated _ = False
+doExpansionOrigin :: Origin
+doExpansionOrigin = Generated DoExpansion DoPmc
+ -- It is important that we perfrom PMC on these
+ -- statements to get the right warnings
+
instance Outputable Origin where
ppr FromSource = text "FromSource"
ppr (Generated reason pmc) = text "Generated" <+> ppr reason <+> ppr pmc
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7280f48c990d853342724642e0d17e7f5aeb873f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7280f48c990d853342724642e0d17e7f5aeb873f
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/20230724/3cbf38e9/attachment-0001.html>
More information about the ghc-commits
mailing list