improved make facility: remember state if fails; does not need source

src/GF/API.hs

@@ -125,8 +125,8 @@ string2GFCat = string2CFCat
 
 optFile2grammar :: Options -> FilePath -> IOE GFGrammar
 optFile2grammar os f = do
-  gr <- compileModule os emptyShellState f
-  ioeErr $ grammar2stateGrammar os (fst gr)
+  ((_,_,gr),_) <- compileModule os emptyShellState f
+  ioeErr $ grammar2stateGrammar os gr
 
 optFile2grammarE :: Options -> FilePath -> IOE GFGrammar
 optFile2grammarE = optFile2grammar

src/GF/API/IOGrammar.hs

@@ -39,8 +39,8 @@ string2annotTree gr m = annotate gr . string2absTerm (prt m) ---- prt
 shellStateFromFiles :: Options -> ShellState -> FilePath -> IOE ShellState
 shellStateFromFiles opts st file = case fileSuffix file of
   "gfcm" -> do
-     (_,_,cgr) <- compileOne opts (compileEnvShSt st []) file
-     ioeErr $ updateShellState opts st (cgr,(emptyMGrammar,[]))
+     cenv <- compileOne opts (compileEnvShSt st []) file
+     ioeErr $ updateShellState opts st cenv
   s | elem s ["cf","ebnf"] -> do
      let osb = addOptions (options [beVerbose]) opts
      grts <- compileModule osb st file

src/GF/Compile/Compile.hs

@@ -53,8 +53,8 @@ batchCompileOld f = compileOld defOpts f
 -- As for path: if it is read from file, the file path is prepended to each name.
 -- If from command line, it is used as it is.
 
-compileModule :: Options -> ShellState -> FilePath -> 
-                 IOE (GFC.CanonGrammar, (SourceGrammar,[(FilePath,ModTime)]))
+compileModule :: Options -> ShellState -> FilePath -> IOE TimedCompileEnv
+----             IOE (GFC.CanonGrammar, (SourceGrammar,[(FilePath,ModTime)]))
 
 compileModule opts st0 file | 
      oElem showOld opts || 
@@ -68,15 +68,17 @@ compileModule opts st0 file |
               else putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
   let mods = modules grammar1
   let env = compileEnvShSt st0 []
-  (_,sgr,cgr) <- foldM (comp putp path) env mods
-  return $ (reverseModules cgr,       -- to preserve dependency order
-            (reverseModules sgr,[]))
+  foldM (comp putp path) env mods
+----  (_,sgr,cgr) <- foldM (comp putp path) env mods
+----  return $ (reverseModules cgr,       -- to preserve dependency order
+----            (reverseModules sgr,[]))
  where
    suff = fileSuffix file
    comp putp path env sm0 = do
