X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=170834997a4d6a3eac4dda45c20cfd735d8547a0;hp=de572ba65bb215fb2370746c11f601f9bc1aae8d;hb=f1cc3eb980a634e62f2739a7a25387c902fa9d8a;hpb=388e3356f71daffa62f1d4157e1e07e4c68f218a diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index de572ba..1708349 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -318,7 +318,7 @@ zonkValBinds env (ValBindsOut binds sigs) zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id) zonkRecMonoBinds env binds = fixM (\ ~(_, new_binds) -> do - { let env1 = extendZonkEnv env (collectHsBindBinders new_binds) + { let env1 = extendZonkEnv env (collectHsBindsBinders new_binds) ; binds' <- zonkMonoBinds env1 binds ; return (env1, binds') }) @@ -333,10 +333,10 @@ zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) ; new_ty <- zonkTcTypeToType env ty ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) } -zonk_bind env (VarBind { var_id = var, var_rhs = expr }) +zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl }) = zonkIdBndr env var `thenM` \ new_var -> zonkLExpr env expr `thenM` \ new_expr -> - returnM (VarBind { var_id = new_var, var_rhs = new_expr }) + returnM (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn }) = wrapLocM (zonkIdBndr env) var `thenM` \ new_var -> @@ -351,7 +351,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, fixM (\ ~(new_val_binds, _) -> let env1 = extendZonkEnv env new_dicts - env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds) + env2 = extendZonkEnv env1 (collectHsBindsBinders new_val_binds) in zonkMonoBinds env2 val_binds `thenM` \ new_val_binds -> mappM (zonkExport env2) exports `thenM` \ new_exports -> @@ -363,13 +363,15 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, zonkExport env (tyvars, global, local, prags) -- The tyvars are already zonked = zonkIdBndr env global `thenM` \ new_global -> - mapM zonk_prag prags `thenM` \ new_prags -> + zonk_prags prags `thenM` \ new_prags -> returnM (tyvars, new_global, zonkIdOcc env local, new_prags) - zonk_prag prag@(L _ (InlinePrag {})) = return prag - zonk_prag (L loc (SpecPrag expr ty inl)) - = do { expr' <- zonkExpr env expr - ; ty' <- zonkTcTypeToType env ty - ; return (L loc (SpecPrag expr' ty' inl)) } + + zonk_prags IsDefaultMethod = return IsDefaultMethod + zonk_prags (SpecPrags ps) = do { ps' <- mapM zonk_prag ps; return (SpecPrags ps') } + + zonk_prag (L loc (SpecPrag co_fn inl)) + = do { (_, co_fn') <- zonkCoFn env co_fn + ; return (L loc (SpecPrag co_fn' inl)) } \end{code} %************************************************************************ @@ -600,7 +602,6 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) ------------------------------------------------------------------------- zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) zonkCoFn env WpHole = return (env, WpHole) -zonkCoFn env WpInline = return (env, WpInline) zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } @@ -682,21 +683,26 @@ zonkStmt env (ParStmt stmts_w_bndrs) zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) -> returnM (new_stmts, zonkIdOccs env1 bndrs) -zonkStmt env (RecStmt segStmts lvs rvs rets binds) - = zonkIdBndrs env rvs `thenM` \ new_rvs -> - let - env1 = extendZonkEnv env new_rvs - in - zonkStmts env1 segStmts `thenM` \ (env2, new_segStmts) -> +zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs + , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id + , recS_rec_rets = rets, recS_dicts = binds }) + = do { new_rvs <- zonkIdBndrs env rvs + ; new_lvs <- zonkIdBndrs env lvs + ; new_ret_id <- zonkExpr env ret_id + ; new_mfix_id <- zonkExpr env mfix_id + ; new_bind_id <- zonkExpr env bind_id + ; let env1 = extendZonkEnv env new_rvs + ; (env2, new_segStmts) <- zonkStmts env1 segStmts -- Zonk the ret-expressions in an envt that -- has the polymorphic bindings in the envt - mapM (zonkExpr env2) rets `thenM` \ new_rets -> - let - new_lvs = zonkIdOccs env2 lvs - env3 = extendZonkEnv env new_lvs -- Only the lvs are needed - in - zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) -> - returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds) + ; new_rets <- mapM (zonkExpr env2) rets + ; let env3 = extendZonkEnv env new_lvs -- Only the lvs are needed + ; (env4, new_binds) <- zonkRecMonoBinds env3 binds + ; return (env4, + RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs + , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id + , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id + , recS_rec_rets = new_rets, recS_dicts = new_binds }) } zonkStmt env (ExprStmt expr then_op ty) = zonkLExpr env expr `thenM` \ new_expr -> @@ -704,32 +710,21 @@ zonkStmt env (ExprStmt expr then_op ty) zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (env, ExprStmt new_expr new_then new_ty) -zonkStmt env (TransformStmt (stmts, binders) usingExpr maybeByExpr) +zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr) = do { (env', stmts') <- zonkStmts env stmts ; let binders' = zonkIdOccs env' binders ; usingExpr' <- zonkLExpr env' usingExpr ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr - ; return (env', TransformStmt (stmts', binders') usingExpr' maybeByExpr') } + ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') } -zonkStmt env (GroupStmt (stmts, binderMap) groupByClause) +zonkStmt env (GroupStmt stmts binderMap by using) = do { (env', stmts') <- zonkStmts env stmts ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap - ; groupByClause' <- - case groupByClause of - GroupByNothing usingExpr -> (zonkLExpr env' usingExpr) >>= (return . GroupByNothing) - GroupBySomething eitherUsingExpr byExpr -> do - eitherUsingExpr' <- mapEitherM (zonkLExpr env') (zonkExpr env') eitherUsingExpr - byExpr' <- zonkLExpr env' byExpr - return $ GroupBySomething eitherUsingExpr' byExpr' - + ; by' <- fmapMaybeM (zonkLExpr env') by + ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using ; let env'' = extendZonkEnv env' (map snd binderMap') - ; return (env'', GroupStmt (stmts', binderMap') groupByClause') } + ; return (env'', GroupStmt stmts' binderMap' by' using') } where - mapEitherM f g x = do - case x of - Left a -> f a >>= (return . Left) - Right b -> g b >>= (return . Right) - zonkBinderMapEntry env (oldBinder, newBinder) = do let oldBinder' = zonkIdOcc env oldBinder newBinder' <- zonkIdBndr env newBinder