- partition_eqn :: Maybe Id -> HsLit -> EquationInfo ->
- (Maybe EquationInfo, Maybe EquationInfo)
-
- partition_eqn Nothing lit (EqnInfo n ctx (LitPat k _ : remaining_pats) match_result)
- | lit `eq_lit` k = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
- -- NB the pattern is stripped off the EquationInfo
-
- partition_eqn Nothing lit (EqnInfo n ctx (NPat k _ _ : remaining_pats) match_result)
- | lit `eq_lit` k = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
- -- NB the pattern is stripped off the EquationInfo
-
- partition_eqn (Just master_n) lit (EqnInfo n ctx (NPlusKPat n' k _ _ _ : remaining_pats) match_result)
- | lit `eq_lit` k = (Just (EqnInfo n ctx 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 n ctx (WildPat _ : remaining_pats) match_result)
- = (Just (EqnInfo n ctx 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"
+ get_lit eqn = case firstPat eqn of
+ LitPat hs_lit -> mk_core_lit hs_lit
+ NPatOut hs_lit _ _ -> mk_core_lit hs_lit
+ NPlusKPatOut _ i _ _ -> MachInt i
+ other -> panic "tagLitEqns:bad pattern"
+
+mk_core_lit :: HsLit -> Literal
+mk_core_lit (HsIntPrim i) = mkMachInt i
+mk_core_lit (HsCharPrim c) = MachChar c
+mk_core_lit (HsStringPrim s) = MachStr s
+mk_core_lit (HsFloatPrim f) = MachFloat f
+mk_core_lit (HsDoublePrim d) = MachDouble d
+
+ -- These ones are only needed in the NPatOut case,
+ -- and the Literal is only used as a key for grouping,
+ -- so the type doesn't matter. Actually I think HsInt, HsChar
+ -- can't happen, but it does no harm to include them
+mk_core_lit (HsString s) = MachStr s
+mk_core_lit (HsRat r _) = MachFloat r
+mk_core_lit (HsInteger i _) = MachInt i
+mk_core_lit (HsInt i) = MachInt i
+mk_core_lit (HsChar c) = MachChar c