[project @ 2000-10-05 10:05:53 by sewardj]

Add finder, summariser, part of CM, to repo.

ghc/compiler/ghci/CmFind.lhs

@@ -5,27 +5,148 @@
 
 \begin{code}
 module CmFind ( Path, ModName, PkgName,
-                ModLocation(..), Finder, newFinder )
+                ModLocation(..), ml_modname, isPackageLoc,
+		Finder, newFinder )
 where
 
 #include "HsVersions.h"
 
+import IO		( hPutStr, stderr )
+import List		( maximumBy )
+import Maybe		( catMaybes )
+import Char		( isUpper )
+import List		( nub )
+import Time		( ClockTime )
+import Directory	( doesFileExist, getModificationTime,
+                          getDirectoryContents) 
+
 import Module		( Module )
-import CmStaticInfo	( PCI )
+import CmStaticInfo	( PCI, Package(..) )
 \end{code}
 
 \begin{code}
-type Path = String
+type Path    = String
 type ModName = String
 type PkgName = String
 
 data ModLocation 
-   = SourceOnly Module Path        -- .hs
-   | ObjectCode Module Path Path   -- .o, .hi
-   | InPackage  Module PkgName
+   = SourceOnly ModName Path        -- .hs
+   | ObjectCode ModName Path Path   -- .o, .hi
+   | InPackage  ModName PkgName
+   | NotFound
+     deriving Show
 
 type Finder = ModName -> IO ModLocation
 
+ml_modname (SourceOnly nm _)   = nm
+ml_modname (ObjectCode nm _ _) = nm
+ml_modname (InPackage  nm _)   = nm
+
+isPackageLoc (InPackage _ _) = True
+isPackageLoc _               = False
+
+mkFinder :: [(ModName,PkgName,Path)] -> [Path] -> Finder
+mkFinder pkg_ifaces home_dirs modnm
+   = do found <- mkFinderX pkg_ifaces home_dirs modnm
+        putStrLn ("FINDER pkginfo\n" ++ unlines (map show pkg_ifaces) ++ "\n")
+        putStrLn ("FINDER: request  = " ++ modnm ++ "\n" ++
+                  "FINDER: response = " ++ show found)
+        return found
+
+
+mkFinderX :: [(ModName,PkgName,Path)] -> [Path] -> Finder
+mkFinderX pkg_ifaces home_dirs modnm
+   -- If the module exists both as package and home, emit a warning
+   -- and (arbitrarily) choose the user's one.
+   = do home_maybe_found <- mapM (homeModuleExists modnm) home_dirs
+                         :: IO [Maybe (ModLocation, ClockTime)]
+        case (in_package, catMaybes home_maybe_found) of
+           ([], []) 
+              -> return NotFound
+           ([], locs_n_times@(_:_))
+              -> return (homeMod locs_n_times)
+           ((pkgname,path):_, [])
+              -> return (InPackage modnm pkgname)
+           (packages, locs_n_times)
+              -> do hPutStr stderr ( "GHCI: warning: module `" ++ modnm ++
+                                     "' appears as both a home and package module\n")
+                    return (homeMod locs_n_times)
+     where
+        in_package 
+           = [(pkgname,path) | (modname,pkgname,path) <- pkg_ifaces, 
+                               modname == modnm]
+        homeMod :: [(ModLocation, ClockTime)] -> ModLocation
+        homeMod locs_n_times
+           = fst (maximumBy (\lt1 lt2 -> if snd lt1 > snd lt2 then lt1 else lt2)
+                            locs_n_times)
+        
+
+-- See if a .hs or (.hi, .o) pair exist on the given path,
+-- and return a ModLocation for whichever is younger
+homeModuleExists :: ModName -> Path -> IO (Maybe (ModLocation, ClockTime))
+homeModuleExists modname path
+   = do m_ths <- maybeTime nm_hs
+        m_thi <- maybeTime nm_hi
+        m_to  <- maybeTime nm_o
+        return (
+           case (m_ths, m_thi, m_to) of
+              (Just ths, Just thi, Just to)
+                 |  thi >= ths && to >= ths -> object thi to
+                 |  otherwise               -> source ths
+              (Just ths, _, _)              -> source ths
+              (Nothing, Just thi, Just to)  -> object thi to
+              (Nothing, _, _)               -> Nothing
+           )
+     where
+        object thi to = Just (ObjectCode modname nm_o nm_hi, max thi to)
+        source ths    = Just (SourceOnly modname nm_hs, ths)
+        nm = path ++ "/" ++ modname
+        nm_hs = nm ++ ".hs"
+        nm_hi = nm ++ ".hi"
+        nm_o  = nm ++ ".o"
+
+        maybeTime :: String -> IO (Maybe ClockTime)
+        maybeTime f
+           = do putStrLn ("maybeTime: " ++ f)
+                exists <- doesFileExist f
+                if not exists 
+                 then do putStrLn " ... no"
+                         return Nothing
+                 else do tm <- getModificationTime f
+                         putStrLn (" ... " ++ show tm)
+                         return (Just tm)
+
+
+
 newFinder :: PCI -> IO Finder
