-tagLitEqns eqns
- = [(get_lit eqn, eqn) | eqn <- eqns]
- where
- 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
+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)