X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=851d833fcedf5ffd93aeb2c90c4274d8bbf4ed5f;hb=2a8cdc3aee5997374273e27365f92c161aca8453;hp=8ab91ce893a505358117a311a2936e733c70a55a;hpb=3e83dfb21b2f2220dce97427fff5c19459ae68d1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 8ab91ce..851d833 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1,4 +1,4 @@ -% + % % (c) The AQUA Project, Glasgow University, 1996-1998 % \section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker} @@ -512,10 +512,10 @@ zonkExpr env (HsArrForm op fixity args) mappM (zonkCmdTop env) args `thenM` \ new_args -> returnM (HsArrForm new_op fixity new_args) -zonkExpr env (HsCoerce co_fn expr) +zonkExpr env (HsWrap co_fn expr) = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) -> zonkExpr env1 expr `thenM` \ new_expr -> - return (HsCoerce new_co_fn new_expr) + return (HsWrap new_co_fn new_expr) zonkExpr env other = pprPanic "zonkExpr" (ppr other) @@ -530,23 +530,23 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids) ------------------------------------------------------------------------- -zonkCoFn :: ZonkEnv -> ExprCoFn -> TcM (ZonkEnv, ExprCoFn) -zonkCoFn env CoHole = return (env, CoHole) -zonkCoFn env (ExprCoFn co) = do { co' <- zonkTcTypeToType env co - ; return (env, ExprCoFn co') } -zonkCoFn env (CoCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 +zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) +zonkCoFn env WpHole = return (env, WpHole) +zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 - ; return (env2, CoCompose c1' c2') } -zonkCoFn env (CoLams ids) = do { ids' <- zonkIdBndrs env ids - ; let env1 = extendZonkEnv env ids' - ; return (env1, CoLams ids') } -zonkCoFn env (CoTyLams tvs) = ASSERT( all isImmutableTyVar tvs ) - do { return (env, CoTyLams tvs) } -zonkCoFn env (CoApps ids) = do { return (env, CoApps (zonkIdOccs env ids)) } -zonkCoFn env (CoTyApps tys) = do { tys' <- zonkTcTypeToTypes env tys - ; return (env, CoTyApps tys') } -zonkCoFn env (CoLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs - ; return (env1, CoLet bs') } + ; return (env2, WpCompose c1' c2') } +zonkCoFn env (WpCo co) = do { co' <- zonkTcTypeToType env co + ; return (env, WpCo co') } +zonkCoFn env (WpLam id) = do { id' <- zonkIdBndr env id + ; let env1 = extendZonkEnv1 env id' + ; return (env1, WpLam id') } +zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) + do { return (env, WpTyLam tv) } +zonkCoFn env (WpApp id) = do { return (env, WpApp (zonkIdOcc env id)) } +zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty + ; return (env, WpTyApp ty') } +zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs + ; return (env1, WpLet bs') } ------------------------------------------------------------------------- @@ -651,8 +651,7 @@ zonkRbinds env rbinds ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b) -mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r) -mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r) +mapIPNameTc f (IPName n) = f n `thenM` \ r -> returnM (IPName r) \end{code} @@ -772,16 +771,16 @@ zonkConStuff env (InfixCon p1 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 + = do { let (fields, pats) = unzip [ (f, p) | HsRecField f p _ <- rpats ] + ; (env', pats') <- zonkPats env pats + ; let recCon = RecCon [ mkRecField f p | (f, p) <- zip fields pats' ] + ; returnM (env', recCon) } --------------------------- zonkPats env [] = return (env, []) zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat - ; (env', pats') <- zonkPats env1 pats - ; return (env', pat':pats') } + ; (env', pats') <- zonkPats env1 pats + ; return (env', pat':pats') } \end{code} %************************************************************************