X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fmain%2FGHC.hs;h=6ce921de3f27e98c8a59ab7c5975da80217d79c5;hb=e7da484086a7be73dbd0747b945fe63e7cd53ed0;hp=5c8a5b8fbf69c4b8827972ca4a46661cb37b69ad;hpb=c1f6021bc6eb8e68fd2787a93eedfe4b7233e290;p=ghc-hetmet.git diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 5c8a5b8..6ce921d 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -36,6 +36,7 @@ module GHC ( loadMsgs, workingDirectoryChanged, checkModule, CheckedModule(..), + TypecheckedSource, ParsedSource, -- * Inspecting the module structure of the program ModuleGraph, ModSummary(..), @@ -48,6 +49,8 @@ module GHC ( getModuleInfo, modInfoTyThings, modInfoTopLevelScope, + modInfoPrintUnqualified, + modInfoExports, lookupName, -- * Interactive evaluation @@ -155,7 +158,7 @@ import DataCon ( DataCon ) import Name ( Name, getName, nameModule_maybe ) import RdrName ( RdrName, gre_name, globalRdrEnvElts ) import NameEnv ( nameEnvElts ) -import SrcLoc ( Located(..) ) +import SrcLoc ( Located(..), mkSrcLoc, srcLocSpan ) import DriverPipeline import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import GetImports ( getImports ) @@ -179,6 +182,8 @@ import SysTools ( cleanTempFilesExcept ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Maybes ( orElse, expectJust, mapCatMaybes ) import TcType ( tcSplitSigmaTy, isDictTy ) +import Bag ( unitBag, emptyBag ) +import FastString ( mkFastString ) import Directory ( getModificationTime, doesFileExist ) import Maybe ( isJust, isNothing, fromJust, fromMaybe, catMaybes ) @@ -652,7 +657,21 @@ checkModule session@(Session ref) mod msg_act = do case [ ms | ms <- mg, ms_mod ms == mod ] of [] -> return Nothing (ms:_) -> do - r <- hscFileCheck hsc_env msg_act ms + -- Add in the OPTIONS from the source file This is nasty: + -- we've done this once already, in the compilation manager + -- It might be better to cache the flags in the + -- ml_hspp_file field, say + let dflags0 = hsc_dflags hsc_env + hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms) + opts = getOptionsFromStringBuffer hspp_buf + (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts) + if (not (null leftovers)) + then do let filename = fromJust (ml_hs_file (ms_location ms)) + msg_act (optionsErrorMsgs leftovers opts filename) + return Nothing + else do + + r <- hscFileCheck hsc_env{hsc_dflags=dflags1} msg_act ms case r of HscFail -> return Nothing @@ -872,22 +891,26 @@ upsweep HscEnv, -- With an updated HPT [ModSummary]) -- Mods which succeeded -upsweep hsc_env old_hpt stable_mods cleanup msg_act - [] +upsweep hsc_env old_hpt stable_mods cleanup msg_act mods + = upsweep' hsc_env old_hpt stable_mods cleanup msg_act mods 1 (length mods) + +upsweep' hsc_env old_hpt stable_mods cleanup msg_act + [] _ _ = return (Succeeded, hsc_env, []) -upsweep hsc_env old_hpt stable_mods cleanup msg_act - (CyclicSCC ms:_) +upsweep' hsc_env old_hpt stable_mods cleanup msg_act + (CyclicSCC ms:_) _ _ = do putMsg (showSDoc (cyclicModuleErr ms)) return (Failed, hsc_env, []) -upsweep hsc_env old_hpt stable_mods cleanup msg_act - (AcyclicSCC mod:mods) +upsweep' hsc_env old_hpt stable_mods cleanup msg_act + (AcyclicSCC mod:mods) mod_index nmods = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods msg_act mod + mod_index nmods cleanup -- Remove unwanted tmp files between compilations @@ -911,8 +934,8 @@ upsweep hsc_env old_hpt stable_mods cleanup msg_act | otherwise = delModuleEnv old_hpt this_mod ; (restOK, hsc_env2, modOKs) - <- upsweep hsc_env1 old_hpt1 stable_mods cleanup - msg_act mods + <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup + msg_act mods (mod_index+1) nmods ; return (restOK, hsc_env2, mod:modOKs) } @@ -924,9 +947,11 @@ upsweep_mod :: HscEnv -> ([Module],[Module]) -> (Messages -> IO ()) -> ModSummary + -> Int -- index of module + -> Int -- total number of modules -> IO (Maybe HomeModInfo) -- Nothing => Failed -upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary +upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index nmods = do let this_mod = ms_mod summary @@ -936,7 +961,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) compile_it = upsweep_compile hsc_env old_hpt this_mod - msg_act summary + msg_act summary mod_index nmods case ghcMode (hsc_dflags hsc_env) of BatchCompile -> @@ -989,7 +1014,9 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary old_hmi = lookupModuleEnv old_hpt this_mod -- Run hsc to compile a module -upsweep_compile hsc_env old_hpt this_mod msg_act summary mb_old_linkable = do +upsweep_compile hsc_env old_hpt this_mod msg_act summary + mod_index nmods + mb_old_linkable = do let -- The old interface is ok if it's in the old HPT -- a) we're compiling a source file, and the old HPT @@ -1010,6 +1037,7 @@ upsweep_compile hsc_env old_hpt this_mod msg_act summary mb_old_linkable = do iface = hm_iface hm_info compresult <- compile hsc_env msg_act summary mb_old_linkable mb_old_iface + mod_index nmods case compresult of -- Compilation failed. Compile may still have updated the PCS, tho. @@ -1389,7 +1417,7 @@ preprocessFile dflags src_fn (Just (buf, time)) let local_opts = getOptionsFromStringBuffer buf -- - (dflags', errs) <- parseDynamicFlags dflags local_opts + (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts) let needs_preprocessing @@ -1533,6 +1561,9 @@ modInfoTopLevelScope minf modInfoExports :: ModuleInfo -> [Name] modInfoExports minf = nameSetToList $! (md_exports $! minf_details minf) +modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified +modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf) + isDictonaryId :: Id -> Bool isDictonaryId id = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }