diff --git a/compiler/GHC/Core/UsageEnv.hs b/compiler/GHC/Core/UsageEnv.hs
index b43b9332975f68880325543b9697b5e665c7793e..9d2b4438d0e4e69ca57e17bcf67ef7c77bde0252 100644
--- a/compiler/GHC/Core/UsageEnv.hs
+++ b/compiler/GHC/Core/UsageEnv.hs
@@ -90,9 +90,13 @@ supUE (UsageEnv e1 b1) (UsageEnv e2 b2) = UsageEnv (plusNameEnv_CD2 combineUsage
combineUsage Nothing Nothing = pprPanic "supUE" (ppr e1 <+> ppr e2)
-- Note: If you are changing this logic, check 'mkMultSup' in Multiplicity as well.
-supUEs :: [UsageEnv] -> UsageEnv
+-- Used with @f = '[]'@ and @f = 'NonEmpty'@
+supUEs :: Foldable f => f UsageEnv -> UsageEnv
supUEs = foldr supUE bottomUE
+-- INLINE to ensure specialization at use site, and to avoid multiple specialization on the same
+-- type
+{-# INLINE supUEs #-}
deleteUE :: NamedThing n => UsageEnv -> n -> UsageEnv
deleteUE (UsageEnv e b) x = UsageEnv (delFromNameEnv e (getName x)) b
diff --git a/compiler/GHC/Data/List/NonEmpty.hs b/compiler/GHC/Data/List/NonEmpty.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d34de7cf6282b8a85bdae4b3e235c8757af2f066
--- /dev/null
+++ b/compiler/GHC/Data/List/NonEmpty.hs
@@ -0,0 +1,20 @@
+module GHC.Data.List.NonEmpty (module Data.List.NonEmpty, module GHC.Data.List.NonEmpty) where
+
+import Prelude (Applicative (..), Bool, (.))
+import qualified Control.Monad as List (zipWithM)
+import Data.List.NonEmpty hiding (unzip)
+import qualified Data.List as List
+
+zipWithM :: Applicative f => (a -> b -> f c) -> NonEmpty a -> NonEmpty b -> f (NonEmpty c)
+zipWithM f (a:|as) (b:|bs) = liftA2 (:|) (f a b) (List.zipWithM f as bs)
+-- Inline to enable fusion of `List.zipWithM`
+-- See Note [Fusion for zipN/zipWithN] in List.hs
+{-# INLINE zipWithM #-}
+
+unzip :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)
+unzip ((a,b):|xs) = (a:|as, b:|bs)
+ where
+ (as, bs) = List.unzip xs
+
+isSingleton :: NonEmpty a -> Bool
+isSingleton = List.null . tail
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 484b5a0ce37a211120322c8922e7af13ad7abaea..142ebe8ec299027c72a89ceda9045debd9c55efb 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -75,7 +75,8 @@ import qualified Data.Data as Data (Fixity(..))
import qualified Data.Kind
import Data.Maybe (isJust)
import Data.Foldable ( toList )
-import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as NE
import Data.Void (Void)
{- *********************************************************************
@@ -804,14 +805,9 @@ ppr_expr (HsIf _ e1 e2 e3)
nest 4 (ppr e3)]
ppr_expr (HsMultiIf _ alts)
- = hang (text "if") 3 (vcat (map ppr_alt alts))
+ = hang (text "if") 3 (vcat $ toList $ NE.map ppr_alt alts)
where ppr_alt (L _ (GRHS _ guards expr)) =
- hang vbar 2 (ppr_one one_alt)
- where
- ppr_one [] = panic "ppr_exp HsMultiIf"
- ppr_one (h:t) = hang h 2 (sep t)
- one_alt = [ interpp'SP guards
- , text "->" <+> pprDeeper (ppr expr) ]
+ hang vbar 2 (hang (interpp'SP guards) 2 (text "->" <+> pprDeeper (ppr expr)))
ppr_alt (L _ (XGRHS x)) = ppr x
-- special case: let ... in let ...
@@ -1569,18 +1565,15 @@ isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
isSingletonMatchGroup :: [LMatch (GhcPass p) body] -> Bool
isSingletonMatchGroup matches
| [L _ match] <- matches
- , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match
+ , Match { m_grhss = GRHSs { grhssGRHSs = _ :| [] } } <- match
= True
| otherwise
= False
matchGroupArity :: MatchGroup (GhcPass id) body -> Arity
--- Precondition: MatchGroup is non-empty
-- This is called before type checking, when mg_arg_tys is not set
-matchGroupArity (MG { mg_alts = alts })
- | L _ (alt1:_) <- alts = count (isVisArgPat . unLoc) (hsLMatchPats alt1)
- | otherwise = panic "matchGroupArity"
-
+matchGroupArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts]
+matchGroupArity MG { mg_alts = L _ (alt1 : _) } = count (isVisArgPat . unLoc) (hsLMatchPats alt1)
hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]
hsLMatchPats (L _ (Match { m_pats = L _ pats })) = pats
@@ -1681,7 +1674,7 @@ pprMatch (Match { m_pats = L _ pats, m_ctxt = ctxt, m_grhss = grhss })
pprGRHSs :: (OutputableBndrId idR, Outputable body)
=> HsMatchContext fn -> GRHSs (GhcPass idR) body -> SDoc
pprGRHSs ctxt (GRHSs _ grhss binds)
- = vcat (map (pprGRHS ctxt . unLoc) grhss)
+ = vcat (toList $ NE.map (pprGRHS ctxt . unLoc) grhss)
-- Print the "where" even if the contents of the binds is empty. Only
-- EmptyLocalBinds means no "where" keyword
$$ ppUnless (eqEmptyLocalBinds binds)
@@ -2459,7 +2452,7 @@ FieldLabelStrings
instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where
ppr (FieldLabelStrings flds) =
- hcat (punctuate dot (map (ppr . unXRec @p) flds))
+ hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds))
instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where
pprInfixOcc = pprFieldLabelStrings
@@ -2471,7 +2464,7 @@ instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (Lo
pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc
pprFieldLabelStrings (FieldLabelStrings flds) =
- hcat (punctuate dot (map (ppr . unXRec @p) flds))
+ hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds))
pprPrefixFastString :: FastString -> SDoc
pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs)
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 67ff00920bf784b52bda8d171e63a1801c65a513..a0d07b1e04c1b985ed242225288cba572de1e990 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -157,7 +157,7 @@ import GHC.Utils.Panic
import Control.Arrow ( first )
import Data.Foldable ( toList )
import Data.List ( partition )
-import Data.List.NonEmpty ( nonEmpty )
+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )
import qualified Data.List.NonEmpty as NE
import Data.IntMap ( IntMap )
@@ -207,8 +207,8 @@ unguardedGRHSs loc rhs an
unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ EpAnn NoEpAnns
=> EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p))
- -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))]
-unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)]
+ -> NonEmpty (LGRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+unguardedRHS an loc rhs = NE.singleton $ L (noAnnSrcSpan loc) (GRHS an [] rhs)
type AnnoBody p body
= ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ Origin
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 4890718f0033ee18683b6783f0b572f369eebaed..d3f2a528e4a8ea434770f69d6713e106642bf681 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -530,7 +530,7 @@ multiple scrutinees)
dsCmd ids local_vars stack_ty res_ty
(HsCmdLam _ LamSingle (MG { mg_alts
= (L _ [L _ (Match { m_pats = L _ pats
- , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) }))
+ , m_grhss = GRHSs _ (L _ (GRHS _ [] body) :| _) _ })]) }))
env_ids
= dsCmdLam ids local_vars stack_ty res_ty pats body env_ids
@@ -1215,7 +1215,7 @@ leavesMatch (L _ (Match { m_pats = L _ pats
[(body,
mkVarSet (collectLStmtsBinders CollWithDictBinders stmts)
`unionVarSet` defined_vars)
- | L _ (GRHS _ stmts body) <- grhss]
+ | L _ (GRHS _ stmts body) <- toList grhss]
-- Replace the leaf commands in a match
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index efebb811cc3ccf61fffb090c4c6105c4ad6c90f9..7bbc10aff88a8692e2289de7be16758bfc6baf44 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -434,10 +434,6 @@ dsExpr (HsIf _ guard_expr then_expr else_expr)
; return $ mkIfThenElse pred b1 b2 }
dsExpr (HsMultiIf res_ty alts)
- | null alts
- = mkErrorExpr
-
- | otherwise
= do { let grhss = GRHSs emptyComments alts emptyLocalBinds
; rhss_nablas <- pmcGRHSs IfAlt grhss
; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas
diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs
index 828dc6eb12366a8c5892e78e673c915b428c9bd4..f48ee3808a3694000c24e0d05ad98c14d93b36e9 100644
--- a/compiler/GHC/HsToCore/GuardedRHSs.hs
+++ b/compiler/GHC/HsToCore/GuardedRHSs.hs
@@ -24,13 +24,12 @@ import GHC.HsToCore.Monad
import GHC.HsToCore.Utils
import GHC.HsToCore.Pmc.Types ( Nablas )
import GHC.Core.Type ( Type )
-import GHC.Utils.Misc
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Core.Multiplicity
-import Control.Monad ( zipWithM )
-import Data.List.NonEmpty ( NonEmpty, toList )
+import Data.List.NonEmpty ( NonEmpty )
+import qualified GHC.Data.List.NonEmpty as NE
{-
@dsGuarded@ is used for GRHSs.
@@ -62,9 +61,8 @@ dsGRHSs :: HsMatchContextRn
-- one for each GRHS.
-> DsM (MatchResult CoreExpr)
dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas
- = assert (notNull grhss) $
- do { match_results <- assert (length grhss == length rhss_nablas) $
- zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_nablas) grhss
+ = do { match_results <- assert (length grhss == length rhss_nablas) $
+ NE.zipWithM (dsGRHS hs_ctx rhs_ty) rhss_nablas grhss
; nablas <- getPmNablas
-- We need to remember the Nablas from the particular match context we
-- are in, which might be different to when dsLocalBinds is actually
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
index d84cc977787c7263e4d93a7f588c6977e0ce034f..64458155407ba475fcc26ddc0dd62a7b55e0d7b1 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ b/compiler/GHC/HsToCore/Pmc.hs
@@ -133,7 +133,7 @@ pmcGRHSs
-> DsM (NonEmpty Nablas) -- ^ Covered 'Nablas' for each RHS, for long
-- distance info
pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do
- let combined_loc = foldl1 combineSrcSpans (map getLocA grhss)
+ let combined_loc = foldl1 combineSrcSpans (NE.map getLocA grhss)
ctxt = DsMatchContext hs_ctxt combined_loc
!missing <- getLdiNablas
matches <- noCheckDs $ desugarGRHSs combined_loc empty guards
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index 2dab790bdfe04dfea74ce5fe77d3364cb5cb584f..578203005cbb80f75c7a6a5f277f5ad9ee0f150d 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -48,7 +48,6 @@ import GHC.Types.SourceText (FractionalLit(..))
import Control.Monad (zipWithM, replicateM)
import Data.List (elemIndex)
import Data.List.NonEmpty ( NonEmpty(..) )
-import qualified Data.List.NonEmpty as NE
-- import GHC.Driver.Ppr
@@ -344,10 +343,7 @@ desugarMatch vars (L match_loc (Match { m_pats = L _ pats, m_grhss = grhss })) =
desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)
desugarGRHSs match_loc pp_pats grhss = do
lcls <- desugarLocalBinds (grhssLocalBinds grhss)
- grhss' <- traverse (desugarLGRHS match_loc pp_pats)
- . expectJust "desugarGRHSs"
- . NE.nonEmpty
- $ grhssGRHSs grhss
+ grhss' <- traverse (desugarLGRHS match_loc pp_pats) (grhssGRHSs grhss)
return PmGRHSs { pgs_lcls = lcls, pgs_grhss = grhss' }
-- | Desugar a guarded right-hand side to a single 'GrdTree'
@@ -392,7 +388,7 @@ desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) =
-- See Note [Long-distance information for HsLocalBinds] for why this
-- pattern match is so very specific.
| L _ [L _ Match{m_pats = L _ [], m_grhss = grhss}] <- mg_alts mg
- , GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do
+ , GRHSs{grhssGRHSs = L _ (GRHS _ _grds rhs) :| []} <- grhss = do
core_rhs <- dsLExpr rhs
return (GdOne (PmLet x core_rhs))
go (L _ (XHsBindsLR (AbsBinds
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 5a937889e5a49840f36de5255b7116b78764a86a..32e90bea452835ae0537c149a4b85badf90fade6 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -69,6 +69,7 @@ import GHC.Utils.Monad
import GHC.Data.FastString
import GHC.Data.Maybe
+import qualified GHC.Data.List.NonEmpty as NE
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Unique
@@ -1585,8 +1586,8 @@ repE (HsIf _ x y z) = do
c <- repLE z
repCond a b c
repE (HsMultiIf _ alts)
- = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
- ; expr' <- repMultiIf (nonEmptyCoreList alts')
+ = do { (binds, alts') <- NE.unzip <$> mapM repLGRHS alts
+ ; expr' <- repMultiIf (nonEmptyCoreList' alts')
; wrapGenSyms (concat binds) expr' }
repE (HsLet _ bs e) = do { (ss,ds) <- repBinds bs
; e2 <- addBinds ss (repLE e)
@@ -1786,13 +1787,13 @@ repClauseTup (L _ (Match { m_pats = L _ ps
; clause <- repClause ps1 gs ds
; wrapGenSyms (ss1++ss2) clause }}}
-repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> MetaM (Core (M TH.Body))
-repGuards [L _ (GRHS _ [] e)]
+repGuards :: NonEmpty (LGRHS GhcRn (LHsExpr GhcRn)) -> MetaM (Core (M TH.Body))
+repGuards (L _ (GRHS _ [] e) :| [])
= do {a <- repLE e; repNormal a }
repGuards other
= do { zs <- mapM repLGRHS other
- ; let (xs, ys) = unzip zs
- ; gd <- repGuarded (nonEmptyCoreList ys)
+ ; let (xs, ys) = NE.unzip zs
+ ; gd <- repGuarded (nonEmptyCoreList' ys)
; wrapGenSyms (concat xs) gd }
repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
@@ -2118,7 +2119,7 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp))
repLambda (L _ (Match { m_pats = L _ ps
- , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
+ , m_grhss = GRHSs _ (L _ (GRHS _ [] e) :| [])
(EmptyLocalBinds _) } ))
= do { let bndrs = collectPatsBinders CollNoDictBinders ps ;
; ss <- mkGenSyms bndrs
diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs
index eb7a50c88335ca7b54a0db802b7abbb7cf371599..fcef96e45a1722ab79082afa2e6fff13d40a2e2f 100644
--- a/compiler/GHC/HsToCore/Ticks.hs
+++ b/compiler/GHC/HsToCore/Ticks.hs
@@ -52,6 +52,7 @@ import Data.List (isSuffixOf, intersperse)
import Trace.Hpc.Mix
import Data.Bifunctor (second)
+import Data.List.NonEmpty (NonEmpty (..))
import Data.Set (Set)
import qualified Data.Set as Set
@@ -527,7 +528,7 @@ addTickHsExpr (HsIf x e1 e2 e3) =
(addTickLHsExprOptAlt True e2)
(addTickLHsExprOptAlt True e3)
addTickHsExpr (HsMultiIf ty alts)
- = do { let isOneOfMany = case alts of [_] -> False; _ -> True
+ = do { let isOneOfMany = case alts of { (_ :| []) -> False; _ -> True; }
; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False False) alts
; return $ HsMultiIf ty alts' }
addTickHsExpr (HsLet x binds e) =
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 84ba63f62d17fd241134a4034dfe8ef1291b3ff8..d205f1e146df88825e90feb44e2567e9450393e0 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -433,7 +433,7 @@ getRealSpan _ = Nothing
grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns)
=> GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan
-grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLocA xs)
+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (NE.map getLocA xs)
bindingsOnly :: [Context Name] -> HieM [HieAST a]
bindingsOnly [] = pure []
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 53a646fdba0f2e9159cafe3fc0d5adacfbe09d22..c8831802a03fb6cb80406e2d1172c797c4c17e59 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -42,7 +42,7 @@ where
import Control.Monad ( unless, liftM, when, (<=<) )
import GHC.Exts
import Data.Maybe ( maybeToList )
-import Data.List.NonEmpty ( NonEmpty(..) )
+import Data.List.NonEmpty ( NonEmpty(..), head, init, last, tail )
import qualified Data.List.NonEmpty as NE
import qualified Prelude -- for happy-generated code
@@ -63,7 +63,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Error
import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )
import GHC.Utils.Panic
-import GHC.Prelude
+import GHC.Prelude hiding ( head, init, last, tail )
import qualified GHC.Data.Strict as Strict
import GHC.Types.Name.Reader
@@ -2703,11 +2703,11 @@ rhs :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) }
bs)) } }
| gdrhs wherebinds {% do { let {L l (bs, csw) = adaptWhereBinds $2}
; acs (comb2 $1 (L l bs)) (\loc cs -> L loc
- (GRHSs (cs Semi.<> csw) (reverse (unLoc $1)) bs)) }}
+ (GRHSs (cs Semi.<> csw) (NE.reverse (unLoc $1)) bs)) }}
-gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
- : gdrhs gdrh { sLL $1 $> ($2 : unLoc $1) }
- | gdrh { sL1 $1 [$1] }
+gdrhs :: { Located (NonEmpty (LGRHS GhcPs (LHsExpr GhcPs))) }
+ : gdrhs gdrh { sLL $1 $> ($2 NE.<| unLoc $1) }
+ | gdrh { sL1 $1 (NE.singleton $1) }
gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }
: '|' guardquals '=' exp {% runPV (unECP $4) >>= \ $4 ->
@@ -3052,7 +3052,7 @@ aexp :: { ECP }
fmap ecpFromExp $
do { let (L _ ((o,c),_)) = $2
; amsA' (sLL $1 $> $ HsMultiIf (epTok $1, o, c)
- (reverse $ snd $ unLoc $2)) }}
+ (NE.reverse $ snd $ unLoc $2)) }}
| 'case' exp 'of' altslist(pats1) {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->
return $ ECP $
$4 >>= \ $4 ->
@@ -3279,8 +3279,8 @@ tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) }
; return (Tuple (Right t : snd $2)) } }
| commas tup_tail
{ $2 >>= \ $2 ->
- do { let {cos = map (\ll -> (Left (EpAnn (spanAsAnchor ll) True emptyComments))) (fst $1) }
- ; return (Tuple (cos ++ $2)) } }
+ do { let {cos = NE.map (\ll -> (Left (EpAnn (spanAsAnchor ll) True emptyComments))) (fst $1) }
+ ; return (Tuple (toList cos ++ $2)) } }
| texp bars { unECP $1 >>= \ $1 -> return $
(Sum 1 (snd $2 + 1) $1 [] (fst $2)) }
@@ -3492,22 +3492,22 @@ alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }
do { let {L l (bs, csw) = adaptWhereBinds $2}
; acs (comb2 alt (L l bs)) (\loc cs -> L loc (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) }}
-ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }
+ralt :: { forall b. DisambECP b => PV (Located (NonEmpty (LGRHS GhcPs (LocatedA b)))) }
: '->' exp { unECP $2 >>= \ $2 ->
acs (comb2 $1 $>) (\loc cs -> L loc (unguardedRHS (EpAnn (spanAsAnchor $ comb2 $1 $2) (GrhsAnn Nothing (Right $ epUniTok $1)) cs) (comb2 $1 $2) $2)) }
| gdpats { $1 >>= \gdpats ->
- return $ sL1 gdpats (reverse (unLoc gdpats)) }
+ return $ sL1 gdpats (NE.reverse (unLoc gdpats)) }
-gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }
+gdpats :: { forall b. DisambECP b => PV (Located (NonEmpty (LGRHS GhcPs (LocatedA b)))) }
: gdpats gdpat { $1 >>= \gdpats ->
$2 >>= \gdpat ->
- return $ sLL gdpats gdpat (gdpat : unLoc gdpats) }
- | gdpat { $1 >>= \gdpat -> return $ sL1 gdpat [gdpat] }
+ return $ sLL gdpats gdpat (gdpat NE.<| unLoc gdpats) }
+ | gdpat { $1 >>= \gdpat -> return $ sL1 gdpat (NE.singleton gdpat) }
-- layout for MultiWayIf doesn't begin with an open brace, because it's hard to
-- generate the open brace in addition to the vertical bar in the lexer, and
-- we don't need it.
-ifgdpats :: { Located ((EpToken "{", EpToken "}"), [LGRHS GhcPs (LHsExpr GhcPs)]) }
+ifgdpats :: { Located ((EpToken "{", EpToken "}"), NonEmpty (LGRHS GhcPs (LHsExpr GhcPs))) }
: '{' gdpats '}' {% runPV $2 >>= \ $2 ->
return $ sLL $1 $> ((epTok $1,epTok $3),unLoc $2) }
| gdpats close {% runPV $1 >>= \ $1 ->
@@ -3650,7 +3650,7 @@ fbind :: { forall b. DisambECP b => PV (Fbind b) }
let top = sL1a $1 $ DotFieldOcc noAnn $1
((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)
lf' = comb2 $2 (L lf ())
- fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ epTok $2)) f) : t
+ fields = top :| L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ epTok $2)) f) : t
final = last fields
l = comb2 $1 $3
isPun = False
@@ -3666,7 +3666,7 @@ fbind :: { forall b. DisambECP b => PV (Fbind b) }
let top = sL1a $1 $ DotFieldOcc noAnn $1
((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)
lf' = comb2 $2 (L lf ())
- fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ epTok $2)) f) : t
+ fields = top :| L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ epTok $2)) f) : t
final = last fields
l = comb2 $1 $3
isPun = True
@@ -3725,13 +3725,13 @@ name_boolformula :: { LBooleanFormula GhcPs }
name_boolformula_and :: { LBooleanFormula GhcPs }
: name_boolformula_and_list
- { sLLa (head $1) (last $1) (And ($1)) }
+ { sLLa (head $1) (last $1) (And (toList $1)) }
-name_boolformula_and_list :: { [LBooleanFormula GhcPs] }
- : name_boolformula_atom { [$1] }
+name_boolformula_and_list :: { NonEmpty (LBooleanFormula GhcPs) }
+ : name_boolformula_atom { NE.singleton $1 }
| name_boolformula_atom ',' name_boolformula_and_list
{% do { h <- addTrailingCommaL $1 (epTok $2)
- ; return (h : $3) } }
+ ; return (h NE.<| $3) } }
name_boolformula_atom :: { LBooleanFormula GhcPs }
: '(' name_boolformula ')' {% amsr (sLL $1 $> (Parens $2))
@@ -3779,10 +3779,10 @@ qcon_list : qcon { [$1] }
-- See Note [ExplicitTuple] in GHC.Hs.Expr
sysdcon_nolist :: { LocatedN DataCon } -- Wired in data constructors
: '(' commas ')' {% amsr (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))
- (NameAnnCommas (NameParens (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (fst $2)) []) }
+ (NameAnnCommas (NameParens (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (toList $ fst $2)) []) }
| '(#' '#)' {% amsr (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly (NameParensHash (epTok $1) (epTok $2)) []) }
| '(#' commas '#)' {% amsr (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))
- (NameAnnCommas (NameParensHash (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (fst $2)) []) }
+ (NameAnnCommas (NameParensHash (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (toList $ fst $2)) []) }
syscon :: { LocatedN RdrName }
: sysdcon { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }
@@ -3823,12 +3823,12 @@ gtycon :: { LocatedN RdrName } -- A "general" qualified tycon, including unit t
ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit tuples
: oqtycon { $1 }
| '(' commas ')' {% do { n <- mkTupleSyntaxTycon Boxed (snd $2 + 1)
- ; amsr (sLL $1 $> n) (NameAnnCommas (NameParens (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (fst $2)) []) }}
+ ; amsr (sLL $1 $> n) (NameAnnCommas (NameParens (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (toList $ fst $2)) []) }}
| '(#' commas '#)' {% do { n <- mkTupleSyntaxTycon Unboxed (snd $2 + 1)
- ; amsr (sLL $1 $> n) (NameAnnCommas (NameParensHash (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (fst $2)) []) }}
+ ; amsr (sLL $1 $> n) (NameAnnCommas (NameParensHash (epTok $1) (epTok $3)) (map (EpTok . srcSpan2e) (toList $ fst $2)) []) }}
| '(#' bars '#)' {% do { requireLTPuns PEP_SumSyntaxType $1 $>
; amsr (sLL $1 $> $ (getRdrName (sumTyCon (snd $2 + 1))))
- (NameAnnBars (epTok $1, epTok $3) (fst $2) []) } }
+ (NameAnnBars (epTok $1, epTok $3) (toList $ fst $2) []) } }
| '(' '->' ')' {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
(NameAnnRArrow (Just $ epTok $1) (epUniTok $2) (Just $ epTok $3) []) }
@@ -4157,9 +4157,9 @@ modid :: { LocatedA ModuleName }
(concatFS [mod, fsLit ".", c])
}
-commas :: { ([SrcSpan],Int) } -- One or more commas
- : commas ',' { ((fst $1)++[gl $2],snd $1 + 1) }
- | ',' { ([gl $1],1) }
+commas :: { (NonEmpty SrcSpan,Int) } -- One or more commas
+ : commas ',' { (foldr (NE.<|) (NE.singleton $ gl $2) (fst $1) ,snd $1 + 1) }
+ | ',' { (NE.singleton $ gl $1, 1) }
bars0 :: { ([EpToken "|"],Int) } -- Zero or more bars
: bars { $1 }
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index afa5c5734a6f27d32ef61ab83a3f8d6e23a23b1a..99fbed1584fbf56095ab6ba0cc402cafb43d8816 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -174,7 +174,7 @@ import Text.ParserCombinators.ReadP as ReadP
import Data.Char
import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
import Data.Kind ( Type )
-import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty ( NonEmpty (..) )
{- **********************************************************************
@@ -1643,7 +1643,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)
-- | Return a pattern without ambiguity, or fail in a non-pattern context.
ecpFromPat' :: LPat GhcPs -> PV (LocatedA b)
- mkHsProjUpdatePV :: SrcSpan -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
+ mkHsProjUpdatePV :: SrcSpan -> Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))
-> LocatedA b -> Bool -> Maybe (EpToken "=") -> PV (LHsRecProj GhcPs (LocatedA b))
-- | Disambiguate "let ... in ..."
mkHsLetPV
@@ -2934,7 +2934,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
let f = occNameFS . rdrNameOcc $ rdr
fl = DotFieldOcc noAnn (L loc (FieldLabelString f))
lf = locA loc
- in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns
+ in mkRdrProjUpdate l (L lf (L (l2l loc) fl :| [])) (punnedVar f) pun anns
where
-- If punning, compute HsVar "f" otherwise just arg. This
-- has the effect that sentinel HsVar "pun-rhs" is replaced
@@ -3557,10 +3557,9 @@ mkRdrProjection flds anns =
, proj_flds = fmap unLoc flds
}
-mkRdrProjUpdate :: SrcSpanAnnA -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
+mkRdrProjUpdate :: SrcSpanAnnA -> Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))
-> LHsExpr GhcPs -> Bool -> Maybe (EpToken "=")
-> LHsRecProj GhcPs (LHsExpr GhcPs)
-mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!"
mkRdrProjUpdate loc (L l flds) arg isPun anns =
L loc HsFieldBind {
hfbAnn = anns
diff --git a/compiler/GHC/Prelude/Basic.hs b/compiler/GHC/Prelude/Basic.hs
index e86b4ba44d1bf481d4bb7d65d10b7ec25c2dea41..e79e55d5f0a125eaf6c708bd7b5c313216562c7b 100644
--- a/compiler/GHC/Prelude/Basic.hs
+++ b/compiler/GHC/Prelude/Basic.hs
@@ -24,7 +24,7 @@ module GHC.Prelude.Basic
, bit
, shiftL, shiftR
, setBit, clearBit
- , head, tail
+ , head, tail, unzip
, strictGenericLength
) where
@@ -59,9 +59,11 @@ NoImplicitPrelude. There are two motivations for this:
-}
import qualified Prelude
-import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail)
+import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip)
import Control.Applicative (Applicative(..))
import Data.Foldable as X (Foldable(elem, foldMap, foldr, foldl, foldl', foldr1, foldl1, maximum, minimum, product, sum, null, length))
+import qualified Data.List as List
+import qualified GHC.Data.List.NonEmpty as NE
import GHC.Stack.Types (HasCallStack)
import GHC.Bits as Bits hiding (bit, shiftL, shiftR, setBit, clearBit)
@@ -144,3 +146,10 @@ See #25706 for why it is important to use a strict, specialised version.
-}
strictGenericLength :: Num a => [x] -> a
strictGenericLength = fromIntegral . length
+
+-- This is `Data.Functor.unzip`. Unfortunately, that function lacks the RULES for specialization.
+unzip :: Functor f => f (a, b) -> (f a, f b)
+unzip = \ xs -> (fmap fst xs, fmap snd xs)
+{-# NOINLINE [1] unzip #-}
+{-# RULES "unzip/List" unzip = List.unzip #-}
+{-# RULES "unzip/NonEmpty" unzip = NE.unzip #-}
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 59049cddbb50cc7f391d176eb8ca8614267527a9..628ec09ee37933ab275963f459b6db497c53fbad 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -28,7 +28,7 @@ module GHC.Rename.Expr (
AnnoBody, UnexpectedStatement(..)
) where
-import GHC.Prelude
+import GHC.Prelude hiding (head, init, last, scanl, tail)
import GHC.Hs
import GHC.Tc.Errors.Types
@@ -63,6 +63,7 @@ import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Utils.Misc
+import qualified GHC.Data.List.NonEmpty as NE
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
@@ -77,12 +78,12 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Control.Monad
import Data.List (unzip4, minimumBy)
-import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
+import Data.List.NonEmpty ( NonEmpty(..), head, init, last, nonEmpty, scanl, tail )
import Control.Arrow (first)
import Data.Ord
import Data.Array
-import qualified Data.List.NonEmpty as NE
import GHC.Driver.Env (HscEnv)
+import Data.Foldable (toList)
{- Note [Handling overloaded and rebindable constructs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -890,7 +891,7 @@ rnDotFieldOcc :: DotFieldOcc GhcPs -> DotFieldOcc GhcRn
rnDotFieldOcc (DotFieldOcc x label) = DotFieldOcc x label
rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
-rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map (fmap rnDotFieldOcc) fls)
+rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (fmap (fmap rnDotFieldOcc) fls)
{-
************************************************************************
@@ -1033,7 +1034,8 @@ methodNamesMatch (MG { mg_alts = L _ ms })
-------------------------------------------------
-- gaw 2004
methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
-methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
+methodNamesGRHSs (GRHSs _ grhss _)
+ = foldl' (flip plusFV) emptyFVs (NE.map methodNamesGRHS grhss)
-------------------------------------------------
@@ -1803,7 +1805,7 @@ be used later.
glomSegments :: HsStmtContextRn
-> [Segment (LStmt GhcRn body)]
- -> [Segment [LStmt GhcRn body]]
+ -> [Segment (NonEmpty (LStmt GhcRn body))]
-- Each segment has a non-empty list of Stmts
-- See Note [Glomming segments]
@@ -1819,7 +1821,7 @@ glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
seg_defs = plusFVs ds `plusFV` defs
seg_uses = plusFVs us `plusFV` uses
seg_fwds = plusFVs fs `plusFV` fwds
- seg_stmts = stmt : concat ss
+ seg_stmts = stmt :| concatMap toList ss
grab :: NameSet -- The client
-> [Segment a]
@@ -1835,24 +1837,23 @@ glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
----------------------------------------------------
segsToStmts :: Stmt GhcRn (LocatedA (body GhcRn))
-- A RecStmt with the SyntaxOps filled in
- -> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
+ -> [Segment (NonEmpty (LStmt GhcRn (LocatedA (body GhcRn))))]
-- Each Segment has a non-empty list of Stmts
-> FreeVars -- Free vars used 'later'
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
segsToStmts _ [] fvs_later = ([], fvs_later)
segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
- = assert (not (null ss))
- (new_stmt : later_stmts, later_uses `plusFV` uses)
+ = (new_stmt : later_stmts, later_uses `plusFV` uses)
where
(later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
new_stmt | non_rec = head ss
| otherwise = L (getLoc (head ss)) rec_stmt
- rec_stmt = empty_rec_stmt { recS_stmts = noLocA ss
+ rec_stmt = empty_rec_stmt { recS_stmts = noLocA (toList ss)
, recS_later_ids = nameSetElemsStable used_later
, recS_rec_ids = nameSetElemsStable fwds }
-- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
- non_rec = isSingleton ss && isEmptyNameSet fwds
+ non_rec = NE.isSingleton ss && isEmptyNameSet fwds
used_later = defs `intersectNameSet` later_uses
-- The ones needed after the RecStmt
@@ -2246,7 +2247,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
tup = mkBigLHsVarTup pvars noExtField
(stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
(mb_ret, fvs1) <-
- if | L _ (XStmtLR ApplicativeStmt{}) <- last stmts' ->
+ if | Just (L _ (XStmtLR ApplicativeStmt{})) <- lastMaybe stmts' ->
return (unLoc tup, emptyNameSet)
| otherwise -> do
-- Need 'pureAName' and not 'returnMName' here, so that it requires
@@ -2840,7 +2841,7 @@ rnHsIf p b1 b2
-- mkGetField arg field calculates a get_field @field arg expression.
-- e.g. z.x = mkGetField z x = get_field @x z
mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
-mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field)
+mkGetField get_field arg field = unLoc (head $ mkGet get_field (arg :| []) field)
-- mkSetField a field b calculates a set_field @field expression.
-- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' to a on b").
@@ -2849,10 +2850,9 @@ mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LH
mkSetField set_field a (L _ (FieldLabelString field)) b =
genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field) b) a
-mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn]
-mkGet get_field l@(r : _) (L _ (FieldLabelString field)) =
- wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l
-mkGet _ [] _ = panic "mkGet : The impossible has happened!"
+mkGet :: Name -> NonEmpty (LHsExpr GhcRn) -> LocatedAn NoEpAnns FieldLabelString -> NonEmpty (LHsExpr GhcRn)
+mkGet get_field l@(r :| _) (L _ (FieldLabelString field)) =
+ wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) NE.<| l
mkSet :: Name -> LHsExpr GhcRn -> (LocatedAn NoEpAnns FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn
mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc)
@@ -2875,10 +2875,10 @@ mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fie
mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn)
mkProjUpdateSetField get_field set_field (L _ (HsFieldBind { hfbLHS = (L _ (FieldLabelStrings flds')), hfbRHS = arg } ))
= let {
- ; flds = map (fmap (unLoc . dfoLabel)) flds'
+ ; flds = NE.map (fmap (unLoc . dfoLabel)) flds'
; final = last flds -- quux
; fields = init flds -- [foo, bar, baz]
- ; getters = \a -> foldl' (mkGet get_field) [a] fields -- Ordered from deep to shallow.
+ ; getters = \a -> foldl' (mkGet get_field) (a :| []) fields -- Ordered from deep to shallow.
-- [getField@"baz"(getField@"bar"(getField@"foo" a), getField@"bar"(getField@"foo" a), getField@"foo" a, a]
; zips = \a -> (final, head (getters a)) : zip (reverse fields) (tail (getters a)) -- Ordered from deep to shallow.
-- [("quux", getField@"baz"(getField@"bar"(getField@"foo" a)), ("baz", getField@"bar"(getField@"foo" a)), ("bar", getField@"foo" a), ("foo", a)]
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 0d35bc8edefe603852334804f3d2107628c158a4..6b8d2e0116ef67c373fb89301845d736c9148047 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -558,7 +558,7 @@ checkCanonicalInstances cls poly_ty mbinds = do
isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = L _ []
, m_grhss = grhss })])}
- | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss
+ | GRHSs _ (L _ (GRHS _ [] body) :| []) lbinds <- grhss
, EmptyLocalBinds _ <- lbinds
, HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName)
isAliasMG _ = Nothing
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 9ff9513d49e30bde7d86fd9e457fb0ab44718842..7c842cb7e7fcc5dab77e465015f3a6d87cf531b0 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -42,7 +42,7 @@ module GHC.Rename.Utils (
where
-import GHC.Prelude hiding (unzip)
+import GHC.Prelude
import GHC.Core.Type
import GHC.Hs
@@ -74,7 +74,6 @@ import GHC.Unit.Module.Warnings ( WarningTxt(..) )
import GHC.Iface.Load
import qualified GHC.LanguageExtensions as LangExt
-import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import Data.Foldable
import Data.Maybe
@@ -346,11 +345,6 @@ mapFvRn f xs = do
(ys, fvs_s) -> return (ys, foldl' (flip plusFV) emptyFVs fvs_s)
{-# SPECIALIZE mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) #-}
-unzip :: Functor f => f (a, b) -> (f a, f b)
-unzip = \ xs -> (fmap fst xs, fmap snd xs)
-{-# NOINLINE [1] unzip #-}
-{-# RULES "unzip/List" unzip = List.unzip #-}
-
mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)
mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index c5e5b4dccdb7f825a2fc7cca99fcd311443f5bcf..7dd576b92875ac8f2502313a6b723883fa759b0d 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -5705,6 +5705,8 @@ pprConversionFailReason = \case
text "Function binding for"
<+> quotes (text (TH.pprint nm))
<+> text "has no equations"
+ EmptyGuard ->
+ text "Empty guard"
pprTyThingUsedWrong :: WrongThingSort -> TcTyThing -> Name -> SDoc
pprTyThingUsedWrong sort thing name =
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 054dd598f9b347f7cdbac048ecb770b540a9a050..81554f73499883cafb42cb547ef2a3395b151162 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -6782,6 +6782,7 @@ data ConversionFailReason
| InvalidImplicitParamBinding
| DefaultDataInstDecl ![LDataFamInstDecl GhcPs]
| FunBindLacksEquations !TH.Name
+ | EmptyGuard
deriving Generic
data IllegalDecls
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 60ecbdebbe7e326be1f970b241659ea9bfc51adc..58eed3f7215b47713b12b5acc7899560a78075a8 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -56,7 +56,7 @@ import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
import GHC.Tc.Gen.Match( tcBody, tcLambdaMatches, tcCaseMatches
- , tcGRHSList, tcDoStmts )
+ , tcGRHSNE, tcDoStmts )
import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Zonk.TcType
@@ -528,7 +528,7 @@ Not using 'sup' caused #23814.
-}
tcExpr (HsMultiIf _ alts) res_ty
- = do { alts' <- tcGRHSList IfAlt tcBody alts res_ty
+ = do { alts' <- tcGRHSNE IfAlt tcBody alts res_ty
-- See Note [MultiWayIf linearity checking]
; res_ty <- readExpType res_ty
; return (HsMultiIf res_ty alts') }
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index aa6ad2d716a9def4149e30ad774f938f216f6b55..dfc6397926e65d4e24bcf8fbf08f1b081ef5980c 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -19,7 +19,7 @@ module GHC.Tc.Gen.Match
( tcFunBindMatches
, tcCaseMatches
, tcLambdaMatches
- , tcGRHSList
+ , tcGRHSNE
, tcGRHSsPat
, TcStmtChecker
, TcExprStmtChecker
@@ -77,9 +77,11 @@ import GHC.Types.Id
import GHC.Types.SrcLoc
import GHC.Types.Basic( VisArity, isDoExpansionGenerated )
+import qualified GHC.Data.List.NonEmpty as NE
+
import Control.Monad
import Control.Arrow ( second )
-import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (mapMaybe)
import qualified GHC.LanguageExtensions as LangExt
@@ -300,15 +302,15 @@ tcGRHSs :: AnnoBody body
-- but we don't need to do that any more
tcGRHSs ctxt tc_body (GRHSs _ grhss binds) res_ty
= do { (binds', grhss') <- tcLocalBinds binds $ do
- tcGRHSList ctxt tc_body grhss res_ty
+ tcGRHSNE ctxt tc_body grhss res_ty
; return (GRHSs emptyComments grhss' binds') }
-tcGRHSList :: forall body. AnnoBody body
+tcGRHSNE :: forall body. AnnoBody body
=> HsMatchContextRn -> TcMatchAltChecker body
- -> [LGRHS GhcRn (LocatedA (body GhcRn))] -> ExpRhoType
- -> TcM [LGRHS GhcTc (LocatedA (body GhcTc))]
-tcGRHSList ctxt tc_body grhss res_ty
- = do { (usages, grhss') <- mapAndUnzipM (wrapLocSndMA tc_alt) grhss
+ -> NonEmpty (LGRHS GhcRn (LocatedA (body GhcRn))) -> ExpRhoType
+ -> TcM (NonEmpty (LGRHS GhcTc (LocatedA (body GhcTc))))
+tcGRHSNE ctxt tc_body grhss res_ty
+ = do { (usages, grhss') <- unzip <$> traverse (wrapLocSndMA tc_alt) grhss
; tcEmitBindingUsage $ supUEs usages
; return grhss' }
where
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index cc0a77713ee872b3741eb57c6cc4c711b1017dc9..f1088aac39a32bb0ffd2f978fb90976fea2bb575 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -84,6 +84,7 @@ import GHC.Types.Unique.Supply
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import qualified Data.Kind as Hs
+import Data.List.NonEmpty (NonEmpty (..))
{- *********************************************************************
* *
@@ -775,8 +776,8 @@ grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin
grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss
-- | Extract a suitable CtOrigin from a list of guarded RHSs
-lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin
-lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e
+lGRHSCtOrigin :: NonEmpty (LGRHS GhcRn (LHsExpr GhcRn)) -> CtOrigin
+lGRHSCtOrigin (L _ (GRHS _ _ (L _ e)) :| []) = exprCtOrigin e
lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS"
pprCtOrigin :: CtOrigin -> SDoc
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 25002655ae8ae55483e4e91d22767f52b5ebf659..97518261f3e3d2e8daaf88180c6245b6f58951bd 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1107,10 +1107,9 @@ cvtl e = wrapLA (cvt e)
; return $ ExplicitSum noAnn alt arity e'}
cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
; return $ mkHsIf x' y' z' noAnn }
- cvt (MultiIfE alts)
- | null alts = failWith MultiWayIfWithoutAlts
- | otherwise = do { alts' <- mapM cvtpair alts
- ; return $ HsMultiIf noAnn alts' }
+ cvt (MultiIfE alts) = case nonEmpty alts of
+ Nothing -> failWith MultiWayIfWithoutAlts
+ Just alts -> HsMultiIf noAnn <$> traverse cvtpair alts
cvt (LetE ds e) = do { ds' <- cvtLocalDecs LetExpression ds
; e' <- cvtl e; return $ HsLet noAnn ds' e'}
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
@@ -1385,10 +1384,12 @@ cvtMatch ctxt (TH.Match p body decs)
; decs' <- cvtLocalDecs WhereClause decs
; returnLA $ Hs.Match noExtField ctxt (noLocA [lp]) (GRHSs emptyComments g' decs') }
-cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
-cvtGuard (GuardedB pairs) = mapM cvtpair pairs
+cvtGuard :: TH.Body -> CvtM (NonEmpty (LGRHS GhcPs (LHsExpr GhcPs)))
+cvtGuard (GuardedB pairs) = case nonEmpty pairs of
+ Nothing -> failWith EmptyGuard
+ Just pairs -> traverse cvtpair pairs
cvtGuard (NormalB e) = do { e' <- cvtl e
- ; g' <- returnLA $ GRHS noAnn [] e'; return [g'] }
+ ; g' <- returnLA $ GRHS noAnn [] e'; return (g' :| []) }
cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 03254e1f1da610e5993047bccbf043941be10c26..1fadb703b684b4c05a1c5137dea78ee8c0a8064f 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -778,6 +778,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "InvalidImplicitParamBinding" = 51603
GhcDiagnosticCode "DefaultDataInstDecl" = 39639
GhcDiagnosticCode "FunBindLacksEquations" = 52078
+ GhcDiagnosticCode "EmptyGuard" = 45149
-- TcRnDodgyImports/DodgyImportsReason
GhcDiagnosticCode "DodgyImportsEmptyParent" = 99623
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 6157bdfbef6b77469ad1d2c5786e630a3eab041f..54bc91638f5ad74082e29d8628911ec9fe20ed69 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -130,7 +130,7 @@ values (see function @mkRdrRecordUpd@ in 'GHC.Parser.PostProcess').
type LFieldLabelStrings p = XRec p (FieldLabelStrings p)
newtype FieldLabelStrings p =
- FieldLabelStrings [XRec p (DotFieldOcc p)]
+ FieldLabelStrings (NonEmpty (XRec p (DotFieldOcc p)))
-- Field projection updates (e.g. @foo.bar.baz = 1@). See Note
-- [RecordDotSyntax field updates].
@@ -429,7 +429,7 @@ data HsExpr p
(LHsExpr p) -- else part
-- | Multi-way if
- | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)]
+ | HsMultiIf (XMultiIf p) (NonEmpty (LGRHS p (LHsExpr p)))
-- | let(rec)
| HsLet (XLet p)
@@ -871,10 +871,13 @@ patterns in each equation.
data MatchGroup p body
= MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result, and origin
- , mg_alts :: XRec p [LMatch p body] } -- The alternatives
+ , mg_alts :: XRec p [LMatch p body]
+ -- The alternatives, see Note [Empty mg_alts] for what it means if 'mg_alts' is empty.
+ }
-- The type is the type of the entire group
-- t1 -> ... -> tn -> tr
-- where there are n patterns
+
| XMatchGroup !(XXMatchGroup p body)
-- | Located Match
@@ -920,6 +923,21 @@ annotations
(&&& ) [] [] = []
xs &&& [] = xs
( &&& ) [] ys = ys
+
+
+Note [Empty mg_alts]
+~~~~~~~~~~~~~~~~~~~~~~
+A `MatchGroup` for a function definition must have at least one alt, as it is not possible to
+define a function by zero clauses — the compiler would consider this a missing definition,
+rather than one with no clauses.
+
+However, a `MatchGroup` for a `case` or `\ case` expression may be empty, as such an expression
+may have zero branches. (Note: A `\ cases` expression may not have zero branches; see GHC
+proposal 302).
+
+Ergo, if we have no alts, it must be either a `case` or a `\ case` expression; such expressions
+have match arity 1.
+
-}
@@ -929,7 +947,7 @@ annotations
data GRHSs p body
= GRHSs {
grhssExt :: XCGRHSs p body,
- grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs
+ grhssGRHSs :: NonEmpty (LGRHS p body), -- ^ Guarded RHSs
grhssLocalBinds :: HsLocalBinds p -- ^ The where clause
}
| XGRHSs !(XXGRHSs p body)
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index f8b8039832eece0d5c2836a57405d3a135b66e92..6e294e6c1cbc662c9bc26dc9757a2394fba25a24 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -454,6 +454,7 @@ Library
GHC.Data.Graph.UnVar
GHC.Data.IOEnv
GHC.Data.List.Infinite
+ GHC.Data.List.NonEmpty
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout
index 9c135b4f535d8293b9f100abc7271d708cf7da0d..a120245f396f700fd5b0c0563fe4af1f0a6b9793 100644
--- a/testsuite/tests/count-deps/CountDepsAst.stdout
+++ b/testsuite/tests/count-deps/CountDepsAst.stdout
@@ -69,6 +69,7 @@ GHC.Data.Graph.Directed
GHC.Data.Graph.Directed.Internal
GHC.Data.Graph.UnVar
GHC.Data.List.Infinite
+GHC.Data.List.NonEmpty
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout
index 987a7b45c2f0325df2b55af8b4288ceed281f155..ad13a02c1bca57f331f68bde63c6b422ae0d400d 100644
--- a/testsuite/tests/count-deps/CountDepsParser.stdout
+++ b/testsuite/tests/count-deps/CountDepsParser.stdout
@@ -71,6 +71,7 @@ GHC.Data.Graph.Directed.Internal
GHC.Data.Graph.Directed.Reachability
GHC.Data.Graph.UnVar
GHC.Data.List.Infinite
+GHC.Data.List.NonEmpty
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
diff --git a/testsuite/tests/ghc-api/exactprint/T22919.stderr b/testsuite/tests/ghc-api/exactprint/T22919.stderr
index cbda59b70c973ff27cb8179328c9beac4ed0b8f7..b20ffb363523c000a23f0a2b5fc951fac1741810 100644
--- a/testsuite/tests/ghc-api/exactprint/T22919.stderr
+++ b/testsuite/tests/ghc-api/exactprint/T22919.stderr
@@ -107,7 +107,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { T22919.hs:2:5-9 })
(NoEpAnns)
@@ -135,7 +136,8 @@
(NoExtField)
(HsChar
(SourceText 's')
- ('s'))))))]
+ ('s'))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))]))
diff --git a/testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr b/testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
index 8a1db6bb1e8372c094ab6cb1cd0041b465bd94bd..65448605790415cec247a7ace662cccc7ed6c19b 100644
--- a/testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
+++ b/testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
@@ -119,7 +119,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { ZeroWidthSemi.hs:6:3-5 })
(NoEpAnns)
@@ -151,7 +152,8 @@
(IL
(SourceText 0)
(False)
- (0))))))))]
+ (0))))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))]))
diff --git a/testsuite/tests/module/mod185.stderr b/testsuite/tests/module/mod185.stderr
index adbe3de82a3f33de4ad44e542c758e7ed3a5c517..7a1f59d930c7c9a735117ec4f1e1c1bb6f12e77e 100644
--- a/testsuite/tests/module/mod185.stderr
+++ b/testsuite/tests/module/mod185.stderr
@@ -129,7 +129,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { mod185.hs:5:6-24 })
(NoEpAnns)
@@ -164,7 +165,8 @@
[]))
(Qual
{ModuleName: Prelude}
- {OccName: undefined}))))))]
+ {OccName: undefined}))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))]))
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
index d0ef81b153d535a6506424fe1dc2d898c2eeb3e9..f31ca684653f7b0bbcf68529225e26b7fa3820cf 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -2181,7 +2181,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpParsedAst.hs:25:6-23 })
(NoEpAnns)
@@ -2236,7 +2237,8 @@
(NoExtField)
(HsString
(SourceText "hello")
- {FastString: "hello"})))))))]
+ {FastString: "hello"})))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))]))
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
index cef30f2bbfd8aed56a5c2942769831f555aea3f3..88d8f98a1278ef7b4df35bc77c12c920c3e69fea 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
@@ -127,7 +127,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpParsedAstComments.hs:9:5-7 })
(NoEpAnns)
@@ -159,7 +160,8 @@
(IL
(SourceText 1)
(False)
- (1))))))))]
+ (1))))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))
,(L
@@ -246,7 +248,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpParsedAstComments.hs:(14,5)-(16,3) })
(NoEpAnns)
@@ -324,7 +327,8 @@
(False)
(1))))))
(NoExtField)
- (NoExtField)))])))))]
+ (NoExtField)))])))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))
,(L
@@ -397,7 +401,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpParsedAstComments.hs:19:6-23 })
(NoEpAnns)
@@ -452,7 +457,8 @@
(NoExtField)
(HsString
(SourceText "hello")
- {FastString: "hello"})))))))]
+ {FastString: "hello"})))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))]))
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index 02d9e336375fd9628610da244eaa6189b4b61476..4a3cf860d1b98f1dffad15e480034d4eab57164c 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -70,7 +70,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:35:6-23 })
(NoEpAnns)
@@ -123,7 +124,8 @@
(NoExtField)
(HsString
(SourceText "hello")
- {FastString: "hello"})))))))]
+ {FastString: "hello"})))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))]))))])]
[]))
diff --git a/testsuite/tests/parser/should_compile/DumpSemis.stderr b/testsuite/tests/parser/should_compile/DumpSemis.stderr
index 11f1fc19596942e8a1151ebeb5726c1d563f6d30..38ae90e49c97355004eddbe0383133862195a7fb 100644
--- a/testsuite/tests/parser/should_compile/DumpSemis.stderr
+++ b/testsuite/tests/parser/should_compile/DumpSemis.stderr
@@ -316,7 +316,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:(10,5)-(12,3) })
(NoEpAnns)
@@ -468,7 +469,8 @@
(Unqual
{OccName: a}))))
(NoExtField)
- (NoExtField)))])))))]
+ (NoExtField)))])))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))
,(L
@@ -627,7 +629,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:(15,5)-(19,3) })
(NoEpAnns)
@@ -740,7 +743,8 @@
(Unqual
{OccName: b}))))
(NoExtField)
- (NoExtField)))])))))]
+ (NoExtField)))])))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))
,(L
@@ -890,7 +894,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:22:5-30 })
(NoEpAnns)
@@ -1039,7 +1044,8 @@
(Unqual
{OccName: s}))))
(NoExtField)
- (NoExtField)))])))))]
+ (NoExtField)))])))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))
,(L
@@ -1106,7 +1112,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:24:3-13 })
(NoEpAnns)
@@ -1140,7 +1147,8 @@
(EpaComments
[]))
(Unqual
- {OccName: undefined}))))))]
+ {OccName: undefined}))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))
,(L
@@ -1207,7 +1215,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:25:3-13 })
(NoEpAnns)
@@ -1241,7 +1250,8 @@
(EpaComments
[]))
(Unqual
- {OccName: undefined}))))))]
+ {OccName: undefined}))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))
,(L
@@ -1310,7 +1320,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:26:3-13 })
(NoEpAnns)
@@ -1344,7 +1355,8 @@
(EpaComments
[]))
(Unqual
- {OccName: undefined}))))))]
+ {OccName: undefined}))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))
,(L
@@ -1830,7 +1842,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:32:5-7 })
(NoEpAnns)
@@ -1864,7 +1877,8 @@
(EpaComments
[]))
(Unqual
- {OccName: x}))))))]
+ {OccName: x}))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))
,(L
@@ -1936,7 +1950,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:34:9-35 })
(NoEpAnns)
@@ -2058,7 +2073,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:34:20-21 })
(NoEpAnns)
@@ -2090,7 +2106,8 @@
(IL
(SourceText 2)
(False)
- (2))))))))]
+ (2))))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))]))))
,(L
@@ -2166,7 +2183,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:34:25-26 })
(NoEpAnns)
@@ -2198,7 +2216,8 @@
(IL
(SourceText 3)
(False)
- (3))))))))]
+ (3))))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))]))))]
[]))
@@ -2219,7 +2238,8 @@
(EpaComments
[]))
(Unqual
- {OccName: y}))))))))]
+ {OccName: y}))))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))
,(L
@@ -2305,7 +2325,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:(36,7)-(44,4) })
(NoEpAnns)
@@ -2415,7 +2436,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:39:8-13 })
(NoEpAnns)
@@ -2444,7 +2466,8 @@
(NoExtField)
(HsChar
(SourceText 'a')
- ('a'))))))]
+ ('a'))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))
,(L
@@ -2488,7 +2511,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:40:8-13 })
(NoEpAnns)
@@ -2517,7 +2541,8 @@
(NoExtField)
(HsChar
(SourceText 'b')
- ('b'))))))]
+ ('b'))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))
,(L
@@ -2564,7 +2589,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:41:8-13 })
(NoEpAnns)
@@ -2593,7 +2619,8 @@
(NoExtField)
(HsChar
(SourceText 'c')
- ('c'))))))]
+ ('c'))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))
,(L
@@ -2643,7 +2670,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpSemis.hs:42:8-13 })
(NoEpAnns)
@@ -2672,9 +2700,11 @@
(NoExtField)
(HsChar
(SourceText 'd')
- ('d'))))))]
+ ('d'))))))
+ [])
(EmptyLocalBinds
- (NoExtField)))))]))))))]
+ (NoExtField)))))]))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))]))
diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
index e4c30a75815815931aabc795011ca004bca1064d..eea414260ee79f52bc21cb88fec13d22372e8e12 100644
--- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
@@ -1966,7 +1966,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { DumpTypecheckedAst.hs:20:6-23 })
(NoEpAnns)
@@ -2019,7 +2020,8 @@
(NoExtField)
(HsString
(SourceText "hello")
- {FastString: "hello"})))))))]
+ {FastString: "hello"})))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))]))))]
(False))))]
diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr
index c87f89ffc480d205e8cd84376c3506b79fa5a2e9..0fd2135cf6a28cfe3e04fca1eeb3a726061aaa87 100644
--- a/testsuite/tests/parser/should_compile/KindSigs.stderr
+++ b/testsuite/tests/parser/should_compile/KindSigs.stderr
@@ -1064,7 +1064,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { KindSigs.hs:23:9-12 })
(NoEpAnns)
@@ -1103,7 +1104,8 @@
(EpaComments
[]))
(Exact
- {Name: ()}))))))]
+ {Name: ()}))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))
,(L
@@ -1781,7 +1783,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { KindSigs.hs:35:6-11 })
(NoEpAnns)
@@ -1815,7 +1818,8 @@
(EpaComments
[]))
(Unqual
- {OccName: True}))))))]
+ {OccName: True}))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))]))
diff --git a/testsuite/tests/parser/should_compile/T20718.stderr b/testsuite/tests/parser/should_compile/T20718.stderr
index 5519e9f576cb52180a7fe7e2a584a1a3b2784fb4..b2e7c23eefccad135876b265630f8fe8245ccee4 100644
--- a/testsuite/tests/parser/should_compile/T20718.stderr
+++ b/testsuite/tests/parser/should_compile/T20718.stderr
@@ -141,7 +141,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { T20718.hs:8:3-5 })
(NoEpAnns)
@@ -173,7 +174,8 @@
(IL
(SourceText 1)
(False)
- (1))))))))]
+ (1))))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))]))
diff --git a/testsuite/tests/parser/should_compile/T20846.stderr b/testsuite/tests/parser/should_compile/T20846.stderr
index db161649fec90790e3d4b4542444188aa8ccaddc..c57bca6e4b8b86b67bed04f4ef653f07f99bd7b2 100644
--- a/testsuite/tests/parser/should_compile/T20846.stderr
+++ b/testsuite/tests/parser/should_compile/T20846.stderr
@@ -136,7 +136,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { T20846.hs:4:8-18 })
(NoEpAnns)
@@ -170,7 +171,8 @@
(EpaComments
[]))
(Unqual
- {OccName: undefined}))))))]
+ {OccName: undefined}))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))])))))]))
diff --git a/testsuite/tests/perf/compiler/hard_hole_fits.stderr b/testsuite/tests/perf/compiler/hard_hole_fits.stderr
index 7f0e081c3e830b7c75a550d300b06d2cecf0f1d4..57f4ef04c1323a6e1fefcfad9d391bceb504b4b9 100644
--- a/testsuite/tests/perf/compiler/hard_hole_fits.stderr
+++ b/testsuite/tests/perf/compiler/hard_hole_fits.stderr
@@ -358,7 +358,7 @@ hard_hole_fits.hs:32:30: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)]
• Found hole: _ :: Int
• In an equation for ‘testMe’: testMe (HsMultiIf xmi gls) = _
• Relevant bindings include
- gls :: [LGRHS GhcPs (LHsExpr GhcPs)]
+ gls :: GHC.Internal.Base.NonEmpty (LGRHS GhcPs (LHsExpr GhcPs))
(bound at hard_hole_fits.hs:32:23)
xmi :: Language.Haskell.Syntax.Extension.XMultiIf GhcPs
(bound at hard_hole_fits.hs:32:19)
diff --git a/testsuite/tests/printer/Test20297.stdout b/testsuite/tests/printer/Test20297.stdout
index 12d3dd523acb32a39ad7c06612940d20ed66d1a9..03ebf8694f57839911dda11ecba98ec537d600f3 100644
--- a/testsuite/tests/printer/Test20297.stdout
+++ b/testsuite/tests/printer/Test20297.stdout
@@ -107,7 +107,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { Test20297.hs:5:5-7 })
(NoEpAnns)
@@ -147,7 +148,8 @@
(EpaComments
[]))
(Unqual
- {OccName: x}))))))]
+ {OccName: x}))))))
+ [])
(HsValBinds
(EpAnn
(EpaSpan { <no location info> })
@@ -235,7 +237,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { Test20297.hs:9:5-7 })
(NoEpAnns)
@@ -269,7 +272,8 @@
(EpaComments
[]))
(Unqual
- {OccName: x}))))))]
+ {OccName: x}))))))
+ [])
(HsValBinds
(EpAnn
(EpaSpan { Test20297.hs:(10,3)-(11,26) })
@@ -353,7 +357,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { Test20297.hs:11:17-26 })
(NoEpAnns)
@@ -427,7 +432,8 @@
(Unqual
{OccName: stuff}))))
(NoExtField)
- (NoExtField)))])))))]
+ (NoExtField)))])))))
+ [])
(EmptyLocalBinds
(NoExtField)))))]))))]
[])))))])))))]))
@@ -542,7 +548,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { Test20297.ppr.hs:4:3-5 })
(NoEpAnns)
@@ -576,7 +583,8 @@
(EpaComments
[]))
(Unqual
- {OccName: x}))))))]
+ {OccName: x}))))))
+ [])
(HsValBinds
(EpAnn
(EpaSpan { <no location info> })
@@ -658,7 +666,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { Test20297.ppr.hs:7:3-5 })
(NoEpAnns)
@@ -692,7 +701,8 @@
(EpaComments
[]))
(Unqual
- {OccName: x}))))))]
+ {OccName: x}))))))
+ [])
(HsValBinds
(EpAnn
(EpaSpan { Test20297.ppr.hs:(8,3)-(9,24) })
@@ -770,7 +780,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { Test20297.ppr.hs:9:15-24 })
(NoEpAnns)
@@ -844,7 +855,8 @@
(Unqual
{OccName: stuff}))))
(NoExtField)
- (NoExtField)))])))))]
+ (NoExtField)))])))))
+ [])
(EmptyLocalBinds
(NoExtField)))))]))))]
[])))))])))))]))
diff --git a/testsuite/tests/printer/Test24533.stdout b/testsuite/tests/printer/Test24533.stdout
index 40b73416f7c7586eef16d30306b777c7926d2b44..7f44d655488db26ed9409bfe7e20b350b85c8e08 100644
--- a/testsuite/tests/printer/Test24533.stdout
+++ b/testsuite/tests/printer/Test24533.stdout
@@ -632,7 +632,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { Test24533.hs:16:14-19 })
(NoEpAnns)
@@ -666,7 +667,8 @@
(EpaComments
[]))
(Unqual
- {OccName: True}))))))]
+ {OccName: True}))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))]))))]
[]
@@ -1236,7 +1238,8 @@
(GRHSs
(EpaComments
[])
- [(L
+ (:|
+ (L
(EpAnn
(EpaSpan { Test24533.ppr.hs:6:14-19 })
(NoEpAnns)
@@ -1270,7 +1273,8 @@
(EpaComments
[]))
(Unqual
- {OccName: True}))))))]
+ {OccName: True}))))))
+ [])
(EmptyLocalBinds
(NoExtField)))))]))))]
[]
diff --git a/testsuite/tests/th/EmptyGuard.hs b/testsuite/tests/th/EmptyGuard.hs
new file mode 100644
index 0000000000000000000000000000000000000000..5cac32acba2e40c63d027820602ae77817348932
--- /dev/null
+++ b/testsuite/tests/th/EmptyGuard.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module ShouldFail where
+
+import Language.Haskell.TH
+
+$(return [FunD (mkName "foo") [Clause [] (GuardedB []) []]])
diff --git a/testsuite/tests/th/EmptyGuard.stderr b/testsuite/tests/th/EmptyGuard.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..0358dc01fe2b40131f7a7ececbe664d504c275ed
--- /dev/null
+++ b/testsuite/tests/th/EmptyGuard.stderr
@@ -0,0 +1,4 @@
+EmptyGuard.hs:7:2: error: [GHC-45149]
+ Empty guard
+ When splicing a TH declaration: foo
+
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index ce83952da8283f024fc1ae77515ef759f53bb547..facae2ced70e85fadadfea3d553d24ae199b4641 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -147,6 +147,7 @@ test('T2713', normal, compile_fail, ['-v0'])
test('T2674', normal, compile_fail, ['-v0'])
test('TH_emptycase', normal, compile, ['-v0'])
test('T24046', normal, compile, ['-v0'])
+test('EmptyGuard', normal, compile_fail, ['-v0'])
test('T2386', [only_ways(['normal'])], makefile_test, ['T2386'])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index eebab19443525faee53145ee04512eade1bc48f1..9817e66ab3ccd6544664598f501e5cf64234dbd3 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -1515,6 +1515,11 @@ instance (ExactPrint a) => ExactPrint (Maybe a) where
setAnnotationAnchor ma _ _ _ = ma
exact ma = mapM markAnnotated ma
+instance (ExactPrint a) => ExactPrint (NonEmpty a) where
+ getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor ls _ _ _ = ls
+ exact ls = mapM markAnnotated ls
+
-- ---------------------------------------------------------------------
-- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource'
diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs
index 081c729cf9546c0aa73242e7c7306d5ec97b7de6..52bce032e87b3c06f0937f693cd9f4133a8a9a44 100644
--- a/utils/check-exact/Transform.hs
+++ b/utils/check-exact/Transform.hs
@@ -96,6 +96,8 @@ import GHC.Data.FastString
import GHC.Types.SrcLoc
import Data.Data
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.Functor.Identity
@@ -461,9 +463,8 @@ balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds)))
move = map snd move'
stay = map snd stay'
(l'', grhss', binds', _logInfo)
- = case reverse grhss of
- [] -> (l, [], binds, (EpaComments [], noSrcSpanA))
- (L lg (GRHS ag grs rhs):gs) ->
+ = case NE.reverse grhss of
+ L lg (GRHS ag grs rhs):|gs ->
let
anc1' = setFollowingComments anc1 stay
an1' = setCommentsEpAnn l anc1'
@@ -478,7 +479,7 @@ balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds)))
then EpAnn anc an lgc'
else EpAnn anc an (lgc' <> (EpaCommentsBalanced [] move))
- in (an1', (reverse $ (L lg (GRHS ag' grs rhs):gs)), bindsm, (anc1',an1'))
+ in (an1', (NE.reverse $ L lg (GRHS ag' grs rhs):|gs), bindsm, (anc1',an1'))
pushTrailingComments :: WithWhere -> EpAnnComments -> HsLocalBinds GhcPs -> (Bool, HsLocalBinds GhcPs)
pushTrailingComments _ _cs b@EmptyLocalBinds{} = (False, b)
@@ -686,9 +687,8 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb)))
= (L la' (Match anm mctxt pats (GRHSs x grhss' lb)))
where
simpleBreak n (r,_) = r > n
- (la',grhss', _logInfo) = case reverse grhss of
- [] -> (la,grhss,[])
- (L lg (GRHS ga gs rhs):grs) -> (la'',reverse $ (L lg (GRHS ga' gs rhs)):grs,[(gac,(csp,csf))])
+ (la',grhss', _logInfo) = case NE.reverse grhss of
+ L lg (GRHS ga gs rhs):|grs -> (la'',NE.reverse $ L lg (GRHS ga' gs rhs):|grs,[(gac,(csp,csf))])
where
anc1 = comments la
(EpAnn anc an _) = ga :: EpAnn GrhsAnn