[Git][ghc/ghc][master] 3 commits: Scrub some partiality in `GHC.Tc.Gen.Match`.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Feb 18 13:55:13 UTC 2025
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
78de1a55 by M Farkas-Dyck at 2025-02-18T08:54:31-05:00
Scrub some partiality in `GHC.Tc.Gen.Match`.
In particular, we construct a list of the same length as another list, then loop over both and panic if their lengths are unequal. We can avoid this.
- - - - -
1dfe9325 by M Farkas-Dyck at 2025-02-18T08:54:31-05:00
Make list of `ParStmtBlock` in `ParStmt` `NonEmpty`.
In the ParStmt constructor Language.Haskell.Syntax.Expr.StmtLR, the 2nd argument, the list of ParStmtBlocks, must be NonEmpty; make it so.
- - - - -
0e3575b5 by M Farkas-Dyck at 2025-02-18T08:54:31-05:00
GHC.Tc.Gen.Match: Added type signatures for `loop` functions.
- - - - -
17 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/ListComp.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Parser.y
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- docs/users_guide/9.14.1-notes.rst
- + testsuite/tests/th/EmptyParStmt.hs
- + testsuite/tests/th/EmptyParStmt.stderr
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1883,7 +1883,7 @@ pprStmt (LastStmt _ expr m_dollar_stripped _)
pprStmt (BindStmt _ pat expr) = pprBindStmt pat expr
pprStmt (LetStmt _ binds) = hsep [text "let", pprBinds binds]
pprStmt (BodyStmt _ expr _ _) = ppr expr
-pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss))
+pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr $ toList stmtss))
pprStmt (TransStmt { trS_stmts = stmts, trS_by = by
, trS_using = using, trS_form = form })
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1185,7 +1185,7 @@ collectStmtBinders flag = \case
LetStmt _ binds -> collectLocalBinders flag binds
BodyStmt {} -> []
LastStmt {} -> []
- ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]
+ ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- toList xs, s <- ss]
TransStmt { trS_stmts = stmts } -> collectLStmtsBinders flag stmts
RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss
XStmtLR x -> case ghcPass :: GhcPass idR of
@@ -1786,7 +1786,7 @@ lStmtsImplicits = hs_lstmts
hs_stmt (LetStmt _ binds) = hs_local_binds binds
hs_stmt (BodyStmt {}) = []
hs_stmt (LastStmt {}) = []
- hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs , s <- ss]
+ hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- toList xs , s <- ss]
hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
hs_stmt (RecStmt { recS_stmts = L _ ss }) = hs_lstmts ss
=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -36,6 +36,8 @@ import GHC.Utils.Panic
import GHC.Tc.Utils.TcType
import GHC.Data.List.SetOps( getNth )
+import Data.Foldable ( toList )
+
{-
List comprehensions may be desugared in one of two ways: ``ordinary''
(as you would expect if you read SLPJ's book) and ``with foldr/build
@@ -243,13 +245,13 @@ deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
= do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
; let (exps, qual_tys) = unzip exps_and_qual_tys
- ; (zip_fn, zip_rhs) <- mkZipBind qual_tys
+ ; (zip_fn, zip_rhs) <- mkZipBind (toList qual_tys)
-- Deal with [e | pat <- zip l1 .. ln] in example above
- ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
+ ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) (toList exps)))
quals list }
where
- bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs]
+ bndrs_s = [bs | ParStmtBlock _ _ bs _ <- toList stmtss_w_bndrs]
-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
pat = mkBigLHsPatTupId pats
@@ -564,7 +566,7 @@ dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
; mzip_op' <- dsExpr mzip_op
; let -- The pattern variables
- pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks]
+ pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- toList blocks]
-- Pattern with tuples of variables
-- [v1,v2,v3] => (v1, (v2, v3))
pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1886,8 +1886,8 @@ repSts (BodyStmt _ e _ _ : ss) =
; (ss2,zs) <- repSts ss
; return (ss2, z : zs) }
repSts (ParStmt _ stmt_blocks _ _ : ss) =
- do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
- ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
+ do { (ss_s, stmt_blocks1) <- unzip <$> traverse rep_stmt_block stmt_blocks
+ ; let stmt_blocks2 = nonEmptyCoreList' stmt_blocks1
ss1 = concat ss_s
; z <- repParSt stmt_blocks2
; (ss2, zs) <- addBinds ss1 (repSts ss)
=====================================
compiler/GHC/Parser.y
=====================================
@@ -13,6 +13,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MonadComprehensions #-}
-- | This module provides the generated Happy parser for Haskell. It exports
-- a number of parsers which may be used in any library that uses the GHC API.
@@ -3360,8 +3361,8 @@ lexps :: { forall b. DisambECP b => PV [LocatedA b] }
-- List Comprehensions
flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
- : pquals { case (unLoc $1) of
- [qs] -> sL1 $1 qs
+ : pquals { case unLoc $1 of
+ qs:|[] -> sL1 $1 qs
-- We just had one thing in our "parallel" list so
-- we simply return that thing directly
@@ -3372,30 +3373,30 @@ flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
-- we wrap them into as a ParStmt
}
-pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] }
+pquals :: { Located (NonEmpty [LStmt GhcPs (LHsExpr GhcPs)]) }
: squals '|' pquals
{% case unLoc $1 of
- (h:t) -> do
+ h:|t -> do
h' <- addTrailingVbarA h (epTok $2)
- return (sLL $1 $> (reverse (h':t) : unLoc $3)) }
- | squals { L (getLoc $1) [reverse (unLoc $1)] }
+ return (sLL $1 $> (reverse (h':t) NE.<| unLoc $3)) }
+ | squals { L (getLoc $1) (NE.singleton (reverse (toList (unLoc $1)))) }
-squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last
+squals :: { Located (NonEmpty (LStmt GhcPs (LHsExpr GhcPs))) } -- In reverse order, because the last
-- one can "grab" the earlier ones
: squals ',' transformqual
{% case unLoc $1 of
- (h:t) -> do
+ h:|t -> do
h' <- addTrailingCommaA h (epTok $2)
- return (sLL $1 $> [sLLa $1 $> ((unLoc $3) (reverse (h':t)))]) }
+ return (sLL $1 $> (NE.singleton (sLLa $1 $> ((unLoc $3) (reverse (h':t)))))) }
| squals ',' qual
{% runPV $3 >>= \ $3 ->
case unLoc $1 of
- (h:t) -> do
+ h:|t -> do
h' <- addTrailingCommaA h (epTok $2)
- return (sLL $1 $> ($3 : (h':t))) }
- | transformqual { sLL $1 $> [L (getLocAnn $1) ((unLoc $1) [])] }
+ return (sLL $1 $> ($3 :| (h':t))) }
+ | transformqual { sLL $1 $> (NE.singleton (L (getLocAnn $1) ((unLoc $1) []))) }
| qual {% runPV $1 >>= \ $1 ->
- return $ sL1 $1 [$1] }
+ return $ sL1 $1 (NE.singleton $1) }
-- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) }
-- | '{|' pquals '|}' { sL1 $1 [$2] }
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -1377,33 +1377,39 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
rnParallelStmts :: forall thing. HsStmtContextRn
-> SyntaxExpr GhcRn
- -> [ParStmtBlock GhcPs GhcPs]
+ -> NonEmpty (ParStmtBlock GhcPs GhcPs)
-> ([Name] -> RnM (thing, FreeVars))
- -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
+ -> RnM ((NonEmpty (ParStmtBlock GhcRn GhcRn), thing), FreeVars)
-- Note [Renaming parallel Stmts]
rnParallelStmts ctxt return_op segs thing_inside
= do { orig_lcl_env <- getLocalRdrEnv
- ; rn_segs orig_lcl_env [] segs }
+ ; rn_segs (:|) orig_lcl_env [] segs }
where
- rn_segs :: LocalRdrEnv
- -> [Name] -> [ParStmtBlock GhcPs GhcPs]
- -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
- rn_segs _ bndrs_so_far []
- = do { let (bndrs', dups) = removeDupsOn nameOccName bndrs_so_far
- ; mapM_ dupErr dups
- ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
- ; return (([], thing), fvs) }
-
- rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)
+ -- The `cons` argument is how we cons the first `ParStmtBlock` onto the rest.
+ -- It is called with `cons = (:)` or `cons = (:|)`.
+ -- Thus, the return type `parStmtBlocks` is `[ParStmtBlock _ _]` or
+ -- `NonEmpty (ParStmtBlock _ _)`, in turn.
+ rn_segs :: (ParStmtBlock GhcRn GhcRn -> [ParStmtBlock GhcRn GhcRn] -> parStmtBlocks)
+ -> LocalRdrEnv
+ -> [Name] -> NonEmpty (ParStmtBlock GhcPs GhcPs)
+ -> RnM ((parStmtBlocks, thing), FreeVars)
+ rn_segs cons env bndrs_so_far (ParStmtBlock x stmts _ _ :| segs)
= do { ((stmts', (used_bndrs, segs', thing)), fvs)
<- rnStmts ctxt rnExpr stmts $ \ bndrs ->
setLocalRdrEnv env $ do
- { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
+ { ((segs', thing), fvs) <- rn_segs1 env (bndrs ++ bndrs_so_far) segs
; let used_bndrs = filter (`elemNameSet` fvs) bndrs
; return ((used_bndrs, segs', thing), fvs) }
; let seg' = ParStmtBlock x stmts' used_bndrs return_op
- ; return ((seg':segs', thing), fvs) }
+ ; return ((cons seg' segs', thing), fvs) }
+
+ rn_segs1 _ bndrs [] = do
+ { let (bndrs', dups) = removeDupsOn nameOccName bndrs
+ ; mapM_ dupErr dups
+ ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
+ ; return (([], thing), fvs) }
+ rn_segs1 env bndrs (x:xs) = rn_segs (:) env bndrs (x:|xs)
dupErr vs = addErr $ TcRnListComprehensionDuplicateBinding (NE.head vs)
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -5707,6 +5707,8 @@ pprConversionFailReason = \case
<+> text "has no equations"
EmptyGuard ->
text "Empty guard"
+ EmptyParStmt ->
+ text "Empty par stmt"
pprTyThingUsedWrong :: WrongThingSort -> TcTyThing -> Name -> SDoc
pprTyThingUsedWrong sort thing name =
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -6783,6 +6783,7 @@ data ConversionFailReason
| DefaultDataInstDecl ![LDataFamInstDecl GhcPs]
| FunBindLacksEquations !TH.Name
| EmptyGuard
+ | EmptyParStmt
deriving Generic
data IllegalDecls
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -5,7 +5,10 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MonadComprehensions #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-
@@ -73,6 +76,7 @@ import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Types.Name
+import GHC.Types.Name.Reader (LocalRdrEnv)
import GHC.Types.Id
import GHC.Types.SrcLoc
import GHC.Types.Basic( VisArity, isDoExpansionGenerated )
@@ -81,7 +85,8 @@ import qualified GHC.Data.List.NonEmpty as NE
import Control.Monad
import Control.Arrow ( second )
-import Data.List.NonEmpty (NonEmpty)
+import Data.Foldable (toList)
+import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (mapMaybe)
import qualified GHC.LanguageExtensions as LangExt
@@ -553,24 +558,26 @@ tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
; (pairs', thing) <- loop env [] bndr_stmts_s
; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }
where
- -- loop :: LocalRdrEnv -- The original LocalRdrEnv
- -- -> [Name] -- Variables bound by earlier branches
- -- -> [([LStmt GhcRn], [GhcRn])]
- -- -> TcM ([([LStmt GhcTc], [GhcTc])], thing)
- --
+ loop
+ :: LocalRdrEnv -> [Name] -> NonEmpty (ParStmtBlock GhcRn GhcRn)
+ -> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), _)
-- Invariant: on entry to `loop`, the LocalRdrEnv is set to
-- origEnv, the LocalRdrEnv for the entire comprehension
- loop _ allBinds [] = do { thing <- bindLocalNames allBinds $ thing_inside elt_ty
- ; return ([], thing) } -- matching in the branches
-
- loop origEnv priorBinds (ParStmtBlock x stmts names _ : pairs)
+ loop origEnv priorBinds (ParStmtBlock x stmts names _ :| pairs)
= do { (stmts', (ids, pairs', thing))
<- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
do { ids <- tcLookupLocalIds names
; (pairs', thing) <- setLocalRdrEnv origEnv $
- loop origEnv (names ++ priorBinds) pairs
+ loop1 origEnv (names ++ priorBinds) pairs
; return (ids, pairs', thing) }
- ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
+ ; return ( ParStmtBlock x stmts' ids noSyntaxExpr :| pairs', thing ) }
+
+ loop1
+ :: LocalRdrEnv -> [Name] -> [ParStmtBlock GhcRn GhcRn]
+ -> TcM ([ParStmtBlock GhcTc GhcTc], _)
+ -- matching in the branches
+ loop1 _ binds [] = [ ([], a) | a <- bindLocalNames binds (thing_inside elt_ty) ]
+ loop1 env binds (x:xs) = [ (toList ys, a) | (ys, a) <- loop env binds (x:|xs) ]
tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
, trS_bndrs = bindersMap
@@ -869,20 +876,19 @@ tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLocA mzip_op) mzip_ty
-- type dummies since we don't know all binder types yet
- ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
- [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]
+ ; tup_tys_and_bndr_stmts_s <- traverse (\ bndr_stmts@(ParStmtBlock _ _ names _) ->
+ [ (tup_tys, bndr_stmts)
+ | tup_tys <- mkBigCoreTupTy <$> traverse (const (newFlexiTyVarTy liftedTypeKind)) names ]) bndr_stmts_s
-- Typecheck bind:
- ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
- tuple_ty = mk_tuple_ty tup_tys
+ ; let tuple_ty = mk_tuple_ty (NE.map fst tup_tys_and_bndr_stmts_s)
; (((blocks', thing), inner_res_ty), bind_op')
<- tcSyntaxOp MCompOrigin bind_op
[ synKnownType (m_ty `mkAppTy` tuple_ty)
, SynFun (synKnownType tuple_ty) SynRho ] res_ty $
\ [inner_res_ty] _ ->
- do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)
- tup_tys bndr_stmts_s
+ do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) tup_tys_and_bndr_stmts_s
; return (stuff, inner_res_ty) }
; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) }
@@ -890,17 +896,10 @@ tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
where
mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
- -- loop :: Type -- m_ty
- -- -> ExpRhoType -- inner_res_ty
- -- -> [TcType] -- tup_tys
- -- -> [ParStmtBlock Name]
- -- -> TcM ([([LStmt GhcTc], [TcId])], thing)
- loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty
- ; return ([], thing) }
- -- matching in the branches
-
- loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
- (ParStmtBlock x stmts names return_op : pairs)
+ loop
+ :: Type -> ExpRhoType -> NonEmpty (Type, ParStmtBlock GhcRn GhcRn)
+ -> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), _)
+ loop m_ty inner_res_ty ((tup_ty_in, ParStmtBlock x stmts names return_op) :| xs)
= do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
; (stmts', (ids, return_op', pairs', thing))
<- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
@@ -911,10 +910,16 @@ tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
tcSyntaxOp MCompOrigin return_op
[synKnownType tup_ty] m_tup_ty' $
\ _ _ -> return ()
- ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
+ ; (pairs', thing) <- loop1 m_ty inner_res_ty xs
; return (ids, return_op', pairs', thing) }
- ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }
- loop _ _ _ _ = panic "tcMcStmt.loop"
+ ; return (ParStmtBlock x stmts' ids return_op' :| pairs', thing) }
+
+ loop1
+ :: Type -> ExpRhoType -> [(Type, ParStmtBlock GhcRn GhcRn)]
+ -> TcM ([ParStmtBlock GhcTc GhcTc], _)
+ -- matching in the branches
+ loop1 _ r [] = [ ([], a) | a <- thing_inside r ]
+ loop1 m r (x:xs) = [ (toList ys, a) | (ys, a) <- loop m r (x:|xs) ]
tcMcStmt _ stmt _ _
= pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -101,6 +101,7 @@ import Control.Monad
import Control.Monad.Trans.Class ( lift )
import Data.Semigroup
import Data.List.NonEmpty ( NonEmpty )
+import Data.Foldable ( toList )
{- Note [What is zonking?]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1301,7 +1302,7 @@ zonkStmt _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op)
; new_stmts_w_bndrs <- noBinders $ mapM zonk_branch stmts_w_bndrs
-- Add in the binders after we're done with all the branches.
- ; let new_binders = [ b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs
+ ; let new_binders = [ b | ParStmtBlock _ _ bs _ <- toList new_stmts_w_bndrs
, b <- bs ]
; extendIdZonkEnvRec new_binders
; new_mzip <- noBinders $ zonkExpr mzip_op
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1365,8 +1365,11 @@ cvtStmt (NoBindS e) = do { e' <- cvtl e; returnLA $ mkBodyStmt e' }
cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnLA $ mkPsBindStmt noAnn p' e' }
cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs LetBinding ds
; returnLA $ LetStmt noAnn ds' }
-cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss
- ; returnLA $ ParStmt noExtField dss' noExpr noSyntaxExpr }
+cvtStmt (TH.ParS dss) = case nonEmpty dss of
+ Nothing -> failWith EmptyParStmt
+ Just dss -> do
+ { dss' <- mapM cvt_one dss
+ ; returnLA $ ParStmt noExtField dss' noExpr noSyntaxExpr }
where
cvt_one ds = do { ds' <- cvtStmts ds
; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) }
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -779,6 +779,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "DefaultDataInstDecl" = 39639
GhcDiagnosticCode "FunBindLacksEquations" = 52078
GhcDiagnosticCode "EmptyGuard" = 45149
+ GhcDiagnosticCode "EmptyParStmt" = 95595
-- TcRnDodgyImports/DodgyImportsReason
GhcDiagnosticCode "DodgyImportsEmptyParent" = 99623
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -1043,7 +1043,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
-- ParStmts only occur in a list/monad comprehension
| ParStmt (XParStmt idL idR body) -- Post typecheck,
-- S in (>>=) :: Q -> (R -> S) -> T
- [ParStmtBlock idL idR]
+ (NonEmpty (ParStmtBlock idL idR))
(HsExpr idR) -- Polymorphic `mzip` for monad comprehensions
(SyntaxExpr idR) -- The `>>=` operator
-- See notes [Monad Comprehensions]
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -94,6 +94,10 @@ Cmm
HUG (the typical use case), or `traverse` or `unitEnv_foldWithKey` in other
cases.
+* Changes to `Language.Haskell.Syntax.Expr`
+
+ - The `ParStmtBlock` list argument of the `ParStmt` constructor of `StmtLR` is now `NonEmpty`.
+
``ghc-heap`` library
~~~~~~~~~~~~~~~~~~~~
=====================================
testsuite/tests/th/EmptyParStmt.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module ShouldFail where
+
+import Language.Haskell.TH
+
+$(return [FunD (mkName "foo") [Clause [] (NormalB $ CompE [ParS []]) []]])
=====================================
testsuite/tests/th/EmptyParStmt.stderr
=====================================
@@ -0,0 +1,4 @@
+EmptyParStmt.hs:7:2: error: [GHC-95595]
+ Empty par stmt
+ When splicing a TH declaration: foo = []
+
=====================================
testsuite/tests/th/all.T
=====================================
@@ -148,6 +148,7 @@ test('T2674', normal, compile_fail, ['-v0'])
test('TH_emptycase', normal, compile, ['-v0'])
test('T24046', normal, compile, ['-v0'])
test('EmptyGuard', normal, compile_fail, ['-v0'])
+test('EmptyParStmt', normal, compile_fail, ['-v0'])
test('T2386', [only_ways(['normal'])], makefile_test, ['T2386'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/975d932cb4cadecd879660fbcf845e6ba9ac2a52...0e3575b5410b9fc2341c17451d8c616ebbe81721
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/975d932cb4cadecd879660fbcf845e6ba9ac2a52...0e3575b5410b9fc2341c17451d8c616ebbe81721
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/20250218/5290f2f3/attachment-0001.html>
More information about the ghc-commits
mailing list