Improved make facility.

src/GF/Compile/Compile.hs

@@ -62,7 +62,7 @@ compileModule opts st0 file | oElem showOld opts = do
   let env = compileEnvShSt st0 []
   (_,sgr,cgr) <- foldM (comp putp path) env mods
   return $ (reverseModules cgr,       -- to preserve dependency order
-            (reverseModules sgr,[]))  
+            (reverseModules sgr,[]))
  where
    comp putp path env sm0 = do
      (k',sm)  <- makeSourceModule opts env sm0
@@ -78,22 +78,23 @@ compileModule opts1 st0 file = do
   let ps = if useFileOpt 
              then (map (prefixPathName fpath) ps0)
              else ps0
-  ioeIO $ print ps ----
+  ioeIO $ putStrLn $ "module search path:" +++ show ps ----
   let putp = putPointE opts
   let st = st0 --- if useFileOpt then emptyShellState else st0
   let rfs = readFiles st
   let file' = if useFileOpt then justFileName file else file -- to find file itself
   files <- getAllFiles ps rfs file'
-  ioeIO $ print files ----
-  let names = map (fileBody . justFileName) files
-  ioeIO $ print names ----
+  ioeIO $ putStrLn $ "files to read:" +++ show files ----
+  let names = map justModuleName files
+  ioeIO $ putStrLn $ "modules to include:" +++ show names ----
   let env0 = compileEnvShSt st names
   (_,sgr,cgr) <- foldM (compileOne opts) env0 files
   t <- ioeIO getNowTime
   return $ (reverseModules cgr,       -- to preserve dependency order
             (reverseModules sgr, --- keepResModules opts sgr, --- keep all so far
-             [])) ---- (f,t) | f <- files]))   -- pass on the time of creation
-
+             [(justModuleName f,t) | f <- files]   -- pass on the time of reading
+          ++ [(resModName (justModuleName f),t)    -- also #file if file.(gf|gfr)
+                                   | f <- files, not (isGFC f)]))
 compileEnvShSt :: ShellState -> [ModName] -> CompileEnv
 compileEnvShSt st fs = (0,sgr,cgr) where
   cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i]

src/GF/Infra/ReadFiles.hs

@@ -1,6 +1,14 @@
-module ReadFiles where
+module ReadFiles 
+--- where 
 
-import Arch (selectLater, modifiedFiles, ModTime)
+--
+(
+--  
+getAllFiles,fixNewlines,ModName,getOptionsFromFile,
+--  
+gfcFile,gfFile,gfrFile,isGFC,resModName) where
+
+import Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime)
 
 import Option
 import Operations
@@ -10,78 +18,121 @@ import Char
 import Monad
 import List
 
--- make analysis for GF grammar modules. AR 11/6/2003
+-- make analysis for GF grammar modules. AR 11/6/2003--24/2/2004
 
 -- to find all files that have to be read, put them in dependency order, and
 -- decide which files need recompilation. Name file.gf is returned for them,
 -- and file.gfc or file.gfr otherwise.
 
 type ModName = String
-type FileName = String
-type InitPath = String
-type FullPath = String
+type ModEnv  = [(ModName,ModTime)]
 
-getAllFiles :: [InitPath] -> [(FullPath,ModTime)] -> FileName -> 
-               IOE [FullPath]
+getAllFiles :: [InitPath] -> ModEnv -> FileName -> IOE [FullPath]
 getAllFiles ps env file = do
-  ds  <- getImports ps file
-  -- print ds  ---- debug
+
+  -- read module headers from all files recursively
+  ds0  <- getImports ps file
+  let ds = [((snd m,map fst ms),p) | ((m,ms),p) <- ds0]
+  ioeIO $ putStrLn $ "all modules:" +++ show (map (fst . fst) ds)
+
+  -- get a topological sorting of files: returns file names --- deletes paths
   ds1 <- ioeErr $ either 
            return 
-           (\ms -> Bad $ "circular modules" +++ unwords (map show (head ms))) $ 
-              topoTest $ map fst ds
+           (\ms -> Bad $ "circular modules" +++ 
+                     unwords (map show (head ms))) $ topoTest $ map fst ds
+
+  -- associate each file name with its path --- more optimal: save paths in ds1
   let paths = [(f,p) | ((f,_),p) <- ds]
   let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]]
