X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=93a90101575cfef04f905bb782e4cde01fa37d25;hp=96b2ed84c4059b75e48313b01e828bf257ed8080;hb=a8427a4125e9b78e88a487eeabf018f1c6e8bc08;hpb=bb7d80b3b8d1396d481d3b24302bee24a3d92f71 diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 96b2ed8..93a9010 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -162,9 +162,9 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside -- Extend the envt right away with all -- the Ids declared with type signatures - ; gla_exts <- doptM Opt_GlasgowExts + ; poly_rec <- doptM Opt_RelaxedPolyRec ; (binds', thing) <- tcExtendIdEnv poly_ids $ - tc_val_binds gla_exts top_lvl sig_fn prag_fn + tc_val_binds poly_rec top_lvl sig_fn prag_fn binds thing_inside ; return (ValBindsOut binds' sigs, thing) } @@ -176,14 +176,14 @@ tc_val_binds :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun -- Typecheck a whole lot of value bindings, -- one strongly-connected component at a time -tc_val_binds gla_exts top_lvl sig_fn prag_fn [] thing_inside +tc_val_binds poly_rec top_lvl sig_fn prag_fn [] thing_inside = do { thing <- thing_inside ; return ([], thing) } -tc_val_binds gla_exts top_lvl sig_fn prag_fn (group : groups) thing_inside +tc_val_binds poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside = do { (group', (groups', thing)) - <- tc_group gla_exts top_lvl sig_fn prag_fn group $ - tc_val_binds gla_exts top_lvl sig_fn prag_fn groups thing_inside + <- tc_group poly_rec top_lvl sig_fn prag_fn group $ + tc_val_binds poly_rec top_lvl sig_fn prag_fn groups thing_inside ; return (group' ++ groups', thing) } ------------------------ @@ -195,15 +195,15 @@ tc_group :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun -- We get a list of groups back, because there may -- be specialisations etc as well -tc_group gla_exts top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside +tc_group poly_rec top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside -- A single non-recursive binding -- We want to keep non-recursive things non-recursive -- so that we desugar unlifted bindings correctly = do { (binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn NonRecursive binds thing_inside ; return ([(NonRecursive, b) | b <- binds], thing) } -tc_group gla_exts top_lvl sig_fn prag_fn (Recursive, binds) thing_inside - | not gla_exts -- Recursive group, normal Haskell 98 route +tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside + | not poly_rec -- Recursive group, normal Haskell 98 route = do { (binds1, thing) <- tc_haskell98 top_lvl sig_fn prag_fn Recursive binds thing_inside ; return ([(Recursive, unionManyBags binds1)], thing) } @@ -511,7 +511,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, -- e.g. f = \(x::forall a. a->a) -> -- We want to infer a higher-rank type for f setSrcSpan b_loc $ - do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches) + do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches) -- Check for an unboxed tuple type -- f = (# True, False #) @@ -546,7 +546,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ] ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $ - tcMatchesFun mono_name matches mono_ty + tcMatchesFun mono_name inf matches mono_ty ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, fun_matches = matches', @@ -653,8 +653,8 @@ tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind) ------------------- tcRhs :: TcMonoBind -> TcM (HsBind TcId) tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches) - = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches - (idType mono_id) + = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) inf + matches (idType mono_id) ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches', bind_fvs = placeHolderNames, fun_co_fn = co_fn, fun_tick = Nothing }) }