- match_group :: [EquationInfo] -> DsM MatchResult
- match_group (eqn1:eqns)
- = do { ge_expr <- dsExpr ge
- ; minus_expr <- dsExpr minus
- ; lit_expr <- dsOverLit lit
- ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
- minusk_expr = mkApps minus_expr [Var var, lit_expr]
- ; match_result <- match vars ty (eqn1' : map shift eqns)
- ; return (adjustMatchResult (eqn_wrap eqn1) $
- -- Bring the eqn1 wrapper stuff into scope because
- -- it may be used in ge_expr, minusk_expr
- mkGuardedMatchResult pred_expr $
- mkCoLetMatchResult (NonRec n1 minusk_expr) $
- match_result) }
- where
- NPlusKPat (L _ n1) lit ge minus : pats1 = eqn_pats eqn1
- eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
-
- shift eqn@(EqnInfo { eqn_wrap = wrap,
- eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
- = eqn { eqn_wrap = wrap . wrapBind n n1, eqn_pats = pats }
-\end{code}
-
-
-%************************************************************************
-%* *
- Grouping functions
-%* *
-%************************************************************************
-
-Given a blob of @LitPat@s/@NPat@s, we want to split them into those
-that are ``same''/different as one we are looking at. We need to know
-whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
-
-\begin{code}
--- 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)