-  ds2 <- ioeIO $ mapM selectFormat pds1
-  -- print ds2 ---- debug
-  let ds3 = needCompile ds ds2
-  ds4 <- ioeIO $ modifiedFiles env ds3
+
+
+  ds2 <- ioeIO $ mapM (selectFormat env) pds1
+
+  let ds4 = needCompile (map fst ds0) ds2
   return ds4
 
-getImports :: [InitPath] -> FileName -> IOE [((ModName,[ModName]),InitPath)]
-getImports ps = get [] where
-  get ds file = do
-    let name = fileBody file
-    (p,s) <- readFileIfPath ps $ file
-    let imps  = importsOfFile s
-    case imps of
-      _ | elem name (map (fst . fst) ds) -> return ds  --- file already read
-      [] -> return $ ((name,[]),p):ds
-      _  -> do
-        let files = map gfFile imps
-        foldM get (((name,imps),p):ds) files
+-- to decide whether to read gf or gfc, or if in env; returns full file path
 
--- to decide whether to read gf or gfc; returns full file path
+data CompStatus =
+   CSComp -- compile: read gf
+ | CSRead -- read gfc
+ | CSEnv  -- gfc is in env
+ | CSEnvR -- also gfr is in env
+ | CSDont -- don't read at all
+ | CSRes  -- read gfr
+  deriving (Eq,Show)
 
-selectFormat :: (InitPath,ModName) -> IO (ModName,(FullPath,Bool))
-selectFormat (p,f) = do
+selectFormat :: ModEnv -> (InitPath,ModName) -> IO (ModName,(InitPath,CompStatus))
+selectFormat env (p,f) = do
   let pf = prefixPathName p f
-  f0 <- selectLater (gfFile pf) (gfcFile pf)
-  f1 <- selectLater (gfrFile pf) f0
-  return $ (f, (f1, f1 == gfFile pf)) -- True if needs compile
+  let mtenv = lookup f env   -- Nothing if f is not in env
+  let rtenv = lookup (resModName f) env
+  mtgfc <- getModTime $ gfcFile pf
+  mtgf  <- getModTime $ gfFile pf
+  let stat = case (rtenv,mtenv,mtgfc,mtgf) of
+        (Just tenv,_,_,Just tgf) | laterModTime tenv tgf -> CSEnvR
+        (_,Just tenv,_,Just tgf) | laterModTime tenv tgf -> CSEnv
+        (_,_,Just tgfc,Just tgf) | laterModTime tgfc tgf -> CSRead
+        _ -> CSComp
+  return $ (f, (p,stat))
 
-needCompile :: [((ModName,[ModName]),InitPath)] -> [(ModName,(FullPath,Bool))] ->
-               [FullPath]
-needCompile deps sfiles = filt $ mark $ iter changed where
+
+needCompile :: [ModuleHeader] -> [(ModName,(InitPath,CompStatus))] -> [FullPath]
+needCompile headers sfiles0 = paths $ res $ mark $ iter changed where
+
+  deps = [(snd m,map fst ms) | (m,ms) <- headers]
+  typ m = maybe MTyOther id $ lookup m [(m,t) | ((t,m),_) <- headers]
+  uses m = [(n,u) | ((_,n),ms) <- headers, (k,u) <- ms, k==m]
+  stat0 m = maybe CSComp snd $ lookup m sfiles0
+
+  allDeps = [(m,iterFix add ms) | (m,ms) <- deps] where
+    add os = [m | o <- os, Just n <- [lookup o deps],m <- n]
+
+  -- only treat reused, interface, or instantiation if needed
+  sfiles = map relevant sfiles0
+  relevant fp@(f,(p,st)) = 
+    let us = uses f in
+    if not (all noComp us) then
+      fp else 
+    if (typ f == MTyIncomplete || (not (null us) && all isAux us)) then
+      (f,(p,CSDont)) else
+      fp
+
+  isAux = flip elem [MUReuse,MUInstance,MUComplete] . snd
+  noComp = flip elem [CSRead,CSEnv,CSEnvR] . stat0 . fst
 
   -- start with the changed files themselves; returns [ModName]
-  changed = [f | (f,(_,True)) <- sfiles] 
+  changed = [f | (f,(_,CSComp)) <- sfiles] 
 
   -- add other files that depend on some changed file; returns [ModName]
