summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/GF/API.hs4
-rw-r--r--src/GF/API/IOGrammar.hs4
-rw-r--r--src/GF/Compile/Compile.hs69
-rw-r--r--src/GF/Compile/ShellState.hs21
-rw-r--r--src/GF/Data/Operations.hs9
-rw-r--r--src/GF/Infra/ReadFiles.hs24
-rw-r--r--src/GF/Infra/UseIO.hs14
-rw-r--r--src/Today.hs2
8 files changed, 102 insertions, 45 deletions
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),fts) (k,sm,cm) ft =
+ return ((k,MGrammar (sm:ss), MGrammar (cm:cs)),ft++fts) --- reverse later
-extendCompileEnvInt (_,MGrammar ss, MGrammar cs) (k,sm,cm) =
- return (k,MGrammar (sm:ss), MGrammar (cm:cs)) --- reverse later
+extendCompileEnv e@((k,_,_),_) (sm,cm) = extendCompileEnvInt e (k,sm,cm)
-extendCompileEnv (k,s,c) (sm,cm) = extendCompileEnvInt (k,s,c) (k,sm,cm)
+extendCompileEnvCanon ((k,s,c),fts) cgr ft =
+ return ((k,s, MGrammar (modules cgr ++ modules c)),ft++fts)
-extendCompileEnvCanon (k,s,c) cgr =
- return (k,s, MGrammar (modules cgr ++ modules c))
+type TimedCompileEnv = (CompileEnv,[(FilePath,ModTime)])
-compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
+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"
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:20:54 +0000