-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)
+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') }
projects / ghc-hetmet.git / blobdiff