[Git][ghc/ghc][wip/T23916] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Sep 13 10:40:20 UTC 2023
Simon Peyton Jones pushed to branch wip/T23916 at Glasgow Haskell Compiler / GHC
Commits:
d6c61c0a by Simon Peyton Jones at 2023-09-13T11:39:54+01:00
Wibbles
- - - - -
14 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -593,10 +593,10 @@ ppr_expr (ExplicitSum _ alt arity expr)
where
ppr_bars n = hsep (replicate n (char '|'))
-ppr_expr (HsLam _ lc_variant matches)
- = case lc_variant of
+ppr_expr (HsLam _ lam_variant matches)
+ = case lam_variant of
LamSingle -> pprMatches matches
- _ -> sep [ sep [lamCaseKeyword lc_variant]
+ _ -> sep [ sep [lamCaseKeyword lam_variant]
, nest 2 (pprMatches matches) ]
ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts }))
@@ -1226,8 +1226,8 @@ ppr_cmd (HsCmdApp _ c e)
ppr_cmd (HsCmdLam _ LamSingle matches)
= pprMatches matches
-ppr_cmd (HsCmdLam _ lc_variant matches)
- = sep [ lamCaseKeyword lc_variant, nest 2 (pprMatches matches) ]
+ppr_cmd (HsCmdLam _ lam_variant matches)
+ = sep [ lamCaseKeyword lam_variant, nest 2 (pprMatches matches) ]
ppr_cmd (HsCmdCase _ expr matches)
= sep [ sep [text "case", nest 4 (ppr expr), text "of"],
@@ -1898,7 +1898,7 @@ pp_dotdot = text " .. "
instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where
ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)
ppr CaseAlt = text "CaseAlt"
- ppr (LamAlt lc_variant) = text "LamAlt" <+> ppr lc_variant
+ ppr (LamAlt lam_variant) = text "LamAlt" <+> ppr lam_variant
ppr IfAlt = text "IfAlt"
ppr (ArrowMatchCtxt c) = text "ArrowMatchCtxt" <+> ppr c
ppr PatBindRhs = text "PatBindRhs"
@@ -1925,9 +1925,9 @@ pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4))
= ppr (src,(n1,n2),(n3,n4))
instance Outputable HsArrowMatchContext where
- ppr ProcExpr = text "ProcExpr"
- ppr ArrowCaseAlt = text "ArrowCaseAlt"
- ppr (ArrowLamAlt lc_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lc_variant
+ ppr ProcExpr = text "ProcExpr"
+ ppr ArrowCaseAlt = text "ArrowCaseAlt"
+ ppr (ArrowLamAlt lam_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lam_variant
pprHsArrType :: HsArrAppType -> SDoc
pprHsArrType HsHigherOrderApp = text "higher order arrow application"
@@ -1944,7 +1944,7 @@ matchContextErrString :: OutputableBndrId p
=> HsMatchContext (GhcPass p) -> SDoc
matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun
matchContextErrString CaseAlt = text "case"
-matchContextErrString (LamAlt lc_variant) = lamCaseKeyword lc_variant
+matchContextErrString (LamAlt lam_variant) = lamCaseKeyword lam_variant
matchContextErrString IfAlt = text "multi-way if"
matchContextErrString PatBindRhs = text "pattern binding"
matchContextErrString PatBindGuards = text "pattern binding guards"
@@ -1960,10 +1960,10 @@ matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block"
matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour
matchArrowContextErrString :: HsArrowMatchContext -> SDoc
-matchArrowContextErrString ProcExpr = text "proc"
-matchArrowContextErrString ArrowCaseAlt = text "case"
-matchArrowContextErrString (ArrowLamAlt LamSingle) = text "kappa"
-matchArrowContextErrString (ArrowLamAlt lc_variant) = lamCaseKeyword lc_variant
+matchArrowContextErrString ProcExpr = text "proc"
+matchArrowContextErrString ArrowCaseAlt = text "case"
+matchArrowContextErrString (ArrowLamAlt LamSingle) = text "kappa"
+matchArrowContextErrString (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant
matchDoContextErrString :: HsDoFlavour -> SDoc
matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command"
@@ -2030,7 +2030,7 @@ pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for"
<+> quotes (ppr (unXRec @(NoGhcTc p) fun))
pprMatchContextNoun CaseAlt = text "case alternative"
pprMatchContextNoun (LamAlt LamSingle) = text "lambda abstraction"
-pprMatchContextNoun (LamAlt lc_variant) = lamCaseKeyword lc_variant
+pprMatchContextNoun (LamAlt lam_variant) = lamCaseKeyword lam_variant
<+> text "alternative"
pprMatchContextNoun IfAlt = text "multi-way if alternative"
pprMatchContextNoun RecUpd = text "record update"
@@ -2056,16 +2056,16 @@ pprMatchContextNouns ctxt = pprMatchContextNoun ctxt <> char
pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc
pprArrowMatchContextNoun ProcExpr = text "arrow proc pattern"
pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation"
-pprArrowMatchContextNoun (ArrowLamAlt LamSingle) = text "arrow kappa abstraction"
-pprArrowMatchContextNoun (ArrowLamAlt lc_variant) = lamCaseKeyword lc_variant
+pprArrowMatchContextNoun (ArrowLamAlt LamSingle) = text "arrow kappa abstraction"
+pprArrowMatchContextNoun (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant
<+> text "alternative within arrow notation"
pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc
-pprArrowMatchContextNouns ArrowCaseAlt = text "case alternatives within arrow notation"
-pprArrowMatchContextNouns (ArrowLamAlt LamSingle) = text "arrow kappa abstractions"
-pprArrowMatchContextNouns (ArrowLamAlt lc_variant) = lamCaseKeyword lc_variant
- <+> text "alternatives within arrow notation"
-pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's'
+pprArrowMatchContextNouns ArrowCaseAlt = text "case alternatives within arrow notation"
+pprArrowMatchContextNouns (ArrowLamAlt LamSingle) = text "arrow kappa abstractions"
+pprArrowMatchContextNouns (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant
+ <+> text "alternatives within arrow notation"
+pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's'
-----------------
pprAStmtContext, pprStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -228,9 +228,9 @@ mkLamCaseMatchGroup :: AnnoBody p body
-> HsLamVariant
-> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
-mkLamCaseMatchGroup origin lc_variant (L l matches)
+mkLamCaseMatchGroup origin lam_variant (L l matches)
= mkMatchGroup origin (L l $ map fixCtxt matches)
- where fixCtxt (L a match) = L a match{m_ctxt = LamAlt lc_variant}
+ where fixCtxt (L a match) = L a match{m_ctxt = LamAlt lam_variant}
mkLocatedList :: Semigroup a
=> [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]
=====================================
compiler/GHC/HsToCore/Arrows.hs
=====================================
@@ -535,11 +535,11 @@ dsCmd ids local_vars stack_ty res_ty
= dsCmdLam ids local_vars stack_ty res_ty pats body env_ids
dsCmd ids local_vars stack_ty res_ty
- (HsCmdLam _ lc_variant match at MG { mg_ext = MatchGroupTc {mg_arg_tys = arg_tys} } )
+ (HsCmdLam _ lam_variant match at MG { mg_ext = MatchGroupTc {mg_arg_tys = arg_tys} } )
env_ids = do
arg_ids <- newSysLocalsDs arg_tys
- let match_ctxt = ArrowLamAlt lc_variant
+ let match_ctxt = ArrowLamAlt lam_variant
pat_vars = mkVarSet arg_ids
local_vars' = pat_vars `unionVarSet` local_vars
(pat_tys, stack_ty') = splitTypeAt (length arg_tys) stack_ty
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -812,8 +812,8 @@ addTickLHsCmd (L pos c0) = do
return $ L pos c1
addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
-addTickHsCmd (HsCmdLam x lc_variant mgs) =
- liftM (HsCmdLam x lc_variant) (addTickCmdMatchGroup mgs)
+addTickHsCmd (HsCmdLam x lam_variant mgs) =
+ liftM (HsCmdLam x lam_variant) (addTickCmdMatchGroup mgs)
addTickHsCmd (HsCmdApp x c e) =
liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
{-
=====================================
compiler/GHC/Parser/Errors/Ppr.hs
=====================================
@@ -327,8 +327,8 @@ instance Diagnostic PsMessage where
-> mkSimpleDecorated $ text "do-notation in pattern"
PsErrIfThenElseInPat
-> mkSimpleDecorated $ text "(if ... then ... else ...)-syntax in pattern"
- (PsErrLambdaCaseInPat lc_variant)
- -> mkSimpleDecorated $ lamCaseKeyword lc_variant <+> text "...-syntax in pattern"
+ (PsErrLambdaCaseInPat lam_variant)
+ -> mkSimpleDecorated $ lamCaseKeyword lam_variant <+> text "...-syntax in pattern"
PsErrCaseInPat
-> mkSimpleDecorated $ text "(case ... of ...)-syntax in pattern"
PsErrLetInPat
@@ -354,9 +354,9 @@ instance Diagnostic PsMessage where
]
PsErrCaseCmdInFunAppCmd a
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "case command") a
- PsErrLambdaCmdInFunAppCmd lc_variant a
+ PsErrLambdaCmdInFunAppCmd lam_variant a
-> mkSimpleDecorated $
- pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "command") a
+ pp_unexpected_fun_app (lamCaseKeyword lam_variant <+> text "command") a
PsErrIfCmdInFunAppCmd a
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "if command") a
PsErrLetCmdInFunAppCmd a
@@ -369,8 +369,8 @@ instance Diagnostic PsMessage where
-> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "mdo block")) a
PsErrCaseInFunAppExpr a
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "case expression") a
- PsErrLambdaInFunAppExpr lc_variant a
- -> mkSimpleDecorated $ pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "expression") a
+ PsErrLambdaInFunAppExpr lam_variant a
+ -> mkSimpleDecorated $ pp_unexpected_fun_app (lamCaseKeyword lam_variant <+> text "expression") a
PsErrLetInFunAppExpr a
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "let expression") a
PsErrIfInFunAppExpr a
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1118,23 +1118,23 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
where
checkExpr :: LHsExpr GhcPs -> PV ()
checkExpr expr = case unLoc expr of
- HsDo _ (DoExpr m) _ -> check (PsErrDoInFunAppExpr m) expr
- HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m) expr
- HsCase {} -> check PsErrCaseInFunAppExpr expr
- HsLam _ lc_variant _ -> check (PsErrLambdaInFunAppExpr lc_variant) expr
- HsLet {} -> check PsErrLetInFunAppExpr expr
- HsIf {} -> check PsErrIfInFunAppExpr expr
- HsProc {} -> check PsErrProcInFunAppExpr expr
+ HsDo _ (DoExpr m) _ -> check (PsErrDoInFunAppExpr m) expr
+ HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m) expr
+ HsCase {} -> check PsErrCaseInFunAppExpr expr
+ HsLam _ lam_variant _ -> check (PsErrLambdaInFunAppExpr lam_variant) expr
+ HsLet {} -> check PsErrLetInFunAppExpr expr
+ HsIf {} -> check PsErrIfInFunAppExpr expr
+ HsProc {} -> check PsErrProcInFunAppExpr expr
_ -> return ()
checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd cmd = case unLoc cmd of
- HsCmdLam _ lc_variant _ -> check (PsErrLambdaCmdInFunAppCmd lc_variant) cmd
- HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd cmd
- HsCmdIf {} -> check PsErrIfCmdInFunAppCmd cmd
- HsCmdLet {} -> check PsErrLetCmdInFunAppCmd cmd
- HsCmdDo {} -> check PsErrDoCmdInFunAppCmd cmd
- _ -> return ()
+ HsCmdLam _ lam_variant _ -> check (PsErrLambdaCmdInFunAppCmd lam_variant) cmd
+ HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd cmd
+ HsCmdIf {} -> check PsErrIfCmdInFunAppCmd cmd
+ HsCmdLet {} -> check PsErrLetCmdInFunAppCmd cmd
+ HsCmdDo {} -> check PsErrDoCmdInFunAppCmd cmd
+ _ -> return ()
check err a = do
blockArguments <- getBit BlockArgumentsBit
@@ -1711,10 +1711,10 @@ instance DisambECP (HsCmd GhcPs) where
cs <- getCommentsFor l
return $ L (noAnnSrcSpan l) (HsCmdLam (EpAnn (spanAsAnchor l) [] cs) LamSingle (mg cs))
- mkHsLamCasePV l lc_variant (L lm m) anns = do
+ mkHsLamCasePV l lam_variant (L lm m) anns = do
cs <- getCommentsFor l
- let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m)
- return $ L (noAnnSrcSpan l) (HsCmdLam (EpAnn (spanAsAnchor l) anns cs) lc_variant mg)
+ let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m)
+ return $ L (noAnnSrcSpan l) (HsCmdLam (EpAnn (spanAsAnchor l) anns cs) lam_variant mg)
mkHsLetPV l tkLet bs tkIn e = do
cs <- getCommentsFor l
@@ -1817,10 +1817,10 @@ instance DisambECP (HsExpr GhcPs) where
cs <- getCommentsFor l
let mg = mkMatchGroup FromSource (L lm m)
return $ L (noAnnSrcSpan l) (HsCase (EpAnn (spanAsAnchor l) anns cs) e mg)
- mkHsLamCasePV l lc_variant (L lm m) anns = do
+ mkHsLamCasePV l lam_variant (L lm m) anns = do
cs <- getCommentsFor l
- let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m)
- return $ L (noAnnSrcSpan l) (HsLam (EpAnn (spanAsAnchor l) anns cs) lc_variant mg)
+ let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m)
+ return $ L (noAnnSrcSpan l) (HsLam (EpAnn (spanAsAnchor l) anns cs) lam_variant mg)
type FunArg (HsExpr GhcPs) = HsExpr GhcPs
superFunArg m = m
mkHsAppPV l e1 e2 = do
@@ -1904,7 +1904,7 @@ instance DisambECP (PatBuilder GhcPs) where
let anns = EpAnn (spanAsAnchor l) [] cs
return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns
mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat
- mkHsLamCasePV l lc_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaCaseInPat lc_variant)
+ mkHsLamCasePV l lam_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaCaseInPat lam_variant)
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
superFunArg m = m
mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -416,9 +416,9 @@ rnExpr (HsPragE x prag expr)
rn_prag :: HsPragE GhcPs -> HsPragE GhcRn
rn_prag (HsPragSCC x ann) = HsPragSCC x ann
-rnExpr (HsLam x lc_variant matches)
- = do { (matches', fvs_ms) <- rnMatchGroup (LamAlt lc_variant) rnLExpr matches
- ; return (HsLam x lc_variant matches', fvs_ms) }
+rnExpr (HsLam x lam_variant matches)
+ = do { (matches', fvs_ms) <- rnMatchGroup (LamAlt lam_variant) rnLExpr matches
+ ; return (HsLam x lam_variant matches', fvs_ms) }
rnExpr (HsCase _ expr matches)
= do { (new_expr, e_fvs) <- rnLExpr expr
@@ -878,10 +878,10 @@ rnCmd (HsCmdApp x fun arg)
; (arg',fvArg) <- rnLExpr arg
; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }
-rnCmd (HsCmdLam x lc_variant matches)
- = do { let ctxt = ArrowMatchCtxt $ ArrowLamAlt lc_variant
+rnCmd (HsCmdLam x lam_variant matches)
+ = do { let ctxt = ArrowMatchCtxt $ ArrowLamAlt lam_variant
; (new_matches, ms_fvs) <- rnMatchGroup ctxt rnLCmd matches
- ; return (HsCmdLam x lc_variant new_matches, ms_fvs) }
+ ; return (HsCmdLam x lam_variant new_matches, ms_fvs) }
rnCmd (HsCmdPar x lpar e rpar)
= do { (e', fvs_e) <- rnLCmd e
=====================================
compiler/GHC/Tc/Gen/Arrow.hs
=====================================
@@ -260,12 +260,12 @@ tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty)
-- ------------------------------
-- D;G |-a (\x.cmd) : (t,stk) --> res
-tc_cmd env cmd@(HsCmdLam x lc_variant match) cmd_ty
+tc_cmd env cmd@(HsCmdLam x lam_variant match) cmd_ty
= addErrCtxt (cmdCtxt cmd)
- do { let match_ctxt = ArrowLamAlt lc_variant
+ do { let match_ctxt = ArrowLamAlt lam_variant
; checkArgCounts (ArrowMatchCtxt match_ctxt) match
; (wrap, match') <- tcCmdMatchLambda env match_ctxt match cmd_ty
- ; return (mkHsCmdWrap wrap (HsCmdLam x lc_variant match')) }
+ ; return (mkHsCmdWrap wrap (HsCmdLam x lam_variant match')) }
-------------------------------------------
-- Do notation
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -261,12 +261,12 @@ tcExpr e@(HsIPVar _ x) res_ty
unwrapIP $ mkClassPred ipClass [x,ty]
origin = IPOccOrigin x
-tcExpr e@(HsLam x lc_variant matches) res_ty
+tcExpr e@(HsLam x lam_variant matches) res_ty
= do { (wrap, matches') <- tcMatchLambda herald match_ctxt matches res_ty
- ; return (mkHsWrap wrap $ HsLam x lc_variant matches') }
+ ; return (mkHsWrap wrap $ HsLam x lam_variant matches') }
where
- match_ctxt = MC { mc_what = LamAlt lc_variant, mc_body = tcBody }
- herald = ExpectedFunTyLam lc_variant e
+ match_ctxt = MC { mc_what = LamAlt lam_variant, mc_body = tcBody }
+ herald = ExpectedFunTyLam lam_variant e
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1180,9 +1180,10 @@ checkArgCounts :: AnnoBody body
checkArgCounts _ (MG { mg_alts = L _ [] })
= return ()
checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
- | null matches
+ | null matches -- There was only one match; nothing to check
= return ()
+ -- Two or more matches: check that they agree on arity
| Just bad_matches <- mb_bad_matches
= failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext
$ MatchArgMatches match1 bad_matches
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -1453,7 +1453,7 @@ pprExpectedFunTyOrigin funTy_origin i =
| otherwise
-> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts
<+> text "for" <+> quotes (ppr fun)
- ExpectedFunTyLam lc_variant _ -> binder_of $ lamCaseKeyword lc_variant
+ ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant
where
the_arg_of :: SDoc
the_arg_of = text "The" <+> speakNth i <+> text "argument of"
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -938,9 +938,9 @@ zonkExpr (HsOverLit x lit)
= do { lit' <- zonkOverLit lit
; return (HsOverLit x lit') }
-zonkExpr (HsLam x lc_variant matches)
+zonkExpr (HsLam x lam_variant matches)
= do new_matches <- zonkMatchGroup zonkLExpr matches
- return (HsLam x lc_variant new_matches)
+ return (HsLam x lam_variant new_matches)
zonkExpr (HsApp x e1 e2)
= do new_e1 <- zonkLExpr e1
@@ -1154,9 +1154,9 @@ zonkCmd (HsCmdCase x expr ms)
new_ms <- zonkMatchGroup zonkLCmd ms
return (HsCmdCase x new_expr new_ms)
-zonkCmd (HsCmdLam x lc_variant ms)
+zonkCmd (HsCmdLam x lam_variant ms)
= do new_ms <- zonkMatchGroup zonkLCmd ms
- return (HsCmdLam x lc_variant new_ms)
+ return (HsCmdLam x lam_variant new_ms)
zonkCmd (HsCmdIf x eCond ePred cThen cElse)
= runZonkBndrT (zonkSyntaxExpr eCond) $ \ new_eCond ->
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -307,9 +307,11 @@ data HsExpr p
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
| HsLam (XLam p)
- HsLamVariant
+ HsLamVariant -- ^ Tells whether this is for lambda, \case, or \cases
(MatchGroup p (LHsExpr p))
- -- ^ Lambda abstraction. Currently always a single match
+ -- ^ LamSingle: one match
+ -- LamCase: many arity-1 matches
+ -- LamCases: many matches of uniform arity
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',
-- 'GHC.Parser.Annotation.AnnRarrow',
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2658,8 +2658,7 @@ instance ExactPrint (HsExpr GhcPs) where
getAnnotationEntry (HsIPVar an _) = fromAnn an
getAnnotationEntry (HsOverLit an _) = fromAnn an
getAnnotationEntry (HsLit an _) = fromAnn an
- getAnnotationEntry (HsLam _ _) = NoEntryVal
- getAnnotationEntry (HsLamCase an _ _) = fromAnn an
+ getAnnotationEntry (HsLam an _ _) = fromAnn an
getAnnotationEntry (HsApp an _ _) = fromAnn an
getAnnotationEntry (HsAppType _ _ _ _) = NoEntryVal
getAnnotationEntry (OpApp an _ _ _) = fromAnn an
@@ -2697,8 +2696,7 @@ instance ExactPrint (HsExpr GhcPs) where
setAnnotationAnchor (HsIPVar an a) anc cs = (HsIPVar (setAnchorEpa an anc cs) a)
setAnnotationAnchor (HsOverLit an a) anc cs = (HsOverLit (setAnchorEpa an anc cs) a)
setAnnotationAnchor (HsLit an a) anc cs = (HsLit (setAnchorEpa an anc cs) a)
- setAnnotationAnchor a@(HsLam _ _) _ _s = a
- setAnnotationAnchor (HsLamCase an a b) anc cs = (HsLamCase (setAnchorEpa an anc cs) a b)
+ setAnnotationAnchor (HsLam an a b) anc cs = (HsLam (setAnchorEpa an anc cs) a b)
setAnnotationAnchor (HsApp an a b) anc cs = (HsApp (setAnchorEpa an anc cs) a b)
setAnnotationAnchor a@(HsAppType {}) _ _s = a
setAnnotationAnchor (OpApp an a b c) anc cs = (OpApp (setAnchorEpa an anc cs) a b c)
@@ -2763,16 +2761,17 @@ instance ExactPrint (HsExpr GhcPs) where
exact (HsLit an lit) = do
lit' <- withPpr lit
return (HsLit an lit')
- exact (HsLam x mg) = do
- mg' <- markAnnotated mg
- return (HsLam x mg')
- exact (HsLamCase an lc_variant mg) = do
+ -- ToDo: Do these two cases need to be handled separately?
+ exact (HsLam an LamSingle mg) = do
+ mg' <- markAnnotated mg
+ return (HsLam an LamSingle mg')
+ exact (HsLam an lam_variant mg) = do
an0 <- markEpAnnL an lidl AnnLam
- an1 <- markEpAnnL an0 lidl (case lc_variant of LamCase -> AnnCase
- LamCases -> AnnCases)
+ an1 <- markEpAnnL an0 lidl (case lam_variant of LamCase -> AnnCase
+ LamCases -> AnnCases)
mg' <- markAnnotated mg
- return (HsLamCase an1 lc_variant mg')
+ return (HsLam an1 lam_variant mg')
exact (HsApp an e1 e2) = do
p <- getPosP
@@ -3289,14 +3288,14 @@ instance ExactPrint (HsCmd GhcPs) where
exact (HsCmdLam a LamSingle match) = do
match' <- markAnnotated match
- return (HsCmdLam a match')
+ return (HsCmdLam a LamSingle match')
- exact (HsCmdLam an lc_variant matches) = do
+ exact (HsCmdLam an lam_variant matches) = do
an0 <- markEpAnnL an lidl AnnLam
- an1 <- markEpAnnL an0 lidl (case lc_variant of LamCase -> AnnCase
- LamCases -> AnnCases)
+ an1 <- markEpAnnL an0 lidl (case lam_variant of LamCase -> AnnCase
+ LamCases -> AnnCases)
matches' <- markAnnotated matches
- return (HsCmdLam an1 lc_variant matches')
+ return (HsCmdLam an1 lam_variant matches')
exact (HsCmdPar an lpar e rpar) = do
lpar' <- markToken lpar
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d6c61c0a0811c830b60987e8dc68879d84d49d45
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d6c61c0a0811c830b60987e8dc68879d84d49d45
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/20230913/2aca65cc/attachment-0001.html>
More information about the ghc-commits
mailing list