-zonkPat :: TyVarEnv Type
- -> TcPat s -> NF_TcM s (TypecheckedPat, Bag TyVar, Bag Id)
-
-zonkPat te (WildPat ty)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (WildPat new_ty, emptyBag, emptyBag)
-
-zonkPat te (VarPat v)
- = zonkIdBndr te v `thenNF_Tc` \ new_v ->
- returnNF_Tc (VarPat new_v, emptyBag, unitBag new_v)
-
-zonkPat te (LazyPat pat)
- = zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) ->
- returnNF_Tc (LazyPat new_pat, tvs, ids)
-
-zonkPat te (AsPat n pat)
- = zonkIdBndr te n `thenNF_Tc` \ new_n ->
- zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) ->
- returnNF_Tc (AsPat new_n new_pat, tvs, new_n `consBag` ids)
-
-zonkPat te (ListPat ty pats)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- zonkPats te pats `thenNF_Tc` \ (new_pats, tvs, ids) ->
- returnNF_Tc (ListPat new_ty new_pats, tvs, ids)
-
-zonkPat te (TuplePat pats boxed)
- = zonkPats te pats `thenNF_Tc` \ (new_pats, tvs, ids) ->
- returnNF_Tc (TuplePat new_pats boxed, tvs, ids)
-
-zonkPat te (ConPat n ty tvs dicts pats)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
- let
- new_te = extend_te te new_tvs
- in
- mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts ->
- tcExtendGlobalValEnv new_dicts $
-
- zonkPats new_te pats `thenNF_Tc` \ (new_pats, tvs, ids) ->
-
- returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
- listToBag new_tvs `unionBags` tvs,
- listToBag new_dicts `unionBags` ids)
-
-zonkPat te (RecPat n ty tvs dicts rpats)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
+zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
+-- Extend the environment as we go, because it's possible for one
+-- pattern to bind something that is used in another (inside or
+-- to the right)
+zonkPat env pat = wrapLocSndM (zonk_pat env) pat
+
+zonk_pat env (ParPat p)
+ = do { (env', p') <- zonkPat env p
+ ; return (env', ParPat p') }
+
+zonk_pat env (WildPat ty)
+ = do { ty' <- zonkTcTypeToType env ty
+ ; return (env, WildPat ty') }
+
+zonk_pat env (VarPat v)
+ = do { v' <- zonkIdBndr env v
+ ; return (extendZonkEnv1 env v', VarPat v') }
+
+zonk_pat env (VarPatOut v binds)
+ = do { v' <- zonkIdBndr env v
+ ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
+ ; returnM (env', VarPatOut v' binds') }
+
+zonk_pat env (LazyPat pat)
+ = do { (env', pat') <- zonkPat env pat
+ ; return (env', LazyPat pat') }
+
+zonk_pat env (BangPat pat)
+ = do { (env', pat') <- zonkPat env pat
+ ; return (env', BangPat pat') }
+
+zonk_pat env (AsPat (L loc v) pat)
+ = do { v' <- zonkIdBndr env v
+ ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
+ ; return (env', AsPat (L loc v') pat') }
+
+zonk_pat env (ListPat pats ty)
+ = do { ty' <- zonkTcTypeToType env ty
+ ; (env', pats') <- zonkPats env pats
+ ; return (env', ListPat pats' ty') }
+
+zonk_pat env (PArrPat pats ty)
+ = do { ty' <- zonkTcTypeToType env ty
+ ; (env', pats') <- zonkPats env pats
+ ; return (env', PArrPat pats' ty') }
+
+zonk_pat env (TuplePat pats boxed ty)
+ = do { ty' <- zonkTcTypeToType env ty
+ ; (env', pats') <- zonkPats env pats
+ ; return (env', TuplePat pats' boxed ty') }
+
+zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
+ = ASSERT( all isImmutableTyVar tvs )
+ do { new_ty <- zonkTcTypeToType env ty
+ ; new_dicts <- zonkIdBndrs env dicts
+ ; let env1 = extendZonkEnv env new_dicts
+ ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
+ ; (env', new_stuff) <- zonkConStuff env2 stuff
+ ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) }
+
+zonk_pat env (LitPat lit) = return (env, LitPat lit)
+
+zonk_pat env (SigPatOut pat ty)
+ = do { ty' <- zonkTcTypeToType env ty
+ ; (env', pat') <- zonkPat env pat
+ ; return (env', SigPatOut pat' ty') }
+
+zonk_pat env (NPat lit mb_neg eq_expr ty)
+ = do { lit' <- zonkOverLit env lit
+ ; mb_neg' <- case mb_neg of
+ Nothing -> return Nothing
+ Just neg -> do { neg' <- zonkExpr env neg
+ ; return (Just neg') }
+ ; eq_expr' <- zonkExpr env eq_expr
+ ; ty' <- zonkTcTypeToType env ty
+ ; return (env, NPat lit' mb_neg' eq_expr' ty') }
+
+zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
+ = do { n' <- zonkIdBndr env n
+ ; lit' <- zonkOverLit env lit
+ ; e1' <- zonkExpr env e1
+ ; e2' <- zonkExpr env e2
+ ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
+
+zonk_pat env (DictPat ds ms)
+ = do { ds' <- zonkIdBndrs env ds
+ ; ms' <- zonkIdBndrs env ms
+ ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
+
+---------------------------
+zonkConStuff env (PrefixCon pats)
+ = do { (env', pats') <- zonkPats env pats
+ ; return (env', PrefixCon pats') }
+
+zonkConStuff env (InfixCon p1 p2)
+ = do { (env1, p1') <- zonkPat env p1
+ ; (env', p2') <- zonkPat env1 p2
+ ; return (env', InfixCon p1' p2') }
+
+zonkConStuff env (RecCon rpats)
+ = do { (env', pats') <- zonkPats env pats
+ ; returnM (env', RecCon (fields `zip` pats')) }
+ where
+ (fields, pats) = unzip rpats
+
+---------------------------
+zonkPats env [] = return (env, [])
+zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
+ ; (env', pats') <- zonkPats env1 pats
+ ; return (env', pat':pats') }
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[BackSubst-Foreign]{Foreign exports}
+%* *
+%************************************************************************
+
+
+\begin{code}
+zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
+zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
+
+zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
+zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
+ returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
+zonkForeignExport env for_imp
+ = returnM for_imp -- Foreign imports don't need zonking
+\end{code}
+
+\begin{code}
+zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
+zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
+
+zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
+zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
+ = mappM zonk_bndr vars `thenM` \ new_bndrs ->
+ newMutVar emptyVarSet `thenM` \ unbound_tv_set ->