X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=511fcbfcc5c5cd48b2627a88d3629be49a5308dc;hp=4d9055fa8a533f1f42b45dc3021bf8e5816c3d2b;hb=46c673a70fe14fe05d7160b456925b8591b5f779;hpb=a0d2e0fb1a6b717ad5ecf7bfaa208863af4378ab diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 4d9055f..511fcbf 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -40,6 +40,7 @@ import TcHsSyn import TcExpr import TcRnMonad import TcType +import Coercion import Inst import FamInst import InstEnv @@ -74,6 +75,7 @@ import Name import NameEnv import NameSet import TyCon +import TysPrim import TysWiredIn import SrcLoc import HscTypes @@ -111,8 +113,6 @@ import Data.Maybe ( isJust ) #include "HsVersions.h" \end{code} - - %************************************************************************ %* * Typecheck and rename a module @@ -130,7 +130,7 @@ tcRnModule :: HscEnv tcRnModule hsc_env hsc_src save_rn_syntax (L loc (HsModule maybe_mod export_ies import_decls local_decls mod_deprec - module_info maybe_doc)) + maybe_doc_hdr)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_pkg = thisPackage (hsc_dflags hsc_env) ; @@ -178,6 +178,9 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; traceRn (text "rn4b: after exportss") ; + -- Check that main is exported (must be after rnExports) + checkMainExported tcg_env ; + -- Compare the hi-boot iface (if any) with the real thing -- Must be done after processing the exports tcg_env <- checkHiBootIface tcg_env boot_iface ; @@ -188,8 +191,9 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- because the latter might add new bindings for boot_dfuns, -- which may be mentioned in imported unfoldings - -- Rename the Haddock documentation - tcg_env <- rnHaddock module_info maybe_doc tcg_env ; + -- Don't need to rename the Haddock documentation, + -- it's not parsed by GHC anymore. + tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ; -- Report unused names reportUnusedNames export_ies tcg_env ; @@ -556,6 +560,15 @@ checkHiBootIface -- Check the exports of the boot module, one by one ; mapM_ check_export boot_exports + -- Check instance declarations + ; mb_dfun_prs <- mapM check_inst boot_insts + ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds, + tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns } + dfun_prs = catMaybes mb_dfun_prs + boot_dfuns = map fst dfun_prs + dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + -- Check for no family instances ; unless (null boot_fam_insts) $ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ @@ -570,7 +583,7 @@ checkHiBootIface final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns dfun_prs = catMaybes mb_dfun_prs boot_dfuns = map fst dfun_prs - dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun) + dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) | (boot_dfun, dfun) <- dfun_prs ] ; failIfErrsM @@ -930,15 +943,16 @@ check_main dflags tcg_env (mkTyConApp ioTyCon [res_ty]) ; co = mkWpTyApps [res_ty] ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr - ; main_bind = noLoc (VarBind root_main_id rhs) } + ; main_bind = mkVarBind root_main_id rhs } - ; return (tcg_env { tcg_binds = tcg_binds tcg_env + ; return (tcg_env { tcg_main = Just main_name, + tcg_binds = tcg_binds tcg_env `snocBag` main_bind, tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (unitFV main_name) -- Record the use of 'main', so that we don't -- complain about it being defined but not used - }) + }) }}} where mod = tcg_mod tcg_env @@ -954,8 +968,13 @@ check_main dflags tcg_env mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn noMainMsg = ptext (sLit "The") <+> pp_main_fn <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) - pp_main_fn | main_fn == main_RDR_Unqual = ptext (sLit "function") <+> quotes (ppr main_fn) - | otherwise = ptext (sLit "main function") <+> quotes (ppr main_fn) + pp_main_fn = ppMainFn main_fn + +ppMainFn main_fn + | main_fn == main_RDR_Unqual + = ptext (sLit "function") <+> quotes (ppr main_fn) + | otherwise + = ptext (sLit "main function") <+> quotes (ppr main_fn) -- | Get the unqualified name of the function to use as the \"main\" for the main module. -- Either returns the default name or the one configured on the command line with -main-is @@ -963,6 +982,17 @@ getMainFun :: DynFlags -> RdrName getMainFun dflags = case (mainFunIs dflags) of Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) Nothing -> main_RDR_Unqual + +checkMainExported :: TcGblEnv -> TcM () +checkMainExported tcg_env = do + dflags <- getDOpts + case tcg_main tcg_env of + Nothing -> return () -- not the main module + Just main_name -> do + let main_mod = mainModIs dflags + checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $ + ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+> + ptext (sLit "is not exported by module") <+> quotes (ppr main_mod) \end{code} Note [Root-main Id] @@ -1393,7 +1423,7 @@ tcRnGetInfo :: HscEnv -> Name -> IO (Messages, Maybe (TyThing, Fixity, [Instance])) --- Used to implemnent :info in GHCi +-- Used to implement :info in GHCi -- -- Look up a RdrName and return all the TyThings it might be -- A capitalised RdrName is given to us in the DataName namespace, @@ -1572,8 +1602,12 @@ ppr_tydecls tycons where le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 ppr_tycon tycon - | isCoercionTyCon tycon = ptext (sLit "coercion") <+> ppr 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