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)