-zonkPat :: TcPat s -> NF_TcM s TypecheckedPat
-
-zonkPat (WildPat ty)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (WildPat new_ty)
-
-zonkPat (VarPat v)
- = zonkId v `thenNF_Tc` \ new_v ->
- returnNF_Tc (VarPat new_v)
-
-zonkPat (LazyPat pat)
- = zonkPat pat `thenNF_Tc` \ new_pat ->
- returnNF_Tc (LazyPat new_pat)
-
-zonkPat (AsPat n pat)
- = zonkId n `thenNF_Tc` \ new_n ->
- zonkPat pat `thenNF_Tc` \ new_pat ->
- returnNF_Tc (AsPat new_n new_pat)
-
-zonkPat (ConPat n ty pats)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats ->
- returnNF_Tc (ConPat n new_ty new_pats)
-
-zonkPat (ConOpPat pat1 op pat2 ty)
- = zonkPat pat1 `thenNF_Tc` \ new_pat1 ->
- zonkPat pat2 `thenNF_Tc` \ new_pat2 ->
- zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty)
-
-zonkPat (ListPat ty pats)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats ->
- returnNF_Tc (ListPat new_ty new_pats)
-
-zonkPat (TuplePat pats)
- = mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats ->
- returnNF_Tc (TuplePat new_pats)
-
-zonkPat (LitPat lit ty)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (LitPat lit new_ty)
-
-zonkPat (NPat lit ty expr)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- zonkExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (NPat lit new_ty new_expr)
-
-zonkPat (DictPat ds ms)
- = mapNF_Tc zonkId ds `thenNF_Tc` \ new_ds ->
- mapNF_Tc zonkId ms `thenNF_Tc` \ new_ms ->
- returnNF_Tc (DictPat new_ds new_ms)
+zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
+
+zonkPat env (ParPat p)
+ = zonkPat env p `thenM` \ (new_p, ids) ->
+ returnM (ParPat new_p, ids)
+
+zonkPat env (WildPat ty)
+ = zonkTcTypeToType env ty `thenM` \ new_ty ->
+ returnM (WildPat new_ty, emptyBag)
+
+zonkPat env (VarPat v)
+ = zonkIdBndr env v `thenM` \ new_v ->
+ returnM (VarPat new_v, unitBag new_v)
+
+zonkPat env (LazyPat pat)
+ = zonkPat env pat `thenM` \ (new_pat, ids) ->
+ returnM (LazyPat new_pat, ids)
+
+zonkPat env (AsPat n pat)
+ = zonkIdBndr env n `thenM` \ new_n ->
+ zonkPat env pat `thenM` \ (new_pat, ids) ->
+ returnM (AsPat new_n new_pat, new_n `consBag` ids)
+
+zonkPat env (ListPat pats ty)
+ = zonkTcTypeToType env ty `thenM` \ new_ty ->
+ zonkPats env pats `thenM` \ (new_pats, ids) ->
+ returnM (ListPat new_pats new_ty, ids)
+
+zonkPat env (PArrPat pats ty)
+ = zonkTcTypeToType env ty `thenM` \ new_ty ->
+ zonkPats env pats `thenM` \ (new_pats, ids) ->
+ returnM (PArrPat new_pats new_ty, ids)
+
+zonkPat env (TuplePat pats boxed)
+ = zonkPats env pats `thenM` \ (new_pats, ids) ->
+ returnM (TuplePat new_pats boxed, ids)
+
+zonkPat env (ConPatOut n stuff ty tvs dicts)
+ = zonkTcTypeToType env ty `thenM` \ new_ty ->
+ mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs ->
+ zonkIdBndrs env dicts `thenM` \ new_dicts ->
+ let
+ env1 = extendZonkEnv env new_dicts
+ in
+ zonkConStuff env stuff `thenM` \ (new_stuff, ids) ->
+ returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
+ listToBag new_dicts `unionBags` ids)
+
+zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
+
+zonkPat env (SigPatOut pat ty expr)
+ = zonkPat env pat `thenM` \ (new_pat, ids) ->
+ zonkTcTypeToType env ty `thenM` \ new_ty ->
+ zonkExpr env expr `thenM` \ new_expr ->
+ returnM (SigPatOut new_pat new_ty new_expr, ids)
+
+zonkPat env (NPatOut lit ty expr)
+ = zonkTcTypeToType env ty `thenM` \ new_ty ->
+ zonkExpr env expr `thenM` \ new_expr ->
+ returnM (NPatOut lit new_ty new_expr, emptyBag)
+
+zonkPat env (NPlusKPatOut n k e1 e2)
+ = zonkIdBndr env n `thenM` \ new_n ->
+ zonkExpr env e1 `thenM` \ new_e1 ->
+ zonkExpr env e2 `thenM` \ new_e2 ->
+ returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
+
+zonkPat env (DictPat ds ms)
+ = zonkIdBndrs env ds `thenM` \ new_ds ->
+ zonkIdBndrs env ms `thenM` \ new_ms ->
+ returnM (DictPat new_ds new_ms,
+ listToBag new_ds `unionBags` listToBag new_ms)
+
+---------------------------
+zonkConStuff env (PrefixCon pats)
+ = zonkPats env pats `thenM` \ (new_pats, ids) ->
+ returnM (PrefixCon new_pats, ids)
+
+zonkConStuff env (InfixCon p1 p2)
+ = zonkPat env p1 `thenM` \ (new_p1, ids1) ->
+ zonkPat env p2 `thenM` \ (new_p2, ids2) ->
+ returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
+
+zonkConStuff env (RecCon rpats)
+ = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) ->
+ returnM (RecCon new_rpats, unionManyBags ids_s)
+ where
+ zonk_rpat (f, pat)
+ = zonkPat env pat `thenM` \ (new_pat, ids) ->
+ returnM ((f, new_pat), ids)
+
+---------------------------
+zonkPats env []
+ = returnM ([], emptyBag)
+
+zonkPats env (pat:pats)
+ = zonkPat env pat `thenM` \ (pat', ids1) ->
+ zonkPats env pats `thenM` \ (pats', ids2) ->
+ returnM (pat':pats', ids1 `unionBags` ids2)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[BackSubst-Foreign]{Foreign exports}
+%* *
+%************************************************************************
+
+
+\begin{code}
+zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
+zonkForeignExports env ls = mappM (zonkForeignExport env) ls
+
+zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
+zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
+ returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
+\end{code}
+
+\begin{code}
+zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
+zonkRules env rs = mappM (zonkRule env) rs
+
+zonkRule env (HsRule name act vars lhs rhs loc)
+ = mappM zonk_bndr vars `thenM` \ new_bndrs ->
+ newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
+ let
+ env_rhs = extendZonkEnv env (filter isId new_bndrs)
+ -- Type variables don't need an envt
+ -- They are bound through the mutable mechanism
+
+ env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
+ -- We need to gather the type variables mentioned on the LHS so we can
+ -- quantify over them. Example:
+ -- data T a = C
+ --
+ -- foo :: T a -> Int
+ -- foo C = 1
+ --
+ -- {-# RULES "myrule" foo C = 1 #-}
+ --
+ -- After type checking the LHS becomes (foo a (C a))
+ -- and we do not want to zap the unbound tyvar 'a' to (), because
+ -- that limits the applicability of the rule. Instead, we
+ -- want to quantify over it!
+ --
+ -- It's easiest to find the free tyvars here. Attempts to do so earlier
+ -- are tiresome, because (a) the data type is big and (b) finding the
+ -- free type vars of an expression is necessarily monadic operation.
+ -- (consider /\a -> f @ b, where b is side-effected to a)
+ in
+ zonkExpr env_lhs lhs `thenM` \ new_lhs ->
+ zonkExpr env_rhs rhs `thenM` \ new_rhs ->
+
+ readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
+ let
+ final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
+ -- I hate this map RuleBndr stuff
+ in
+ returnM (HsRule name act final_bndrs new_lhs new_rhs loc)
+ where
+ zonk_bndr (RuleBndr v)
+ | isId v = zonkIdBndr env v
+ | otherwise = zonkTcTyVarToTyVar v
+
+zonkRule env (IfaceRuleOut fun rule)
+ = returnM (IfaceRuleOut (zonkIdOcc env fun) rule)