*** compiler/typecheck/TcRnDriver.lhs 2010-11-08 17:39:19.000000000 -0500 --- compiler/typecheck/TcRnDriver.lhs 2010-09-17 18:16:17.781850000 -0400 *************** *** 31,53 **** import TcExpr import TcRnMonad import Coercion - import Inst import FamInst import InstEnv import FamInstEnv import TcAnnotations import TcBinds import TcDefaults import TcEnv import TcRules import TcForeign import TcInstDcls import TcIface import MkIface import IfaceSyn import TcSimplify import TcTyClsDecls - import TcUnify ( withBox ) import LoadIface import RnNames import RnEnv --- 31,53 ---- import TcExpr import TcRnMonad import Coercion import FamInst import InstEnv import FamInstEnv import TcAnnotations import TcBinds + import TcType ( tidyTopType ) import TcDefaults import TcEnv import TcRules import TcForeign import TcInstDcls import TcIface + import TcMType import MkIface import IfaceSyn import TcSimplify import TcTyClsDecls import LoadIface import RnNames import RnEnv *************** *** 64,70 **** import NameEnv import NameSet import TyCon - import TysPrim import SrcLoc import HscTypes import ListSetOps --- 64,69 ---- import NameEnv import NameSet import TyCon import SrcLoc import HscTypes import ListSetOps *************** *** 76,83 **** import Data.List ( sortBy ) #ifdef GHCI import TcHsType - import TcMType import TcMatches import RnTypes import RnExpr --- 75,83 ---- import Data.List ( sortBy ) #ifdef GHCI + import Inst ( tcGetInstEnvs ) + import CoreUtils( mkPiTypes ) import TcHsType import TcMatches import RnTypes import RnExpr *************** *** 362,372 **** -- Reason: solely to report unused imports and bindings tcRnSrcDecls boot_iface decls = do { -- Do all the declarations ! (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ; -- Finish simplifying class constraints -- ! -- tcSimplifyTop deals with constant or ambiguous InstIds. -- How could there be ambiguous ones? They can only arise if a -- top-level decl falls under the monomorphism restriction -- and no subsequent decl instantiates its type. --- 362,372 ---- -- Reason: solely to report unused imports and bindings tcRnSrcDecls boot_iface decls = do { -- Do all the declarations ! (tc_envs, lie) <- getConstraints $ tc_rn_src_decls boot_iface decls ; -- Finish simplifying class constraints -- ! -- simplifyTop deals with constant or ambiguous InstIds. -- How could there be ambiguous ones? They can only arise if a -- top-level decl falls under the monomorphism restriction -- and no subsequent decl instantiates its type. *************** *** 375,407 **** -- thaat checkMain adds -- -- We do it with both global and local env in scope: ! -- * the global env exposes the instances to tcSimplifyTop ! -- * the local env exposes the local Ids to tcSimplifyTop, -- so that we get better error messages (monomorphism restriction) traceTc (text "Tc8") ; ! inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ; -- Backsubstitution. This must be done last. ! -- Even tcSimplifyTop may do some unification. traceTc (text "Tc9") ; let { (tcg_env, _) = tc_envs ; TcGblEnv { tcg_type_env = type_env, ! tcg_binds = binds, ! tcg_rules = rules, ! tcg_fords = fords } = tcg_env ! ; all_binds = binds `unionBags` inst_binds } ; failIfErrsM ; -- Don't zonk if there have been errors -- It's a waste of time; and we may get debug warnings -- about strangely-typed TyCons! ! (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids ! ; tcg_env' = tcg_env { tcg_binds = binds', ! tcg_rules = rules', ! tcg_fords = fords' } } ; setGlobalTypeEnv tcg_env' final_type_env } --- 375,410 ---- -- thaat checkMain adds -- -- We do it with both global and local env in scope: ! -- * the global env exposes the instances to simplifyTop ! -- * the local env exposes the local Ids to simplifyTop, -- so that we get better error messages (monomorphism restriction) traceTc (text "Tc8") ; ! new_ev_binds <- setEnvs tc_envs (simplifyTop lie) ; -- Backsubstitution. This must be done last. ! -- Even simplifyTop may do some unification. traceTc (text "Tc9") ; let { (tcg_env, _) = tc_envs ; TcGblEnv { tcg_type_env = type_env, ! tcg_binds = binds, ! tcg_ev_binds = cur_ev_binds, ! tcg_rules = rules, ! tcg_fords = fords } = tcg_env } ; failIfErrsM ; -- Don't zonk if there have been errors -- It's a waste of time; and we may get debug warnings -- about strangely-typed TyCons! ! let { all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; ! (bind_ids, ev_binds', binds', fords', rules') ! <- zonkTopDecls all_ev_binds binds rules fords ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids ! ; tcg_env' = tcg_env { tcg_binds = binds', ! tcg_ev_binds = ev_binds', ! tcg_rules = rules', ! tcg_fords = fords' } } ; setGlobalTypeEnv tcg_env' final_type_env } *************** *** 460,469 **** \begin{code} tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv tcRnHsBootDecls decls ! = do { (first_group, group_tail) <- findSplice decls -- Rename the declarations ! ; (tcg_env, HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_derivds = deriv_decls, --- 463,474 ---- \begin{code} tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv tcRnHsBootDecls decls ! = do { traceTc (text "hello") ! ; (first_group, group_tail) <- findSplice decls -- Rename the declarations ! ; traceTc (text "next") ! ; (tcg_env, HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_derivds = deriv_decls, *************** *** 472,478 **** hs_ruleds = rule_decls, hs_annds = _, hs_valds = val_binds }) <- rnTopSrcDecls first_group ! ; setGblEnv tcg_env $ do { -- Check for illegal declarations --- 477,484 ---- hs_ruleds = rule_decls, hs_annds = _, hs_valds = val_binds }) <- rnTopSrcDecls first_group ! ; traceTc (text "next2") ! ; (gbl_env, lie) <- getConstraints $ setGblEnv tcg_env $ do { -- Check for illegal declarations *************** *** 521,527 **** } ; setGlobalTypeEnv gbl_env type_env3 ! }}}} badBootDecl :: String -> Located decl -> TcM () badBootDecl what (L loc _) --- 527,534 ---- } ; setGlobalTypeEnv gbl_env type_env3 ! }}} ! ; traceTc (text "boot" <+> ppr lie); return gbl_env } badBootDecl :: String -> Located decl -> TcM () badBootDecl what (L loc _) *************** *** 703,709 **** let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2 env = rnBndrs2 env0 tvs1 tvs2 ! eqSynRhs (OpenSynTyCon k1 _) (OpenSynTyCon k2 _) = tcEqTypeX env k1 k2 eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) = tcEqTypeX env t1 t2 --- 710,716 ---- let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2 env = rnBndrs2 env0 tvs1 tvs2 ! eqSynRhs (SynFamilyTyCon k1 _) (SynFamilyTyCon k2 _) = tcEqTypeX env k1 k2 eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) = tcEqTypeX env t1 t2 *************** *** 727,733 **** env0 = mkRnEnv2 emptyInScopeSet eqAlgRhs AbstractTyCon _ = True ! eqAlgRhs OpenTyCon{} OpenTyCon{} = True eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = eqListBy eqCon (data_cons tc1) (data_cons tc2) eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} = --- 734,740 ---- env0 = mkRnEnv2 emptyInScopeSet eqAlgRhs AbstractTyCon _ = True ! eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = eqListBy eqCon (data_cons tc1) (data_cons tc2) eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} = *************** *** 793,799 **** -- Fails if there are any errors rnTopSrcDecls group = do { -- Rename the source decls (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; -- save the renamed syntax, if we want it let { tcg_env' --- 800,808 ---- -- Fails if there are any errors rnTopSrcDecls group = do { -- Rename the source decls + traceTc (text "rn12") ; (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; + traceTc (text "rn13") ; -- save the renamed syntax, if we want it let { tcg_env' *************** *** 863,869 **** -- Second pass over class and instance declarations, traceTc (text "Tc6") ; inst_binds <- tcInstDecls2 tycl_decls inst_infos ; - showLIE (text "after instDecls2") ; -- Foreign exports traceTc (text "Tc7") ; --- 872,877 ---- -- Second pass over class and instance declarations, traceTc (text "Tc6") ; inst_binds <- tcInstDecls2 tycl_decls inst_infos ; -- Foreign exports traceTc (text "Tc7") ; *************** *** 929,937 **** { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn) ; let loc = srcLocSpan (getSrcLoc main_name) ; ioTyCon <- tcLookupTyCon ioTyConName ! ; (main_expr, res_ty) <- addErrCtxt mainCtxt $ - withBox liftedTypeKind $ \res_ty -> tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty]) -- See Note [Root-main Id] --- 937,945 ---- { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn) ; let loc = srcLocSpan (getSrcLoc main_name) ; ioTyCon <- tcLookupTyCon ioTyConName ! ; res_ty <- newFlexiTyVarTy liftedTypeKind ! ; main_expr <- addErrCtxt mainCtxt $ tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty]) -- See Note [Root-main Id] *************** *** 1257,1274 **** -- OK, we're ready to typecheck the stmts traceTc (text "TcRnDriver.tcGhciStmts: tc stmts") ; ! ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ -> mapM tcLookupId names ; -- Look up the names right in the middle, -- where they will all be in scope -- Simplify the context traceTc (text "TcRnDriver.tcGhciStmts: simplify ctxt") ; ! const_binds <- checkNoErrs (tcSimplifyInteractive lie) ; -- checkNoErrs ensures that the plan fails if context redn fails traceTc (text "TcRnDriver.tcGhciStmts: done") ; ! return (ids, mkHsDictLet const_binds $ noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty)) } \end{code} --- 1265,1282 ---- -- OK, we're ready to typecheck the stmts traceTc (text "TcRnDriver.tcGhciStmts: tc stmts") ; ! ((tc_stmts, ids), lie) <- getConstraints $ tc_io_stmts stmts $ \ _ -> mapM tcLookupId names ; -- Look up the names right in the middle, -- where they will all be in scope -- Simplify the context traceTc (text "TcRnDriver.tcGhciStmts: simplify ctxt") ; ! const_binds <- checkNoErrs (simplifyInteractive lie) ; -- checkNoErrs ensures that the plan fails if context redn fails traceTc (text "TcRnDriver.tcGhciStmts: done") ; ! return (ids, mkHsDictLet (EvBinds const_binds) $ noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty)) } \end{code} *************** *** 1290,1306 **** -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) ! ((_tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; ! ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; ! _ <- tcSimplifyInteractive lie_top ; -- Ignore the dicionary bindings ! ! let { all_expr_ty = mkForAllTys qtvs $ ! mkFunTys (map (idType . instToId) dict_insts) $ ! res_ty } ; zonkTcType all_expr_ty } - where - smpl_doc = ptext (sLit "main expression") \end{code} tcRnType just finds the kind of a type --- 1298,1311 ---- -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) ! ((_tc_expr, res_ty), lie) <- getConstraints (tcInferRho rn_expr) ; ! ((qtvs, dicts, _), lie_top) <- getConstraints (simplifyInfer False {- No MR for now -} ! (tyVarsOfType res_ty) lie) ; ! _ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings ! ! let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ; zonkTcType all_expr_ty } \end{code} tcRnType just finds the kind of a type *************** *** 1612,1625 **** = vcat (map ppr_tycon (sortLe le_sig tycons)) where le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 ! ppr_tycon tycon | isCoercionTyCon tycon = sep [ptext (sLit "coercion") <+> ppr tycon <+> ppr tvs , nest 2 (dcolon <+> pprEqPred (coercionKind (mkTyConApp tycon (mkTyVarTys tvs))))] ! | otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon)) ! where tvs = take (tyConArity tycon) alphaTyVars ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty ppr_rules rs = vcat [ptext (sLit "{-# RULES"), --- 1617,1635 ---- = vcat (map ppr_tycon (sortLe le_sig tycons)) where le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 ! ppr_tycon tycon = ppr (tyThingToIfaceDecl (ATyCon tycon)) ! ! {- BAY: removed this from the above function ! | isCoercionTyCon tycon = sep [ptext (sLit "coercion") <+> ppr tycon <+> ppr tvs , nest 2 (dcolon <+> pprEqPred (coercionKind (mkTyConApp tycon (mkTyVarTys tvs))))] ! where tvs = take (tyConArity tycon) alphaTyVars + Perhaps need to use it to write something for coercions? + -} + ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty ppr_rules rs = vcat [ptext (sLit "{-# RULES"),