-partitionEqnsByLit :: Maybe Id -- (Just v) for N-plus-K patterns, where v
- -- is the "master" variable;
- -- Nothing for NPats and LitPats
- -> HsLit
- -> [EquationInfo]
- -> ([EquationInfo], -- These ones are for this lit, AND
- -- they've been "shifted" by stripping
- -- off the first pattern
- [EquationInfo] -- These are not for this lit; they
- -- are exactly as fed in.
- )
-
-partitionEqnsByLit nPlusK lit eqns
- = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys))
- (unzip (map (partition_eqn nPlusK lit) eqns))
- where
- partition_eqn :: Maybe Id -> HsLit -> EquationInfo ->
- (Maybe EquationInfo, Maybe EquationInfo)
-
- partition_eqn Nothing lit (EqnInfo (LitPat k _ : remaining_pats) match_result)
- | lit `eq_lit` k = (Just (EqnInfo remaining_pats match_result), Nothing)
- -- NB the pattern is stripped off the EquationInfo
-
- partition_eqn Nothing lit (EqnInfo (NPat k _ _ : remaining_pats) match_result)
- | lit `eq_lit` k = (Just (EqnInfo remaining_pats match_result), Nothing)
- -- NB the pattern is stripped off the EquationInfo
-
- partition_eqn (Just master_n) lit (EqnInfo (NPlusKPat n k _ _ _ : remaining_pats) match_result)
- | lit `eq_lit` k = (Just (EqnInfo remaining_pats new_match_result), Nothing)
- -- NB the pattern is stripped off the EquationInfo
- where
- new_match_result | master_n == n = match_result
- | otherwise = mkCoLetsMatchResult [NonRec n (Var master_n)] match_result
-
- -- Wild-card patterns, which will only show up in the shadows, go into both groups
- partition_eqn nPlusK lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result)
- = (Just (EqnInfo remaining_pats match_result), Just eqn)
-
- -- Default case; not for this pattern
- partition_eqn nPlusK lit eqn = (Nothing, Just eqn)
-
--- ToDo: meditate about this equality business...
-
-eq_lit (HsInt i1) (HsInt i2) = i1 == i2
-eq_lit (HsFrac f1) (HsFrac f2) = f1 == f2
-
-eq_lit (HsIntPrim i1) (HsIntPrim i2) = i1 == i2
-eq_lit (HsFloatPrim f1) (HsFloatPrim f2) = f1 == f2
-eq_lit (HsDoublePrim d1) (HsDoublePrim d2) = d1 == d2
-eq_lit (HsChar c1) (HsChar c2) = c1 == c2
-eq_lit (HsCharPrim c1) (HsCharPrim c2) = c1 == c2
-eq_lit (HsString s1) (HsString s2) = s1 == s2
-eq_lit (HsStringPrim s1) (HsStringPrim s2) = s1 == s2
-eq_lit (HsLitLit s1) (HsLitLit s2) = s1 == s2 -- ToDo: ??? (dubious)
-eq_lit other1 other2 = panic "matchLiterals:eq_lit"
+-- Tag equations by the leading literal
+-- NB: we have ordering on Core Literals, but not on HsLits
+cmpTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Ordering
+cmpTaggedEqn (lit1,_) (lit2,_) = lit1 `compare` lit2
+
+eqTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Bool
+eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2
+
+tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)]
+tagLitEqns eqns = [(get_lit (firstPat eqn), eqn) | eqn <- eqns]
+
+get_lit :: Pat Id -> Literal
+-- Get a Core literal to use (only) a grouping key
+-- Hence its type doesn't need to match the type of the original literal
+get_lit (LitPat (HsIntPrim i)) = mkMachInt i
+get_lit (LitPat (HsCharPrim c)) = MachChar c
+get_lit (LitPat (HsStringPrim s)) = MachStr s
+get_lit (LitPat (HsFloatPrim f)) = MachFloat f
+get_lit (LitPat (HsDoublePrim d)) = MachDouble d
+get_lit (LitPat (HsString s)) = MachStr s
+
+get_lit (NPat (HsIntegral i _) Nothing _ _) = MachInt i
+get_lit (NPat (HsIntegral i _) (Just _) _ _) = MachInt (-i)
+get_lit (NPat (HsFractional r _) Nothing _ _) = MachFloat r
+get_lit (NPat (HsFractional r _) (Just _) _ _) = MachFloat (-r)
+
+get_lit (NPlusKPat _ (HsIntegral i _) _ _) = MachInt i
+
+-- These ones can't happen
+-- get_lit (LitPat (HsChar c))
+-- get_lit (LitPat (HsInt i))
+get_lit other = pprPanic "get_lit:bad pattern" (ppr other)