-  iter np = let new = [f | ((f,fs),_) <- deps, 
+  iter np = let new = [f | (f,fs) <- deps, 
                            not (elem f np), any (flip elem np) fs]
             in  if null new then np else (iter (new ++ np))
 
-  -- for each module in the full list, choose source file if change is needed
+  -- for each module in the full list, compile if depends on what needs compile
   -- returns [FullPath]
-  mark cs = [f' | (f,(file,_)) <- sfiles, 
-                  let f' = if (elem f cs) then gfFile (fileBody file) else file]
+  mark cs = [(f,(path,st)) | 
+                (f,(path,st0)) <- sfiles, 
+                let st = if (elem f cs) then CSComp else st0]
 
-  -- if the top file is gfc, only gfc files need be read (could be even better)---
-  filt ds = if isGFC (last ds) 
-    then [gfcFile name | f <- ds, 
-               let (name,suff) = nameAndSuffix f, elem suff ["gfc","gfr"]] 
-    else ds
+  -- if a compilable file depends on a resource, read gfr instead of gfc/env
+  -- but don't read gfr if already in env (by CSEnvR)
+  res cs = map mkRes cs where
+    mkRes x@(f,(path,st)) | elem st [CSRead,CSEnv] = case typ f of
+      MTyResource | not (null [m | (m,(_,CSComp)) <- cs,
+                                   Just ms <- [lookup m allDeps], elem f ms])
+        -> (f,(path,CSRes))
+      _ -> x
+    mkRes x = x
+
+  -- construct list of paths to read
+  paths cs = [mkName f p st | (f,(p,st)) <- cs, elem st [CSComp, CSRead,CSRes]]
+
+  mkName f p st = mk $ prefixPathName p f where
+    mk = case st of
+      CSComp -> gfFile
+      CSRead -> gfcFile
+      CSRes  -> gfrFile
 
 isGFC = (== "gfc") . fileSuffix
 
@@ -89,11 +140,45 @@ gfcFile = suffixFile "gfc"
 gfrFile = suffixFile "gfr"
 gfFile  = suffixFile "gf"
 
--- to get imports without parsing the file
+resModName = ('#':)
 
-importsOfFile :: String -> [FilePath]
+-- to get imports without parsing the whole files
+
+getImports :: [InitPath] -> FileName -> IOE [(ModuleHeader,InitPath)]
+getImports ps = get [] where
+  get ds file = do
+    let name = fileBody file
+    (p,s) <- readFileIfPath ps $ file
+    let ((typ,mname),imps) = importsOfFile s
+    ioeErr $ testErr  (mname == name) $ 
+             "module name differs from file name in" +++ name
+    case imps of
+      _ | elem name (map (snd . fst . fst) ds) -> return ds  --- file already read
+      [] -> return $ (((typ,name),[]),p):ds
+      _ -> do
+        let files = map (gfFile . fst) imps --- requires there's always .gf file
+        foldM get ((((typ,name),imps),p):ds) files
+
+-- internal module dep information
+
+data ModUse =
+   MUReuse
+ | MUInstance
+ | MUComplete
+ | MUOther
+  deriving (Eq,Show)
+
+data ModTyp =
+   MTyResource
+ | MTyIncomplete
+ | MTyOther
+  deriving (Eq,Show)
+
+type ModuleHeader = ((ModTyp,ModName),[(ModName,ModUse)])
+
+importsOfFile :: String -> ModuleHeader
 importsOfFile = 
-  drop 1 .                   -- ignore module name itself
+  getModuleHeader .          -- analyse into mod header
   filter (not . spec) .      -- ignore keywords and special symbols
   unqual .                   -- take away qualifiers
   takeWhile (not . term) .   -- read until curly or semic
@@ -101,14 +186,37 @@ importsOfFile =
   unComm                     -- ignore comments before the headed line
  where
     term = flip elem ["{",";"]
-    spec = flip elem ["of", "open","in", ":", "->", "reuse", "=", "(", ")",",","**","with",
-                      "abstract","concrete","resource","transfer","interface","incomplete",
-                      "instance"]
+    spec = flip elem ["of", "open","in",":", "->","=", "(", ")",",","**"]
     unqual ws = case ws of
       "(":q:ws' -> unqual ws'
       w:ws' -> w:unqual ws'
       _ -> ws
 
+getModuleHeader :: [String] -> ModuleHeader -- with, reuse
+getModuleHeader ws = case ws of
+  "incomplete":ws2 -> let ((_,name),us) = getModuleHeader ws2 in
+    ((MTyIncomplete,name),us)
+  "interface":ws2 -> let ((_,name),us) = getModuleHeader ("resource":ws2) in
+    ((MTyIncomplete,name),us)
+ 
+  "resource":name:ws2 -> case ws2 of
+    "reuse":m:_ -> ((MTyResource,name),[(m,MUReuse)])
+    m:"with":ms -> ((MTyResource,name),(m,MUOther):[(n,MUComplete) | n <- ms])
+    ms -> ((MTyResource,name),[(n,MUOther) | n <- ms])
+
+  "instance":name:m:ws2 -> case ws2 of
+    "reuse":n:_ -> ((MTyResource,name),(m,MUInstance):[(n,MUReuse)])
+    n:"with":ms -> 
+      ((MTyResource,name),(m,MUInstance):(n,MUComplete):[(n,MUOther) | n <- ms])
+    ms -> ((MTyResource,name),(m,MUInstance):[(n,MUOther) | n <- ms])
+
+  _:name:ws2 -> case ws2 of
+    "reuse":m:_ -> ((MTyOther,name),[(m,MUReuse)])
+    m:n:"with":ms -> 
+      ((MTyOther,name),(m,MUInstance):(n,MUOther):[(n,MUComplete) | n <- ms])
+    m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms])
+    ms -> ((MTyOther,name),[(n,MUOther) | n <- ms])
+
 unComm s = case s of
       '-':'-':cs -> unComm $ dropWhile (/='\n') cs
       '{':'-':cs -> dpComm cs

