- shift_con_pat :: EquationInfo -> EquationInfo
- shift_con_pat (EqnInfo n ctx (ConPatOut _ (PrefixCon arg_pats) _ _ _ : pats) match_result)
- = EqnInfo n ctx (map unLoc 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.
+ ConPatOut (L _ con) tvs1 dicts1 _ (PrefixCon arg_pats1) pat_ty = firstPat (head eqns)
+
+ shift eqn@(EqnInfo { eqn_wrap = wrap,
+ eqn_pats = ConPatOut _ tvs ds bind (PrefixCon arg_pats) _ : pats })
+ = do { prs <- dsLHsBinds bind
+ ; return (eqn { eqn_wrap = wrap . wrapBinds (tvs `zip` tvs1)
+ . wrapBinds (ds `zip` dicts1)
+ . mkDsLet (Rec prs),
+ eqn_pats = map unLoc arg_pats ++ pats }) }
+
+ -- Get the arg types, which we use to type the new vars
+ -- to match on, from the "outside"; the types of pats1 may
+ -- be more refined, and hence won't do
+ arg_tys = dataConInstOrigArgTys con inst_tys
+ inst_tys | isVanillaDataCon con = tcTyConAppArgs pat_ty -- Newtypes opaque!
+ | otherwise = mkTyVarTys tvs1