diff --git a/src/GF/API.hs b/src/GF/API.hs index 77bd71849..c3d160bcd 100644 --- a/src/GF/API.hs +++ b/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 diff --git a/src/GF/API/IOGrammar.hs b/src/GF/API/IOGrammar.hs index 83823be16..7d0f0f15f 100644 --- a/src/GF/API/IOGrammar.hs +++ b/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 diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs index cfe8376ec..fa2e65a3c 100644 --- a/src/GF/Compile/Compile.hs +++ b/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 diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs index bc5bc1d33..6a25ed1cb 100644 --- a/src/GF/Compile/ShellState.hs +++ b/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 diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs index 9c374fe83..9bed80392 100644 --- a/src/GF/Data/Operations.hs +++ b/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 diff --git a/src/GF/Infra/ReadFiles.hs b/src/GF/Infra/ReadFiles.hs index c4076ba8c..b1440ee4b 100644 --- a/src/GF/Infra/ReadFiles.hs +++ b/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 diff --git a/src/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs index 347af2adb..243ead306 100644 --- a/src/GF/Infra/UseIO.hs +++ b/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 diff --git a/src/Today.hs b/src/Today.hs index 2a57a3e39..d6f0b1cbb 100644 --- a/src/Today.hs +++ b/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"