- 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)
- where
- add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
- tack_on old new = new++old
+ shift_con_pat (EqnInfo n ctx (ConPatOut _ (PrefixCon arg_pats) _ _ _ : pats) match_result)
+ = EqnInfo n ctx (arg_pats ++ pats) match_result
+
+ other_pats = [p | EqnInfo _ _ (p:_) _ <- other_eqns]
+
+ var_prs = concat [ (ex_tvs' `zip` ex_tvs) ++
+ (ex_dicts' `zip` ex_dicts)
+ | ConPatOut _ _ _ ex_tvs' ex_dicts' <- other_pats ]
+
+ do_subst e = substExpr subst e
+ where
+ subst = foldl (\ s (v', v) -> bindSubst s v' v) in_scope var_prs
+ in_scope = mkSubst (mkInScopeSet (exprFreeVars e)) emptySubstEnv
+ -- We put all the free variables of e into the in-scope
+ -- set of the substitution, not because it is necessary,
+ -- but to suppress the warning in Subst.lookupInScope
+ -- Tiresome, but doing the substitution at all is rare.