-newFinder pci = return (error "newFinder:unimp")
+newFinder pci
+   -- PCI is a list of packages and their names
+   = do 
+        -- the list of directories where package interfaces are
+        let p_i_dirs :: [(PkgName,Path)]
+            p_i_dirs = concatMap nm_and_paths pci
+
+        -- interface names in each directory
+        ifacess <- mapM ifaces_in_dir p_i_dirs
+        let ifaces :: [(ModName,PkgName,Path)] 
+            ifaces = concat ifacess
+
+        -- ToDo: allow a range of home package directories
+        return (mkFinder ifaces ["."])
+     where
+        nm_and_paths :: Package -> [(PkgName,Path)]
+        nm_and_paths package 
+           = [(name package, path) | path <- nub (import_dirs package)]
+
+        ifaces_in_dir :: (PkgName,Path) -> IO [(ModName,PkgName,Path)]
+        ifaces_in_dir (pkgname,path)
+           = getDirectoryContents path >>= \ entries ->
+             return [(zap_hi if_nm, pkgname, path) 
+                    | if_nm <- entries, looks_like_iface_name if_nm]
+        looks_like_iface_name e
+           = not (null e) && isUpper (head e) 
+                          && take 3 (reverse e) == "ih."
+        zap_hi 
+           = reverse . drop 3 . reverse
+
 \end{code}

ghc/compiler/ghci/CmStaticInfo.lhs

@@ -4,7 +4,7 @@
 \section[CmStaticInfo]{Session-static info for the Compilation Manager}
 
 \begin{code}
