summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/deSugar/DsUtils.hs38
-rw-r--r--compiler/deSugar/Match.hs110
-rw-r--r--compiler/deSugar/MatchCon.hs20
-rw-r--r--compiler/deSugar/MatchLit.hs35
-rw-r--r--compiler/utils/Outputable.hs5
5 files changed, 105 insertions, 103 deletions
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index c358c175c6..9d6b709dc9 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -84,6 +84,8 @@ import qualified GHC.LanguageExtensions as LangExt
import TcEvidence
import Control.Monad ( zipWithM )
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NEL
{-
************************************************************************
@@ -186,9 +188,9 @@ worthy of a type synonym and a few handy functions.
firstPat :: EquationInfo -> Pat GhcTc
firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
-shiftEqns :: [EquationInfo] -> [EquationInfo]
+shiftEqns :: Functor f => f EquationInfo -> f EquationInfo
-- Drop the first pattern in each equation
-shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
+shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) }
-- Functions on MatchResults
@@ -286,13 +288,13 @@ data CaseAlt a = MkCaseAlt{ alt_pat :: a,
alt_result :: MatchResult }
mkCoAlgCaseMatchResult
- :: Id -- Scrutinee
- -> Type -- Type of exp
- -> [CaseAlt DataCon] -- Alternatives (bndrs *include* tyvars, dicts)
+ :: Id -- ^ Scrutinee
+ -> Type -- ^ Type of exp
+ -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts)
-> MatchResult
mkCoAlgCaseMatchResult var ty match_alts
| isNewtype -- Newtype case; use a let
- = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
+ = ASSERT( null match_alts_tail && null (tail arg_ids1) )
mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
| otherwise
@@ -303,8 +305,8 @@ mkCoAlgCaseMatchResult var ty match_alts
-- [Interesting: because of GADTs, we can't rely on the type of
-- the scrutinised Id to be sufficiently refined to have a TyCon in it]
- alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 }
- = ASSERT( notNull match_alts ) head match_alts
+ alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail
+ = match_alts
-- Stuff for newtype
arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1
var_ty = idType var
@@ -315,9 +317,6 @@ mkCoAlgCaseMatchResult var ty match_alts
mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt
-sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]
-sort_alts = sortWith (dataConTag . alt_pat)
-
mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
mkPatSynCase var ty alt fail = do
matcher <- dsLExpr $ mkLHsWrap wrapper $
@@ -337,17 +336,16 @@ mkPatSynCase var ty alt fail = do
ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
| otherwise = cont
-mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
-mkDataConCase _ _ [] = panic "mkDataConCase: no alternatives"
-mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
+mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult
+mkDataConCase var ty alts@(alt1 :| _) = MatchResult fail_flag mk_case
where
con1 = alt_pat alt1
tycon = dataConTyCon con1
data_cons = tyConDataCons tycon
- match_results = map alt_result alts
+ match_results = fmap alt_result alts
- sorted_alts :: [CaseAlt DataCon]
- sorted_alts = sort_alts alts
+ sorted_alts :: NonEmpty (CaseAlt DataCon)
+ sorted_alts = NEL.sortWith (dataConTag . alt_pat) alts
var_ty = idType var
(_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
@@ -356,7 +354,7 @@ mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
mk_case :: CoreExpr -> DsM CoreExpr
mk_case fail = do
alts <- mapM (mk_alt fail) sorted_alts
- return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)
+ return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ NEL.toList alts)
mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt
mk_alt fail MkCaseAlt{ alt_pat = con,
@@ -376,11 +374,11 @@ mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
fail_flag :: CanItFail
fail_flag | exhaustive_case
- = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
+ = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- NEL.toList match_results]
| otherwise
= CanFail
- mentioned_constructors = mkUniqSet $ map alt_pat alts
+ mentioned_constructors = mkUniqSet $ map alt_pat $ NEL.toList alts
un_mentioned_constructors
= mkUniqSet data_cons `minusUniqSet` mentioned_constructors
exhaustive_case = isEmptyUniqSet un_mentioned_constructors
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index b11a2e2f06..3cc88e31db 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -7,6 +7,8 @@ The @match@ function
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE MonadComprehensions #-}
+{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
@@ -55,7 +57,8 @@ import Unique
import UniqDFM
import Control.Monad( when, unless )
-import Data.List ( groupBy )
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as Map
{-
@@ -161,11 +164,10 @@ See also Note [Localise pattern binders] in DsUtils
type MatchId = Id -- See Note [Match Ids]
-match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with
- -- ^ See Note [Match Ids]
- -> Type -- ^ Type of the case expression
- -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below)
- -> DsM MatchResult -- ^ Desugared result!
+match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with. See Note [Match Ids]
+ -> Type -- ^ Type of the case expression
+ -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below)
+ -> DsM MatchResult -- ^ Desugared result!
match [] ty eqns
= ASSERT2( not (null eqns), ppr ty )
@@ -175,13 +177,12 @@ match [] ty eqns
eqn_rhs eqn
| eqn <- eqns ]
-match vars@(v:_) ty eqns -- Eqns *can* be empty
+match (v:vs) ty eqns -- Eqns *can* be empty
= ASSERT2( all (isInternalName . idName) vars, ppr vars )
do { dflags <- getDynFlags
-- Tidy the first pattern, generating
-- auxiliary bindings if necessary
; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
-
-- Group the equations and match each group in turn
; let grouped = groupEquations dflags tidy_eqns
@@ -192,21 +193,22 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty
; return (adjustMatchResult (foldr (.) id aux_binds) $
foldr1 combineMatchResults match_results) }
where
- dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
- dropGroup = map snd
+ vars = v :| vs
+
+ dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
+ dropGroup = fmap snd
- match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]
+ match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty MatchResult)
-- Result list of [MatchResult] is always non-empty
match_groups [] = matchEmpty v ty
- match_groups gs = mapM match_group gs
+ match_groups (g:gs) = mapM match_group $ g :| gs
- match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
- match_group [] = panic "match_group"
- match_group eqns@((group,_) : _)
+ match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM MatchResult
+ match_group eqns@((group,_) :| _)
= case group of
- PgCon {} -> matchConFamily vars ty (subGroupUniq [(c,e) | (PgCon c, e) <- eqns])
+ PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
PgSyn {} -> matchPatSyn vars ty (dropGroup eqns)
- PgLit {} -> matchLiterals vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns])
+ PgLit {} -> matchLiterals vars ty (ne $ subGroupOrd [(l,e) | (PgLit l, e) <- eqns'])
PgAny -> matchVariables vars ty (dropGroup eqns)
PgN {} -> matchNPats vars ty (dropGroup eqns)
PgOverS {}-> matchNPats vars ty (dropGroup eqns)
@@ -215,6 +217,10 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty
PgCo {} -> matchCoercion vars ty (dropGroup eqns)
PgView {} -> matchView vars ty (dropGroup eqns)
PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
+ where eqns' = NEL.toList eqns
+ ne l = case NEL.nonEmpty l of
+ Just nel -> nel
+ Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty"
-- FIXME: we should also warn about view patterns that should be
-- commoned up but are not
@@ -231,7 +237,7 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty
maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
(filter (not . null) gs))
-matchEmpty :: MatchId -> Type -> DsM [MatchResult]
+matchEmpty :: MatchId -> Type -> DsM (NonEmpty MatchResult)
-- See Note [Empty case expressions]
matchEmpty var res_ty
= return [MatchResult CanFail mk_seq]
@@ -239,35 +245,32 @@ matchEmpty var res_ty
mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
[(DEFAULT, [], fail)]
-matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
-- Real true variables, just like in matchVar, SLPJ p 94
-- No binding to do: they'll all be wildcards by now (done in tidy)
-matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
-matchVariables [] _ _ = panic "matchVariables"
+matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns
-matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
-matchBangs (var:vars) ty eqns
- = do { match_result <- match (var:vars) ty $
- map (decomposeFirstPat getBangPat) eqns
+matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+matchBangs (var :| vars) ty eqns
+ = do { match_result <- match (var:vars) ty $ NEL.toList $
+ decomposeFirstPat getBangPat <$> eqns
; return (mkEvalMatchResult var ty match_result) }
-matchBangs [] _ _ = panic "matchBangs"
-matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
-- Apply the coercion to the match variable and then match that
-matchCoercion (var:vars) ty (eqns@(eqn1:_))
+matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
= do { let CoPat _ co pat _ = firstPat eqn1
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var pat_ty'
- ; match_result <- match (var':vars) ty $
- map (decomposeFirstPat getCoPat) eqns
+ ; match_result <- match (var':vars) ty $ NEL.toList $
+ decomposeFirstPat getCoPat <$> eqns
; core_wrap <- dsHsWrapper co
; let bind = NonRec var' (core_wrap (Var var))
; return (mkCoLetMatchResult bind match_result) }
-matchCoercion _ _ _ = panic "matchCoercion"
-matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
-- Apply the view function to the match variable and then match that
-matchView (var:vars) ty (eqns@(eqn1:_))
+matchView (var :| vars) ty (eqns@(eqn1 :| _))
= do { -- we could pass in the expr from the PgView,
-- but this needs to extract the pat anyway
-- to figure out the type of the fresh variable
@@ -275,26 +278,25 @@ matchView (var:vars) ty (eqns@(eqn1:_))
-- do the rest of the compilation
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var pat_ty'
- ; match_result <- match (var':vars) ty $
- map (decomposeFirstPat getViewPat) eqns
+ ; match_result <- match (var':vars) ty $ NEL.toList $
+ decomposeFirstPat getViewPat <$> eqns
-- compile the view expressions
; viewExpr' <- dsLExpr viewExpr
; return (mkViewMatchResult var'
(mkCoreAppDs (text "matchView") viewExpr' (Var var))
match_result) }
-matchView _ _ _ = panic "matchView"
-matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
-matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
+matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _))
-- Since overloaded list patterns are treated as view patterns,
-- the code is roughly the same as for matchView
= do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1
; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand
- ; match_result <- match (var':vars) ty $
- map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
+ ; match_result <- match (var':vars) ty $ NEL.toList $
+ decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
; e' <- dsSyntaxExpr e [Var var]
- ; return (mkViewMatchResult var' e' match_result) }
-matchOverloadedList _ _ _ = panic "matchOverloadedList"
+ ; return (mkViewMatchResult var' e' match_result)
+ }
-- decompose the first pattern and leave the rest alone
decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
@@ -889,22 +891,24 @@ the PgN constructor as a Rational if numeric, and add a PgOverStr constructor
for overloaded strings.
-}
-groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
+groupEquations :: DynFlags -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
-- If the result is of form [g1, g2, g3],
-- (a) all the (pg,eq) pairs in g1 have the same pg
-- (b) none of the gi are empty
-- The ordering of equations is unchanged
groupEquations dflags eqns
- = groupBy same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
+ = NEL.groupBy same_gp $ [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
+ -- comprehension on NonEmpty
where
same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
(pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
-subGroup :: (m -> [[EquationInfo]]) -- Map.elems
+-- TODO Make subGroup1 using a NonEmptyMap
+subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems
-> m -- Map.empty
- -> (a -> m -> Maybe [EquationInfo]) -- Map.lookup
- -> (a -> [EquationInfo] -> m -> m) -- Map.insert
- -> [(a, EquationInfo)] -> [[EquationInfo]]
+ -> (a -> m -> Maybe (NonEmpty EquationInfo)) -- Map.lookup
+ -> (a -> NonEmpty EquationInfo -> m -> m) -- Map.insert
+ -> [(a, EquationInfo)] -> [NonEmpty EquationInfo]
-- Input is a particular group. The result sub-groups the
-- equations by with particular constructor, literal etc they match.
-- Each sub-list in the result has the same PatGroup
@@ -912,19 +916,19 @@ subGroup :: (m -> [[EquationInfo]]) -- Map.elems
-- Parameterized by map operations to allow different implementations
-- and constraints, eg. types without Ord instance.
subGroup elems empty lookup insert group
- = map reverse $ elems $ foldl' accumulate empty group
+ = fmap NEL.reverse $ elems $ foldl' accumulate empty group
where
accumulate pg_map (pg, eqn)
= case lookup pg pg_map of
- Just eqns -> insert pg (eqn:eqns) pg_map
- Nothing -> insert pg [eqn] pg_map
+ Just eqns -> insert pg (NEL.cons eqn eqns) pg_map
+ Nothing -> insert pg [eqn] pg_map
-- pg_map :: Map a [EquationInfo]
-- Equations seen so far in reverse order of appearance
-subGroupOrd :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
+subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert
-subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]]
+subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupUniq =
subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v)
diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs
index d1a0390da1..d27e1b37af 100644
--- a/compiler/deSugar/MatchCon.hs
+++ b/compiler/deSugar/MatchCon.hs
@@ -34,6 +34,7 @@ import SrcLoc
import Outputable
import Control.Monad(liftM)
import Data.List (groupBy)
+import Data.List.NonEmpty (NonEmpty(..))
{-
We are confronted with the first column of patterns in a set of
@@ -88,40 +89,38 @@ have-we-used-all-the-constructors? question; the local function
@match_cons_used@ does all the real work.
-}
-matchConFamily :: [Id]
+matchConFamily :: NonEmpty Id
-> Type
- -> [[EquationInfo]]
+ -> NonEmpty (NonEmpty EquationInfo)
-> DsM MatchResult
-- Each group of eqns is for a single constructor
-matchConFamily (var:vars) ty groups
+matchConFamily (var :| vars) ty groups
= do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups
return (mkCoAlgCaseMatchResult var ty alts)
where
toRealAlt alt = case alt_pat alt of
RealDataCon dcon -> alt{ alt_pat = dcon }
_ -> panic "matchConFamily: not RealDataCon"
-matchConFamily [] _ _ = panic "matchConFamily []"
-matchPatSyn :: [Id]
+matchPatSyn :: NonEmpty Id
-> Type
- -> [EquationInfo]
+ -> NonEmpty EquationInfo
-> DsM MatchResult
-matchPatSyn (var:vars) ty eqns
+matchPatSyn (var :| vars) ty eqns
= do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns
return (mkCoSynCaseMatchResult var ty alt)
where
toSynAlt alt = case alt_pat alt of
PatSynCon psyn -> alt{ alt_pat = psyn }
_ -> panic "matchPatSyn: not PatSynCon"
-matchPatSyn _ _ _ = panic "matchPatSyn []"
type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc))
matchOneConLike :: [Id]
-> Type
- -> [EquationInfo]
+ -> NonEmpty EquationInfo
-> DsM (CaseAlt ConLike)
-matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
+matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor
= do { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs )
-- ex_tvs can only be tyvars as data types in source
-- Haskell cannot mention covar yet (Aug 2018).
@@ -195,7 +194,6 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env
(idName (unLoc (hsRecFieldId rpat)))
select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
-matchOneConLike _ _ [] = panic "matchOneCon []"
-----------------
compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
index 4f65362b2b..3fb64f6769 100644
--- a/compiler/deSugar/MatchLit.hs
+++ b/compiler/deSugar/MatchLit.hs
@@ -53,6 +53,8 @@ import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.Int
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NEL
import Data.Word
import Data.Proxy
@@ -397,14 +399,13 @@ tidyNPat over_lit mb_neg eq outer_ty
************************************************************************
-}
-matchLiterals :: [Id]
- -> Type -- Type of the whole case expression
- -> [[EquationInfo]] -- All PgLits
+matchLiterals :: NonEmpty Id
+ -> Type -- ^ Type of the whole case expression
+ -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits
-> DsM MatchResult
-matchLiterals (var:vars) ty sub_groups
- = ASSERT( notNull sub_groups && all notNull sub_groups )
- do { -- Deal with each group
+matchLiterals (var :| vars) ty sub_groups
+ = do { -- Deal with each group
; alts <- mapM match_group sub_groups
-- Combine results. For everything except String
@@ -415,14 +416,14 @@ matchLiterals (var:vars) ty sub_groups
; mrs <- mapM (wrap_str_guard eq_str) alts
; return (foldr1 combineMatchResults mrs) }
else
- return (mkCoPrimCaseMatchResult var ty alts)
+ return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts)
}
where
- match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
- match_group eqns
+ match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult)
+ match_group eqns@(firstEqn :| _)
= do { dflags <- getDynFlags
- ; let LitPat _ hs_lit = firstPat (head eqns)
- ; match_result <- match vars ty (shiftEqns eqns)
+ ; let LitPat _ hs_lit = firstPat firstEqn
+ ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
; return (hsLitKey dflags hs_lit, match_result) }
wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
@@ -436,7 +437,6 @@ matchLiterals (var:vars) ty sub_groups
; return (mkGuardedMatchResult pred mr) }
wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
-matchLiterals [] _ _ = panic "matchLiterals []"
---------------------------
hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
@@ -467,8 +467,8 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
************************************************************************
-}
-matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal
+matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal
= do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
; lit_expr <- dsOverLit lit
; neg_lit <- case mb_neg of
@@ -477,7 +477,6 @@ matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal
; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]
; match_result <- match vars ty (shiftEqns (eqn1:eqns))
; return (mkGuardedMatchResult pred_expr match_result) }
-matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
{-
************************************************************************
@@ -497,9 +496,9 @@ We generate:
\end{verbatim}
-}
-matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult
-- All NPlusKPats, for the *same* literal k
-matchNPlusKPats (var:vars) ty (eqn1:eqns)
+matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
= do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus
= firstPat eqn1
; lit1_expr <- dsOverLit lit1
@@ -517,5 +516,3 @@ matchNPlusKPats (var:vars) ty (eqn1:eqns)
= (wrapBind n n1, eqn { eqn_pats = pats })
-- The wrapBind is a no-op for the first equation
shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
-
-matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 6717430a58..d81c754866 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -124,6 +124,8 @@ import Text.Printf
import Numeric (showFFloat)
import Data.Graph (SCC(..))
import Data.List (intersperse)
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as NEL
import GHC.Fingerprint
import GHC.Show ( showMultiLineString )
@@ -819,6 +821,9 @@ instance Outputable () where
instance (Outputable a) => Outputable [a] where
ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
+instance (Outputable a) => Outputable (NonEmpty a) where
+ ppr = ppr . NEL.toList
+
instance (Outputable a) => Outputable (Set a) where
ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))