reintroduce the compiler API

src/compiler/api/GF/Compile/ReadFiles.hs

@@ -0,0 +1,277 @@
+----------------------------------------------------------------------
+-- |
+-- 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)