diff --git a/src/GF/Devel/Compile.hs b/src/GF/Devel/Compile.hs index 69062457a..36bee5f2a 100644 --- a/src/GF/Devel/Compile.hs +++ b/src/GF/Devel/Compile.hs @@ -30,6 +30,7 @@ import GF.Devel.Arch import Control.Monad import System.Directory import System.FilePath +import qualified Data.Map as Map batchCompile :: Options -> [FilePath] -> IOE SourceGrammar batchCompile opts files = do @@ -72,7 +73,7 @@ compileModule opts1 env file = do let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ())) ioeIOIf $ putStrLn $ "module search path:" +++ show ps ---- let sgr = snd env - let rfs = [] ---- files already in memory and their read times + let rfs = Map.empty ---- files already in memory and their read times let file' = if useFileOpt then takeFileName file else file -- to find file itself files <- getAllFiles opts ps rfs file' ioeIOIf $ putStrLn $ "files to read:" +++ show files ---- 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 + 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 _ = [] - -- 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 + -- | 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.") - ds2 <- ioeIO $ mapM (selectFormat opts env) pds1 + let mb_envmod = Map.lookup name env + (st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime - let ds4 = needCompile opts (map fst ds0) ds2 - return ds4 + 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 --- to decide whether to read gf or gfo, or if in env; returns full file path + 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) +data CompStatus = + CSComp -- compile: read gf + | CSRead -- read gfo + | CSEnv -- gfo is in env + deriving Eq -type ModuleHeader = ((ModTyp,ModName),[(ModName,ModUse)]) +type ModuleInfo = (ModName,CompStatus,Maybe ClockTime,[ModName],InitPath) -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 + +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 -