diff options
| -rw-r--r-- | compiler/deSugar/DsUtils.hs | 38 | ||||
| -rw-r--r-- | compiler/deSugar/Match.hs | 110 | ||||
| -rw-r--r-- | compiler/deSugar/MatchCon.hs | 20 | ||||
| -rw-r--r-- | compiler/deSugar/MatchLit.hs | 35 | ||||
| -rw-r--r-- | compiler/utils/Outputable.hs | 5 |
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)))) |