forked from GitHub/gf-core
223 lines
8.6 KiB
Haskell
223 lines
8.6 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : ReadFiles
|
|
-- Maintainer : AR
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/11/11 23:24:34 $
|
|
-- > CVS $Author: aarne $
|
|
-- > CVS $Revision: 1.26 $
|
|
--
|
|
-- Decide what files to read as function of dependencies and time stamps.
|
|
--
|
|
-- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004
|
|
--
|
|
-- to find all files that have to be read, put them in dependency order, and
|
|
-- decide which files need recompilation. Name @file.gf@ is returned for them,
|
|
-- and @file.gfo@ otherwise.
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Compile.ReadFiles
|
|
( getAllFiles,ModName,ModEnv,importsOfModule,
|
|
gfoFile,gfFile,isGFO,gf2gfo,
|
|
getOptionsFromFile) where
|
|
|
|
import GF.Infra.UseIO
|
|
import GF.Infra.Option
|
|
import GF.Infra.Ident
|
|
import GF.Infra.Modules
|
|
import GF.Data.Operations
|
|
import qualified GF.Source.AbsGF as S
|
|
import GF.Grammar.Lexer
|
|
import GF.Grammar.Parser
|
|
import GF.Grammar.Grammar
|
|
import GF.Grammar.Binary
|
|
|
|
import Control.Monad
|
|
import Data.Char
|
|
import Data.List
|
|
import Data.Maybe(isJust)
|
|
import qualified Data.ByteString.Char8 as BS
|
|
import qualified Data.Map as Map
|
|
import System.Time
|
|
import System.Directory
|
|
import System.FilePath
|
|
import Text.PrettyPrint
|
|
|
|
type ModName = String
|
|
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
|
|
ds <- liftM reverse $ get [] [] (justModuleName file)
|
|
ioeIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_) <- ds]
|
|
return $ paths ds
|
|
where
|
|
-- construct list of paths to read
|
|
paths ds = concatMap mkFile ds
|
|
where
|
|
mkFile (f,st,gfTime,gfoTime,p) =
|
|
case st of
|
|
CSComp -> [p </> gfFile f]
|
|
CSRead | isJust gfTime -> [gf2gfo opts (p </> gfFile f)]
|
|
| otherwise -> [p </> gfoFile f]
|
|
CSEnv -> []
|
|
|
|
-- | 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,_,t1,_,_) <- ds, elem f imps && liftM2 (>=) t0 t1 /= Just True]
|
|
= (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 $ getFilePath ps (gfFile name)
|
|
case mb_gfFile of
|
|
Just gfFile -> do gfTime <- ioeIO $ getModificationTime gfFile
|
|
mb_gfoTime <- ioeIO $ catch (liftM Just $ getModificationTime (gf2gfo opts gfFile))
|
|
(\_->return Nothing)
|
|
return (gfFile, Just gfTime, mb_gfoTime)
|
|
Nothing -> do mb_gfoFile <- ioeIO $ getFilePath (maybe id (:) (flag optGFODir opts) ps) (gfoFile name)
|
|
case mb_gfoFile of
|
|
Just gfoFile -> do gfoTime <- ioeIO $ getModificationTime gfoFile
|
|
return (gfoFile, Nothing, Just gfoTime)
|
|
Nothing -> ioeErr $ Bad (render (text "File" <+> text (gfFile name) <+> text "does not exist." $$
|
|
text "searched in:" <+> vcat (map text ps)))
|
|
|
|
|
|
let mb_envmod = Map.lookup name env
|
|
(st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime
|
|
|
|
(mname,imps) <- case st of
|
|
CSEnv -> return (name, maybe [] snd mb_envmod)
|
|
CSRead -> ioeIO $ fmap importsOfModule (decodeModHeader ((if isGFO file then id else gf2gfo opts) file))
|
|
CSComp -> do s <- ioeIO $ BS.readFile file
|
|
case runP pModHeader s of
|
|
Left (Pn l c,msg) -> ioeBad (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
|
|
Right mo -> return (importsOfModule mo)
|
|
ioeErr $ testErr (mname == name)
|
|
("module name" +++ mname +++ "differs from file name" +++ name)
|
|
return (name,st,t,imps,dropFileName file)
|
|
|
|
isGFO :: FilePath -> Bool
|
|
isGFO = (== ".gfo") . takeExtensions
|
|
|
|
gfoFile :: FilePath -> FilePath
|
|
gfoFile f = addExtension f "gfo"
|
|
|
|
gfFile :: FilePath -> FilePath
|
|
gfFile f = addExtension f "gf"
|
|
|
|
gf2gfo :: Options -> FilePath -> FilePath
|
|
gf2gfo opts file = maybe (gfoFile (dropExtension file))
|
|
(\dir -> dir </> gfoFile (dropExtension (takeFileName file)))
|
|
(flag optGFODir opts)
|
|
|
|
-- 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
|
|
(_,Just tgfo,Nothing) -> (CSRead,Just tgfo) -- source does not exist
|
|
_ -> (CSComp,Nothing)
|
|
where
|
|
fromComp = flag optRecomp opts == NeverRecomp
|
|
fromSrc = flag optRecomp opts == AlwaysRecomp
|
|
|
|
|
|
-- internal module dep information
|
|
|
|
|
|
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 :: SourceModule -> (ModName,[ModName])
|
|
importsOfModule (m,mi) = (modName m,depModInfo mi [])
|
|
where
|
|
depModInfo mi =
|
|
depModType (mtype mi) .
|
|
depExtends (extend mi) .
|
|
depWith (mwith mi) .
|
|
depExDeps (mexdeps mi).
|
|
depOpens (opens mi)
|
|
|
|
depModType (MTAbstract) xs = xs
|
|
depModType (MTResource) xs = xs
|
|
depModType (MTInterface) xs = xs
|
|
depModType (MTConcrete m2) xs = modName m2:xs
|
|
depModType (MTInstance m2) xs = modName m2:xs
|
|
depModType (MTTransfer o1 o2) xs = depOpen o1 (depOpen o2 xs)
|
|
|
|
depExtends es xs = foldr depInclude xs es
|
|
|
|
depWith (Just (m,_,is)) xs = modName m : depInsts is xs
|
|
depWith Nothing xs = xs
|
|
|
|
depExDeps eds xs = map modName eds ++ xs
|
|
|
|
depOpens os xs = foldr depOpen xs os
|
|
|
|
depInsts is xs = foldr depInst xs is
|
|
|
|
depInclude (m,_) xs = modName m:xs
|
|
|
|
depOpen (OSimple n ) xs = modName n:xs
|
|
depOpen (OQualif _ n) xs = modName n:xs
|
|
|
|
depInst (m,n) xs = modName m:modName n:xs
|
|
|
|
modName = prIdent
|
|
|
|
-- | options can be passed to the compiler by comments in @--#@, in the main file
|
|
getOptionsFromFile :: FilePath -> IOE Options
|
|
getOptionsFromFile file = do
|
|
s <- ioe $ catch (fmap Ok $ BS.readFile file)
|
|
(\_ -> return (Bad $ "File " ++ file ++ " does not exist"))
|
|
let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s
|
|
fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls
|
|
ioeErr $ parseModuleOptions fs
|
|
|
|
getFilePath :: [FilePath] -> String -> IO (Maybe FilePath)
|
|
getFilePath paths file = get paths
|
|
where
|
|
get [] = return Nothing
|
|
get (p:ps) = do
|
|
let pfile = p </> file
|
|
exist <- doesFileExist pfile
|
|
if not exist
|
|
then get ps
|
|
else do pfile <- canonicalizePath pfile
|
|
return (Just pfile)
|