completely rewriten readFiles implementation. Much simpler and more efficient

1 files changed, 115 insertions, 244 deletions

diff --git a/src/GF/Devel/ReadFiles.hs b/src/GF/Devel/ReadFiles.hs
index 0637b48f1..8c4954a01 100644
--- a/src/GF/Devel/ReadFiles.hs
+++ b/src/GF/Devel/ReadFiles.hs
@@ -18,176 +18,98 @@
 -- and @file.gfo@ otherwise.
 -----------------------------------------------------------------------------
 
-module GF.Devel.ReadFiles (-- * Heading 1
-		  getAllFiles,fixNewlines,ModName,getOptionsFromFile,
-		  -- * Heading 2
-		  gfoFile,gfFile,isGFO,resModName,isOldFile
-		 ) where
-
-import GF.Devel.Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime)
+module GF.Devel.ReadFiles 
+           ( getAllFiles,ModName,getOptionsFromFile,importsOfModule,
+             gfoFile,gfFile,isGFO ) where
 
 import GF.Infra.Option
 import GF.Data.Operations
 import GF.Devel.UseIO
-
-import Data.Char
-import Control.Monad
-import Data.List
-import qualified Data.ByteString.Char8 as BS
 import GF.Source.AbsGF hiding (FileName)
 import GF.Source.LexGF
 import GF.Source.ParGF
 
+import Control.Monad
+import Data.Char
+import Data.List
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.Map as Map
 import System
+import System.Time
 import System.Directory
 import System.FilePath
 
 type ModName = String
-type ModEnv  = [(ModName,ModTime)]
+type ModEnv  = Map.Map ModName (ClockTime,[ModName])
 
+
+-- | Returns a list of all files to be compiled in topological order i.e.
+-- the low level (leaf) modules are first.
 getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath]
 getAllFiles opts ps env file = do
-
   -- read module headers from all files recursively
-  ds0  <- getImports ps file
-  let ds = [((snd m,map fst ms),p) | ((m,ms),p) <- ds0]
-  if oElem beVerbose opts 
-    then ioeIO $ putStrLn $ "all modules:" +++ show (map (fst . fst) ds)
+  ds <- liftM reverse $ get [] [] (justModuleName file)
+  if oElem beVerbose opts
+    then ioeIO $ putStrLn $ "all modules:" +++ show [name | (name,_,_,_,_) <- ds]
     else return ()
