---------------------------------------------------------------------- -- | -- 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, findFile,gfImports,gfoImports,VersionTagged(..), parseSource,getOptionsFromFile,getPragmas) where import Prelude hiding (catch) import GF.System.Catch import GF.Infra.UseIO import GF.Infra.Option import GF.Infra.Ident import GF.Data.Operations import GF.Grammar.Lexer import GF.Grammar.Parser import GF.Grammar.Grammar import GF.Grammar.Binary(VersionTagged(..),decodeModuleHeader) import System.IO(mkTextEncoding) import GF.Text.Coding(decodeUnicodeIO) import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.Char8 as BS import Control.Monad import Data.Maybe(isJust) import Data.Char(isSpace) import qualified Data.Map as Map import Data.Time(UTCTime) import GF.System.Directory(getModificationTime,doesFileExist,canonicalizePath) import System.FilePath import GF.Text.Pretty type ModName = String type ModEnv = Map.Map ModName (UTCTime,[ModName]) -- | Returns a list of all files to be compiled in topological order i.e. -- the low level (leaf) modules are first. --getAllFiles :: (MonadIO m,ErrorMonad m) => Options -> [InitPath] -> ModEnv -> FileName -> m [FullPath] getAllFiles opts ps env file = do -- read module headers from all files recursively ds <- reverse `fmap` get [] [] (justModuleName file) 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,time,has_src,imps,p) = case st of CSComp -> [p gfFile f] CSRead | has_src -> [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 = raise $ "circular modules" +++ unwords trc | (not . null) [n | (n,_,_,_,_,_) <- ds, name == n] --- file already read = return ds | otherwise = do (name,st0,t0,has_src,imps,p) <- findModule name ds <- foldM (get (name:trc)) ds imps let (st,t) | has_src && flag optRecomp opts == RecompIfNewer && (not . null) [f | (f,st,t1,_,_,_) <- ds, elem f imps && liftM2 (>=) t0 t1 /= Just True] = (CSComp,Nothing) | otherwise = (st0,t0) return ((name,st,t,has_src,imps,p):ds) gfoDir = flag optGFODir opts -- 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) <- findFile gfoDir ps name let mb_envmod = Map.lookup name env (st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime (st,(mname,imps)) <- case st of CSEnv -> return (st, (name, maybe [] snd mb_envmod)) CSRead -> do let gfo = if isGFO file then file else gf2gfo opts file t_imps <- gfoImports gfo case t_imps of Tagged imps -> return (st,imps) WrongVersion | isGFO file -> raise (file ++ " is compiled with different GF version and I can't find the source file") | otherwise -> do imps <- gfImports opts file return (CSComp,imps) CSComp -> do imps <- gfImports opts file return (st,imps) testErr (mname == name) ("module name" +++ mname +++ "differs from file name" +++ name) return (name,st,t,isJust gfTime,imps,dropFileName file) -------------------------------------------------------------------------------- findFile gfoDir ps name = maybe noSource haveSource =<< getFilePath ps (gfFile name) where haveSource gfFile = do gfTime <- getModificationTime gfFile mb_gfoTime <- maybeIO $ getModificationTime (gf2gfo' gfoDir gfFile) return (gfFile, Just gfTime, mb_gfoTime) noSource = maybe noGFO haveGFO =<< getFilePath gfoPath (gfoFile name) where gfoPath = maybe id (:) gfoDir ps haveGFO gfoFile = do gfoTime <- getModificationTime gfoFile return (gfoFile, Nothing, Just gfoTime) noGFO = raise (render ("File" <+> gfFile name <+> "does not exist." $$ "searched in:" <+> vcat ps)) gfImports opts file = importsOfModule `fmap` parseModHeader opts file gfoImports gfo = fmap importsOfModule `fmap` decodeModuleHeader gfo -------------------------------------------------------------------------------- -- 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 UTCTime -> Maybe UTCTime -> Maybe UTCTime -> (CompStatus,Maybe UTCTime) 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 UTCTime,Bool,[ModName],InitPath) importsOfModule :: SourceModule -> (ModName,[ModName]) importsOfModule (m,mi) = (modName m,depModInfo mi []) where depModInfo mi = depModType (mtype mi) . depExtends (mextend mi) . depWith (mwith mi) . depExDeps (mexdeps mi). depOpens (mopens 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 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 (MN m) = showIdent m parseModHeader opts file = do --ePutStrLn file (_,parsed) <- parseSource opts pModHeader =<< liftIO (BS.readFile file) case parsed of Right mo -> return mo Left (Pn l c,msg) -> raise (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg) parseSource opts p raw = do (coding,utf8) <- toUTF8 opts raw return (coding,runP p utf8) toUTF8 opts0 raw = do opts <- getPragmas raw let given = flag optEncoding opts -- explicitly given encoding coding = getEncoding $ opts0 `addOptions` opts utf8 <- if coding=="UTF-8" then return raw else if coding=="CP1252" -- Latin1 then return . UTF8.fromString $ BS.unpack raw -- faster else do --ePutStrLn $ "toUTF8 from "++coding recodeToUTF8 coding raw return (given,utf8) recodeToUTF8 coding raw = liftIO $ do enc <- mkTextEncoding coding -- decodeUnicodeIO uses a lot of stack space, -- so we need to split the file into smaller pieces ls <- mapM (decodeUnicodeIO enc) (BS.lines raw) return $ UTF8.fromString (unlines ls) -- | options can be passed to the compiler by comments in @--#@, in the main file --getOptionsFromFile :: (MonadIO m,ErrorMonad m) => FilePath -> m Options getOptionsFromFile file = do opts <- either failed getPragmas =<< (liftIO $ try $ BS.readFile file) -- The coding flag should not be inherited by other files return (addOptions opts (modifyFlags $ \ f -> f{optEncoding=Nothing})) where failed _ = raise $ "File " ++ file ++ " does not exist" getPragmas :: (ErrorMonad m) => BS.ByteString -> m Options getPragmas = parseModuleOptions . map (BS.unpack . BS.unwords . BS.words . BS.drop 3) . filter (BS.isPrefixOf (BS.pack "--#")) . -- takeWhile (BS.isPrefixOf (BS.pack "--")) . -- filter (not . BS.null) . map (BS.dropWhile isSpace) . BS.lines getFilePath :: MonadIO m => [FilePath] -> String -> m (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)