src/GF/Infra/UseIO.hs

@@ -57,6 +57,10 @@ readFileIf f = catch (readFile f) (\_ -> reportOn f) where
    putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string")
    return ""
 
+type FileName = String
+type InitPath = String
+type FullPath = String
+
 getFilePath :: [FilePath] -> String -> IO (Maybe FilePath)
 getFilePath paths file = get paths where
   get []     = putStrLnFlush ("file" +++ file +++ "not found") >> return Nothing
@@ -104,6 +108,9 @@ justFileName = reverse . takeWhile (/='/') . reverse
 suffixFile :: String -> FilePath -> FilePath
 suffixFile suff file = file ++ "." ++ suff
 
+justModuleName :: FilePath -> String
+justModuleName = fileBody . justFileName
+
 --
 
 getLineWell :: IO String -> IO String

src/GF/System/Arch.hs

@@ -1,6 +1,6 @@
 module Arch (
  myStdGen, prCPU, selectLater, modifiedFiles, ModTime, getModTime,getNowTime,
- welcomeArch, fetchCommand) where
+ welcomeArch, fetchCommand, laterModTime) where
 
 import Time
 import Random
@@ -52,20 +52,31 @@ selectLater x y = do
           ty <- getModificationTime y
           return $ if tx < ty then y else x
 
--- a file is considered as modified also if it has not been read yet
+-- a file is considered modified also if it has not been read yet
+-- new 23/2/2004: the environment ofs has just module names
 
 modifiedFiles :: [(FilePath,ModTime)] -> [FilePath] -> IO [FilePath]
-modifiedFiles ofs fs = print (map fst ofs) >> filterM isModified fs where
-  isModified file = case lookup file ofs of
+modifiedFiles ofs fs = do
+  filterM isModified fs
+ where
+  isModified file = case lookup (justModName file) ofs of
     Just to -> do
-      t <- getModTime file
+      t <- getModificationTime file
       return $ to < t
     _ -> return True
 
+  justModName = 
+    reverse . takeWhile (/='/') . tail . dropWhile (/='.') . reverse
+
 type ModTime = ClockTime
 
-getModTime :: FilePath -> IO ModTime
-getModTime = getModificationTime
+laterModTime :: ModTime -> ModTime -> Bool
+laterModTime = (>)
+
+getModTime :: FilePath -> IO (Maybe ModTime)
+getModTime f = do
+  b <- doesFileExist f
+  if b then (getModificationTime f >>= return . Just) else return Nothing
 
 getNowTime :: IO ModTime
 getNowTime = getClockTime

src/Today.hs

@@ -1 +1 @@
-module Today where today = "Thu Jan 29 13:42:01 CET 2004"
+module Today where today = "Thu Feb 26 16:08:20 CET 2004"