[Git][ghc/ghc][wip/expand-do] 5 commits: cleanup 1
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Fri Aug 4 21:31:17 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
a22ab7cc by Apoorv Ingle at 2023-08-02T12:26:57-05:00
cleanup 1
- - - - -
3189c92d by Apoorv Ingle at 2023-08-02T17:30:59-05:00
cleanup 2
- - - - -
7b44cc50 by Apoorv Ingle at 2023-08-03T17:27:56-05:00
cleanup 3
- - - - -
6440f280 by Apoorv Ingle at 2023-08-04T11:45:55-05:00
move gen definitions in renamer.utils fix some comments
- - - - -
54f1a8f9 by Apoorv Ingle at 2023-08-04T16:31:00-05:00
refactor tcExpr into tcExpr and tcXExpr
- - - - -
8 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -467,16 +467,22 @@ data XXExprGhcRn
| ExpandedStmt
{-# UNPACK #-} !(HsExpansion (ExprLStmt GhcRn) -- Original source do statement with location
(HsExpr GhcRn)) -- Expanded expression
- | PopErrCtxt
- {-# UNPACK #-} !(LHsExpr GhcRn)
- -- Placeholder for identifying generated source locations in GhcRn phase
- -- Should not presist post typechecking
- -- Note [Expanding HsDo with HsExpansion] in GHC.Tc.Gen.Match
+ -- See Note [Expanding HsDo with HsExpansion]
+
+ | PopErrCtxt -- A hint for typechecker to pop
+ {-# UNPACK #-} !(LHsExpr GhcRn) -- the top of the error context stack
+ -- Does not presist post type checking phase
+ -- See Note [Expanding HsDo with HsExpansion]
+
-- | Wrap a located expression with a PopSrcExpr
mkPopErrCtxtExpr :: LHsExpr GhcRn -> HsExpr GhcRn
mkPopErrCtxtExpr a = XExpr (PopErrCtxt a)
+-- | Wrap a located expression with a PopSrcExpr with an appropriate location
+mkPopErrCtxtExprAt :: SrcSpanAnnA -> LHsExpr GhcRn -> LHsExpr GhcRn
+mkPopErrCtxtExprAt loc a = L loc $ mkPopErrCtxtExpr a
+
-- | Build a 'HsExpansion' out of an extension constructor,
-- and the two components of the expansion: original and
-- desugared expressions.
@@ -487,11 +493,26 @@ mkExpandedExpr
mkExpandedExpr a b = XExpr (ExpandedExpr (HsExpanded a b))
mkExpandedStmt
- :: ExprLStmt GhcRn -- ^ source statement
- -> HsExpr GhcRn -- ^ expanded expression
- -> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
+ :: ExprLStmt GhcRn -- ^ source statement
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
mkExpandedStmt a b = XExpr (ExpandedStmt (HsExpanded a b))
+
+mkExpandedStmtAt
+ :: SrcSpanAnnA -- ^ Location for the expansion expression
+ -> ExprLStmt GhcRn -- ^ source statement
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> LHsExpr GhcRn -- ^ suitably wrapped located 'HsExpansion'
+mkExpandedStmtAt loc a b = L loc $ mkExpandedStmt a b
+
+mkExpandedStmtPopAt
+ :: SrcSpanAnnA -- ^ Location for the expansion statement
+ -> ExprLStmt GhcRn -- ^ source statement
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> LHsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
+mkExpandedStmtPopAt loc stmt expansion = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc stmt expansion
+
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
{-# UNPACK #-} !(HsWrap HsExpr)
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -41,7 +41,7 @@ just attach noSrcSpan to everything.
module GHC.Hs.Utils(
-- * Terms
mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith,
- mkHsAppType, mkHsAppTypes, mkHsCaseAlt, mkHsCaseAltDoExp,
+ mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
@@ -291,16 +291,6 @@ mkHsCaseAlt pat expr
= mkSimpleMatch CaseAlt [pat] expr
-mkHsCaseAltDoExp :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
- ~ SrcAnn NoEpAnns,
- Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
- ~ SrcSpanAnnA)
- => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))
- -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
-mkHsCaseAltDoExp pat expr
- = mkSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) [pat] expr
-
-
nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc
nlHsTyApp fun_id tys
= noLocA (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLocA fun_id)))
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -30,7 +30,6 @@ import GHC.HsToCore.Utils
import GHC.HsToCore.Arrows
import GHC.HsToCore.Monad
import GHC.HsToCore.Pmc
-import GHC.HsToCore.Pmc.Utils
import GHC.HsToCore.Errors.Types
import GHC.Types.SourceText
import GHC.Types.Name hiding (varName)
@@ -921,6 +920,28 @@ dsConLike con tvs tys
************************************************************************
-}
+-- Warn about certain types of values discarded in monadic bindings (#3263)
+warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
+warnUnusedBindValue fun arg@(L loc _) arg_ty
+ | Just (l, f) <- fish_var fun
+ , f `hasKey` thenMClassOpKey -- it is a (>>)
+ = when (isGeneratedSrcSpan l) $ -- it is compiler generated (>>)
+ putSrcSpanDs (locA loc) $ warnDiscardedDoBindings arg arg_ty
+ where
+ -- Retrieve the location info and the head of the application
+ -- It is important that we /do not/ look through HsApp to avoid
+ -- generating duplicate warnings
+ fish_var :: LHsExpr GhcTc -> Maybe (SrcSpan , Id)
+ fish_var (L l (HsVar _ id)) = return (locA l, unLoc id)
+ fish_var (L _ (HsAppType _ e _ _)) = fish_var e
+ fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e)
+ return (l, e')
+ fish_var (L l (XExpr (ExpansionExpr (HsExpanded _ e)))) = fish_var (L l e)
+ fish_var (L l (XExpr (ExpansionStmt (HsExpanded _ e)))) = fish_var (L l e)
+ fish_var _ = Nothing
+
+warnUnusedBindValue _ _ _ = return ()
+
-- Warn about certain types of values discarded in monadic bindings (#3263)
warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
warnDiscardedDoBindings rhs rhs_ty
@@ -948,36 +969,6 @@ warnDiscardedDoBindings rhs rhs_ty
| otherwise -- RHS does have type of form (m ty), which is weird
= return () -- but at least this warning is irrelevant
-
-warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
-warnUnusedBindValue fun arg@(L loc _) arg_ty
- | Just (l, f) <- fish_var fun
- , f `hasKey` thenMClassOpKey -- it is a (>>)
- = do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun
- , text "loc" <+> ppr l
- , text "locGen?" <+> ppr (isGeneratedSrcSpan l)
- , text "noLoc?" <+> ppr (isNoSrcSpan l)
- , text "arg" <+> ppr arg
- , text "arg_loc" <+> ppr loc
- ])
- when (isGeneratedSrcSpan l) $ -- it is compiler generated (>>)
- putSrcSpanDs (locA loc) $ warnDiscardedDoBindings arg arg_ty
- where
- -- Retrieve the location info and the head of the application
- -- It is important that we /do not/ look through HsApp to avoid
- -- generating duplicate warnings
- fish_var :: LHsExpr GhcTc -> Maybe (SrcSpan , Id)
- fish_var (L l (HsVar _ id)) = return (locA l, unLoc id)
- fish_var (L _ (HsAppType _ e _ _)) = fish_var e
- fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e)
- return (l, e')
- fish_var (L l (XExpr (ExpansionExpr (HsExpanded _ e)))) = fish_var (L l e)
- fish_var (L l (XExpr (ExpansionStmt (HsExpanded _ e)))) = fish_var (L l e)
- fish_var _ = Nothing
-
-warnUnusedBindValue _ _ _ = return ()
-
-
{-
************************************************************************
* *
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -18,12 +18,16 @@ module GHC.Rename.Utils (
warnForallIdentifier,
checkUnusedRecordWildcard,
badQualBndrErr, typeAppErr, badFieldConErr,
- wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genLHsApp,
+ wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genLHsApp, genHsExpApps,
genAppType,
genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat,
genVarPat, genWildPat,
genSimpleFunBind, genFunBind,
+ genHsLamDoExp, genHsCaseAltDoExp, genSimpleMatch,
+
+ genHsLet,
+
newLocalBndrRn, newLocalBndrsRn,
bindLocalNames, bindLocalNamesFV, delLocalNames,
@@ -578,6 +582,9 @@ wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
genHsApps fun args = foldl genHsApp (genHsVar fun) args
+genHsExpApps :: HsExpr GhcRn -> [LHsExpr GhcRn] -> HsExpr GhcRn
+genHsExpApps fun arg = foldl genHsApp fun arg
+
genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg
@@ -632,7 +639,44 @@ genFunBind fn ms
, fun_ext = emptyNameSet
}
+
isIrrefutableHsPatRn :: forall p. (OutputableBndrId p)
=> DynFlags -> LPat (GhcPass p) -> Bool
isIrrefutableHsPatRn dflags =
isIrrefutableHsPat (xopt LangExt.Strict dflags)
+
+genHsLet :: HsLocalBindsLR GhcRn GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
+genHsLet bindings body = HsLet noExtField noHsTok bindings noHsTok body
+
+genHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
+ => [LPat (GhcPass p)]
+ -> LHsExpr (GhcPass p)
+ -> LHsExpr (GhcPass p)
+genHsLamDoExp pats body = mkHsPar (wrapGenSpan $ HsLam noExtField matches)
+ where
+ matches = mkMatchGroup doExpansionOrigin
+ (wrapGenSpan [genSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) pats' body])
+ pats' = map (parenthesizePat appPrec) pats
+
+
+genHsCaseAltDoExp :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcAnn NoEpAnns,
+ Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpanAnnA)
+ => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))
+ -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
+genHsCaseAltDoExp pat expr
+ = genSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) [pat] expr
+
+
+genSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpanAnnA,
+ Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcAnn NoEpAnns)
+ => HsMatchContext (GhcPass p)
+ -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
+ -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
+genSimpleMatch ctxt pats rhs
+ = wrapGenSpan $
+ Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = pats
+ , m_grhss = unguardedGRHSs generatedSrcSpan rhs noAnn }
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -144,7 +144,7 @@ tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType
-- False <=> don't instantiate -- return a sigma-type
tcInferSigma inst (L loc rn_expr)
| (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr
- = addExprCtxt (text "tcInferSigma") rn_expr $
+ = addExprCtxt rn_expr $
setSrcSpanA loc $
do { do_ql <- wantQuickLook rn_fun
; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
@@ -334,14 +334,8 @@ tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp rn_expr exp_res_ty
| (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr
= do { traceTc "tcApp {" $
- vcat [ text "rn_expr:" <+> ppr rn_expr
- , text "rn_fun:" <+> ppr rn_fun
- , text "rn_args:" <+> ppr rn_args
- , text "fun_ctxt:" <+> ppr fun_ctxt
- , text "fun_ctxt loc" <+> ppr (appCtxtLoc fun_ctxt)
- , text "fun_ctxt isGen" <+> ppr (isGeneratedSrcSpan (appCtxtLoc fun_ctxt))
- , text "insideExpansion" <+> ppr (insideExpansion fun_ctxt)
- ]
+ vcat [ text "rn_fun:" <+> ppr rn_fun
+ , text "rn_args:" <+> ppr rn_args ]
; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
@@ -353,8 +347,7 @@ tcApp rn_expr exp_res_ty
; app_res_rho <- if do_ql
then quickLookResultType delta app_res_rho exp_res_ty
else return app_res_rho
- ; traceTc "tcApp1" (vcat [ text "tc_fun" <+> ppr tc_fun
- , text "fun_sigma" <+> ppr fun_sigma ])
+
-- Unify with expected type from the context
-- See Note [Unify with expected type before typechecking arguments]
--
@@ -364,22 +357,13 @@ tcApp rn_expr exp_res_ty
-- Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
; let perhaps_add_res_ty_ctxt thing_inside
| insideExpansion fun_ctxt
- , VACall (XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) _))) _ _ <- fun_ctxt
- = do traceTc "tcApp" (vcat [text "VACall stmt", ppr stmt, ppr loc, ppr rn_fun, ppr fun_ctxt])
- -- setSrcSpanA loc $ -- addStmtCtxt (text "tcApp VACall stmt") stmt
- thing_inside
- | insideExpansion fun_ctxt
- , VAExpansionStmt (L _ stmt) loc <- fun_ctxt
- = do traceTc "tcApp" (vcat [text "VAExpansionStmt", ppr stmt, ppr loc, ppr rn_fun, ppr fun_ctxt])
- --setSrcSpan loc $
- addStmtCtxt (text "tcApp VAExpansionStmt") stmt
+ , VAExpansionStmt (L _ stmt) _ <- fun_ctxt
+ = do addStmtCtxt (text "tcApp VAExpansionStmt") stmt
thing_inside
| insideExpansion fun_ctxt
- = do traceTc "tcApp" (vcat [text "insideExpansion", ppr rn_fun, ppr fun_ctxt])
- addHeadCtxt fun_ctxt thing_inside
+ = addHeadCtxt fun_ctxt thing_inside
| otherwise
- = do traceTc "tcApp" (vcat [text "no expansion", ppr rn_fun, ppr fun_ctxt])
- addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $
+ = do addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $
thing_inside
-- Match up app_res_rho: the result type of rn_expr
@@ -402,10 +386,10 @@ tcApp rn_expr exp_res_ty
-- delta variables to polytypes, and tcSubType doesn't expect that
do { app_res_rho <- liftZonkM $ zonkQuickLook do_ql app_res_rho
; tcSubTypeDS rn_expr app_res_rho exp_res_ty }
- ; traceTc "tcApp2" empty
+
-- Typecheck the value arguments
; tc_args <- tcValArgs do_ql inst_args
- ; traceTc "tcApp3" empty
+
-- Reconstruct, with a special case for tagToEnum#.
; tc_expr <-
if isTagToEnum rn_fun
@@ -556,10 +540,7 @@ tcInstFun :: Bool -- True <=> Do quick-look
-- modification in Fig 5, of the QL paper:
-- "A quick look at impredicativity" (ICFP'20).
tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
- = do { traceTc "tcInstFun" (vcat [ text "tc_fun" <+> ppr tc_fun
- , text "fun_sigma" <+> ppr fun_sigma
- , text "fun_orig" <+> ppr fun_orig
- , text "fun_ctxt" <+> ppr fun_ctxt
+ = do { traceTc "tcInstFun" (vcat [ ppr tc_fun , ppr fun_sigma
, text "args:" <+> ppr rn_args
, text "do_ql" <+> ppr do_ql ])
; go emptyVarSet [] [] fun_sigma rn_args }
@@ -571,7 +552,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
| HsVar _ (L _ fun_id) <- tc_fun
, fun_id `hasKey` failMClassOpKey
, isGeneratedSrcSpan (appCtxtLoc fun_ctxt)
- -> DoOrigin -- Ideally i want the pattern here that is failable but thats in another match
+ -> DoOrigin -- Ideally I want the pattern here that is failable but thats in another match
| otherwise
-> exprCtOrigin e
@@ -800,69 +781,49 @@ looks_like_type_arg _ = False
addArgCtxt :: AppCtxt -> LHsExpr GhcRn
-> TcM a -> TcM a
--- There are two cases:
--- * In the normal case, we add an informative context
--- "In the third argument of f, namely blah"
--- * If we are deep inside generated code (isGeneratedCode)
--- or if all or part of this particular application is an expansion
--- (VAExpansion), just use the less-informative context
--- "In the expression: arg"
+-- There are four cases:
+-- 1. In the normal case, we add an informative context
+-- "In the third argument of f, namely blah"
+-- 2. If we are deep inside generated code (isGeneratedCode)
+-- or if all or part of this particular application is an expansion
+-- (VAExpansion), just use the less-informative context
+-- "In the expression: arg"
-- Unless the arg is also a generated thing, in which case do nothing.
---- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
+-- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
+-- 3. We are in an expanded do block's non-bind statement
+-- we simply add the statement context
+-- "In the statement of the do block .."
+-- 4. We are in an expanded do block's bind statement
+-- a. Then either we are typechecking the first argument of the bind which is user located
+-- so we set the location to be that of the argument
+-- b. Or, we are typechecking the second argument which would likely be a generated lambda
+-- so we set the location to be whatever the location in the context is
+-- See Note [Expanding HsDo with HsExpansion] in GHC.Tc.Gen.Match
addArgCtxt ctxt (L arg_loc arg) thing_inside
= do { in_generated_code <- inGeneratedCode
- ; let in_src_ctxt = isGoodSrcSpan (appCtxtLoc ctxt)
- -- ; rebindableOn <- xoptM LangExt.RebindableSyntax
- ; traceTc "addArgCtxt" (vcat [ text "ctxt" <+> ppr ctxt
- , text "arg" <+> ppr arg
- , text "arg_loc" <+> ppr arg_loc
- , text "is src ctxt" <+> ppr in_src_ctxt
- , text "is generated code" <+> ppr in_generated_code
- -- , text "is then/bind"
- -- <+> ppr (is_then_fun (appCtxtExpr ctxt))
- -- <+> ppr (is_bind_fun (appCtxtExpr ctxt))
- ])
; case ctxt of
- VACall (XExpr (ExpandedStmt (HsExpanded (L loc stmt) _))) _ _
- -> do traceTc "addArgCtxt 2c" empty -- Set the context "In the stmt .."
- setSrcSpanA loc $
- addStmtCtxt (text "addArgCtxt 2c") stmt $
- thing_inside
VACall fun arg_no _ | not in_generated_code
- -> do traceTc "addArgCtxt 2a" empty
- setSrcSpanA arg_loc $
+ -> do setSrcSpanA arg_loc $
addErrCtxt (funAppCtxt fun arg arg_no) $
thing_inside
- VAExpansionStmt stmt@(L loc BodyStmt{}) _
- -> do traceTc "addArgCtxt 2e body" empty
- setSrcSpanA loc $
- addStmtCtxt ((text "addArgCtxt 2e")) (unLoc stmt) $
- thing_inside
- VAExpansionStmt stmt@(L _ LastStmt {}) loc
- -> do traceTc "addArgCtxt 2e last" empty
- setSrcSpan loc $
- addStmtCtxt ((text "addArgCtxt last 2e")) (unLoc stmt) $
- thing_inside
- VAExpansionStmt stmt@(L _ BindStmt {}) loc
- | isGeneratedSrcSpan (locA arg_loc)
- -> do traceTc "addArgCtxt 2e bind arg_gen" empty
- setSrcSpan loc $
- addStmtCtxt ((text "addArgCtxt bind 2e")) (unLoc stmt) $
- thing_inside
- | otherwise
- -> do traceTc "addArgCtxt 2e bind" empty
- setSrcSpanA arg_loc $
- addStmtCtxt ((text "addArgCtxt bind 2e")) (unLoc stmt) $
- thing_inside
-
- VAExpansionStmt (L _ LetStmt {}) _
- -> do traceTc "addArgCtxt 2e let" empty
- thing_inside
- _ -> do traceTc "addArgCtxt 3" empty
- setSrcSpanA arg_loc $
- addExprCtxt (text "addArgCtxt 3") arg $ -- Auto-suppressed if arg_loc is generated
- thing_inside }
+ VAExpansionStmt (L _ stmt@(BindStmt {})) loc
+ | isGeneratedSrcSpan (locA arg_loc) -- This arg is the second argument to generated (>>=)
+ -> setSrcSpan loc $
+ addStmtCtxt ((text "addArgCtxt bind 1")) stmt $
+ thing_inside
+ | otherwise -- This arg is the first argument to generated (>>=)
+ -> setSrcSpanA arg_loc $
+ addStmtCtxt ((text "addArgCtxt bind 2")) stmt $
+ thing_inside
+ VAExpansionStmt (L loc stmt) _
+ -> setSrcSpanA loc $
+ addStmtCtxt (text "addArgCtxt 2e") stmt $
+ thing_inside
+
+ _ -> setSrcSpanA arg_loc $
+ addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
+ thing_inside }
{- *********************************************************************
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -4,7 +4,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module Language.Haskell.Syntax.Extension
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -122,7 +121,7 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
tcPolyLExpr (L loc expr) res_ty
= setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
- addExprCtxt (text "tcPolyLExpr") expr $ -- Note [Error contexts in generated code]
+ addExprCtxt expr $ -- Note [Error contexts in generated code]
do { expr' <- tcPolyExpr expr res_ty
; return (L loc expr') }
@@ -148,7 +147,7 @@ tcMonoExpr, tcMonoExprNC
tcMonoExpr (L loc expr) res_ty
= setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
- addExprCtxt (text "tcMonoExpr") expr $ -- Note [Error contexts in generated code]
+ addExprCtxt expr $ -- Note [Error contexts in generated code]
do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
@@ -162,7 +161,7 @@ tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
-- Infer a *rho*-type. The return type is always instantiated.
tcInferRho (L loc expr)
= setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
- addExprCtxt (text "tcInferRho") expr $ -- Note [Error contexts in generated code]
+ addExprCtxt expr $ -- Note [Error contexts in generated code]
do { (expr', rho) <- tcInfer (tcExpr expr)
; return (L loc expr', rho) }
@@ -204,102 +203,13 @@ tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
tcExpr e@(HsVar {}) res_ty = tcApp e res_ty
-tcExpr e@(HsApp {}) res_ty = do traceTc "tcExpr" (text "hsApp")
- tcApp e res_ty
+tcExpr e@(HsApp {}) res_ty = tcApp e res_ty
tcExpr e@(OpApp {}) res_ty = tcApp e res_ty
tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty
tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty
tcExpr e@(HsRecSel {}) res_ty = tcApp e res_ty
-tcExpr e@(XExpr (ExpandedExpr {})) res_ty
- = do { traceTc "tcExpr" (text "ExpandedExpr")
- ; tcApp e res_ty
- }
-
-tcExpr rn_expr@(XExpr (PopErrCtxt (L _ e))) res_ty
- | XExpr (ExpandedStmt (HsExpanded stmt _)) <- e
- , L _ (LastStmt{}) <- stmt
- = do traceTc "tcExpr" (text "PopErrCtxt last stmt")
- popErrCtxt $
- -- setSrcSpanA loc $
- tcExpr e res_ty
- -- It is important that we call tcExpr and not tcApp here as
- -- `e` is just the last statement's body expression
- -- and not a HsApp of a generated (>>) or (>>=)
- -- This improves error messages e.g. T18324b.hs
-
- | XExpr (ExpandedStmt (HsExpanded stmt _)) <- e
- , L _ (LetStmt{}) <- stmt
- = do traceTc "tcExpr" (text "PopErrCtxt let stmt")
- popErrCtxt $
- -- setSrcSpanA loc $
- tcExpr e res_ty
- | XExpr (ExpandedStmt (HsExpanded stmt _)) <- e
- , L loc _ <- stmt
- = do traceTc "tcExpr" (text "PopErrCtxt tcApp")
- popErrCtxt $
- setSrcSpanA loc $
- tcApp e res_ty
- -- We call tcApp here as opposed to tcExpr
- -- as the head of the expression
- -- is a generated (>>) or a generated (>>=)
- -- and we associate it with an AppCtxt of VAExpansionStmt
- -- to get better error messages
- -- eg. T18324b.hs
- | otherwise = pprPanic "impossible happened tcExpr" (ppr rn_expr)
-
-tcExpr e@(XExpr (ExpandedStmt (HsExpanded stmt@(L loc s) expd_expr))) res_ty
- | LetStmt{} <- s
- , HsLet x tkLet binds tkIn e <- expd_expr
- = do { traceTc "tcDoStmts let" (vcat [ text "stmt:" <+> ppr stmt
- , text "expr:" <+> ppr expd_expr
- , text "res_ty:" <+> ppr res_ty
- , text "loc" <+> ppr loc
- ])
- ; (binds', e') <- setSrcSpanA loc $
- addStmtCtxt (text "tcExpr let") s $
- tcLocalBinds binds $
- tcMonoExprNC e res_ty
- ; return $ mkExpandedStmtTc stmt (HsLet x tkLet binds' tkIn e')
- }
- | BindStmt{} <- s
- = do { traceTc "tcDoStmts bind" (vcat [ text "stmt:" <+> ppr stmt
- , text "expr:" <+> ppr expd_expr
- , text "res_ty:" <+> ppr res_ty
- , text "loc" <+> ppr loc
- ])
- ; setSrcSpanA loc $
- mkExpandedStmtTc stmt <$> tcApp e res_ty
- }
- | BodyStmt{} <- s
- = do { traceTc "tcDoStmts Body" (vcat [ text "stmt:" <+> ppr stmt
- , text "expr:" <+> ppr expd_expr
- , text "res_ty:" <+> ppr res_ty
- , text "loc" <+> ppr loc
- ])
- ; setSrcSpanA loc $
- mkExpandedStmtTc stmt <$> tcApp e res_ty
- }
- | LastStmt{} <- s
- = do { traceTc "tcDoStmts last" (vcat [ text "stmt:" <+> ppr stmt
- , text "expr:" <+> ppr expd_expr
- , text "res_ty:" <+> ppr res_ty
- , text "loc" <+> ppr loc
- ])
- ; setSrcSpanA loc $
- addStmtCtxt (text "tcExpr last") s $
- mkExpandedStmtTc stmt <$> tcExpr expd_expr res_ty
- }
- | otherwise
- = do { traceTc "tcDoStmts other" (vcat [ text "stmt:" <+> ppr stmt
- , text "expr:" <+> ppr expd_expr
- , text "res_ty:" <+> ppr res_ty
- , text "loc" <+> ppr loc
- ])
- ; setSrcSpanA loc $
- addStmtCtxt (text "tcExpr other") s $
- mkExpandedStmtTc stmt <$> tcExpr expd_expr res_ty
- }
+tcExpr (XExpr e) res_ty = tcXExpr e res_ty
tcExpr e@(HsOverLit _ lit) res_ty
= do { mb_res <- tcShortCutLit lit res_ty
@@ -478,7 +388,6 @@ tcExpr (HsCase x scrut matches) res_ty
-- This design choice is discussed in #17790
; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut
- ; traceTc "HsCase" (ppr scrut_ty)
; hasFixedRuntimeRep_syntactic FRRCase scrut_ty
; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty
; return (HsCase x scrut' matches') }
@@ -506,14 +415,13 @@ tcExpr hsDo@(HsDo _ do_or_lc@(DoExpr{}) ss@(L _ stmts)) res_ty
-- See Note [Expanding HsDo with HsExpansion] in GHC.Tc.Gen.Match.hs
= do { isApplicativeDo <- xoptM LangExt.ApplicativeDo
; if isApplicativeDo
- 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
+ then tcDoStmts do_or_lc ss res_ty -- Use tcSyntaxOp if ApplicativeDo is turned on
+ else do { expanded_expr <- expandDoStmts do_or_lc stmts
-- Do expansion on the fly
- ; traceTc "tcDoStmts hsDo" (vcat [ ppr hsDo
- , text "expr:" <+> ppr expanded_expr
- ])
- ; -- setSrcSpanA loc $
- mkExpandedExprTc hsDo <$> (tcExpr expanded_expr res_ty)
+ -- ; traceTc "tcDoStmts hsDo" (vcat [ ppr hsDo
+ -- , text "expr:" <+> ppr expanded_expr
+ -- ])
+ ; mkExpandedExprTc hsDo <$> tcExpr (unLoc expanded_expr) res_ty
}
}
@@ -712,6 +620,46 @@ tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty)
tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
+{-
+************************************************************************
+* *
+ Expansion Expressions (XXExprGhcRn)
+* *
+************************************************************************
+-}
+
+tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+
+tcXExpr xe@(ExpandedExpr {}) res_ty = tcApp (XExpr xe) res_ty
+
+tcXExpr xe@(ExpandedStmt (HsExpanded stmt@(L loc s) expd_expr)) res_ty
+ | LetStmt{} <- s
+ , HsLet x tkLet binds tkIn e <- expd_expr
+ = do { (binds', e') <- setSrcSpanA loc $
+ addStmtCtxt (text "tcExpr let") s $
+ tcLocalBinds binds $
+ tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds
+ -- a duplicate error context
+ ; return $ mkExpandedStmtTc stmt (HsLet x tkLet binds' tkIn e')
+ }
+ | LastStmt{} <- s
+ = setSrcSpanA loc $
+ addStmtCtxt (text "tcExpr last") s $
+ mkExpandedStmtTc stmt <$> tcExpr expd_expr res_ty
+ -- It is important that we call tcExpr (and not tcApp) here as
+ -- `e` is just the last statement's body expression
+ -- and not a HsApp of a generated (>>) or (>>=)
+ -- This improves error messages e.g. T18324b.hs
+ | otherwise = setSrcSpanA loc $
+ mkExpandedStmtTc stmt <$> tcApp (XExpr xe) res_ty
+
+tcXExpr (PopErrCtxt (L loc e)) res_ty
+ = popErrCtxt $
+ setSrcSpanA loc $
+ tcExpr e res_ty
+
+
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -5,7 +5,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DisambiguateRecordFields #-}
@@ -856,7 +855,7 @@ addHeadCtxt fun_ctxt thing_inside
= setSrcSpan fun_loc $
do traceTc "addHeadCtxt okay" (ppr fun_ctxt)
case fun_ctxt of
- VAExpansion orig _ -> addExprCtxt (text "addHeadCtxt") orig thing_inside
+ VAExpansion orig _ -> addExprCtxt orig thing_inside
VACall {} -> thing_inside
where
fun_loc = appCtxtLoc fun_ctxt
@@ -1554,16 +1553,15 @@ addStmtCtxt doc stmt thing_inside
-- 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
+addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
+addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
- --- XExpr (ExpandedStmt (HsExpanded stmt _)) -> addStmtCtxt doc stmt thing_inside
- _ -> addErrCtxt (exprCtxt doc e) thing_inside
+ _ -> addErrCtxt (exprCtxt e) thing_inside
-- The HsUnboundVar special case addresses situations like
-- f x = _
-- when we don't want to say "In the expression: _",
-- because it is mentioned in the error message itself
-exprCtxt :: SDoc -> HsExpr GhcRn -> SDoc
-exprCtxt _ expr = hang ({-doc <+>-} text "In the expression:") 2 (ppr (stripParensHsExpr expr))
+exprCtxt :: HsExpr GhcRn -> SDoc
+exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr))
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -44,7 +44,10 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC
, tcCheckMonoExpr, tcCheckMonoExprNC
, tcCheckPolyExpr )
-import GHC.Rename.Utils ( bindLocalNames, wrapGenSpan, isIrrefutableHsPatRn )
+import GHC.Rename.Utils ( bindLocalNames, wrapGenSpan, isIrrefutableHsPatRn,
+ genHsExpApps, genLHsApp, genHsApp, genHsLet,
+ genHsLamDoExp, genHsCaseAltDoExp,
+ genWildPat )
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
@@ -1211,17 +1214,8 @@ checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
************************************************************************
-}
-
--- | Generated location for PopSrcExpr
--- genPopSrcSpanExpr :: LHsExpr GhcRn -> LHsExpr GhcRn
--- genPopSrcSpanExpr = wrapGenSpan . mkPopErrCtxtExpr
-
--- mkExpandedStmtLExpr
--- :: ExprLStmt GhcRn -- ^ source statement
--- -> LHsExpr GhcRn -- ^ expanded expression
--- -> LHsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
--- mkExpandedStmtLExpr a b = noLocA $ mkExpandedStmt a b
-
+-- | Expand the Do statments so that it works fine with Quicklook impredicativity
+-- See Note [Expanding HsDo with HsExpansion]
expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts
case expanded_expr of
@@ -1231,8 +1225,8 @@ expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts
-- the error context
_ -> return expanded_expr
--- | Expand the Do statments so that it works fine with Quicklook
--- See Note[Rebindable Do and Expanding Statements]
+-- | The main work horse for expanding do block statements into applications of binds and thens
+-- See Note [Expanding HsDo with HsExpansion]
expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
expand_do_stmts ListComp _ = pprPanic "expand_do_stmts: impossible happened. ListComp" empty
@@ -1248,13 +1242,13 @@ expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
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))]
+expand_do_stmts _ [stmt@(L loc (LastStmt _ (L body_loc 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
= do traceTc "expand_do_stmts last" (ppr ret_expr)
- return $ L loc (mkPopErrCtxtExpr $ L loc (mkExpandedStmt stmt body))
+ return $ mkExpandedStmtPopAt body_loc stmt body
| SyntaxExprRn ret <- ret_expr
--
@@ -1262,37 +1256,33 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ (L _ body) _ ret_expr))]
-- return e ~~> return e
-- to make T18324 work
= do traceTc "expand_do_stmts last" (ppr ret_expr)
- return $ L loc (mkPopErrCtxtExpr $
- L loc (mkExpandedStmt stmt (
- genHsApp (wrapGenSpan ret) (L loc body))))
+ let expansion = genHsApp ret (L body_loc body)
+ return $ mkExpandedStmtPopAt loc stmt expansion
expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bs)) : lstmts) =
-- stmts ~~> stmts'
-- ------------------------------------------------
-- let x = e ; stmts ~~> let x = e in stmts'
do expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ L loc (mkPopErrCtxtExpr $
- L loc (mkExpandedStmt stmt (genHsLet bs $ expand_stmts)))
+ let expansion = genHsLet bs expand_stmts
+ return $ mkExpandedStmtPopAt loc stmt expansion
expand_do_stmts do_or_lc (stmt@(L loc (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 lambda
+-- instead of making a new internal name, the fail block is just an anonymous lambda
-- stmts ~~> stmt' f = / -> pat = stmts';
-- _ = fail "Pattern match failure .."
-- -------------------------------------------------------
-- pat <- e ; stmts ~~> (>>=) e f
- 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_expr pat
- expand_stmts
- fail_op
- return $ L loc (mkPopErrCtxtExpr $ (L loc (mkExpandedStmt stmt (
- (wrapGenSpan ((wrapGenSpan bind_op) -- (>>=)
- `genHsApp` e))
- `genHsApp` expr))))
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ failable_expr <- mk_failable_expr pat expand_stmts fail_op
+ let expansion = genHsExpApps bind_op -- (>>=)
+ [ e
+ , failable_expr ]
+ return $ mkExpandedStmtPopAt loc stmt expansion
+
| otherwise
= pprPanic "expand_do_stmts: The impossible happened, missing bind operator" (text "stmt" <+> ppr stmt)
@@ -1302,22 +1292,22 @@ expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) :
-- ----------------------------------------------
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts_expr <- expand_do_stmts do_or_lc lstmts
- return $ L loc (mkPopErrCtxtExpr $ (L loc (mkExpandedStmt stmt (
- (wrapGenSpan ((wrapGenSpan then_op) -- (>>)
- `genHsApp` e))
- `genHsApp` expand_stmts_expr))))
+ let expansion = genHsExpApps then_op -- (>>)
+ [ e
+ , expand_stmts_expr ]
+ return $ mkExpandedStmtPopAt loc stmt expansion
expand_do_stmts do_or_lc
- ((L do_loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
- , recS_later_ids = later_ids -- forward referenced local ids
- , recS_rec_ids = local_ids -- ids referenced outside of the rec block
- , recS_bind_fn = SyntaxExprRn bind_fun -- the (>>=) expr
- , recS_mfix_fn = SyntaxExprRn mfix_fun -- the `mfix` expr
- , recS_ret_fn = SyntaxExprRn return_fun -- the `return` expr
+ ((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
+ , recS_later_ids = later_ids -- forward referenced local ids
+ , recS_rec_ids = local_ids -- ids referenced outside of the rec block
+ , recS_bind_fn = SyntaxExprRn bind_fun -- the (>>=) expr
+ , recS_mfix_fn = SyntaxExprRn mfix_fun -- the `mfix` expr
+ , recS_ret_fn = SyntaxExprRn return_fun -- the `return` expr
-- use it explicitly
-- at the end of expanded rec block
- }))
- : lstmts) =
+ }))
+ : lstmts) =
-- See Note [Typing a RecStmt]
-- stmts ~~> stmts'
-- -------------------------------------------------------------------------------------------
@@ -1327,6 +1317,8 @@ expand_do_stmts do_or_lc
-- ; return (local_only_ids ++ later_ids) } ))
-- (\ [ local_only_ids ++ later_ids ] -> stmts')
do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ -- NB: No need to wrap the expansion with an ExpandedStmt
+ -- as we want to flatten the rec block statements into its parent do block anyway
return $ mkHsApps (wrapGenSpan bind_fun) -- (>>=)
[ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
, genHsLamDoExp [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
@@ -1345,7 +1337,7 @@ expand_do_stmts do_or_lc
do_stmts :: XRec GhcRn [ExprLStmt GhcRn]
do_stmts = L stmts_loc $ rec_stmts ++ [return_stmt]
do_block :: LHsExpr GhcRn
- do_block = L do_loc $ HsDo noExtField (DoExpr Nothing) $ do_stmts
+ do_block = L loc $ HsDo noExtField do_or_lc do_stmts
mfix_expr :: LHsExpr GhcRn
mfix_expr = genHsLamDoExp [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ] $ do_block
-- NB: LazyPat because we do not want to eagerly evaluate the pattern
@@ -1353,8 +1345,8 @@ expand_do_stmts do_or_lc
expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
-mk_failable_expr :: 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 :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
mk_failable_expr pat@(L loc _) expr fail_op =
do { tc_env <- getGblEnv
; is_strict <- xoptM LangExt.Strict
@@ -1363,9 +1355,8 @@ mk_failable_expr pat@(L loc _) expr fail_op =
, text "isIrrefutable:" <+> ppr irrf_pat
])
- ; if irrf_pat
- -- don't decorate with fail block if
- -- the pattern is irrefutable
+ ; if irrf_pat -- don't decorate with fail block if
+ -- the pattern is irrefutable
then return $ genHsLamDoExp [pat] expr
else L loc <$> mk_fail_block pat expr fail_op
}
@@ -1374,59 +1365,23 @@ mk_failable_expr pat@(L loc _) expr fail_op =
mk_fail_block :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
mk_fail_block pat e (Just (SyntaxExprRn fail_op)) =
do dflags <- getDynFlags
- return $ 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))
- ])
+ return $ HsLam noExtField $ mkMatchGroup doExpansionOrigin -- \
+ (wrapGenSpan [ genHsCaseAltDoExp pat e -- pat -> expr
+ , fail_alt_case dflags pat -- _ -> fail "fail pattern"
+ ])
where
+ fail_alt_case dflags pat = genHsCaseAltDoExp genWildPat $
+ genLHsApp fail_op (mk_fail_msg_expr dflags pat)
+
mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
mk_fail_msg_expr dflags pat
= nlHsLit $ mkHsString $ showPpr dflags $
text "Pattern match failure in" <+> pprHsDoFlavour (DoExpr Nothing)
<+> text "at" <+> ppr (getLocA pat)
-mk_fail_block _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
-
-genHsApp :: LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
-genHsApp fun arg = HsApp noAnn fun arg
+mk_fail_block _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
-genHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
- => [LPat (GhcPass p)]
- -> LHsExpr (GhcPass p)
- -> LHsExpr (GhcPass p)
-genHsLamDoExp pats body = mkHsPar (wrapGenSpan $ HsLam noExtField matches)
- where
- matches = mkMatchGroup doExpansionOrigin
- (wrapGenSpan [genSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) pats' body])
- pats' = map (parenthesizePat appPrec) pats
-
-
-genHsCaseAltDoExp :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
- ~ SrcAnn NoEpAnns,
- Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
- ~ SrcSpanAnnA)
- => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))
- -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
-genHsCaseAltDoExp pat expr
- = genSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) [pat] expr
-
-
-genSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
- ~ SrcSpanAnnA,
- Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
- ~ SrcAnn NoEpAnns)
- => HsMatchContext (GhcPass p)
- -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
- -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
-genSimpleMatch ctxt pats rhs
- = wrapGenSpan $
- Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = pats
- , m_grhss = unguardedGRHSs generatedSrcSpan rhs noAnn }
-
-genHsLet :: HsLocalBindsLR GhcRn GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
-genHsLet bindings body = HsLet noExtField noHsTok bindings noHsTok body
{- Note [Expanding HsDo with HsExpansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b59d091f8e359643f69830f7348a20a2b46a69a1...54f1a8f90a47820a20e98efcb417e50edc8e6c3a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b59d091f8e359643f69830f7348a20a2b46a69a1...54f1a8f90a47820a20e98efcb417e50edc8e6c3a
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/20230804/fb3dac8d/attachment-0001.html>
More information about the ghc-commits
mailing list