X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=a6f33310c27a972926a5ee1b3ce0f78d854750b5;hb=221b6b69d68ad9b8de2948b6af40d1c08ffaa0c6;hp=2710980b36b771392b61d7709492e061d1a7801b;hpb=5ee05a2b6c422f9fb4bcec184de9fdb49b82e43f;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 2710980..a6f3331 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -41,11 +41,11 @@ import RdrName ( RdrName, getRdrName, mkRdrUnqual, import RnHsSyn ( RenamedStmt, RenamedTyClDecl, ruleDeclFVs, instDeclFVs, tyClDeclFVs ) import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl, - zonkTopBinds, zonkTopDecls, mkHsLet, + zonkTopDecls, mkHsLet, zonkTopExpr, zonkTopBndrs ) -import TcExpr ( tcExpr_id ) +import TcExpr ( tcInferRho ) import TcRnMonad import TcMType ( newTyVarTy, zonkTcType ) import TcType ( Type, liftedTypeKind, @@ -58,7 +58,6 @@ import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, - tcExtendGlobalEnv, tcExtendInstEnv, tcExtendRules, tcLookupTyCon, tcLookupGlobal, tcLookupId @@ -116,7 +115,6 @@ import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance( isLocalGRE ) #endif -import Maybe ( catMaybes ) import Panic ( showException ) import List ( partition ) import Util ( sortLt ) @@ -154,7 +152,7 @@ tcRnModule hsc_env pcs traceRn (text "rn1a") ; -- Rename and type check the declarations - (tcg_env, src_fvs) <- tcRnSrcDecls local_decls ; + (tcg_env, src_dus) <- tcRnSrcDecls local_decls ; setGblEnv tcg_env $ do { traceRn (text "rn3") ; @@ -186,8 +184,8 @@ tcRnModule hsc_env pcs setGblEnv tcg_env $ do { -- Report unused names - let { used_fvs = src_fvs `plusFV` export_fvs } ; - reportUnusedNames tcg_env used_fvs ; + let { all_dus = src_dus `plusDU` usesOnly export_fvs } ; + reportUnusedNames tcg_env all_dus ; -- Dump output and return tcDump tcg_env ; @@ -446,8 +444,7 @@ tcRnExpr hsc_env pcs ictxt rdr_expr -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) - -- Hence the hole type (c.f. TcExpr.tcExpr_id) - ((tc_expr, res_ty), lie) <- getLIE (tcExpr_id rn_expr) ; + ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; tcSimplifyTop lie_top ; @@ -478,24 +475,28 @@ tcRnThing hsc_env pcs ictxt rdr_name -- constructor and type class identifiers. let { rdr_names = dataTcOccs rdr_name } ; - (msgs_s, mb_names) <- initRnInteractive ictxt - (mapAndUnzipM (tryTc . lookupOccRn) rdr_names) ; - let { names = catMaybes mb_names } ; + -- results :: [(Messages, Maybe Name)] + results <- initRnInteractive ictxt + (mapM (tryTc . lookupOccRn) rdr_names) ; - if null names then - do { addMessages (head msgs_s) ; failM } - else do { - - -- Add deprecation warnings - mapM_ addMessages msgs_s ; + -- The successful lookups will be (Just name) + let { (warns_s, good_names) = unzip [ (msgs, name) + | (msgs, Just name) <- results] ; + errs_s = [msgs | (msgs, Nothing) <- results] } ; + -- Fail if nothing good happened, else add warnings + if null good_names then -- Fail + do { addMessages (head errs_s) ; failM } + else -- Add deprecation warnings + mapM_ addMessages warns_s ; + -- Slurp in the supporting declarations - tcg_env <- importSupportingDecls (mkFVs names) ; + tcg_env <- importSupportingDecls (mkFVs good_names) ; setGblEnv tcg_env $ do { -- And lookup up the entities - mapM tcLookupGlobal names - }}} + mapM tcLookupGlobal good_names + }} \end{code} @@ -539,14 +540,21 @@ tcRnExtCore hsc_env pcs -- rnSrcDecls handles fixity decls etc too, which won't occur -- but that doesn't matter let { local_group = mkGroup local_decls } ; - (_, rn_local_decls, fvs) <- initRn (InterfaceMode this_mod) + (_, rn_local_decls, dus) <- initRn (InterfaceMode this_mod) (rnSrcDecls local_group) ; failIfErrsM ; - -- Get the supporting decls, and typecheck them all together - -- so that any mutually recursive types are done right - extra_decls <- slurpImpDecls fvs ; - tcg_env <- typecheckIfaceDecls (rn_local_decls `addImpDecls` extra_decls) ; + -- Get the supporting decls + rn_imp_decls <- slurpImpDecls (duUses dus) ; + let { rn_decls = rn_local_decls `addImpDecls` rn_imp_decls } ; + + -- Dump trace of renaming part + rnDump (ppr rn_decls) ; + rnStats rn_imp_decls ; + + -- Typecheck them all together so that + -- any mutually recursive types are done right + tcg_env <- typecheckIfaceDecls rn_decls ; setGblEnv tcg_env $ do { -- Now the core bindings @@ -592,13 +600,12 @@ tcRnExtCore hsc_env pcs %************************************************************************ \begin{code} -tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars) +tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses) -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings - tcRnSrcDecls decls = do { -- Do all the declarations - ((tc_envs, fvs), lie) <- getLIE (tc_rn_src_decls decls) ; + ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ; -- tcSimplifyTop deals with constant or ambiguous InstIds. -- How could there be ambiguous ones? They can only arise if a @@ -625,17 +632,17 @@ tcRnSrcDecls decls return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids, tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }, - fvs) + dus) }} -tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), FreeVars) +tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses) tc_rn_src_decls ds = do { let { (first_group, group_tail) = findSplice ds } ; -- If ds is [] we get ([], Nothing) -- Type check the decls up to, but not including, the first splice - (tc_envs@(_,tcl_env), src_fvs1) <- tcRnGroup first_group ; + (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ; -- Bale out if errors; for example, error recovery when checking -- the RHS of 'main' can mean that 'main' is not in the envt for @@ -648,7 +655,8 @@ tc_rn_src_decls ds case group_tail of { Nothing -> do { -- Last thing: check for `main' (tcg_env, main_fvs) <- checkMain ; - return ((tcg_env, tcl_env), src_fvs1 `plusFV` main_fvs) + return ((tcg_env, tcl_env), + src_dus1 `plusDU` usesOnly main_fvs) } ; -- If there's a splice, we must carry on @@ -658,19 +666,19 @@ tc_rn_src_decls ds #else -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, fvs) <- initRn SourceMode $ - addSrcLoc splice_loc $ - rnExpr splice_expr ; - tcg_env <- importSupportingDecls (fvs `plusFV` templateHaskellNames) ; + (rn_splice_expr, splice_fvs) <- initRn SourceMode $ + addSrcLoc splice_loc $ + rnExpr splice_expr ; + tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ; setGblEnv tcg_env $ do { -- Execute the splice spliced_decls <- tcSpliceDecls rn_splice_expr ; -- Glue them on the front of the remaining decls and loop - (tc_envs, src_fvs2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ; + (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ; - return (tc_envs, src_fvs1 `plusFV` src_fvs2) + return (tc_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2) } #endif /* GHCI */ }}} @@ -695,20 +703,21 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), FreeVars) +tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses) -- Returns the variables free in the decls, for unused-binding reporting tcRnGroup decls = do { -- Rename the declarations - (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ; + (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ; setGblEnv tcg_env $ do { -- Typecheck the declarations tc_envs <- tcTopSrcDecls rn_decls ; - return (tc_envs, src_fvs) + + return (tc_envs, src_dus) }} ------------------------------------------------ -rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, FreeVars) +rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses) rnTopSrcDecls group = do { -- Bring top level binders into scope (rdr_env, imports) <- importsFromLocalDecls group ; @@ -721,12 +730,13 @@ rnTopSrcDecls group failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations -- Rename the source decls - (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls group) ; + (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ; setGblEnv tcg_env $ do { failIfErrsM ; -- Import consquential imports + let { src_fvs = duUses src_dus } ; rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ; let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; @@ -734,7 +744,7 @@ rnTopSrcDecls group rnDump (ppr rn_decls) ; rnStats rn_imp_decls ; - return (tcg_env, rn_decls, src_fvs) + return (tcg_env, rn_decls, src_dus) }}} ------------------------------------------------ @@ -786,7 +796,7 @@ tcTopSrcDecls (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ; tcExtendGlobalValEnv dm_ids $ do { inst_binds <- tcInstDecls2 inst_infos ; - showLIE "after instDecls2" ; + showLIE (text "after instDecls2") ; -- Foreign exports -- They need to be zonked, so we return them @@ -1105,7 +1115,7 @@ check_main ghci_mode tcg_env -- $main :: IO () = runIO main let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ; - (main_expr, ty) <- tcExpr_id rhs ; + (main_expr, ty) <- tcInferRho rhs ; let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ; main_bind = VarMonoBind dollar_main_id main_expr ;