-module CmStaticInfo ( FLAGS, PCI, 
+module CmStaticInfo ( FLAGS, Package(..), PCI, 
                       mkSI, SI -- abstract
                     )
 where
@@ -15,8 +15,25 @@ where
 
 \begin{code}
 type FLAGS = [String]       -- or some such fiction
-type PCI = [PkgConfig]
-data PkgConfig = PkgConfig   -- add details here
+type PCI = [Package]
+
+-- copied from the driver
+data Package
+   = Package {
+        name            :: String,
+        import_dirs     :: [String],
+        library_dirs    :: [String],
+        hs_libraries    :: [String],
+        extra_libraries :: [String],
+        include_dirs    :: [String],
+        c_includes      :: [String],
+        package_deps    :: [String],
+        extra_ghc_opts  :: [String],
+        extra_cc_opts   :: [String],
+        extra_ld_opts   :: [String]
+     }
+  deriving (Read, Show)
+
 
 data SI = MkSI FLAGS PCI
 

ghc/compiler/ghci/CmSummarise.lhs

@@ -4,7 +4,8 @@
 \section[CmSummarise]{Module summariser for GHCI}
 
 \begin{code}
-module CmSummarise ( ModImport(..), ModSummary(..), summarise )
+module CmSummarise ( ModImport(..), mi_name,
+                     ModSummary(..), summarise )
 where
 
 #include "HsVersions.h"
@@ -13,20 +14,26 @@ import List 		( nub )
 import Char		( ord, isAlphaNum )
 
 import CmFind	 	( ModName, ModLocation(..) )
-
+import Outputable	( pprPanic, text )
 \end{code}
 
 \begin{code}
 
 
 data ModSummary
-   = ModSummary ModLocation                    -- location and kind
-                (Maybe (String, Fingerprint))  -- source and sig if .hs
-                (Maybe [ModImport])            -- imports if .hs or .hi
+   = ModSummary {
+        ms_loc     :: ModLocation,                   -- location and kind
+        ms_source  :: (Maybe (String, Fingerprint)), -- source and sig if .hs
+        ms_imports :: (Maybe [ModImport])            -- imports if .hs or .hi
+     }
+     deriving Show
 
 data ModImport
    = MINormal ModName | MISource ModName
-     deriving Eq
+     deriving (Eq, Show)
+
+mi_name (MINormal nm) = nm
+mi_name (MISource nm) = nm
 
 type Fingerprint = Int
 
@@ -46,6 +53,8 @@ summarise loc
            -> readFile hiPath >>= \ hisrc ->
               let imps = getImports hisrc
               in  return (ModSummary loc Nothing (Just imps))
+        NotFound
+           -> pprPanic "summarise:NotFound" (text (show loc))
 
 fingerprint :: String -> Int
 fingerprint s

ghc/compiler/ghci/CompManager.lhs

@@ -6,18 +6,21 @@
 \begin{code}
 module CompManager ( cmInit, cmLoadModule, 
                      cmGetExpr, cmRunExpr,
-                     CmState  -- abstract
+                     CmState, emptyCmState  -- abstract
                    )
 where
 
 #include "HsVersions.h"
 
+import List		( nub )
+import Maybe		( catMaybes )
 import Outputable	( SDoc )
 import FiniteMap	( emptyFM )
 
 import CmStaticInfo 	( FLAGS, PCI, SI, mkSI )
-import CmFind 		( Finder, newFinder, ModName )
-import CmSummarise 	( )
+import CmFind 		( Finder, newFinder, 
+			  ModName, ml_modname, isPackageLoc )
+import CmSummarise 	( summarise, ModSummary(..), mi_name )
 import CmCompile 	( PCS, emptyPCS, HST, HIT )
 import CmLink 		( PLS, emptyPLS, HValue, Linkable )
 
@@ -29,12 +32,6 @@ cmInit :: FLAGS
 cmInit flags pkginfo
    = emptyCmState flags pkginfo
 
-cmLoadModule :: CmState 
-             -> ModName
-             -> IO (CmState, Either [SDoc] ModHandle)
-cmLoadModule cmstate modname
-   = return (error "cmLoadModule:unimp")
-
 cmGetExpr :: CmState
           -> ModHandle
           -> String
@@ -51,13 +48,18 @@ type ModHandle = String   -- ToDo: do better?
 
 -- Persistent state just for CM, excluding link & compile subsystems
 data PCMS
-   = PCMS HST   -- home symbol table
-          HIT   -- home interface table
-          UI    -- the unlinked images
-          MG    -- the module graph
+   = PCMS { 
+        hst :: HST,   -- home symbol table
+        hit :: HIT,   -- home interface table
+        ui  :: UI,    -- the unlinked images
+        mg  :: MG    -- the module graph
+     }
 
 emptyPCMS :: PCMS
-emptyPCMS = PCMS emptyHST emptyHIT emptyUI emptyMG
+emptyPCMS = PCMS { hst = emptyHST,
+                   hit = emptyHIT,
+                   ui  = emptyUI,
+                   mg  = emptyMG }
 
 emptyHIT :: HIT
 emptyHIT = emptyFM
@@ -69,11 +71,13 @@ emptyHST = emptyFM
 
 -- Persistent state for the entire system
 data CmState
-   = CmState PCMS      -- CM's persistent state
-             PCS       -- compile's persistent state
-             PLS       -- link's persistent state
-             SI        -- static info, never changes
-             Finder    -- the module finder
+   = CmState {
+        pcms   :: PCMS,      -- CM's persistent state
+        pcs    :: PCS,       -- compile's persistent state
+        pls    :: PLS,       -- link's persistent state
+        si     :: SI,        -- static info, never changes
+        finder :: Finder    -- the module finder
+     }
 
 emptyCmState :: FLAGS -> PCI -> IO CmState
 emptyCmState flags pci
@@ -82,7 +86,11 @@ emptyCmState flags pci
          pls     <- emptyPLS
          let si   = mkSI flags pci
          finder  <- newFinder pci
-         return (CmState pcms pcs pls si finder)
+         return (CmState { pcms   = pcms,
+                           pcs    = pcs,
+                           pls    =   pls,
+                           si     = si,
+                           finder = finder })
 
 -- CM internal types
 type UI = [Linkable]	-- the unlinked images (should be a set, really)
@@ -90,11 +98,57 @@ emptyUI :: UI
 emptyUI = []
 
 
-data MG = MG            -- the module graph
+type MG = [[ModSummary]]            -- the module graph
 emptyMG :: MG
-emptyMG = MG
+emptyMG = []
 
+\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 
+             -> ModName
+             -> IO (CmState, Either [SDoc] ModHandle)
 
+cmLoadModule cmstate modname
+   = do putStr "cmLoadModule: downsweep begins\n"
+        let find  = finder cmstate
+        mgNew <- downsweep modname find
+        putStrLn ( "after chasing:\n\n" ++ unlines (map show mgNew))
+        return (error "cmLoadModule:unimp")
+
+downsweep :: ModName          -- module to chase from
+          -> Finder
+          -> IO [ModSummary]
+downsweep rootNm finder
+   = do rootLoc <- getSummary rootNm
+        loop [rootLoc]
+     where
+        getSummary :: ModName -> IO ModSummary
+        getSummary nm
+           = do loc     <- finder nm
+                summary <- summarise loc
+                return summary
+
+        -- loop invariant: homeSummaries doesn't contain package modules
+        loop :: [ModSummary] -> IO [ModSummary]
+        loop homeSummaries
+           = do let allImps   -- all imports
+                       = (nub . map mi_name . concat . catMaybes . map ms_imports)
+                         homeSummaries
+                let allHome   -- all modules currently in homeSummaries
+                       = map (ml_modname.ms_loc) homeSummaries
+                let neededImps
+                       = filter (`notElem` allHome) allImps
+                neededSummaries
+                       <- mapM getSummary neededImps
+                let newHomeSummaries
+                       = filter (not.isPackageLoc.ms_loc) neededSummaries
+                if null newHomeSummaries
+                 then return homeSummaries
+                 else loop (newHomeSummaries ++ homeSummaries)
+                 
 \end{code}