X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcompMan%2FCompManager.lhs;h=a571fa7373246b89f83995e2de4defa177d9e964;hb=d68887047bcfb9021151f768fe1a22df2d3fbe1e;hp=73c5bf315a59c97532c8b940867a1247d75e6109;hpb=1c62b517711ac232a8024d91fd4b317a6804d28e;p=ghc-hetmet.git diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 73c5bf3..a571fa7 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -6,14 +6,25 @@ \begin{code} module CompManager ( cmInit, -- :: GhciMode -> IO CmState + cmLoadModule, -- :: CmState -> FilePath -> IO (CmState, [String]) + cmUnload, -- :: CmState -> IO CmState - cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String) cmSetContext, -- :: CmState -> String -> IO CmState + cmGetContext, -- :: CmState -> IO String + #ifdef GHCI cmRunStmt, -- :: CmState -> DynFlags -> String -> IO (CmState, [Name]) + + cmTypeOfExpr, -- :: CmState -> DynFlags -> String + -- -> IO (CmState, Maybe String) + + cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String) + + cmCompileExpr,-- :: CmState -> DynFlags -> String + -- -> IO (CmState, Maybe HValue)#endif #endif CmState, emptyCmState -- abstract ) @@ -23,29 +34,28 @@ where import CmLink import CmTypes +import CmStaticInfo ( GhciMode(..) ) +import DriverPipeline +import DriverFlags ( getDynFlags ) +import DriverPhases +import DriverUtil +import Finder +import HscMain ( initPersistentCompilerState ) import HscTypes import RnEnv ( unQualInScope ) import Id ( idType, idName ) -import Name ( Name, lookupNameEnv ) -import RdrName ( emptyRdrEnv ) -import Module ( Module, ModuleName, moduleName, isHomeModule, - mkModuleName, moduleNameUserString, moduleUserString ) -import CmStaticInfo ( GhciMode(..) ) -import DriverPipeline +import Name ( Name, NamedThing(..), nameRdrName ) +import NameEnv +import RdrName ( lookupRdrEnv, emptyRdrEnv ) +import Module import GetImports -import HscTypes -import HscMain ( initPersistentCompilerState ) -import Finder -import UniqFM ( lookupUFM, addToUFM, delListFromUFM, - UniqFM, listToUFM ) +import Type ( tidyType ) +import VarEnv ( emptyTidyEnv ) +import UniqFM import Unique ( Uniquable ) import Digraph ( SCC(..), stronglyConnComp, flattenSCC ) -import DriverFlags ( getDynFlags ) -import DriverPhases -import DriverUtil ( splitFilename3 ) import ErrUtils ( showPass ) import Util -import DriverUtil import TmpFiles import Outputable import Panic @@ -62,12 +72,11 @@ import PrelGHC ( unsafeCoerce# ) import Exception ( throwDyn ) -- std -import Time ( ClockTime ) import Directory ( getModificationTime, doesFileExist ) import IO import Monad import List ( nub ) -import Maybe ( catMaybes, fromMaybe, isJust, fromJust ) +import Maybe \end{code} @@ -140,7 +149,7 @@ cmSetContext cmstate str Nothing -> do mod <- moduleNameToModule mn if isHomeModule mod - then throwDyn (OtherError (showSDoc + then throwDyn (CmdLineError (showSDoc (quotes (ppr (moduleName mod)) <+> text "is not currently loaded"))) else return mod @@ -154,7 +163,7 @@ moduleNameToModule :: ModuleName -> IO Module moduleNameToModule mn = do maybe_stuff <- findModule mn case maybe_stuff of - Nothing -> throwDyn (OtherError ("can't find module `" + Nothing -> throwDyn (CmdLineError ("can't find module `" ++ moduleNameUserString mn ++ "'")) Just (m,_) -> return m @@ -162,26 +171,90 @@ moduleNameToModule mn -- cmRunStmt: Run a statement/expr. #ifdef GHCI -cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, [Name]) +cmRunStmt :: CmState -> DynFlags -> String + -> IO (CmState, -- new state + [Name]) -- names bound by this evaluation cmRunStmt cmstate dflags expr - = do (new_pcs, maybe_stuff) <- hscStmt dflags hst hit pcs (ic cmstate) expr + = do + let InteractiveContext { + ic_rn_env = rn_env, + ic_type_env = type_env, + ic_module = this_mod } = icontext + + (new_pcs, maybe_stuff) + <- hscStmt dflags hst hit pcs icontext expr False{-stmt-} + case maybe_stuff of Nothing -> return (cmstate{ pcs=new_pcs }, []) - Just (new_ic, ids, bcos) -> do + Just (ids, _, bcos) -> do + + -- update the interactive context + let + names = map idName ids + + -- these names have just been shadowed + shadowed = [ n | r <- map nameRdrName names, + Just n <- [lookupRdrEnv rn_env r] ] + + new_rn_env = extendLocalRdrEnv rn_env names + + -- remove any shadowed bindings from the type_env + filtered_type_env = delListFromNameEnv type_env shadowed + + new_type_env = extendNameEnvList filtered_type_env + [ (getName id, AnId id) | id <- ids] + + new_ic = icontext { ic_rn_env = new_rn_env, + ic_type_env = new_type_env } + + -- link it hval <- linkExpr pls bcos - hvals <- unsafeCoerce# hval :: IO [HValue] - let names = map idName ids - new_pls <- updateClosureEnv pls (zip names hvals) + + -- run it! + let thing_to_run = unsafeCoerce# hval :: IO [HValue] + hvals <- thing_to_run + + -- Get the newly bound things, and bind them. Don't forget + -- to delete any shadowed bindings from the closure_env, lest + -- we end up with a space leak. + pls <- delListFromClosureEnv pls shadowed + new_pls <- addListToClosureEnv pls (zip names hvals) + return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names) + where + CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate +#endif + +----------------------------------------------------------------------------- +-- cmTypeOfExpr: returns a string representing the type of an expression - -- ToDo: check that the module we passed in is sane/exists? +#ifdef GHCI +cmTypeOfExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe String) +cmTypeOfExpr cmstate dflags expr + = do (new_pcs, maybe_stuff) + <- hscStmt dflags hst hit pcs ic expr True{-just an expr-} + + let new_cmstate = cmstate{pcs = new_pcs} + + case maybe_stuff of + Nothing -> return (new_cmstate, Nothing) + Just (_, ty, _) -> + let pit = pcs_PIT pcs + modname = moduleName (ic_module ic) + tidy_ty = tidyType emptyTidyEnv ty + str = case lookupIfaceByModName hit pit modname of + Nothing -> showSDoc (ppr tidy_ty) + Just iface -> showSDocForUser unqual (ppr tidy_ty) + where unqual = unQualInScope (mi_globals iface) + in return (new_cmstate, Just str) where - CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls } = cmstate + CmState{ hst=hst, hit=hit, pcs=pcs, ic=ic } = cmstate #endif ----------------------------------------------------------------------------- --- cmTypeOf: returns a string representing the type of a name. +-- cmTypeOfName: returns a string representing the type of a name. +#ifdef GHCI cmTypeOfName :: CmState -> Name -> IO (Maybe String) cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name = case lookupNameEnv (ic_type_env ic) name of @@ -189,13 +262,50 @@ cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name Just (AnId id) -> let pit = pcs_PIT pcs modname = moduleName (ic_module ic) + ty = tidyType emptyTidyEnv (idType id) str = case lookupIfaceByModName hit pit modname of - Nothing -> showSDoc (ppr (idType id)) - Just iface -> showSDocForUser unqual (ppr (idType id)) + Nothing -> showSDoc (ppr ty) + Just iface -> showSDocForUser unqual (ppr ty) where unqual = unQualInScope (mi_globals iface) in return (Just str) _ -> panic "cmTypeOfName" +#endif + +----------------------------------------------------------------------------- +-- cmCompileExpr: compile an expression and deliver an HValue + +#ifdef GHCI +cmCompileExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe HValue) +cmCompileExpr cmstate dflags expr + = do + let InteractiveContext { + ic_rn_env = rn_env, + ic_type_env = type_env, + ic_module = this_mod } = icontext + + (new_pcs, maybe_stuff) + <- hscStmt dflags hst hit pcs icontext + ("let __cmCompileExpr = "++expr) False{-stmt-} + + case maybe_stuff of + Nothing -> return (cmstate{ pcs=new_pcs }, Nothing) + Just (ids, _, bcos) -> do + + -- link it + hval <- linkExpr pls bcos + + -- run it! + let thing_to_run = unsafeCoerce# hval :: IO [HValue] + hvals <- thing_to_run + + case (ids,hvals) of + ([id],[hv]) -> return (cmstate{ pcs=new_pcs }, Just hv) + _ -> panic "cmCompileExpr" + + where + CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate +#endif ----------------------------------------------------------------------------- -- cmInfo: return "info" about an expression. The info might be: @@ -252,9 +362,6 @@ cmLoadModule cmstate1 rootname let ghci_mode = gmode cmstate1 -- this never changes -- Do the downsweep to reestablish the module graph - -- then generate version 2's by retaining in HIT,HST,UI a - -- stable set S of modules, as defined below. - dflags <- getDynFlags let verb = verbosity dflags @@ -292,9 +399,8 @@ cmLoadModule cmstate1 rootname -- 1. All home imports of ms are either in ms or S -- 2. A valid linkable exists for each module in ms - stable_mods - <- preUpsweep valid_linkables ui1 mg2unsorted_names - [] mg2_with_srcimps + stable_mods <- preUpsweep valid_linkables hit1 + mg2unsorted_names [] mg2_with_srcimps let stable_summaries = concatMap (findInSummaries mg2unsorted) stable_mods @@ -434,12 +540,14 @@ ppFilesFromSummaries summaries -- For each module (or SCC of modules), we take: -- --- - the old in-core linkable, if available --- - an on-disk linkable, if available +-- - an on-disk linkable, if this is the first time around and one +-- is available. +-- +-- - the old linkable, otherwise (and if one is available). -- --- and we take the youngest of these, provided it is younger than the --- source file. We ignore the on-disk linkables unless all of the --- dependents of this SCC also have on-disk linkables. +-- and we throw away the linkable if it is older than the source +-- file. We ignore the on-disk linkables unless all of the dependents +-- of this SCC also have on-disk linkables. -- -- If a module has a valid linkable, then it may be STABLE (see below), -- and it is classified as SOURCE UNCHANGED for the purposes of calling @@ -487,47 +595,45 @@ getValidLinkablesSCC old_linkables all_home_mods new_linkables scc0 getValidLinkable :: [Linkable] -> Bool -> [Linkable] -> ModSummary -> IO [Linkable] getValidLinkable old_linkables objects_allowed new_linkables summary - = do - let mod_name = name_of_summary summary + = do let mod_name = name_of_summary summary - maybe_disk_linkable - <- if (not objects_allowed) + maybe_disk_linkable + <- if (not objects_allowed) then return Nothing else case ml_obj_file (ms_location summary) of Just obj_fn -> maybe_getFileLinkable mod_name obj_fn Nothing -> return Nothing - -- find an old in-core linkable if we have one. (forget about - -- on-disk linkables for now, we'll check again whether there's - -- one here below, just in case a new one has popped up recently). - let old_linkable = findModuleLinkable_maybe old_linkables mod_name - maybe_old_linkable = - case old_linkable of - Just (LM _ _ ls) | all isInterpretable ls -> old_linkable - _ -> Nothing - - -- The most recent of the old UI linkable or whatever we could - -- find on disk is returned as the linkable if compile - -- doesn't think we need to recompile. - let linkable_list - = case (maybe_old_linkable, maybe_disk_linkable) of - (Nothing, Nothing) -> [] - (Nothing, Just di) -> [di] - (Just ui, Nothing) -> [ui] - (Just ui, Just di) - | linkableTime ui >= linkableTime di -> [ui] - | otherwise -> [di] - - -- only linkables newer than the source code are valid - let maybe_src_date = ms_hs_date summary - - valid_linkable_list - = case maybe_src_date of - Nothing -> panic "valid_linkable_list" - Just src_date - -> filter (\li -> linkableTime li > src_date) linkable_list - - return (valid_linkable_list ++ new_linkables) + let old_linkable = findModuleLinkable_maybe old_linkables mod_name + maybe_old_linkable = + case old_linkable of + Just l | not (isObjectLinkable l) || stillThere l + -> old_linkable + -- ToDo: emit a warning if not (stillThere l) + other -> Nothing + + -- make sure that if we had an old disk linkable around, that it's + -- still there on the disk (in case we need to re-link it). + stillThere l = + case maybe_disk_linkable of + Nothing -> False + Just l_disk -> linkableTime l == linkableTime l_disk + + -- we only look for objects on disk the first time around; + -- if the user compiles a module on the side during a GHCi session, + -- it won't be picked up until the next ":load". This is what the + -- "null old_linkables" test below is. + linkable | null old_linkables = maybeToList maybe_disk_linkable + | otherwise = maybeToList maybe_old_linkable + + -- only linkables newer than the source code are valid + src_date = ms_hs_date summary + + valid_linkable + = filter (\l -> linkableTime l > src_date) linkable + + return (valid_linkable ++ new_linkables) + maybe_getFileLinkable :: ModuleName -> FilePath -> IO (Maybe Linkable) @@ -549,16 +655,20 @@ maybe_getFileLinkable mod_name obj_fn -- Do a pre-upsweep without use of "compile", to establish a -- (downward-closed) set of stable modules for which we won't call compile. +-- a stable module: +-- * has a valid linkable (see getValidLinkables above) +-- * depends only on stable modules +-- * has an interface in the HIT (interactive mode only) + preUpsweep :: [Linkable] -- new valid linkables - -> [Linkable] -- old linkables + -> HomeIfaceTable -> [ModuleName] -- names of all mods encountered in downsweep -> [ModuleName] -- accumulating stable modules -> [SCC ModSummary] -- scc-ified mod graph, including src imps -> IO [ModuleName] -- stable modules -preUpsweep valid_lis old_lis all_home_mods stable [] - = return stable -preUpsweep valid_lis old_lis all_home_mods stable (scc0:sccs) +preUpsweep valid_lis hit all_home_mods stable [] = return stable +preUpsweep valid_lis hit all_home_mods stable (scc0:sccs) = do let scc = flattenSCC scc0 scc_allhomeimps :: [ModuleName] scc_allhomeimps @@ -571,27 +681,20 @@ preUpsweep valid_lis old_lis all_home_mods stable (scc0:sccs) = m `elem` scc_names || m `elem` stable -- now we check for valid linkables: each module in the SCC must - -- have a valid linkable (see getValidLinkables above), and the - -- newest linkable must be the same as the previous linkable for - -- this module (if one exists). + -- have a valid linkable (see getValidLinkables above). has_valid_linkable new_summary - = case findModuleLinkable_maybe valid_lis modname of - Nothing -> False - Just l -> case findModuleLinkable_maybe old_lis modname of - Nothing -> True - Just m -> linkableTime l == linkableTime m + = isJust (findModuleLinkable_maybe valid_lis modname) where modname = name_of_summary new_summary + has_interface summary = ms_mod summary `elemUFM` hit + scc_is_stable = all_imports_in_scc_or_stable && all has_valid_linkable scc + && all has_interface scc if scc_is_stable - then preUpsweep valid_lis old_lis all_home_mods - (scc_names++stable) sccs - else preUpsweep valid_lis old_lis all_home_mods - stable sccs - - where + then preUpsweep valid_lis hit all_home_mods (scc_names++stable) sccs + else preUpsweep valid_lis hit all_home_mods stable sccs -- Helper for preUpsweep. Assuming that new_summary's imports are all @@ -698,20 +801,11 @@ upsweep_mod :: GhciMode -> [ModuleName] -> IO (CmThreaded, Maybe Linkable) -upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_from_here +upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me = do let mod_name = name_of_summary summary1 let verb = verbosity dflags - when (verb == 1) $ - if (ghci_mode == Batch) - then hPutStr stderr (progName ++ ": module " - ++ moduleNameUserString mod_name - ++ ": ") - else hPutStr stderr ("Compiling " - ++ moduleNameUserString mod_name - ++ " ... ") - let (CmThreaded pcs1 hst1 hit1) = threaded1 let old_iface = lookupUFM hit1 mod_name @@ -719,49 +813,40 @@ upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_from_here source_unchanged = isJust maybe_old_linkable + reachable_only = filter (/= (name_of_summary summary1)) + reachable_inc_me + + -- in interactive mode, all home modules below us *must* have an + -- interface in the HIT. We never demand-load home interfaces in + -- interactive mode. (hst1_strictDC, hit1_strictDC) - = retainInTopLevelEnvs - (filter (/= (name_of_summary summary1)) reachable_from_here) - (hst1,hit1) + = ASSERT(ghci_mode == Batch || + all (`elemUFM` hit1) reachable_only) + retainInTopLevelEnvs reachable_only (hst1,hit1) old_linkable = unJust "upsweep_mod:old_linkable" maybe_old_linkable + have_object + | Just l <- maybe_old_linkable, isObjectLinkable l = True + | otherwise = False + compresult <- compile ghci_mode summary1 source_unchanged - old_iface hst1_strictDC hit1_strictDC pcs1 + have_object old_iface hst1_strictDC hit1_strictDC pcs1 case compresult of - -- Compilation "succeeded", but didn't return a new - -- linkable, meaning that compilation wasn't needed, and the - -- new details were manufactured from the old iface. - CompOK pcs2 new_details new_iface Nothing - -> do let hst2 = addToUFM hst1 mod_name new_details - hit2 = addToUFM hit1 mod_name new_iface - threaded2 = CmThreaded pcs2 hst2 hit2 - - if ghci_mode == Interactive && verb >= 1 then - -- if we're using an object file, tell the user - case old_linkable of - (LM _ _ objs@(DotO _:_)) - -> do hPutStrLn stderr (showSDoc (space <> - parens (hsep (text "using": - punctuate comma - [ text o | DotO o <- objs ])))) - _ -> return () - else - return () - - return (threaded2, Just old_linkable) - - -- Compilation really did happen, and succeeded. A new - -- details, iface and linkable are returned. - CompOK pcs2 new_details new_iface (Just new_linkable) + -- Compilation "succeeded", and may or may not have returned a new + -- linkable (depending on whether compilation was actually performed + -- or not). + CompOK pcs2 new_details new_iface maybe_new_linkable -> do let hst2 = addToUFM hst1 mod_name new_details hit2 = addToUFM hit1 mod_name new_iface threaded2 = CmThreaded pcs2 hst2 hit2 - return (threaded2, Just new_linkable) + return (threaded2, if isJust maybe_new_linkable + then maybe_new_linkable + else Just old_linkable) -- Compilation failed. compile may still have updated -- the PCS, tho. @@ -797,8 +882,12 @@ retainInTopLevelEnvs keep_these (hst, hit) downwards_closure_of_module :: [ModSummary] -> ModuleName -> [ModuleName] downwards_closure_of_module summaries root = let toEdge :: ModSummary -> (ModuleName,[ModuleName]) - toEdge summ = (name_of_summary summ, ms_allimps summ) - res = simple_transitive_closure (map toEdge summaries) [root] + toEdge summ = (name_of_summary summ, + filter (`elem` all_mods) (ms_allimps summ)) + + all_mods = map name_of_summary summaries + + res = simple_transitive_closure (map toEdge summaries) [root] in --trace (showSDoc (text "DC of mod" <+> ppr root -- <+> text "=" <+> ppr res)) ( @@ -855,7 +944,9 @@ downsweep rootNm old_summaries rootSummaries all_summaries <- loop (concat (map ms_imps rootSummaries)) - (filter (isHomeModule.ms_mod) rootSummaries) + (mkModuleEnv [ (mod, s) | s <- rootSummaries, + let mod = ms_mod s, isHomeModule mod + ]) return (all_summaries, a_root_is_Main) where getRootSummary :: FilePath -> IO ModSummary @@ -863,52 +954,50 @@ downsweep rootNm old_summaries | haskellish_file file = do exists <- doesFileExist file if exists then summariseFile file else do - throwDyn (OtherError ("can't find file `" ++ file ++ "'")) + throwDyn (CmdLineError ("can't find file `" ++ file ++ "'")) | otherwise = do exists <- doesFileExist hs_file if exists then summariseFile hs_file else do exists <- doesFileExist lhs_file if exists then summariseFile lhs_file else do - getSummary (mkModuleName file) + let mod_name = mkModuleName file + maybe_summary <- getSummary mod_name + case maybe_summary of + Nothing -> packageModErr mod_name + Just s -> return s where hs_file = file ++ ".hs" lhs_file = file ++ ".lhs" - getSummary :: ModuleName -> IO ModSummary + getSummary :: ModuleName -> IO (Maybe ModSummary) getSummary nm = do found <- findModule nm case found of Just (mod, location) -> do let old_summary = findModInSummaries old_summaries mod - new_summary <- summarise mod location old_summary - case new_summary of - Nothing -> return (fromJust old_summary) - Just s -> return s + summarise mod location old_summary - Nothing -> throwDyn (OtherError + Nothing -> throwDyn (CmdLineError ("can't find module `" ++ showSDoc (ppr nm) ++ "'")) - - -- loop invariant: home_summaries doesn't contain package modules - loop :: [ModuleName] -> [ModSummary] -> IO [ModSummary] - loop [] home_summaries = return home_summaries - loop imps home_summaries - = do -- all modules currently in homeSummaries - let all_home = map (moduleName.ms_mod) home_summaries - -- imports for modules we don't already have - let needed_imps = nub (filter (`notElem` all_home) imps) + -- loop invariant: env doesn't contain package modules + loop :: [ModuleName] -> ModuleEnv ModSummary -> IO [ModSummary] + loop [] env = return (moduleEnvElts env) + loop imps env + = do -- imports for modules we don't already have + let needed_imps = nub (filter (not . (`elemUFM` env)) imps) -- summarise them needed_summaries <- mapM getSummary needed_imps -- get just the "home" modules - let new_home_summaries - = filter (isHomeModule.ms_mod) needed_summaries + let new_home_summaries = [ s | Just s <- needed_summaries ] -- loop, checking the new imports let new_imps = concat (map ms_imps new_home_summaries) - loop new_imps (new_home_summaries ++ home_summaries) + loop new_imps (extendModuleEnvList env + [ (ms_mod s, s) | s <- new_home_summaries ]) ----------------------------------------------------------------------------- -- Summarising modules @@ -926,68 +1015,59 @@ downsweep rootNm old_summaries summariseFile :: FilePath -> IO ModSummary summariseFile file = do hspp_fn <- preprocess file - modsrc <- readFile hspp_fn + (srcimps,imps,mod_name) <- getImportsFromFile hspp_fn - let (srcimps,imps,mod_name) = getImports modsrc - (path, basename, ext) = splitFilename3 file + let (path, basename, ext) = splitFilename3 file Just (mod, location) <- mkHomeModuleLocn mod_name (path ++ '/':basename) file - - maybe_src_timestamp + + src_timestamp <- case ml_hs_file location of - Nothing -> return Nothing - Just src_fn -> maybe_getModificationTime src_fn + Nothing -> noHsFileErr mod_name + Just src_fn -> getModificationTime src_fn return (ModSummary mod location{ml_hspp_file=Just hspp_fn} - srcimps imps - maybe_src_timestamp) + srcimps imps src_timestamp) -- Summarise a module, and pick up source and timestamp. -summarise :: Module -> ModuleLocation -> Maybe ModSummary - -> IO (Maybe ModSummary) +summarise :: Module -> ModuleLocation -> Maybe ModSummary + -> IO (Maybe ModSummary) summarise mod location old_summary | isHomeModule mod = do let hs_fn = unJust "summarise" (ml_hs_file location) - maybe_src_timestamp + src_timestamp <- case ml_hs_file location of - Nothing -> return Nothing - Just src_fn -> maybe_getModificationTime src_fn + Nothing -> noHsFileErr mod + Just src_fn -> getModificationTime src_fn -- return the cached summary if the source didn't change case old_summary of { - Just s | ms_hs_date s == maybe_src_timestamp -> return Nothing; + Just s | ms_hs_date s == src_timestamp -> return (Just s); _ -> do hspp_fn <- preprocess hs_fn - modsrc <- readFile hspp_fn - let (srcimps,imps,mod_name) = getImports modsrc - - maybe_src_timestamp - <- case ml_hs_file location of - Nothing -> return Nothing - Just src_fn -> maybe_getModificationTime src_fn + (srcimps,imps,mod_name) <- getImportsFromFile hspp_fn when (mod_name /= moduleName mod) $ - throwDyn (OtherError - (showSDoc (text "file name does not match module name: " - <+> ppr (moduleName mod) <+> text "vs" - <+> ppr mod_name))) + throwDyn (ProgramError + (showSDoc (text hs_fn + <> text ": file name does not match module name" + <+> quotes (ppr (moduleName mod))))) return (Just (ModSummary mod location{ml_hspp_file=Just hspp_fn} - srcimps imps - maybe_src_timestamp)) + srcimps imps src_timestamp)) } - | otherwise - = return (Just (ModSummary mod location [] [] Nothing)) + | otherwise = return Nothing + +noHsFileErr mod + = panic (showSDoc (text "no source file for module" <+> quotes (ppr mod))) -maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime) -maybe_getModificationTime fn - = (do time <- getModificationTime fn - return (Just time)) - `catch` - (\err -> return Nothing) +packageModErr mod + = throwDyn (CmdLineError (showSDoc (text "module" <+> + quotes (ppr mod) <+> + text "is a package module"))) \end{code}