-zonkPat :: TyVarEnv Type
- -> TcPat s -> NF_TcM s (TypecheckedPat, Bag Id)
-
-zonkPat te (WildPat ty)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (WildPat new_ty, emptyBag)
-
-zonkPat te (VarPat v)
- = zonkIdBndr te v `thenNF_Tc` \ new_v ->
- returnNF_Tc (VarPat new_v, unitBag new_v)
-
-zonkPat te (LazyPat pat)
- = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
- returnNF_Tc (LazyPat new_pat, ids)
-
-zonkPat te (AsPat n pat)
- = zonkIdBndr te n `thenNF_Tc` \ new_n ->
- zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
- returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
-
-zonkPat te (ConPat n ty pats)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
- returnNF_Tc (ConPat n new_ty new_pats, ids)
-
-zonkPat te (ConOpPat pat1 op pat2 ty)
- = zonkPat te pat1 `thenNF_Tc` \ (new_pat1, ids1) ->
- zonkPat te pat2 `thenNF_Tc` \ (new_pat2, ids2) ->
- zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 `unionBags` ids2)
-
-zonkPat te (ListPat ty pats)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
- returnNF_Tc (ListPat new_ty new_pats, ids)
-
-zonkPat te (TuplePat pats)
- = zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
- returnNF_Tc (TuplePat new_pats, ids)
-
-zonkPat te (RecPat n ty rpats)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
- returnNF_Tc (RecPat n new_ty new_rpats, unionManyBags ids_s)
+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 ->
+ let
+ env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
+ -- 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
+ zonkLExpr env_lhs lhs `thenM` \ new_lhs ->
+ zonkLExpr env_rhs rhs `thenM` \ new_rhs ->
+
+ readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
+ let
+ final_bndrs :: [Located Var]
+ final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
+ in
+ returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs)
+ -- I hate this map RuleBndr stuff