-    -- 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
-
-  -- 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]]
-  if oElem fromSource opts 
-    then return [gfFile (p </> f) | (p,f) <- pds1]
-    else do
-
-
-    ds2 <- ioeIO $ mapM (selectFormat opts env) pds1
-
-    let ds4 = needCompile opts (map fst ds0) ds2
-    return ds4
-
--- to decide whether to read gf or gfo, or if in env; returns full file path
+  return $ paths ds
+  where
+    -- construct list of paths to read
+    paths cs = [mk (p </> f) | (f,st,_,_,p) <- cs, mk <- mkFile st]
+      where
+        mkFile CSComp = [gfFile ]
+        mkFile CSRead = [gfoFile]
+        mkFile _      = []
+
+    -- | traverses the dependency graph and returns a topologicaly sorted
+    -- list of ModuleInfo. An error is raised if there is circular dependency
+    get :: [ModName]          -- ^ keeps the current path in the dependency graph to avoid cycles
+        -> [ModuleInfo]       -- ^ a list of already traversed modules
+        -> ModName            -- ^ the current module
+        -> IOE [ModuleInfo]   -- ^ the final 
+    get trc ds name
+      | name `elem` trc = ioeErr $ Bad $ "circular modules" +++ unwords trc
+      | (not . null) [n | (n,_,_,_,_) <- ds, name == n]     --- file already read
+                        = return ds
+      | otherwise       = do
+           (name,st0,t0,imps,p) <- findModule name
+           ds <- foldM (get (name:trc)) ds imps
+           let (st,t) | (not . null) [f | (f,CSComp,_,_,_) <- ds, elem f imps]
+                                  = (CSComp,Nothing)
+                      | otherwise = (st0,t0)
+           return ((name,st,t,imps,p):ds)
+
+    -- searches for module in the search path and if it is found
+    -- returns 'ModuleInfo'. It fails if there is no such module
+    findModule :: ModName -> IOE ModuleInfo
+    findModule name = do
+      (file,gfTime,gfoTime) <- do
+          mb_gfFile <- ioeIO $ getFilePathMsg "" ps (gfFile name)
+          case mb_gfFile of
+            Just gfFile -> do gfTime  <- ioeIO $ getModificationTime gfFile
+                              mb_gfoTime <- ioeIO $ catch (liftM Just $ getModificationTime (replaceExtension gfFile "gfo"))
+                                                        (\_->return Nothing)
+                              return (gfFile, Just gfTime, mb_gfoTime)
+            Nothing     -> do mb_gfoFile <- ioeIO $ getFilePathMsg "" ps (gfoFile name)
+                              case mb_gfoFile of
+                                Just gfoFile -> do gfoTime <- ioeIO $ getModificationTime gfoFile
+                                                   return (gfoFile, Nothing, Just gfoTime)
+                                Nothing      -> ioeErr $ Bad ("File " ++ gfFile name ++ " does not exist.")
+
+
+      let mb_envmod = Map.lookup name env
+          (st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime
+
+      imps <- if st == CSEnv
+                then return (maybe [] snd mb_envmod)
+                else do s <- ioeIO $ BS.readFile file
+                        (mname,imps) <- ioeErr ((liftM importsOfModule . pModHeader . myLexer) s)
+                        ioeErr $ testErr  (mname == name)
+                                          ("module name" +++ mname +++ "differs from file name" +++ name)
+                        return imps
+
+      return (name,st,t,imps,dropFileName file)
 
-data CompStatus =
-   CSComp -- compile: read gf
- | CSRead -- read gfo
- | CSEnv  -- gfo is in env
- | CSEnvR -- also gfr is in env
- | CSDont -- don't read at all
- | CSRes  -- read gfr
-  deriving (Eq,Show)
-
--- for gfo, we also return ModTime to cope with earlier compilation of libs
-
-selectFormat :: Options -> ModEnv -> (InitPath,ModName) -> 
-                IO (ModName,(InitPath,(CompStatus,Maybe ModTime)))
-
-selectFormat opts env (p,f) = do
-  let pf = p </> f
-  let mtenv = lookup f env   -- Nothing if f is not in env
-  let rtenv = lookup (resModName f) env
-  let fromComp = oElem isCompiled opts -- i -gfo
-  mtgfc <- getModTime $ gfoFile pf
-  mtgf  <- getModTime $ gfFile pf
-  let stat = case (rtenv,mtenv,mtgfc,mtgf) of
-        (_,Just tenv,_,_)        | fromComp -> (CSEnv, Just tenv)
-        (_,_,Just tgfc,_)        | fromComp -> (CSRead,Just tgfc)
-        (Just tenv,_,_,Just tgf) | laterModTime tenv tgf -> (CSEnvR,Just tenv)
-        (_,Just tenv,_,Just tgf) | laterModTime tenv tgf -> (CSEnv, Just tenv)
-        (_,_,Just tgfc,Just tgf) | laterModTime tgfc tgf -> (CSRead,Just tgfc)
-        (_,Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist
-        (_,_,_,        Nothing) -> (CSRead,Nothing)  -- source does not exist
-        _ -> (CSComp,Nothing)
-  return $ (f, (p,stat))
-
-needCompile :: Options -> 
-               [ModuleHeader] -> 
-               [(ModName,(InitPath,(CompStatus,Maybe ModTime)))] -> [FullPath]
-needCompile opts 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 (fst . 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 = sfiles0 ---- map relevant sfiles0
-  relevant fp@(f,(p,(st,_))) = 
-    let us = uses f
-        isUsed = not (null us)
-    in
-    if not (isUsed && all noComp us) then
-      fp else 
-    if (elem (typ f) [] ---- MTyIncomplete, MTyIncResource]
-        || 
-        (isUsed && all isAux us)) then
-      (f,(p,(CSDont,Nothing))) else
-      fp
-
-  isAux = flip elem [MUReuse,MUInstance,MUComplete] . snd
-  noComp = flip elem [CSRead,CSEnv,CSEnvR] . stat0 . fst
-
-  -- mark as to be compiled those whose gfo is earlier than a deeper gfo
-  sfiles1 = map compTimes sfiles
-  compTimes fp@(f,(p,(_, Just t))) =
-    if any (> t) [t' | Just fs <- [lookup f deps], 
-                       f0 <- fs,
-                       Just (_,(_,Just t')) <- [lookup f0 sfiles]]
-    then (f,(p,(CSComp, Nothing)))
-    else fp
-  compTimes fp = fp
-
-  -- start with the changed files themselves; returns [ModName]
-  changed = [f | (f,(_,(CSComp,_))) <- sfiles1] 
-
-  -- add other files that depend on some changed file; returns [ModName]
-  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, compile if depends on what needs compile
-  -- returns [FullPath]
-  mark cs = [(f,(path,st)) | 
-                (f,(path,(st0,_))) <- sfiles1, 
-                let st = if (elem f cs) then CSComp else st0]
-
-
-  -- Also read res if the option "retain" is present
-  -- Also, if a "with" file has to be compiled, read its mother file from source
-
-  res cs = map mkRes cs where
-    mkRes x@(f,(path,st)) | elem st [CSRead,CSEnv] = case typ f of
-      t | (not (null [m | (m,(_,CSComp)) <- cs,
-                                   Just ms <- [lookup m allDeps], elem f ms])
-                    || oElem retainOpers opts)
-        -> if elem t [MTyResource,MTyIncResource] 
-           then (f,(path,CSRes)) else
-              if t == MTyIncomplete
-              then (f,(path,CSComp)) else
-              x
-      _ -> 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 (p </> f) where
-    mk = case st of
-      CSComp -> gfFile
-      CSRead -> gfoFile
-      CSRes  -> gfoFile ---- gfr
 
 isGFO :: FilePath -> Bool
 isGFO = (== ".gfo") . takeExtensions
@@ -198,70 +120,47 @@ gfoFile f = addExtension f "gfo"
 gfFile :: FilePath -> FilePath
 gfFile f = addExtension f "gf"
 
-resModName :: ModName -> ModName
-resModName = ('#':)
-
--- to get imports without parsing the whole files
-
-getImports :: [InitPath] -> FileName -> IOE [(ModuleHeader,InitPath)]
-getImports ps = get [] where
-  get ds file0 = do
-    let name = justModuleName file0 ---- dropExtension file0
-    (p,s) <- tryRead name
-    ((typ,mname),imps) <- ioeErr (importsOfFile s)
-    let namebody = takeFileName name
-    ioeErr $ testErr  (mname == namebody) $ 
-             "module name" +++ mname +++ "differs from file name" +++ namebody
-    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 
-        foldM get ((((typ,name),imps),p):ds) files
-  tryRead name = do
-    file <- do
-      let file_gf = gfFile name
-      b <- doesFileExistPath ps file_gf                 -- try gf file first
-      if b then return file_gf else do
-          return (gfoFile name)                         -- gfo next
-
-    readFileIfPath ps $ file
 
+-- From the given Options and the time stamps computes
+-- whether the module have to be computed, read from .gfo or
+-- the environment version have to be used
+selectFormat :: Options -> Maybe ClockTime -> Maybe ClockTime -> Maybe ClockTime -> (CompStatus,Maybe ClockTime)
+selectFormat opts mtenv mtgf mtgfo =
+  case (mtenv,mtgfo,mtgf) of
+    (_,_,Just tgf)         | fromSrc  -> (CSComp,Nothing)
+    (Just tenv,_,_)        | fromComp -> (CSEnv, Just tenv)
+    (_,Just tgfo,_)        | fromComp -> (CSRead,Just tgfo)
+    (Just tenv,_,Just tgf) | tenv > tgf -> (CSEnv, Just tenv)
+    (_,Just tgfo,Just tgf) | tgfo > tgf -> (CSRead,Just tgfo)
+    (Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist
+    (_,_,        Nothing) -> (CSRead,Nothing)  -- source does not exist
+    _ -> (CSComp,Nothing)
+  where
+    fromComp = oElem isCompiled opts -- i -gfo
+    fromSrc  = oElem fromSource opts
 
 
 -- internal module dep information
 
-data ModUse =
-   MUReuse
- | MUInstance
- | MUComplete
- | MUOther
-  deriving (Eq,Show)
-
-data ModTyp =
-   MTyResource
- | MTyIncomplete
- | MTyIncResource -- interface, incomplete resource
- | MTyOther
-  deriving (Eq,Show)
-
-type ModuleHeader = ((ModTyp,ModName),[(ModName,ModUse)])
-
-importsOfFile :: BS.ByteString -> Err ModuleHeader
-importsOfFile bs = do
-  (MModule compl typ body) <- (pModHeader . myLexer) bs
-  return $
-      case (compl,modType typ (modBody body [])) of
-            (CMIncompl, ((MTyResource,m),xs)) -> ((MTyIncResource,m),xs)
-            (CMIncompl, ((t,m),xs)) -> ((MTyIncomplete,m),xs)
-            (CMCompl,   v) -> v
+
+data CompStatus =
+   CSComp -- compile: read gf
+ | CSRead -- read gfo
+ | CSEnv  -- gfo is in env
+  deriving Eq
+
+type ModuleInfo = (ModName,CompStatus,Maybe ClockTime,[ModName],InitPath)
+
+ 
+importsOfModule :: ModDef -> (ModName,[ModName])
+importsOfModule (MModule _ typ body) = modType typ (modBody body [])
   where
-    modType (MTAbstract  m)      xs = ((MTyOther,modName m),xs)
-    modType (MTResource m)       xs = ((MTyResource,modName m),xs)
-    modType (MTInterface m)      xs = ((MTyIncResource,modName m),xs)
-    modType (MTConcrete m m2)    xs = ((MTyOther,modName m),(modName m2,MUOther):xs)
-    modType (MTInstance m m2)    xs = ((MTyResource,modName m),(modName m2,MUInstance):xs)
-    modType (MTTransfer m o1 o2) xs = ((MTyOther,modName m),open o1 (open o2 xs))
+    modType (MTAbstract  m)      xs = (modName m,xs)
+    modType (MTResource m)       xs = (modName m,xs)
+    modType (MTInterface m)      xs = (modName m,xs)
+    modType (MTConcrete m m2)    xs = (modName m,modName m2:xs)
+    modType (MTInstance m m2)    xs = (modName m,modName m2:xs)
+    modType (MTTransfer m o1 o2) xs = (modName m,open o1 (open o2 xs))
 
     modBody (MBody e o _)            xs = extend e (opens o xs)
     modBody (MNoBody is)             xs = foldr include xs is
@@ -269,16 +168,16 @@ importsOfFile bs = do
     modBody (MWithBody i os o _)     xs = include i (foldr open (opens o xs) os)
     modBody (MWithE is i os)         xs = foldr include (include i (foldr open xs os)) is
     modBody (MWithEBody is i os o _) xs = foldr include (include i (foldr open (opens o xs) os)) is
-    modBody (MReuse m)               xs = (modName m,MUReuse):xs
+    modBody (MReuse m)               xs = modName m:xs
     modBody (MUnion is)              xs = foldr include xs is
 
-    include (IAll   m)   xs = (modName m,MUOther):xs
-    include (ISome  m _) xs = (modName m,MUOther):xs
-    include (IMinus m _) xs = (modName m,MUOther):xs
+    include (IAll   m)   xs = modName m:xs
+    include (ISome  m _) xs = modName m:xs
+    include (IMinus m _) xs = modName m:xs
 
-    open (OName n)     xs = (modName n,MUComplete):xs
-    open (OQualQO _ n) xs = (modName n,MUComplete):xs
-    open (OQual _ _ n) xs = (modName n,MUComplete):xs
+    open (OName n)     xs = modName n:xs
+    open (OQualQO _ n) xs = modName n:xs
+    open (OQual _ _ n) xs = modName n:xs
 
     extend NoExt    xs = xs
     extend (Ext is) xs = foldr include xs is
@@ -295,31 +194,3 @@ getOptionsFromFile file = do
   s <- readFileIfStrict file
   let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s
   return $ fst $ getOptions "-" $ map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls
-
--- | check if old GF file
-isOldFile :: FilePath -> IO Bool
-isOldFile f = do
-  s <- readFileIfStrict f
-  let toks = myLexer s
-  return $ not (null toks) && old (head toks)
- where
-   old (PT _ (TS t)) = elem t $ words
-     "cat category data def flags fun include lin lincat lindef lintype oper param pattern printname rule"
-   old _ = False
-
-
-
--- | old GF tolerated newlines in quotes. No more supported!
-fixNewlines :: String -> String
-fixNewlines s = case s of
-     '"':cs -> '"':mk cs
-     c  :cs -> c:fixNewlines cs
-     _ -> s
- where
-   mk s = case s of
-     '\\':'"':cs -> '\\':'"': mk cs
-     '"'     :cs -> '"' :fixNewlines cs
-     '\n'    :cs -> '\\':'n': mk cs
-     c       :cs -> c : mk cs
-     _ -> s 
-