-     (k',sm)  <- makeSourceModule opts env sm0
+     (k',sm)  <- makeSourceModule opts (fst env) sm0
      cm  <- putp "  generating code... " $ generateModuleCode opts path sm
-     extendCompileEnvInt env (k',sm,cm)
+     ft <- getReadTimes file ---
+     extendCompileEnvInt env (k',sm,cm) ft
 
 compileModule opts1 st0 file = do
   opts0 <- ioeIO $ getOptionsFromFile file
@@ -98,6 +100,11 @@ compileModule opts1 st0 file = do
   let names = map justModuleName files
   ioeIOIf $ putStrLn $ "modules to include:" +++ show names ----
   let env0 = compileEnvShSt st names
+  (e,mm) <- foldIOE (compileOne opts) env0 files
+  maybe (return ()) putStrLnE mm
+  return e
+
+{- ----
   (_,sgr,cgr) <- foldM (compileOne opts) env0 files
   t <- ioeIO getNowTime
   return $ (reverseModules cgr,       -- to preserve dependency order
@@ -105,12 +112,20 @@ compileModule opts1 st0 file = do
              [(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
+-}
+
+getReadTimes file = do
+  t <- ioeIO getNowTime
+  let m = justModuleName file
+  return $ (m,t) : [(resModName m,t) | not (isGFC file)]
+
+compileEnvShSt :: ShellState -> [ModName] -> TimedCompileEnv
+compileEnvShSt st fs = ((0,sgr,cgr),fts) where
   cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i]
   sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i]
   notInc i = notElem (prt i) $ map fileBody fs
   notIns i = notElem (prt i) $ map fileBody fs
+  fts = readFiles st
 
 pathListOpts :: Options -> [InitPath]
 pathListOpts opts = maybe [""] pFilePaths $ getOptVal opts pathList
@@ -128,18 +143,20 @@ keepResModules opts gr =
 
 type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar)
 
-emptyCompileEnv :: CompileEnv
-emptyCompileEnv = (0,emptyMGrammar,emptyMGrammar)
+emptyCompileEnv :: TimedCompileEnv
+emptyCompileEnv = ((0,emptyMGrammar,emptyMGrammar),[])
 
-extendCompileEnvInt (_,MGrammar ss, MGrammar cs) (k,sm,cm) = 
-  return (k,MGrammar (sm:ss), MGrammar (cm:cs)) --- reverse later
+extendCompileEnvInt ((_,MGrammar ss, MGrammar cs),fts) (k,sm,cm) ft = 
+  return ((k,MGrammar (sm:ss), MGrammar (cm:cs)),ft++fts) --- reverse later
 
-extendCompileEnv (k,s,c) (sm,cm) = extendCompileEnvInt (k,s,c) (k,sm,cm)
+extendCompileEnv e@((k,_,_),_) (sm,cm) = extendCompileEnvInt e (k,sm,cm)
 
-extendCompileEnvCanon (k,s,c) cgr = 
-  return (k,s, MGrammar (modules cgr ++ modules c))
+extendCompileEnvCanon ((k,s,c),fts) cgr ft = 
+  return ((k,s, MGrammar (modules cgr ++ modules c)),ft++fts)
 
-compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
+type TimedCompileEnv = (CompileEnv,[(FilePath,ModTime)])
+
+compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv
 compileOne opts env file = do
 
   let putp = putPointE opts
@@ -151,29 +168,33 @@ compileOne opts env file = do
     -- for multilingual canonical gf, just read the file and update environment
     "gfcm" -> do
        cgr <- putp ("+ reading" +++ file) $ getCanonGrammar file
-       extendCompileEnvCanon env cgr
+       ft <- getReadTimes file
+       extendCompileEnvCanon env cgr ft
 
     -- for canonical gf, read the file and update environment, also source env
     "gfc" -> do
        cm <- putp ("+ reading" +++ file) $ getCanonModule file
        sm <- ioeErr $ CG.canon2sourceModule cm
-       extendCompileEnv env (sm, cm)
+       ft <- getReadTimes file
+       extendCompileEnv env (sm, cm) ft
 
     -- for compiled resource, parse and organize, then update environment
     "gfr" -> do
        sm0  <- putp ("| parsing" +++ file) $ getSourceModule file
-       let mos = case env of (_,gr,_) -> modules gr
+       let mos = case env of ((_,gr,_),_) -> modules gr
        sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm0
        let gfc = gfcFile name 
        cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
-       extendCompileEnv env (sm,cm)
+       ft <- getReadTimes file
+       extendCompileEnv env (sm,cm) ft
 
     -- for gf source, do full compilation
     _ -> do
        sm0 <- putp ("- parsing" +++ file) $ getSourceModule file
-       (k',sm)  <- makeSourceModule opts env sm0
+       (k',sm)  <- makeSourceModule opts (fst env) sm0
        cm  <- putp "  generating code... " $ generateModuleCode opts path sm
-       extendCompileEnvInt env (k',sm,cm)
+       ft <- getReadTimes file
+       extendCompileEnvInt env (k',sm,cm) ft
 
 -- dispatch reused resource at early stage
 
@@ -268,7 +289,7 @@ compileOld opts file = do
   let putp = putPointE opts
   grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
   files <- mapM writeNewGF $ modules grammar1
-  (_,_,grammar) <- foldM (compileOne opts) emptyCompileEnv files
+  ((_,_,grammar),_) <- foldM (compileOne opts) emptyCompileEnv files
   return grammar
 
 writeNewGF :: SourceModule -> IOE FilePath

src/GF/Compile/ShellState.hs

@@ -107,16 +107,17 @@ cncModuleIdST = stateGrammarST
 
 grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState 
 grammar2shellState opts (gr,sgr) = 
-  updateShellState opts emptyShellState (gr,(sgr,[]))
+  updateShellState opts emptyShellState ((0,sgr,gr),[]) --- is 0 safe?
 
 -- update a shell state from a canonical grammar
 
 updateShellState :: Options -> ShellState -> 
-                    (CanonGrammar,(G.SourceGrammar,[(FilePath,ModTime)])) -> 
+                    ((Int,G.SourceGrammar,CanonGrammar),[(FilePath,ModTime)]) ->
+               ---- (CanonGrammar,(G.SourceGrammar,[(FilePath,ModTime)])) -> 
                     Err ShellState 
-updateShellState opts sh (gr,(sgr,rts)) = do 
+updateShellState opts sh ((_,sgr,gr),rts) = do 
   let cgr0 = M.updateMGrammar (canModules sh) gr
-      a' = ifNull Nothing (return . last) $ allAbstracts cgr0
+      a' = ifNull Nothing (return . head) $ allAbstracts cgr0
   abstr0 <- case abstract sh of
     Just a -> do
       --- test that abstract is compatible
@@ -124,7 +125,7 @@ updateShellState opts sh (gr,(sgr,rts)) = do
     _ -> return a'
   let cgr = filterAbstracts abstr0 cgr0
   let concrs = maybe [] (allConcretes cgr) abstr0
-      concr0 = ifNull Nothing (return . last) concrs
+      concr0 = ifNull Nothing (return . head) concrs
       notInrts f = notElem f $ map fst rts
   cfs <- mapM (canon2cf opts cgr) concrs --- would not need to update all...
 
@@ -149,7 +150,7 @@ updateShellState opts sh (gr,(sgr,rts)) = do
     cfs        = zip concrs cfs,
     pInfos     = pinfos, -- peb 8/6
     morphos    = zip concrs (map (mkMorpho cgr) concrs),
-    gloptions  = opts,
+    gloptions  = gloptions sh, --- opts, -- this would be command-line options
     readFiles  = [ft | ft@(f,_) <- readFiles sh, notInrts f] ++ rts,
     absCats    = csi,
     statistics = [StDepTypes deps,StBoundVars binds]
@@ -216,22 +217,22 @@ grammar2stateGrammar opts gr = do
 allAbstracts :: CanonGrammar -> [Ident]
 allAbstracts gr = [i | (i,M.ModMod m) <- M.modules gr, M.mtype m == M.MTAbstract]
 
--- the last abstract in dependency order
+-- the last abstract in dependency order (head of list)
 greatestAbstract :: CanonGrammar -> Maybe Ident
 greatestAbstract gr = case allAbstracts gr of
   [] -> Nothing
-  a -> return $ last a
+  a -> return $ head a
 
 -- all resource modules
 allResources :: G.SourceGrammar -> [Ident]
 allResources gr = [i | (i,M.ModMod m) <- M.modules gr, M.mtype m == M.MTResource]
 
 
--- the last resource in dependency order
+-- the greatest resource in dependency order
 greatestResource :: G.SourceGrammar -> Maybe Ident
 greatestResource gr = case allResources gr of
   [] -> Nothing
-  a -> return $ last a
+  a -> return $ head a
 
 resourceOfShellState :: ShellState -> Maybe Ident
 resourceOfShellState = greatestResource . srcModules

src/GF/Data/Operations.hs

@@ -122,6 +122,15 @@ mapErrN maxN f xs = Ok (ys, unlines (errHdr : ss2))
     nss = length ss
     fxs = map f xs
 
+-- like foldM, but also return the latest value if fails
+
+foldErr :: (a -> b -> Err a) -> a -> [b] -> Err (a, Maybe String)
+foldErr f s xs = case xs of
+  [] -> return (s,Nothing)
+  x:xx -> case f s x of
+    Ok v  -> foldErr f v xx
+    Bad m -> return $ (s, Just m)
+
 -- !! with the error monad
 (!?) :: [a] -> Int -> Err a
 xs !? i = foldr (const . return) (Bad "too few elements in list") $ drop i xs

src/GF/Infra/ReadFiles.hs

@@ -13,10 +13,12 @@ import Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime)
 import Option
 import Operations
 import UseIO
+
 import System
 import Char
 import Monad
 import List
+import Directory
 
 -- make analysis for GF grammar modules. AR 11/6/2003--24/2/2004
 
@@ -76,6 +78,7 @@ selectFormat env (p,f) = do
         (Just tenv,_,_,Just tgf) | laterModTime tenv tgf -> CSEnvR
         (_,Just tenv,_,Just tgf) | laterModTime tenv tgf -> CSEnv
         (_,_,Just tgfc,Just tgf) | laterModTime tgfc tgf -> CSRead
+        (_,_,_,        Nothing) -> CSRead -- source does not exist
         _ -> CSComp
   return $ (f, (p,stat))
 
@@ -126,9 +129,9 @@ needCompile opts headers sfiles0 = paths $ res $ mark $ iter changed where
   res cs = map mkRes cs where
     mkRes x@(f,(path,st)) | elem st [CSRead,CSEnv] = case typ f of
       t | elem t [MTyResource,MTyIncResource] &&
-          not (null [m | (m,(_,CSComp)) <- cs,
+          (not (null [m | (m,(_,CSComp)) <- cs,
                                    Just ms <- [lookup m allDeps], elem f ms])
-                    || oElem retainOpers opts
+                    || oElem retainOpers opts)
         -> (f,(path,CSRes))
       _ -> x
     mkRes x = x
@@ -154,9 +157,9 @@ resModName = ('#':)
 
 getImports :: [InitPath] -> FileName -> IOE [(ModuleHeader,InitPath)]
 getImports ps = get [] where
-  get ds file = do
-    let name = fileBody file
-    (p,s) <- readFileIfPath ps $ file
+  get ds file0 = do
+    let name = fileBody file0
+    (p,s) <- tryRead name
     let ((typ,mname),imps) = importsOfFile s
     ioeErr $ testErr  (mname == name) $ 
              "module name differs from file name in" +++ name
@@ -164,8 +167,17 @@ getImports ps = get [] where
       _ | 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
+        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 return (gfcFile name) -- gfc next
+
+    readFileIfPath ps $ file
+
+
 
 -- internal module dep information
 

src/GF/Infra/UseIO.hs

@@ -76,6 +76,11 @@ readFileIfPath paths file = do
       return (justInitPath pfile,s)
     _ -> ioeErr $ Bad ("File " ++ file ++ " does not exist.")
 
+doesFileExistPath :: [FilePath] -> String -> IOE Bool
+doesFileExistPath paths file = do
+  mpfile <- ioeIO $ getFilePath paths file
+  return $ maybe False (const True) mpfile
+
 pFilePaths :: String -> [FilePath]
 pFilePaths s = case span (/=':') s of
   (f,_:cs) -> f : pFilePaths cs
@@ -179,6 +184,15 @@ ioeBad = ioe . return . Bad
 useIOE :: a -> IOE a -> IO a
 useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return 
 
+foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String)
+foldIOE f s xs = case xs of
+  [] -> return (s,Nothing)
+  x:xx -> do
+    ev <- ioeIO $ appIOE (f s x) 
+    case ev of 
+      Ok v  -> foldIOE f v xx
+      Bad m -> return $ (s, Just m)
+
 putStrLnE :: String -> IOE ()
 putStrLnE = ioeIO . putStrLnFlush 
 

src/Today.hs

@@ -1 +1 @@
-module Today where today = "Thu Jun 10 16:36:31 CEST 2004"
+module Today where today = "Tue Jun 15 16:37:14 CEST 2004"