[Git][ghc/ghc][wip/sand-witch/lazy-skol] 2 commits: Make the right HsMatchContext for record updates
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Jan 29 22:26:38 UTC 2024
Simon Peyton Jones pushed to branch wip/sand-witch/lazy-skol at Glasgow Haskell Compiler / GHC
Commits:
3653ac86 by Simon Peyton Jones at 2024-01-29T19:45:21+00:00
Make the right HsMatchContext for record updates
- - - - -
10349a90 by Simon Peyton Jones at 2024-01-29T22:23:56+00:00
Deal (again) with HsMatchContext
- - - - -
26 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/HsToCore/Errors/Ppr.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- compiler/GHC/HsToCore/GuardedRHSs.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match.hs-boot
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Utils.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Expr.hs-boot
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Deriv/Functor.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Expr.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -280,8 +280,8 @@ type instance XExplicitSum GhcRn = NoExtField
type instance XExplicitSum GhcTc = [Type]
type instance XCase GhcPs = EpAnn EpAnnHsCase
-type instance XCase GhcRn = HsMatchContext GhcTc
-type instance XCase GhcTc = HsMatchContext GhcTc
+type instance XCase GhcRn = HsMatchContextRn
+type instance XCase GhcTc = HsMatchContextRn
type instance XIf GhcPs = EpAnn AnnsIf
type instance XIf GhcRn = NoExtField
@@ -1943,7 +1943,11 @@ pp_dotdot = text " .. "
************************************************************************
-}
-instance Outputable (LIdP (NoGhcTc p)) => Outputable (HsMatchContext p) where
+type HsMatchContextPs = HsMatchContext (LIdP GhcPs)
+type HsMatchContextRn = HsMatchContext (LIdP GhcRn)
+type HsStmtContextRn = HsStmtContext (LIdP GhcRn)
+
+instance Outputable fn => Outputable (HsMatchContext fn) where
ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)
ppr CaseAlt = text "CaseAlt"
ppr (LamAlt lam_variant) = text "LamAlt" <+> ppr lam_variant
@@ -1984,11 +1988,11 @@ pprHsArrType HsFirstOrderApp = text "first order arrow application"
-----------------
-instance Outputable (LIdP (NoGhcTc p)) => Outputable (HsStmtContext p) where
+instance Outputable fn => Outputable (HsStmtContext fn) where
ppr = pprStmtContext
-- Used to generate the string for a *runtime* error message
-matchContextErrString :: Outputable (LIdP (NoGhcTc p)) => HsMatchContext p -> SDoc
+matchContextErrString :: Outputable fn => HsMatchContext fn -> SDoc
matchContextErrString (FunRhs{mc_fun=fun}) = text "function" <+> ppr fun
matchContextErrString CaseAlt = text "case"
matchContextErrString (LamAlt lam_variant) = lamCaseKeyword lam_variant
@@ -2028,10 +2032,10 @@ pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
pprStmtInCtxt :: (OutputableBndrId idL,
OutputableBndrId idR,
- Outputable (LIdP (NoGhcTc p)),
+ Outputable fn,
Outputable body,
Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)
- => HsStmtContext p
+ => HsStmtContext fn
-> StmtLR (GhcPass idL) (GhcPass idR) body
-> SDoc
pprStmtInCtxt ctxt (LastStmt _ e _ _)
@@ -2047,7 +2051,7 @@ pprStmtInCtxt ctxt stmt
, trS_form = form }) = pprTransStmt by using form
ppr_stmt stmt = pprStmt stmt
-pprMatchContext :: Outputable (LIdP (NoGhcTc p)) => HsMatchContext p -> SDoc
+pprMatchContext :: Outputable fn => HsMatchContext fn -> SDoc
pprMatchContext ctxt
| want_an ctxt = text "an" <+> pprMatchContextNoun ctxt
| otherwise = text "a" <+> pprMatchContextNoun ctxt
@@ -2058,7 +2062,7 @@ pprMatchContext ctxt
want_an LazyPatCtx = True
want_an _ = False
-pprMatchContextNoun :: Outputable (LIdP (NoGhcTc p)) => HsMatchContext p -> SDoc
+pprMatchContextNoun :: Outputable fn => HsMatchContext fn -> SDoc
pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for" <+> quotes (ppr fun)
pprMatchContextNoun CaseAlt = text "case alternative"
pprMatchContextNoun (LamAlt LamSingle) = text "lambda abstraction"
@@ -2076,7 +2080,7 @@ pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
pprMatchContextNoun PatSyn = text "pattern synonym declaration"
pprMatchContextNoun LazyPatCtx = text "irrefutable pattern"
-pprMatchContextNouns :: Outputable (LIdP (NoGhcTc p)) => HsMatchContext p -> SDoc
+pprMatchContextNouns :: Outputable fn => HsMatchContext fn -> SDoc
pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for" <+> quotes (ppr fun)
pprMatchContextNouns PatBindGuards = text "pattern binding guards"
pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c
@@ -2099,7 +2103,7 @@ pprArrowMatchContextNouns (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant
pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's'
-----------------
-pprAStmtContext, pprStmtContext :: Outputable (LIdP (NoGhcTc p)) => HsStmtContext p -> SDoc
+pprAStmtContext, pprStmtContext :: Outputable fn => HsStmtContext fn -> SDoc
pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour
pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -386,15 +386,8 @@ deriving instance Data (ApplicativeArg GhcTc)
deriving instance Data HsArrowMatchContext
deriving instance Data HsDoFlavour
--- Triplicated instances -- ugh!
-deriving instance Data (HsStmtContext GhcPs)
-deriving instance Data (HsStmtContext GhcRn)
-deriving instance Data (HsStmtContext GhcTc)
-
--- Triplicated instances -- ugh!
-deriving instance Data (HsMatchContext GhcPs)
-deriving instance Data (HsMatchContext GhcRn)
-deriving instance Data (HsMatchContext GhcTc)
+deriving instance Data fn => Data (HsStmtContext fn)
+deriving instance Data fn => Data (HsMatchContext fn)
-- deriving instance (DataIdLR p p) => Data (HsUntypedSplice p)
deriving instance Data (HsUntypedSplice GhcPs)
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -186,7 +186,7 @@ mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ EpAnn NoEpAnns)
- => HsMatchContext (GhcPass p)
+ => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch ctxt pats rhs
@@ -895,18 +895,18 @@ mkSimpleGeneratedFunBind loc fun pats expr
= L (noAnnSrcSpan loc) $ mkFunBind (Generated SkipPmc) (L (noAnnSrcSpan loc) fun)
[mkMatch ctxt pats expr emptyLocalBinds]
where
- ctxt :: HsMatchContext GhcPs
+ ctxt :: HsMatchContextPs
ctxt = mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)
-- | Make a prefix, non-strict function 'HsMatchContext'
-mkPrefixFunRhs :: LIdP (NoGhcTc p) -> HsMatchContext p
+mkPrefixFunRhs :: fn -> HsMatchContext fn
mkPrefixFunRhs n = FunRhs { mc_fun = n
, mc_fixity = Prefix
, mc_strictness = NoSrcStrict }
------------
mkMatch :: forall p. IsPass p
- => HsMatchContext (GhcPass p)
+ => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
=====================================
compiler/GHC/HsToCore/Arrows.hs
=====================================
@@ -1190,7 +1190,7 @@ dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
-- Match a list of expressions against a list of patterns, left-to-right.
matchSimplys :: [CoreExpr] -- Scrutinees
- -> HsMatchContext GhcTc -- Match kind
+ -> HsMatchContextRn -- Match kind
-> [LPat GhcTc] -- Patterns they should match
-> CoreExpr -- Return this if they all match
-> CoreExpr -- Return this if they don't
=====================================
compiler/GHC/HsToCore/Errors/Ppr.hs
=====================================
@@ -304,11 +304,11 @@ badMonadBind elt_ty
2 (quotes (ppr elt_ty))
-- Print a single clause (for redundant/with-inaccessible-rhs)
-pprEqn :: HsMatchContext GhcTc -> SDoc -> String -> SDoc
+pprEqn :: HsMatchContextRn -> SDoc -> String -> SDoc
pprEqn ctx q txt = pprContext True ctx (text txt) $ \f ->
f (q <+> matchSeparator ctx <+> text "...")
-pprContext :: Bool -> HsMatchContext GhcTc -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
+pprContext :: Bool -> HsMatchContextRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext singular kind msg rest_of_msg_fun
= vcat [text txt <+> msg,
sep [ text "In" <+> ppr_match <> char ':'
=====================================
compiler/GHC/HsToCore/Errors/Types.hs
=====================================
@@ -86,18 +86,18 @@ data DsMessage
-- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately
-- 'SrcInfo' gives us an 'SDoc' to begin with.
- | DsRedundantBangPatterns !(HsMatchContext GhcTc) !SDoc
+ | DsRedundantBangPatterns !HsMatchContextRn !SDoc
-- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately
-- 'SrcInfo' gives us an 'SDoc' to begin with.
- | DsOverlappingPatterns !(HsMatchContext GhcTc) !SDoc
+ | DsOverlappingPatterns !HsMatchContextRn !SDoc
-- FIXME(adn) Use a proper type instead of 'SDoc'
- | DsInaccessibleRhs !(HsMatchContext GhcTc) !SDoc
+ | DsInaccessibleRhs !HsMatchContextRn !SDoc
| DsMaxPmCheckModelsReached !MaxPmCheckModels
- | DsNonExhaustivePatterns !(HsMatchContext GhcTc)
+ | DsNonExhaustivePatterns !HsMatchContextRn
!ExhaustivityCheckType
!MaxUncoveredPatterns
[Id]
=====================================
compiler/GHC/HsToCore/GuardedRHSs.hs
=====================================
@@ -54,7 +54,7 @@ dsGuarded grhss rhs_ty rhss_nablas = do
-- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr at .
-dsGRHSs :: HsMatchContext GhcTc
+dsGRHSs :: HsMatchContextRn
-> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs
-> Type -- ^ Type of RHS
-> NonEmpty Nablas -- ^ Refined pattern match checking
@@ -75,7 +75,7 @@ dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas
-- NB: nested dsLet inside matchResult
; return match_result2 }
-dsGRHS :: HsMatchContext GhcTc -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)
+dsGRHS :: HsMatchContextRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)
-> DsM (MatchResult CoreExpr)
dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))
= matchGuards (map unLoc guards) hs_ctx rhs_nablas rhs rhs_ty
@@ -89,7 +89,7 @@ dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))
-}
matchGuards :: [GuardStmt GhcTc] -- Guard
- -> HsMatchContext GhcTc -- Context
+ -> HsMatchContextRn -- Context
-> Nablas -- The RHS's covered set for PmCheck
-> LHsExpr GhcTc -- RHS
-> Type -- Type of RHS of guard
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -733,7 +733,7 @@ Call @match@ with all of this information!
-- p2 q2 -> ...
matchWrapper
- :: HsMatchContext GhcTc -- ^ For shadowing warning messages
+ :: HsMatchContextRn -- ^ For shadowing warning messages
-> Maybe [LHsExpr GhcTc] -- ^ Scrutinee(s)
-- see Note [matchWrapper scrutinees]
-> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared
@@ -875,7 +875,7 @@ the expression (in this case, it will end up recursively calling 'matchWrapper'
on the user-written case statement).
-}
-matchEquations :: HsMatchContext GhcTc
+matchEquations :: HsMatchContextRn
-> [MatchId] -> [EquationInfo] -> Type
-> DsM CoreExpr
matchEquations ctxt vars eqns_info rhs_ty
@@ -889,7 +889,7 @@ matchEquations ctxt vars eqns_info rhs_ty
-- situation where we want to match a single expression against a single
-- pattern. It returns an expression.
matchSimply :: CoreExpr -- ^ Scrutinee
- -> HsMatchContext GhcTc -- ^ Match kind
+ -> HsMatchContextRn -- ^ Match kind
-> Mult -- ^ Scaling factor of the case expression
-> LPat GhcTc -- ^ Pattern it should match
-> CoreExpr -- ^ Return this if it matches
@@ -912,7 +912,7 @@ matchSimply scrut hs_ctx mult pat result_expr fail_expr = do
match_result' <- matchSinglePat scrut hs_ctx pat mult rhs_ty match_result
extractMatchResult match_result' fail_expr
-matchSinglePat :: CoreExpr -> HsMatchContext GhcTc -> LPat GhcTc -> Mult
+matchSinglePat :: CoreExpr -> HsMatchContextRn -> LPat GhcTc -> Mult
-> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
-- matchSinglePat ensures that the scrutinee is a variable
-- and then calls matchSinglePatVar
@@ -933,7 +933,7 @@ matchSinglePat scrut hs_ctx pat mult ty match_result
matchSinglePatVar :: Id -- See Note [Match Ids]
-> Maybe CoreExpr -- ^ The scrutinee the match id is bound to
- -> HsMatchContext GhcTc -> LPat GhcTc
+ -> HsMatchContextRn -> LPat GhcTc
-> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
matchSinglePatVar var mb_scrut ctx pat ty match_result
= assertPpr (isInternalName (idName var)) (ppr var) $
=====================================
compiler/GHC/HsToCore/Match.hs-boot
=====================================
@@ -5,7 +5,8 @@ import GHC.Types.Var ( Id )
import GHC.Tc.Utils.TcType ( Type )
import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult )
import GHC.Core ( CoreExpr )
-import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr, Mult )
+import GHC.Hs ( LPat, MatchGroup, LHsExpr, Mult )
+import GHC.Hs.Expr( HsMatchContextRn )
import GHC.Hs.Extension ( GhcTc )
match :: [Id]
@@ -14,14 +15,14 @@ match :: [Id]
-> DsM (MatchResult CoreExpr)
matchWrapper
- :: HsMatchContext GhcTc
+ :: HsMatchContextRn
-> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchSimply
:: CoreExpr
- -> HsMatchContext GhcTc
+ -> HsMatchContextRn
-> Mult
-> LPat GhcTc
-> CoreExpr
@@ -31,7 +32,7 @@ matchSimply
matchSinglePatVar
:: Id
-> Maybe CoreExpr
- -> HsMatchContext GhcTc
+ -> HsMatchContextRn
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -125,7 +125,7 @@ import qualified Data.Set as S
-}
data DsMatchContext
- = DsMatchContext (HsMatchContext GhcTc) SrcSpan
+ = DsMatchContext HsMatchContextRn SrcSpan
deriving ()
instance Outputable DsMatchContext where
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -128,7 +128,7 @@ pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p
-- | Exhaustive for guard matches, is used for guards in pattern bindings and
-- in @MultiIf@ expressions. Returns the 'Nablas' covered by the RHSs.
pmcGRHSs
- :: HsMatchContext GhcTc -- ^ Match context, for warning messages
+ :: HsMatchContextRn -- ^ Match context, for warning messages
-> GRHSs GhcTc (LHsExpr GhcTc) -- ^ The GRHSs to check
-> DsM (NonEmpty Nablas) -- ^ Covered 'Nablas' for each RHS, for long
-- distance info
=====================================
compiler/GHC/HsToCore/Pmc/Utils.hs
=====================================
@@ -65,13 +65,13 @@ allPmCheckWarnings =
]
-- | Check whether the redundancy checker should run (redundancy only)
-overlapping :: DynFlags -> HsMatchContext p -> Bool
+overlapping :: DynFlags -> HsMatchContext fn -> Bool
-- See Note [Inaccessible warnings for record updates]
overlapping _ RecUpd = False
overlapping dflags _ = wopt Opt_WarnOverlappingPatterns dflags
-- | Check whether the exhaustiveness checker should run (exhaustiveness only)
-exhaustive :: DynFlags -> HsMatchContext p -> Bool
+exhaustive :: DynFlags -> HsMatchContext fn -> Bool
exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
-- | Check whether unnecessary bangs should be warned about
@@ -81,7 +81,7 @@ redundantBang dflags = wopt Opt_WarnRedundantBangPatterns dflags
-- | Denotes whether an exhaustiveness check is supported, and if so,
-- via which 'WarningFlag' it's controlled.
-- Returns 'Nothing' if check is not supported.
-exhaustiveWarningFlag :: HsMatchContext p -> Maybe WarningFlag
+exhaustiveWarningFlag :: HsMatchContext fn -> Maybe WarningFlag
exhaustiveWarningFlag FunRhs{} = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag IfAlt = Just Opt_WarnIncompletePatterns
@@ -116,7 +116,7 @@ isMatchContextPmChecked dflags origin ctxt
-- | Check whether exhaustivity checks are enabled for this 'HsMatchContext',
-- when dealing with a single pattern (using the 'matchSinglePatVar' function).
-isMatchContextPmChecked_SinglePat :: DynFlags -> Origin -> HsMatchContext p -> LPat GhcTc -> Bool
+isMatchContextPmChecked_SinglePat :: DynFlags -> Origin -> HsMatchContext fn -> LPat GhcTc -> Bool
isMatchContextPmChecked_SinglePat dflags origin ctxt pat
| not (needToRunPmCheck dflags origin)
= False
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -459,7 +459,7 @@ For uniformity, calls to 'error' in both cases are wrapped even if -XLinearTypes
is disabled.
-}
-mkFailExpr :: HsMatchContext GhcTc -> Type -> DsM CoreExpr
+mkFailExpr :: HsMatchContextRn -> Type -> DsM CoreExpr
mkFailExpr ctxt ty
= mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
@@ -736,7 +736,7 @@ work out well:
-- to select Many as the multiplicity of every let-expression introduced.
mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly
-> LPat GhcTc -- ^ The pattern
- -> HsMatchContext GhcTc -- ^ Where the pattern occurs
+ -> HsMatchContextRn -- ^ Where the pattern occurs
-> CoreExpr -- ^ Expression to which the pattern is bound
-> DsM (Id,[(Id,CoreExpr)])
-- ^ Id the rhs is bound to, for desugaring strict
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -932,7 +932,8 @@ instance ( HiePass p
, toHie grhss
]
-toHieHsMatchContext :: forall p. HiePass p => HsMatchContext (GhcPass p) -> HieM [HieAST Type]
+toHieHsMatchContext :: forall p. HiePass p => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
+ -> HieM [HieAST Type]
toHieHsMatchContext ctxt
= case ctxt of
FunRhs{mc_fun=name} -> toHie $ C MatchBind (get_name name)
@@ -945,7 +946,8 @@ toHieHsMatchContext ctxt
HieRn -> name
HieTc -> name
-toHieHsStmtContext :: forall p. HiePass p => HsStmtContext (GhcPass p) -> HieM [HieAST Type]
+toHieHsStmtContext :: forall p. HiePass p => HsStmtContext (LIdP (NoGhcTc (GhcPass p)))
+ -> HieM [HieAST Type]
toHieHsStmtContext ctxt
= case ctxt of
PatGuard a -> toHieHsMatchContext @p a
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -1276,7 +1276,7 @@ type AnnoBody body
-- \cases expressions or commands. In that case, or if we encounter an empty
-- MatchGroup but -XEmptyCases is disabled, we add an error.
-rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn
+rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
@@ -1292,14 +1292,14 @@ rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin })
_ -> not <$> xoptM LangExt.EmptyCase
rnMatch :: AnnoBody body
- => HsMatchContext GhcRn
+ => HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> LMatch GhcPs (LocatedA (body GhcPs))
-> RnM (LMatch GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatch ctxt rnBody = wrapLocFstMA (rnMatch' ctxt rnBody)
rnMatch' :: (AnnoBody body)
- => HsMatchContext GhcRn
+ => HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> Match GhcPs (LocatedA (body GhcPs))
-> RnM (Match GhcRn (LocatedA (body GhcRn)), FreeVars)
@@ -1323,7 +1323,7 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
-}
rnGRHSs :: AnnoBody body
- => HsMatchContext GhcRn
+ => HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> GRHSs GhcPs (LocatedA (body GhcPs))
-> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), FreeVars)
@@ -1333,13 +1333,13 @@ rnGRHSs ctxt rnBody (GRHSs _ grhss binds)
return (GRHSs emptyComments grhss' binds', fvGRHSs)
rnGRHS :: AnnoBody body
- => HsMatchContext GhcRn
+ => HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> LGRHS GhcPs (LocatedA (body GhcPs))
-> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars)
rnGRHS ctxt rnBody = wrapLocFstMA (rnGRHS' ctxt rnBody)
-rnGRHS' :: HsMatchContext GhcRn
+rnGRHS' :: HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> GRHS GhcPs (LocatedA (body GhcPs))
-> RnM (GRHS GhcRn (LocatedA (body GhcRn)), FreeVars)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -1052,7 +1052,7 @@ type AnnoBody body
-- | Rename some Stmts
rnStmts :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-- ^ How to rename the body of each statement (e.g. rnLExpr)
-> [LStmt GhcPs (LocatedA (body GhcPs))]
@@ -1088,14 +1088,14 @@ postProcessStmtsForApplicativeDo ctxt stmts
-- | strip the FreeVars annotations from statements
noPostProcessStmts
- :: HsStmtContext GhcRn
+ :: HsStmtContextRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
rnStmtsWithFreeVars :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> ((body GhcPs) -> RnM ((body GhcRn), FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
@@ -1158,7 +1158,7 @@ At one point we failed to make this distinction, leading to #11216.
-}
rnStmt :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-- ^ How to rename the body of the statement
-> LStmt GhcPs (LocatedA (body GhcPs))
@@ -1303,7 +1303,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
rnStmt _ _ (L _ ApplicativeStmt{}) _ =
panic "rnStmt: ApplicativeStmt"
-rnParallelStmts :: forall thing. HsStmtContext GhcRn
+rnParallelStmts :: forall thing. HsStmtContextRn
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
-> ([Name] -> RnM (thing, FreeVars))
@@ -1335,7 +1335,7 @@ rnParallelStmts ctxt return_op segs thing_inside
dupErr vs = addErr $ TcRnListComprehensionDuplicateBinding (NE.head vs)
-lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
+lookupQualifiedDoStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
-- Like lookupStmtName, but respects QualifiedDo
lookupQualifiedDoStmtName ctxt n
= case qualifiedDoModuleName_maybe ctxt of
@@ -1343,7 +1343,7 @@ lookupQualifiedDoStmtName ctxt n
Just modName ->
first (mkSyntaxExpr . nl_HsVar) <$> lookupNameWithQualifier n modName
-lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
+lookupStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
-- Like lookupSyntax, but respects contexts
lookupStmtName ctxt n
| rebindableContext ctxt
@@ -1351,7 +1351,7 @@ lookupStmtName ctxt n
| otherwise
= return (mkRnSyntaxExpr n, emptyFVs)
-lookupStmtNamePoly :: HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
+lookupStmtNamePoly :: HsStmtContextRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly ctxt name
| rebindableContext ctxt
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
@@ -1367,7 +1367,7 @@ lookupStmtNamePoly ctxt name
-- | Is this a context where we respect RebindableSyntax?
-- but ListComp are never rebindable
-- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows
-rebindableContext :: HsStmtContext GhcRn -> Bool
+rebindableContext :: HsStmtContextRn -> Bool
rebindableContext ctxt = case ctxt of
HsDoStmt flavour -> rebindableDoStmtContext flavour
ArrowExpr -> False
@@ -1423,7 +1423,7 @@ type Segment stmts = (Defs,
-- wrapper that does both the left- and right-hand sides
rnRecStmtsAndThen :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-- assumes that the FreeVars returned includes
@@ -1528,7 +1528,7 @@ rn_rec_stmts_lhs fix_env stmts
-- right-hand-sides
rn_rec_stmt :: AnnoBody body =>
- HsStmtContext GhcRn
+ HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
@@ -1587,7 +1587,7 @@ rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _)
= pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
rn_rec_stmts :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
@@ -1597,7 +1597,7 @@ rn_rec_stmts ctxt rnBody bndrs stmts
; return (concat segs_s) }
---------------------------------------------
-segmentRecStmts :: SrcSpan -> HsStmtContext GhcRn
+segmentRecStmts :: SrcSpan -> HsStmtContextRn
-> Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> (FreeVars, Bool)
@@ -1737,7 +1737,7 @@ in which case that function conservatively assumes that everything might well
be used later.
-}
-glomSegments :: HsStmtContext GhcRn
+glomSegments :: HsStmtContextRn
-> [Segment (LStmt GhcRn body)]
-> [Segment [LStmt GhcRn body]]
-- Each segment has a non-empty list of Stmts
@@ -2479,7 +2479,7 @@ isReturnApp monad_names (L loc e) mb_pure = case e of
************************************************************************
-}
-checkEmptyStmts :: HsStmtContext GhcRn -> RnM ()
+checkEmptyStmts :: HsStmtContextRn -> RnM ()
-- We've seen an empty sequence of Stmts... is that ok?
checkEmptyStmts ctxt
= mapM_ (addErr . TcRnEmptyStmtsGroup) mb_err
@@ -2493,7 +2493,7 @@ checkEmptyStmts ctxt
----------------------
checkLastStmt :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
checkLastStmt ctxt lstmt@(L loc stmt)
@@ -2525,7 +2525,7 @@ checkLastStmt ctxt lstmt@(L loc stmt)
-- Checking when a particular Stmt is ok
checkStmt :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM ()
checkStmt ctxt (L _ stmt)
@@ -2541,7 +2541,7 @@ emptyInvalid :: Validity' (Maybe LangExt.Extension)
emptyInvalid = NotValid Nothing -- Invalid, and no extension to suggest
okStmt, okDoStmt, okCompStmt, okParStmt
- :: DynFlags -> HsStmtContext GhcRn
+ :: DynFlags -> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension)
-- Return Nothing if OK, (Just extra) if not ok
-- The "extra" is an SDoc that is appended to a generic error message
@@ -2555,7 +2555,7 @@ okStmt dflags ctxt stmt
TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
okDoFlavourStmt
- :: DynFlags -> HsDoFlavour -> HsStmtContext GhcRn
+ :: DynFlags -> HsDoFlavour -> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension)
okDoFlavourStmt dflags flavour ctxt stmt = case flavour of
DoExpr{} -> okDoStmt dflags ctxt stmt
@@ -2626,7 +2626,7 @@ badIpBinds = TcRnIllegalImplicitParameterBindings
---------
monadFailOp :: LPat GhcPs
- -> HsStmtContext GhcRn
+ -> HsStmtContextRn
-> RnM (FailOperator GhcRn, FreeVars)
monadFailOp pat ctxt = do
dflags <- getDynFlags
=====================================
compiler/GHC/Rename/Expr.hs-boot
=====================================
@@ -18,7 +18,7 @@ type AnnoBody body
)
rnStmts :: --forall thing body.
- AnnoBody body => HsStmtContext GhcRn
+ AnnoBody body => HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -418,7 +418,7 @@ There are various entry points to renaming patterns, depending on
-- * unused and duplicate checking
-- * no fixities
rnPats :: Traversable f
- => HsMatchContext GhcRn -- for error messages
+ => HsMatchContextRn -- For error messages
-> f (LPat GhcPs)
-> (f (LPat GhcRn) -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
@@ -445,10 +445,10 @@ rnPats ctxt pats thing_inside
; thing_inside pats' } }
where
doc_pat = text "In" <+> pprMatchContext ctxt
-{-# SPECIALIZE rnPats :: HsMatchContext GhcRn -> [LPat GhcPs] -> ([LPat GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-}
-{-# SPECIALIZE rnPats :: HsMatchContext GhcRn -> Identity (LPat GhcPs) -> (Identity (LPat GhcRn) -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-}
+{-# SPECIALIZE rnPats :: HsMatchContextRn -> [LPat GhcPs] -> ([LPat GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-}
+{-# SPECIALIZE rnPats :: HsMatchContextRn -> Identity (LPat GhcPs) -> (Identity (LPat GhcRn) -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-}
-rnPat :: HsMatchContext GhcRn -- for error messages
+rnPat :: HsMatchContextRn -- For error messages
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars) -- Variables bound by pattern do not
=====================================
compiler/GHC/Tc/Deriv/Functor.hs
=====================================
@@ -247,7 +247,7 @@ gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
-- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
match_for_con :: Monad m
- => HsMatchContext GhcPs
+ => HsMatchContextPs
-> [LPat GhcPs] -> DataCon
-> [LHsExpr GhcPs -> m (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
@@ -629,7 +629,7 @@ mkSimpleLam2 lam =
-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
-- and its arguments, applying an expression (from @insides@) to each of the
-- respective arguments of @con at .
-mkSimpleConMatch :: Monad m => HsMatchContext GhcPs
+mkSimpleConMatch :: Monad m => HsMatchContextPs
-> (RdrName -> [a] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
@@ -664,7 +664,7 @@ mkSimpleConMatch ctxt fold extra_pats con insides = do
--
-- See Note [Generated code for DeriveFoldable and DeriveTraversable]
mkSimpleConMatch2 :: Monad m
- => HsMatchContext GhcPs
+ => HsMatchContextPs
-> (LHsExpr GhcPs -> [LHsExpr GhcPs]
-> m (LHsExpr GhcPs))
-> [LPat GhcPs]
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -2403,7 +2403,7 @@ data TcRnMessage where
typecheck/should_fail/T20768_fail
-}
TcRnMatchesHaveDiffNumArgs
- :: !(HsMatchContext GhcRn) -- ^ Pattern match specifics
+ :: !HsMatchContextRn -- ^ Pattern match specifics
-> !MatchArgBadMatches
-> TcRnMessage
@@ -2878,7 +2878,7 @@ data TcRnMessage where
parser/should_fail/readFail028
-}
TcRnLastStmtNotExpr
- :: HsStmtContext GhcRn
+ :: HsStmtContextRn
-> UnexpectedStatement
-> TcRnMessage
@@ -2892,7 +2892,7 @@ data TcRnMessage where
parser/should_fail/readFail043
-}
TcRnUnexpectedStatementInContext
- :: HsStmtContext GhcRn
+ :: HsStmtContextRn
-> UnexpectedStatement
-> Maybe LangExt.Extension
-> TcRnMessage
@@ -3009,7 +3009,7 @@ data TcRnMessage where
Test cases: rename/should_fail/RnEmptyCaseFail
-}
- TcRnEmptyCase :: HsMatchContext GhcRn -> TcRnMessage
+ TcRnEmptyCase :: HsMatchContextRn -> TcRnMessage
{-| TcRnNonStdGuards is a warning thrown when a user uses
non-standard guards (e.g. patterns in guards) without
@@ -5806,7 +5806,7 @@ data MatchArgsContext
= EquationArgs
!Name -- ^ Name of the function
| PatternArgs
- !(HsMatchContext GhcTc) -- ^ Pattern match specifics
+ !HsMatchContextRn -- ^ Pattern match specifics
-- | The information necessary to report mismatched
-- numbers of arguments in a match group.
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1346,7 +1346,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
-- we let-bind x' = e1, y' = e2 and generate the equation:
--
-- T1 _ _ z -> T1 x' y' z
- make_pat conLike = mkSimpleMatch CaseAlt [pat] rhs
+ make_pat conLike = mkSimpleMatch RecUpd [pat] rhs
where
(lhs_con_pats, rhs_con_args)
= zipWithAndUnzip mk_con_arg [1..] con_fields
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -264,12 +264,17 @@ tcMatch tc_body pat_tys rhs_ty match
tc_match pat_tys rhs_ty
match@(Match { m_ctxt = ctxt, m_pats = pats, m_grhss = grhss })
= add_match_ctxt $
- do { let ctxt' = convertHsMatchCtxt ctxt -- Ugh!
-
- ; (pats', (wrapper, grhss')) <- tcMatchPats ctxt' pats pat_tys $
- tcGRHSs ctxt' tc_body grhss rhs_ty
+ do { (pats', (wrapper, grhss')) <- tcMatchPats ctxt pats pat_tys $
+ tcGRHSs ctxt tc_body grhss rhs_ty
-- NB: pats' are just the /value/ patterns
-- See Note [tcMatchPats] in GHC.Tc.Gen.Pat
+
+ -- Tricky point: ctxt :: HsMatchContext (LIdP (NoGhcTc GhcRn))
+ -- and we need ctxt' :: HsMatchContext (LIdP (NoGhcTc GhcTc))
+ -- but GhcNoTc GhcRn = GhcNoTc GhcTc, so all is well
+ -- See Note [mc-fun field of FunRhs] in Language.Haskell.Syntax.Expr
+ ; let ctxt' = ctxt
+
; return (wrapper, Match { m_ext = noAnn
, m_ctxt = ctxt'
, m_pats = pats'
@@ -285,7 +290,7 @@ tcMatch tc_body pat_tys rhs_ty match
-------------
tcGRHSs :: AnnoBody body
- => HsMatchContext GhcTc
+ => HsMatchContextRn
-> TcMatchBodyChecker body
-> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
-> TcM (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))
@@ -302,7 +307,7 @@ tcGRHSs ctxt tc_body (GRHSs _ grhss binds) res_ty
; return (wrapper, GRHSs emptyComments grhss' binds') }
tcGRHSList :: forall body. AnnoBody body
- => HsMatchContext GhcTc -> TcMatchBodyChecker body
+ => HsMatchContextRn -> TcMatchBodyChecker body
-> [LGRHS GhcRn (LocatedA (body GhcRn))] -> ExpRhoType
-> TcM [LGRHS GhcTc (LocatedA (body GhcTc))]
tcGRHSList ctxt tc_body grhss res_ty
@@ -312,7 +317,7 @@ tcGRHSList ctxt tc_body grhss res_ty
; tcEmitBindingUsage $ supUEs usages
; return grhss' }
where
- stmt_ctxt = PatGuard ctxt
+ stmt_ctxt = PatGuard ctxt
tc_alt :: GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc)))
@@ -377,13 +382,13 @@ type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType
type TcStmtChecker body rho_type
- = forall thing. HsStmtContext GhcTc
+ = forall thing. HsStmtContextRn
-> Stmt GhcRn (LocatedA (body GhcRn))
-> rho_type -- Result type for comprehension
-> (rho_type -> TcM thing) -- Checker for what follows the stmt
-> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing)
-tcStmts :: (AnnoBody body) => HsStmtContext GhcTc
+tcStmts :: (AnnoBody body) => HsStmtContextRn
-> TcStmtChecker body rho_type -- NB: higher-rank type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
@@ -393,7 +398,7 @@ tcStmts ctxt stmt_chk stmts res_ty
const (return ())
; return stmts' }
-tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcTc
+tcStmtsAndThen :: (AnnoBody body) => HsStmtContextRn
-> TcStmtChecker body rho_type -- NB: higher-rank type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
@@ -1066,7 +1071,7 @@ To achieve this we:
-}
tcApplicativeStmts
- :: HsStmtContext GhcTc
+ :: HsStmtContextRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType -- rhs_ty
-> (TcRhoType -> TcM t) -- thing_inside
@@ -1213,30 +1218,3 @@ checkArgCounts (MG { mg_alts = L _ (match1:matches) })
-- Counts the number of /required/ args in the match
-- IMPORTANT: THIS WILL NEED TO CHANGE WHEN @ty BECOMES A PATTERN
reqd_args_in_match (L _ (Match { m_pats = pats })) = length pats
-
-
--- | Ths horrible function converts HsMatchContext GhcRn to HsMatchContext GhcTc
--- It is a little silly to do it this way as all except for FunRhs constructor, are independent
--- of the GhcPass index parameter.
-convertHsMatchCtxt :: HsMatchContext GhcRn -> HsMatchContext GhcTc
-convertHsStmtCtxt :: HsStmtContext GhcRn -> HsStmtContext GhcTc
-
-convertHsMatchCtxt CaseAlt = CaseAlt
-convertHsMatchCtxt (LamAlt x) = LamAlt x
-convertHsMatchCtxt IfAlt = IfAlt
-convertHsMatchCtxt (ArrowMatchCtxt x) = ArrowMatchCtxt x
-convertHsMatchCtxt PatBindRhs = PatBindRhs
-convertHsMatchCtxt LazyPatCtx = LazyPatCtx
-convertHsMatchCtxt PatBindGuards = CaseAlt
-convertHsMatchCtxt RecUpd = RecUpd
-convertHsMatchCtxt (StmtCtxt x) = StmtCtxt $ convertHsStmtCtxt x
-convertHsMatchCtxt ThPatSplice = ThPatSplice
-convertHsMatchCtxt ThPatQuote = ThPatQuote
-convertHsMatchCtxt PatSyn = PatSyn
-convertHsMatchCtxt (FunRhs x y z) = FunRhs x y z
-
-convertHsStmtCtxt (HsDoStmt x) = HsDoStmt x
-convertHsStmtCtxt (PatGuard x) = PatGuard $ convertHsMatchCtxt x
-convertHsStmtCtxt (ParStmtCtxt x) = ParStmtCtxt $ convertHsStmtCtxt x
-convertHsStmtCtxt (TransStmtCtxt x) = TransStmtCtxt $ convertHsStmtCtxt x
-convertHsStmtCtxt ArrowExpr = ArrowExpr
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -123,7 +123,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
-----------------
tcMatchPats :: forall a.
- HsMatchContext GhcTc
+ HsMatchContextRn
-> [LPat GhcRn] -- ^ patterns
-> [ExpPatType] -- ^ types of the patterns
-> TcM a -- ^ checker for the body
@@ -193,7 +193,7 @@ tcMatchPats match_ctxt pats pat_tys thing_inside
tcInferPat :: FixedRuntimeRepContext
- -> HsMatchContext GhcTc
+ -> HsMatchContextRn
-> LPat GhcRn
-> TcM a
-> TcM ((LPat GhcTc, a), TcSigmaTypeFRR)
@@ -203,14 +203,14 @@ tcInferPat frr_orig ctxt pat thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
-tcCheckPat :: HsMatchContext GhcTc
+tcCheckPat :: HsMatchContextRn
-> LPat GhcRn -> Scaled TcSigmaTypeFRR
-> TcM a -- Checker for body
-> TcM (LPat GhcTc, a)
tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin
-- | A variant of 'tcPat' that takes a custom origin
-tcCheckPat_O :: HsMatchContext GhcTc
+tcCheckPat_O :: HsMatchContextRn
-> CtOrigin -- ^ origin to use if the type needs inst'ing
-> LPat GhcRn -> Scaled TcSigmaTypeFRR
-> TcM a -- Checker for body
@@ -256,7 +256,7 @@ data PatEnv
data PatCtxt
= LamPat -- Used for lambdas, case etc
- (HsMatchContext GhcTc)
+ HsMatchContextRn
| LetPat -- Used only for let(rec) pattern bindings
-- See Note [Typing patterns in pattern bindings]
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -288,7 +288,7 @@ data SkolemInfoAnon
| FamInstSkol -- Bound at a family instance decl
| PatSkol -- An existential type variable bound by a pattern for
ConLike -- a data constructor with an existential type.
- (HsMatchContext GhcTc)
+ HsMatchContextRn
-- e.g. data T = forall a. Eq a => MkT a
-- f (MkT x) = ...
-- The pattern MkT x will allocate an existential type
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1004,8 +1004,7 @@ cvtLocalDecs declDescr ds
((_:_), (_:_)) ->
failWith ImplicitParamsWithOtherBinds
-cvtClause :: HsMatchContext GhcPs
- -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
+cvtClause :: HsMatchContextPs -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtClause ctxt (Clause ps body wheres)
= do { ps' <- cvtPats ps
; let pps = map (parenthesizePat appPrec) ps'
@@ -1328,8 +1327,7 @@ cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss
; rec_stmt <- wrapParLA (mkRecStmt noAnn) ss'
; returnLA rec_stmt }
-cvtMatch :: HsMatchContext GhcPs
- -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
+cvtMatch :: HsMatchContextPs -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtMatch ctxt (TH.Match p body decs)
= do { p' <- cvtPat p
; let lp = case p' of
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -977,10 +977,9 @@ type LMatch id body = XRec id (Match id body)
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
data Match p body
= Match {
- m_ext :: XCMatch p body,
- m_ctxt :: HsMatchContext p,
- -- See Note [m_ctxt in Match]
- m_pats :: [LPat p], -- The patterns
+ m_ext :: XCMatch p body,
+ m_ctxt :: HsMatchContext (LIdP (NoGhcTc p)), -- See Note [m_ctxt in Match]
+ m_pats :: [LPat p], -- The patterns
m_grhss :: (GRHSs p body)
}
| XMatch !(XXMatch p body)
@@ -1529,17 +1528,14 @@ data ArithSeqInfo id
--
-- Context of a pattern match. This is more subtle than it would seem. See
-- Note [FunBind vs PatBind].
--- type HsMatchContext p = HsMatchContext_ (LIdP (NoGhcTc p))
-data HsMatchContext p
+data HsMatchContext fn
= FunRhs
-- ^ A pattern matching on an argument of a
-- function binding
--- { mc_fun :: fn -- ^ function binder of @f@
- { mc_fun :: LIdP (NoGhcTc p) -- ^ function binder of @f@
- -- See Note [mc_fun field of FunRhs]
- -- See #20415 for a long discussion about
- -- this field and why it uses NoGhcTc.
+ { mc_fun :: fn -- ^ function binder of @f@
+ -- See Note [mc_fun field of FunRhs]
+ -- See #20415 for a long discussion about this field
, mc_fixity :: LexicalFixity -- ^ fixing of @f@
, mc_strictness :: SrcStrictness -- ^ was @f@ banged?
-- See Note [FunBind vs PatBind]
@@ -1558,7 +1554,7 @@ data HsMatchContext p
-- tell matchWrapper what sort of
-- runtime error message to generate]
- | StmtCtxt (HsStmtContext p) -- ^Pattern of a do-stmt, list comprehension,
+ | StmtCtxt (HsStmtContext fn) -- ^Pattern of a do-stmt, list comprehension,
-- pattern guard, etc
| ThPatSplice -- ^A Template Haskell pattern splice
@@ -1569,32 +1565,42 @@ data HsMatchContext p
{-
Note [mc_fun field of FunRhs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The mc_fun field of FunRhs has type `LIdP (NoGhcTc p)`, which means it will be
-a `RdrName` in pass `GhcPs`, a `Name` in `GhcRn`, and (importantly) still a
-`Name` in `GhcTc` -- not an `Id`. See Note [NoGhcTc] in GHC.Hs.Extension.
+HsMatchContext is parameterised over `fn`, the function binder stored in `FunRhs`.
+This makes pretty printing easy.
-Why a `Name` in the typechecker phase? Because:
-* A `Name` is all we need, as it turns out.
-* Using an `Id` involves knot-tying in the monad, which led to #22695.
+In the use of `HsMatchContext` in `Match`, it is parameterised tus:
+ data Match p body = Match { m_ctxt :: HsMatchContext (LIdP (NoGhcTc p)), ... }
+So in a Match, the mc_fun field `FunRhs` will be a `RdrName` in pass `GhcPs`, a `Name`
+in `GhcRn`, and (importantly) still a `Name` in `GhcTc` -- not an `Id`.
+See Note [NoGhcTc] in GHC.Hs.Extension.
-Why a /located/ name? Because we want to record the location of the Id
-on the LHS of /this/ match. See Note [m_ctxt in Match]. Example:
+* Why a `Name` in the typechecker phase? Because:
+ * A `Name` is all we need, as it turns out.
+ * Using an `Id` involves knot-tying in the monad, which led to #22695.
+
+* Why a /located/ name? Because we want to record the location of the Id
+ on the LHS of /this/ match. See Note [m_ctxt in Match]. Example:
(&&& ) [] [] = []
xs &&& [] = xs
-The two occurrences of `&&&` have different locations.
+ The two occurrences of `&&&` have different locations.
+
+* Why parameterise `HsMatchContext` over `fn` rather than over the pass `p`?
+ Because during typechecking (specifically GHC.Tc.Gen.Match.tcMatch) we need to convert
+ HsMatchContext (LIdP (NoGhcTc GhcRn)) --> HsMatchContext (LIdP (NoGhcTc GhcTc))
+ With this parameterisation it's easy; if it was parametersed over `p` we'd need
+ a recursive traversal of the HsMatchContext.
See #20415 for a long discussion.
-}
-- | Haskell Statement Context.
--- type HsStmtContext p = HsStmtContext_ (LIdP (NoGhcTc p))
-
-data HsStmtContext p
- = HsDoStmt HsDoFlavour -- ^ Context for HsDo (do-notation and comprehensions)
- | PatGuard (HsMatchContext p) -- ^ Pattern guard for specified thing
- | ParStmtCtxt (HsStmtContext p) -- ^ A branch of a parallel stmt
- | TransStmtCtxt (HsStmtContext p) -- ^ A branch of a transform stmt
- | ArrowExpr -- ^ do-notation in an arrow-command context
+
+data HsStmtContext fn
+ = HsDoStmt HsDoFlavour -- ^ Context for HsDo (do-notation and comprehensions)
+ | PatGuard (HsMatchContext fn) -- ^ Pattern guard for specified thing
+ | ParStmtCtxt (HsStmtContext fn) -- ^ A branch of a parallel stmt
+ | TransStmtCtxt (HsStmtContext fn) -- ^ A branch of a transform stmt
+ | ArrowExpr -- ^ do-notation in an arrow-command context
-- | Haskell arrow match context.
data HsArrowMatchContext
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/478c705ebab67a99b03334bf29604ccc83a85707...10349a90b3dd5ef6fbc52edc28080b1c48bde322
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/478c705ebab67a99b03334bf29604ccc83a85707...10349a90b3dd5ef6fbc52edc28080b1c48bde322
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/20240129/14dbc592/attachment-0001.html>
More information about the ghc-commits
mailing list