Commit 0805ed7e authored by John Ericson's avatar John Ericson Committed by Marge Bot

Use non-empty lists to remove partiality in matching code

parent 7aa4a061
Pipeline #14322 failed with stages
in 744 minutes and 2 seconds
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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))
......@@ -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))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment