% % (c) The University of Glasgow, 2000 % \section[CompManager]{The Compilation Manager} \begin{code} module CompManager ( cmInit, cmLoadModule, cmUnload, #ifdef GHCI cmGetExpr, cmRunExpr, #endif CmState, emptyCmState -- abstract ) where #include "HsVersions.h" import CmLink import CmTypes import HscTypes import Module ( Module, ModuleName, moduleName, isHomeModule, mkModuleName, moduleNameUserString ) import CmStaticInfo ( GhciMode(..) ) import DriverPipeline import GetImports import HscTypes ( HomeSymbolTable, HomeIfaceTable, PersistentCompilerState, ModDetails(..) ) import HscMain ( initPersistentCompilerState ) import Finder import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM, UniqFM, listToUFM ) import Unique ( Uniquable ) import Digraph ( SCC(..), stronglyConnComp, flattenSCC ) import DriverFlags ( getDynFlags ) import DriverPhases import DriverUtil ( splitFilename3 ) import ErrUtils ( showPass ) import Util import DriverUtil import Outputable import Panic import CmdLineOpts ( DynFlags(..) ) import IOExts #ifdef GHCI import Interpreter ( HValue ) import HscMain ( hscExpr ) import Type ( Type ) import PrelGHC ( unsafeCoerce# ) #endif -- lang import Exception ( throwDyn ) -- std import Time ( ClockTime ) import Directory ( getModificationTime, doesFileExist ) import IO import Monad import List ( nub ) import Maybe ( catMaybes, fromMaybe, maybeToList, isJust ) \end{code} \begin{code} cmInit :: GhciMode -> IO CmState cmInit gmode = emptyCmState gmode #ifdef GHCI cmGetExpr :: CmState -> DynFlags -> Bool -- True <=> wrap in 'print' to get an IO-typed result -> Module -> String -> IO (CmState, Maybe (HValue, PrintUnqualified, Type)) cmGetExpr cmstate dflags wrap_io mod expr = do (new_pcs, maybe_stuff) <- hscExpr dflags wrap_io hst hit pcs mod expr case maybe_stuff of Nothing -> return (cmstate{ pcs=new_pcs }, Nothing) Just (bcos, print_unqual, ty) -> do hValue <- linkExpr pls bcos return (cmstate{ pcs=new_pcs }, Just (hValue, print_unqual, ty)) -- ToDo: check that the module we passed in is sane/exists? where CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls } = cmstate -- The HValue should represent a value of type IO () (Perhaps IO a?) cmRunExpr :: HValue -> IO () cmRunExpr hval = do unsafeCoerce# hval :: IO () -- putStrLn "done." #endif emptyHIT :: HomeIfaceTable emptyHIT = emptyUFM emptyHST :: HomeSymbolTable emptyHST = emptyUFM -- Persistent state for the entire system data CmState = CmState { hst :: HomeSymbolTable, -- home symbol table hit :: HomeIfaceTable, -- home interface table ui :: UnlinkedImage, -- the unlinked images mg :: ModuleGraph, -- the module graph gmode :: GhciMode, -- NEVER CHANGES pcs :: PersistentCompilerState, -- compile's persistent state pls :: PersistentLinkerState -- link's persistent state } emptyCmState :: GhciMode -> IO CmState emptyCmState gmode = do pcs <- initPersistentCompilerState pls <- emptyPLS return (CmState { hst = emptyHST, hit = emptyHIT, ui = emptyUI, mg = emptyMG, gmode = gmode, pcs = pcs, pls = pls }) -- CM internal types type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really) emptyUI :: UnlinkedImage emptyUI = [] type ModuleGraph = [ModSummary] -- the module graph, topologically sorted emptyMG :: ModuleGraph emptyMG = [] \end{code} Unload the compilation manager's state: everything it knows about the current collection of modules in the Home package. \begin{code} cmUnload :: CmState -> IO CmState cmUnload state = do -- Throw away the old home dir cache emptyHomeDirCache -- Throw away the HIT and the HST return state{ hst=new_hst, hit=new_hit, ui=emptyUI } where CmState{ hst=hst, hit=hit } = state (new_hst, new_hit) = retainInTopLevelEnvs [] (hst,hit) \end{code} The real business of the compilation manager: given a system state and a module name, try and bring the module up to date, probably changing the system state at the same time. \begin{code} cmLoadModule :: CmState -> FilePath -> IO (CmState, -- new state Bool, -- was successful [Module]) -- list of modules loaded cmLoadModule cmstate1 rootname = do -- version 1's are the original, before downsweep let pls1 = pls cmstate1 let pcs1 = pcs cmstate1 let hst1 = hst cmstate1 let hit1 = hit cmstate1 -- similarly, ui1 is the (complete) set of linkables from -- the previous pass, if any. let ui1 = ui cmstate1 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 showPass dflags "Chasing dependencies" when (verb >= 1 && ghci_mode == Batch) $ hPutStrLn stderr (progName ++ ": chasing modules from: " ++ rootname) (mg2unsorted, a_root_is_Main) <- downsweep [rootname] let mg2unsorted_names = map name_of_summary mg2unsorted -- reachable_from follows source as well as normal imports let reachable_from :: ModuleName -> [ModuleName] reachable_from = downwards_closure_of_module mg2unsorted -- should be cycle free; ignores 'import source's let mg2 = topological_sort False mg2unsorted -- ... whereas this takes them into account. Used for -- backing out partially complete cycles following a failed -- upsweep, and for removing from hst/hit all the modules -- not in strict downwards closure, during calls to compile. let mg2_with_srcimps = topological_sort True mg2unsorted -- Sort out which linkables we wish to keep in the unlinked image. -- For each module, we take: -- -- - the old in-core linkable, if available -- - an on-disk linkable, if available -- -- and we take the youngest of these, provided it is younger than the -- source file. -- -- 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 -- compile. valid_linkables <- getValidLinkables ui1 mg2unsorted -- Figure out a stable set of modules which can be retained -- the top level envs, to avoid upsweeping them. Goes to a -- bit of trouble to avoid upsweeping module cycles. -- -- Construct a set S of stable modules like this: -- Travel upwards, over the sccified graph. For each scc -- of modules ms, add ms to S only if: -- 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 mg2unsorted_names [] mg2_with_srcimps let stable_summaries = concatMap (findInSummaries mg2unsorted) stable_mods when (verb >= 2) $ putStrLn (showSDoc (text "STABLE MODULES:" <+> sep (map (text.moduleNameUserString) stable_mods))) -- We could at this point detect cycles which aren't broken by -- a source-import, and complain immediately, but it seems better -- to let upsweep_mods do this, so at least some useful work gets -- done before the upsweep is abandoned. let upsweep_these = filter (\scc -> any (`notElem` stable_mods) (map name_of_summary (flattenSCC scc))) mg2 --hPutStrLn stderr "after tsort:\n" --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) -- Because we don't take into account source imports when doing -- the topological sort, there shouldn't be any cycles in mg2. -- If there is, we complain and give up -- the user needs to -- break the cycle using a boot file. -- Now do the upsweep, calling compile for each module in -- turn. Final result is version 3 of everything. let threaded2 = CmThreaded pcs1 hst1 hit1 (upsweep_complete_success, threaded3, modsUpswept, newLis) <- upsweep_mods ghci_mode dflags valid_linkables reachable_from threaded2 upsweep_these let ui3 = add_to_ui valid_linkables newLis let (CmThreaded pcs3 hst3 hit3) = threaded3 -- At this point, modsUpswept and newLis should have the same -- length, so there is one new (or old) linkable for each -- mod which was processed (passed to compile). -- Make modsDone be the summaries for each home module now -- available; this should equal the domains of hst3 and hit3. -- (NOT STRICTLY TRUE if an interactive session was started -- with some object on disk ???) -- Get in in a roughly top .. bottom order (hence reverse). let modsDone = reverse modsUpswept ++ stable_summaries -- Try and do linking in some form, depending on whether the -- upsweep was completely or only partially successful. if upsweep_complete_success then -- Easy; just relink it all. do when (verb >= 2) $ hPutStrLn stderr "Upsweep completely successful." linkresult <- link ghci_mode dflags a_root_is_Main ui3 pls1 case linkresult of LinkErrs _ _ -> panic "cmLoadModule: link failed (1)" LinkOK pls3 -> do let cmstate3 = CmState { hst=hst3, hit=hit3, ui=ui3, mg=modsDone, gmode=ghci_mode, pcs=pcs3, pls=pls3 } return (cmstate3, True, map ms_mod modsDone) else -- Tricky. We need to back out the effects of compiling any -- half-done cycles, both so as to clean up the top level envs -- and to avoid telling the interactive linker to link them. do when (verb >= 2) $ hPutStrLn stderr "Upsweep partially successful." let modsDone_names = map name_of_summary modsDone let mods_to_zap_names = findPartiallyCompletedCycles modsDone_names mg2_with_srcimps let (hst4, hit4, ui4) = removeFromTopLevelEnvs mods_to_zap_names (hst3,hit3,ui3) let mods_to_keep = filter ((`notElem` mods_to_zap_names).name_of_summary) modsDone let mods_to_keep_names = map name_of_summary mods_to_keep -- we could get the relevant linkables by filtering newLis, but -- it seems easier to drag them out of the updated, cleaned-up UI let linkables_to_link = map (unJust "linkables_to_link" . findModuleLinkable_maybe ui4) mods_to_keep_names linkresult <- link ghci_mode dflags False linkables_to_link pls1 case linkresult of LinkErrs _ _ -> panic "cmLoadModule: link failed (2)" LinkOK pls4 -> do let cmstate4 = CmState { hst=hst4, hit=hit4, ui=ui4, mg=mods_to_keep, gmode=ghci_mode, pcs=pcs3, pls=pls4 } return (cmstate4, False, map ms_mod mods_to_keep) ----------------------------------------------------------------------------- -- getValidLinkables getValidLinkables :: [Linkable] -- old linkables -> [ModSummary] -- all modules in the program -> IO [Linkable] -- still-valid linkables getValidLinkables old_linkables summaries = do lis <- mapM (getValidLinkable old_linkables) summaries return (concat lis) getValidLinkable old_linkables summary = do let mod_name = moduleName (ms_mod summary) maybe_disk_linkable <- case ml_obj_file (ms_location summary) of Nothing -> return Nothing Just obj_fn -> maybe_getFileLinkable mod_name obj_fn -- 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 maybe_getFileLinkable :: ModuleName -> FilePath -> IO (Maybe Linkable) maybe_getFileLinkable mod_name obj_fn = do obj_exist <- doesFileExist obj_fn if not obj_exist then return Nothing else do let stub_fn = case splitFilename3 obj_fn of (dir, base, ext) -> dir ++ "/" ++ base ++ ".stub_o" stub_exist <- doesFileExist stub_fn obj_time <- getModificationTime obj_fn if stub_exist then return (Just (LM obj_time mod_name [DotO obj_fn, DotO stub_fn])) else return (Just (LM obj_time mod_name [DotO obj_fn])) ----------------------------------------------------------------------------- -- Do a pre-upsweep without use of "compile", to establish a -- (downward-closed) set of stable modules which can be retained -- in the top-level environments. Also return linkables for those -- modules determined to be stable, since (in Batch mode, at least) -- there's no other way for them to get into UI. preUpsweep :: [Linkable] -- valid linkables -> [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 all_home_mods stable [] = return stable preUpsweep valid_lis all_home_mods stable (scc0:sccs) = do let scc = flattenSCC scc0 scc_allhomeimps :: [ModuleName] scc_allhomeimps = nub (filter (`elem` all_home_mods) (concatMap ms_allimps scc)) all_imports_in_scc_or_stable = all in_stable_or_scc scc_allhomeimps scc_names = map name_of_summary scc in_stable_or_scc m = --trace (showSDoc (text "ISOS" <+> ppr m <+> ppr scc_names <+> ppr stable)) ( m `elem` scc_names || m `elem` stable --) all_scc_stable <- if not all_imports_in_scc_or_stable then do --putStrLn ("PART1 fail " ++ showSDoc (ppr scc_allhomeimps <+> ppr (filter (not.in_stable_or_scc) scc_allhomeimps))) return False else do --when (not (and bools)) (putStrLn ("PART2 fail: " ++ showSDoc (ppr scc_names))) return (all is_stable scc) if not all_scc_stable then preUpsweep valid_lis all_home_mods stable sccs else preUpsweep valid_lis all_home_mods (scc_names++stable) sccs where is_stable new_summary = isJust (findModuleLinkable_maybe valid_lis (name_of_summary new_summary)) -- Helper for preUpsweep. Assuming that new_summary's imports are all -- stable (in the sense of preUpsweep), determine if new_summary is itself -- stable, and, if so, in batch mode, return its linkable. findInSummaries :: [ModSummary] -> ModuleName -> [ModSummary] findInSummaries old_summaries mod_name = [s | s <- old_summaries, name_of_summary s == mod_name] -- Return (names of) all those in modsDone who are part of a cycle -- as defined by theGraph. findPartiallyCompletedCycles :: [ModuleName] -> [SCC ModSummary] -> [ModuleName] findPartiallyCompletedCycles modsDone theGraph = chew theGraph where chew [] = [] chew ((AcyclicSCC v):rest) = chew rest -- acyclic? not interesting. chew ((CyclicSCC vs):rest) = let names_in_this_cycle = nub (map name_of_summary vs) mods_in_this_cycle = nub ([done | done <- modsDone, done `elem` names_in_this_cycle]) chewed_rest = chew rest in if not (null mods_in_this_cycle) && length mods_in_this_cycle < length names_in_this_cycle then mods_in_this_cycle ++ chewed_rest else chewed_rest -- Does this ModDetails export Main.main? --exports_main :: ModDetails -> Bool --exports_main md -- = isJust (lookupNameEnv (md_types md) mainName) -- Add the given (LM-form) Linkables to the UI, overwriting previous -- versions if they exist. add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage add_to_ui ui lis = foldr add1 ui lis where add1 :: Linkable -> UnlinkedImage -> UnlinkedImage add1 li ui = li : filter (\li2 -> not (for_same_module li li2)) ui for_same_module :: Linkable -> Linkable -> Bool for_same_module li1 li2 = not (is_package_linkable li1) && not (is_package_linkable li2) && modname_of_linkable li1 == modname_of_linkable li2 data CmThreaded -- stuff threaded through individual module compilations = CmThreaded PersistentCompilerState HomeSymbolTable HomeIfaceTable -- Compile multiple modules, stopping as soon as an error appears. -- There better had not be any cyclic groups here -- we check for them. upsweep_mods :: GhciMode -> DynFlags -> UnlinkedImage -- valid linkables -> (ModuleName -> [ModuleName]) -- to construct downward closures -> CmThreaded -- PCS & HST & HIT -> [SCC ModSummary] -- mods to do (the worklist) -- ...... RETURNING ...... -> IO (Bool{-complete success?-}, CmThreaded, [ModSummary], -- mods which succeeded [Linkable]) -- new linkables upsweep_mods ghci_mode dflags oldUI reachable_from threaded [] = return (True, threaded, [], []) upsweep_mods ghci_mode dflags oldUI reachable_from threaded ((CyclicSCC ms):_) = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++ unwords (map (moduleNameUserString.name_of_summary) ms)) return (False, threaded, [], []) upsweep_mods ghci_mode dflags oldUI reachable_from threaded ((AcyclicSCC mod):mods) = do --case threaded of -- CmThreaded pcsz hstz hitz -- -> putStrLn ("UPSWEEP_MOD: hit = " ++ show (map (moduleNameUserString.moduleName.mi_module) (eltsUFM hitz))) (threaded1, maybe_linkable) <- upsweep_mod ghci_mode dflags oldUI threaded mod (reachable_from (name_of_summary mod)) case maybe_linkable of Just linkable -> -- No errors; do the rest do (restOK, threaded2, modOKs, linkables) <- upsweep_mods ghci_mode dflags oldUI reachable_from threaded1 mods return (restOK, threaded2, mod:modOKs, linkable:linkables) Nothing -- we got a compilation error; give up now -> return (False, threaded1, [], []) -- Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. upsweep_mod :: GhciMode -> DynFlags -> UnlinkedImage -> CmThreaded -> ModSummary -> [ModuleName] -> IO (CmThreaded, Maybe Linkable) upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_from_here = 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 let maybe_old_linkable = findModuleLinkable_maybe oldUI mod_name source_unchanged = isJust maybe_old_linkable (hst1_strictDC, hit1_strictDC) = retainInTopLevelEnvs (filter (/= (name_of_summary summary1)) reachable_from_here) (hst1,hit1) old_linkable = unJust "upsweep_mod:old_linkable" maybe_old_linkable compresult <- compile ghci_mode summary1 source_unchanged 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 maybe_old_linkable of Just (LM _ _ objs@(DotO _:_)) -> do hPutStr stderr (showSDoc (space <> parens (hsep (text "using": punctuate comma [ text o | DotO o <- objs ])))) when (verb > 1) $ hPutStrLn stderr "" _ -> return () else return () when (verb == 1) $ hPutStrLn stderr "" 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) -> do let hst2 = addToUFM hst1 mod_name new_details hit2 = addToUFM hit1 mod_name new_iface threaded2 = CmThreaded pcs2 hst2 hit2 when (verb == 1) $ hPutStrLn stderr "" return (threaded2, Just new_linkable) -- Compilation failed. compile may still have updated -- the PCS, tho. CompErrs pcs2 -> do let threaded2 = CmThreaded pcs2 hst1 hit1 when (verb == 1) $ hPutStrLn stderr "" return (threaded2, Nothing) -- Remove unwanted modules from the top level envs (HST, HIT, UI). removeFromTopLevelEnvs :: [ModuleName] -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage) -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage) removeFromTopLevelEnvs zap_these (hst, hit, ui) = (delListFromUFM hst zap_these, delListFromUFM hit zap_these, filterModuleLinkables (`notElem` zap_these) ui ) retainInTopLevelEnvs :: [ModuleName] -> (HomeSymbolTable, HomeIfaceTable) -> (HomeSymbolTable, HomeIfaceTable) retainInTopLevelEnvs keep_these (hst, hit) = (retainInUFM hst keep_these, retainInUFM hit keep_these ) where retainInUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt retainInUFM ufm keys_to_keep = listToUFM (concatMap (maybeLookupUFM ufm) keys_to_keep) maybeLookupUFM ufm u = case lookupUFM ufm u of Nothing -> []; Just val -> [(u, val)] -- Needed to clean up HIT and HST so that we don't get duplicates in inst env 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] in --trace (showSDoc (text "DC of mod" <+> ppr root -- <+> text "=" <+> ppr res)) ( res --) -- Calculate transitive closures from a set of roots given an adjacency list simple_transitive_closure :: Eq a => [(a,[a])] -> [a] -> [a] simple_transitive_closure graph set = let set2 = nub (concatMap dsts set ++ set) dsts node = fromMaybe [] (lookup node graph) in if length set == length set2 then set else simple_transitive_closure graph set2 -- Calculate SCCs of the module graph, with or without taking into -- account source imports. topological_sort :: Bool -> [ModSummary] -> [SCC ModSummary] topological_sort include_source_imports summaries = let toEdge :: ModSummary -> (ModSummary,ModuleName,[ModuleName]) toEdge summ = (summ, name_of_summary summ, (if include_source_imports then ms_srcimps summ else []) ++ ms_imps summ) mash_edge :: (ModSummary,ModuleName,[ModuleName]) -> (ModSummary,Int,[Int]) mash_edge (summ, m, m_imports) = case lookup m key_map of Nothing -> panic "reverse_topological_sort" Just mk -> (summ, mk, -- ignore imports not from the home package catMaybes (map (flip lookup key_map) m_imports)) edges = map toEdge summaries key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)] scc_input = map mash_edge edges sccs = stronglyConnComp scc_input in sccs -- Chase downwards from the specified root set, returning summaries -- for all home modules encountered. Only follow source-import -- links. Also returns a Bool to indicate whether any of the roots -- are module Main. downsweep :: [FilePath] -> IO ([ModSummary], Bool) downsweep rootNm = do rootSummaries <- mapM getRootSummary rootNm let a_root_is_Main = any ((=="Main").moduleNameUserString.name_of_summary) rootSummaries all_summaries <- loop (filter (isHomeModule.ms_mod) rootSummaries) return (all_summaries, a_root_is_Main) where getRootSummary :: FilePath -> IO ModSummary getRootSummary file | haskellish_file file = do exists <- doesFileExist file if exists then summariseFile file else do throwDyn (OtherError ("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) where hs_file = file ++ ".hs" lhs_file = file ++ ".lhs" getSummary :: ModuleName -> IO ModSummary getSummary nm -- | trace ("getSummary: "++ showSDoc (ppr nm)) True = do found <- findModule nm case found of -- Be sure not to use the mod and location passed in to -- summarise for any other purpose -- summarise may change -- the module names in them if name of module /= name of file, -- and put the changed versions in the returned summary. -- These will then conflict with the passed-in versions. Just (mod, location) -> summarise mod location Nothing -> throwDyn (OtherError ("can't find module `" ++ showSDoc (ppr nm) ++ "'")) -- loop invariant: homeSummaries doesn't contain package modules loop :: [ModSummary] -> IO [ModSummary] loop homeSummaries = do let allImps :: [ModuleName] allImps = (nub . concatMap ms_imps) homeSummaries let allHome -- all modules currently in homeSummaries = map (moduleName.ms_mod) homeSummaries let neededImps = filter (`notElem` allHome) allImps neededSummaries <- mapM getSummary neededImps let newHomeSummaries = filter (isHomeModule.ms_mod) neededSummaries if null newHomeSummaries then return homeSummaries else loop (newHomeSummaries ++ homeSummaries) ----------------------------------------------------------------------------- -- Summarising modules -- We have two types of summarisation: -- -- * Summarise a file. This is used for the root module passed to -- cmLoadModule. The file is read, and used to determine the root -- module name. The module name may differ from the filename. -- -- * Summarise a module. We are given a module name, and must provide -- a summary. The finder is used to locate the file in which the module -- resides. summariseFile :: FilePath -> IO ModSummary summariseFile file = do hspp_fn <- preprocess file modsrc <- readFile hspp_fn let (srcimps,imps,mod_name) = getImports modsrc (path, basename, ext) = splitFilename3 file Just (mod, location) <- mkHomeModuleLocn mod_name (path ++ '/':basename) file maybe_src_timestamp <- case ml_hs_file location of Nothing -> return Nothing Just src_fn -> maybe_getModificationTime src_fn return (ModSummary mod location{ml_hspp_file=Just hspp_fn} srcimps imps maybe_src_timestamp) -- Summarise a module, and pick up source and interface timestamps. summarise :: Module -> ModuleLocation -> IO ModSummary summarise mod location | isHomeModule mod = do let hs_fn = unJust "summarise" (ml_hs_file location) 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 if mod_name == moduleName mod then return () else throwDyn (OtherError (showSDoc (text "file name does not match module name: " <+> ppr (moduleName mod) <+> text "vs" <+> ppr mod_name))) return (ModSummary mod location{ml_hspp_file=Just hspp_fn} srcimps imps maybe_src_timestamp) | otherwise = return (ModSummary mod location [] [] Nothing) maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime) maybe_getModificationTime fn = (do time <- getModificationTime fn return (Just time)) `catch` (\err -> return Nothing) \end{code}