-matchConFamily (var:vars) ty eqns_info
- = let
- -- Sort into equivalence classes by the unique on the constructor
- -- All the EqnInfos should start with a ConPat
- groups = equivClassesByUniq get_uniq eqns_info
- get_uniq (EqnInfo { eqn_pats = ConPatOut (L _ data_con) _ _ _ _ _ : _}) = getUnique data_con
-
- -- Get the wrapper from the head of each group. We're going to
- -- use it as the pattern in this case expression, so we need to
- -- ensure that any type variables it mentions in the pattern are
- -- in scope. So we put its wrappers outside the case, and
- -- zap the wrapper for it.
- wraps :: [CoreExpr -> CoreExpr]
- wraps = map (eqn_wrap . head) groups
-
- groups' = [ eqn { eqn_wrap = idWrapper } : eqns | eqn:eqns <- groups ]
- in
- -- Now make a case alternative out of each group
- mappM (match_con vars ty) groups' `thenDs` \ alts ->
- returnDs (adjustMatchResult (foldr (.) idWrapper wraps) $
- mkCoAlgCaseMatchResult var ty alts)
-\end{code}
-
-And here is the local function that does all the work. It is
-more-or-less the @matchCon@/@matchClause@ functions on page~94 in
-Wadler's chapter in SLPJ. The function @shift_con_pats@ does what the
-list comprehension in @matchClause@ (SLPJ, p.~94) does, except things
-are trickier in real life. Works for @ConPats@, and we want it to
-fail catastrophically for anything else (which a list comprehension
-wouldn't). Cf.~@shift_lit_pats@ in @MatchLits@.
-
-\begin{code}
-match_con vars ty eqns
- = do { -- Make new vars for the con arguments; avoid new locals where possible
- arg_vars <- selectMatchVars (map unLoc arg_pats1) arg_tys
- ; eqns' <- mapM shift eqns
+-- Each group of eqns is for a single constructor
+matchConFamily (var:vars) ty groups
+ = do { alts <- mapM (matchOneCon vars ty) groups
+ ; return (mkCoAlgCaseMatchResult var ty alts) }
+
+matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor
+ = do { (wraps, eqns') <- mapAndUnzipM shift (eqn1:eqns)
+ ; arg_vars <- selectMatchVars (take (dataConSourceArity con1)
+ (eqn_pats (head eqns')))
+ -- Use the new arugment patterns as a source of
+ -- suggestions for the new variables