diff options
Diffstat (limited to 'compiler/deSugar/Match.lhs')
| -rw-r--r-- | compiler/deSugar/Match.lhs | 31 |
1 files changed, 16 insertions, 15 deletions
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 8fd3a203f3..adb9099c14 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -292,12 +292,13 @@ match [] ty eqns match vars@(v:_) ty eqns = ASSERT( not (null eqns ) ) - do { -- Tidy the first pattern, generating + 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 tidy_eqns + ; let grouped = groupEquations dflags tidy_eqns -- print the view patterns that are commoned up to help debug ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped) @@ -787,13 +788,13 @@ data PatGroup -- the LHsExpr is the expression e Type -- the Type is the type of p (equivalently, the result type of e) -groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] +groupEquations :: DynFlags -> [EquationInfo] -> [[(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 eqns - = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns] +groupEquations dflags eqns + = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns] where same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 @@ -948,16 +949,16 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 eq_co (TcTyConAppCo tc1 cos1) (TcTyConAppCo tc2 cos2) = tc1==tc2 && eq_list eq_co cos1 cos2 eq_co _ _ = False -patGroup :: Pat Id -> PatGroup -patGroup (WildPat {}) = PgAny -patGroup (BangPat {}) = PgBang -patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc) -patGroup (LitPat lit) = PgLit (hsLitKey lit) -patGroup (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) -patGroup (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) -patGroup (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern -patGroup (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) -patGroup pat = pprPanic "patGroup" (ppr pat) +patGroup :: DynFlags -> Pat Id -> PatGroup +patGroup _ (WildPat {}) = PgAny +patGroup _ (BangPat {}) = PgBang +patGroup _ (ConPatOut { pat_con = dc }) = PgCon (unLoc dc) +patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit) +patGroup _ (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) +patGroup _ (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) +patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern +patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) +patGroup _ pat = pprPanic "patGroup" (ppr pat) \end{code} Note [Grouping overloaded literal patterns] |