-match_con vars all_eqns@(EqnInfo n ctx (ConPat data_con _ ex_tvs ex_dicts arg_pats : pats1) match_result1 : other_eqns)
- = -- Make new vars for the con arguments; avoid new locals where possible
- mapDs selectMatchVar arg_pats `thenDs` \ arg_vars ->
-
- -- Now do the business to make the alt for _this_ ConPat ...
- match (ex_dicts ++ arg_vars ++ vars)
- (map shift_con_pat all_eqns) `thenDs` \ match_result ->
-
- -- Substitute over the result
- let
- match_result' | null ex_tvs = match_result
- | otherwise = adjustMatchResult subst_it match_result
- in
- returnDs (data_con, ex_tvs ++ ex_dicts ++ arg_vars, match_result')
- where
- shift_con_pat :: EquationInfo -> EquationInfo
- shift_con_pat (EqnInfo n ctx (ConPat _ _ ex_tvs' ex_dicts' arg_pats: pats) match_result)
- = EqnInfo n ctx (new_pats ++ pats) match_result
- where
- new_pats = map VarPat ex_dicts' ++ arg_pats
-
- -- We 'substitute' by going: (/\ tvs' -> e) tvs
- subst_it e = foldr subst_one e other_eqns
- subst_one (EqnInfo _ _ (ConPat _ _ ex_tvs' _ _ : _) _) e = mkTyApps (mkLams ex_tvs' e) ex_tys
- ex_tys = mkTyVarTys ex_tvs
-
-
--- Belongs in Util.lhs
-equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
- -- NB: it's *very* important that if we have the input list [a,b,c],
- -- where a,b,c all have the same unique, then we get back the list
- -- [a,b,c]
- -- not
- -- [c,b,a]
- -- Hence the use of foldr, plus the reversed-args tack_on below
-equivClassesByUniq get_uniq xs
- = eltsUFM (foldr add emptyUFM xs)
+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
+ ; match_result <- match (arg_vars ++ vars) ty eqns'
+ ; return (con, tvs1 ++ dicts1 ++ arg_vars, match_result) }