summaryrefslogtreecommitdiff
path: root/src/compiler/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF')
-rw-r--r--src/compiler/GF/Compile/GeneratePMCFG.hs4
-rw-r--r--src/compiler/GF/Compile/GetGrammar.hs22
-rw-r--r--src/compiler/GF/Compile/ReadFiles.hs71
-rw-r--r--src/compiler/GF/CompileInParallel.hs218
-rw-r--r--src/compiler/GF/CompileOne.hs49
-rw-r--r--src/compiler/GF/Infra/Option.hs9
-rw-r--r--src/compiler/GF/Infra/UseIO.hs78
-rw-r--r--src/compiler/GF/System/Directory.hs9
8 files changed, 343 insertions, 117 deletions
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index e6067c854..aa22ea412 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -45,7 +45,7 @@ import Control.Monad.Identity
----------------------------------------------------------------------
-- main conversion function
-generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule
+--generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule
generatePMCFG opts sgr opath cmo@(cm,cmi) = do
(seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv opath am cm) Map.empty (jments cmi)
when (verbAtLeast opts Verbose) $ ePutStrLn ""
@@ -67,7 +67,7 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
return (a,(k,y):kys)
-addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
+--addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
--when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
let pres = protoFCat gr res val
diff --git a/src/compiler/GF/Compile/GetGrammar.hs b/src/compiler/GF/Compile/GetGrammar.hs
index e10081cff..b4d2e13ef 100644
--- a/src/compiler/GF/Compile/GetGrammar.hs
+++ b/src/compiler/GF/Compile/GetGrammar.hs
@@ -25,29 +25,29 @@ import GF.Grammar.Parser
import GF.Grammar.Grammar
import GF.Grammar.CFG
import GF.Grammar.EBNF
-import GF.Compile.ReadFiles(parseSource,lift)
+import GF.Compile.ReadFiles(parseSource)
import qualified Data.ByteString.Char8 as BS
import Data.Char(isAscii)
import Control.Monad (foldM,when,unless)
import System.Process (system)
-import System.Directory(removeFile,getCurrentDirectory)
+import GF.System.Directory(removeFile,getCurrentDirectory)
import System.FilePath(makeRelative)
-getSourceModule :: Options -> FilePath -> IOE SourceModule
+--getSourceModule :: Options -> FilePath -> IOE SourceModule
getSourceModule opts file0 =
--errIn file0 $
- do tmp <- lift $ foldM runPreprocessor (Source file0) (flag optPreprocessors opts)
- raw <- lift $ keepTemp tmp
+ do tmp <- liftIO $ foldM runPreprocessor (Source file0) (flag optPreprocessors opts)
+ raw <- liftIO $ keepTemp tmp
--ePutStrLn $ "1 "++file0
(optCoding,parsed) <- parseSource opts pModDef raw
case parsed of
- Left (Pn l c,msg) -> do file <- lift $ writeTemp tmp
- cwd <- lift $ getCurrentDirectory
+ Left (Pn l c,msg) -> do file <- liftIO $ writeTemp tmp
+ cwd <- getCurrentDirectory
let location = makeRelative cwd file++":"++show l++":"++show c
raise (location++":\n "++msg)
Right (i,mi0) ->
- do lift $ removeTemp tmp
+ do liftIO $ removeTemp tmp
let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0}
optCoding' = renameEncoding `fmap` flag optEncoding (mflags mi0)
case (optCoding,optCoding') of
@@ -59,7 +59,7 @@ getSourceModule opts file0 =
raise $ "Encoding mismatch: "++coding++" /= "++coding'
where coding = maybe defaultEncoding renameEncoding optCoding
_ -> return ()
- --lift $ transcodeModule' (i,mi) -- old lexer
+ --liftIO $ transcodeModule' (i,mi) -- old lexer
return (i,mi) -- new lexer
getCFRules :: Options -> FilePath -> IOE [CFRule]
@@ -67,7 +67,7 @@ getCFRules opts fpath = do
raw <- liftIO (BS.readFile fpath)
(optCoding,parsed) <- parseSource opts pCFRules raw
case parsed of
- Left (Pn l c,msg) -> do cwd <- lift $ getCurrentDirectory
+ Left (Pn l c,msg) -> do cwd <- getCurrentDirectory
let location = makeRelative cwd fpath++":"++show l++":"++show c
raise (location++":\n "++msg)
Right rules -> return rules
@@ -77,7 +77,7 @@ getEBNFRules opts fpath = do
raw <- liftIO (BS.readFile fpath)
(optCoding,parsed) <- parseSource opts pEBNFRules raw
case parsed of
- Left (Pn l c,msg) -> do cwd <- lift $ getCurrentDirectory
+ Left (Pn l c,msg) -> do cwd <- getCurrentDirectory
let location = makeRelative cwd fpath++":"++show l++":"++show c
raise (location++":\n "++msg)
Right rules -> return rules
diff --git a/src/compiler/GF/Compile/ReadFiles.hs b/src/compiler/GF/Compile/ReadFiles.hs
index 4e57e5ba4..1523e91f1 100644
--- a/src/compiler/GF/Compile/ReadFiles.hs
+++ b/src/compiler/GF/Compile/ReadFiles.hs
@@ -20,8 +20,8 @@
module GF.Compile.ReadFiles
( getAllFiles,ModName,ModEnv,importsOfModule,
- parseSource,lift,
- getOptionsFromFile,getPragmas) where
+ findFile,gfImports,gfoImports,
+ parseSource,getOptionsFromFile,getPragmas) where
import Prelude hiding (catch)
import GF.System.Catch
@@ -32,15 +32,17 @@ import GF.Data.Operations
import GF.Grammar.Lexer
import GF.Grammar.Parser
import GF.Grammar.Grammar
-import GF.Grammar.Binary
+import GF.Grammar.Binary(decodeModuleHeader)
import System.IO(mkTextEncoding)
-import qualified Data.ByteString.UTF8 as UTF8
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 qualified Data.ByteString.Char8 as BS
+import Data.Char(isSpace)
import qualified Data.Map as Map
import Data.Time(UTCTime)
import GF.System.Directory(getModificationTime,doesFileExist,canonicalizePath)
@@ -123,8 +125,8 @@ findFile gfoDir ps name =
maybe noSource haveSource =<< getFilePath ps (gfFile name)
where
haveSource gfFile =
- do gfTime <- modtime gfFile
- mb_gfoTime <- maybeIO $ modtime (gf2gfo' gfoDir gfFile)
+ do gfTime <- getModificationTime gfFile
+ mb_gfoTime <- maybeIO $ getModificationTime (gf2gfo' gfoDir gfFile)
return (gfFile, Just gfTime, mb_gfoTime)
noSource =
@@ -133,14 +135,12 @@ findFile gfoDir ps name =
gfoPath = maybe id (:) gfoDir ps
haveGFO gfoFile =
- do gfoTime <- modtime gfoFile
+ do gfoTime <- getModificationTime gfoFile
return (gfoFile, Nothing, Just gfoTime)
noGFO = raise (render ("File" <+> gfFile name <+> "does not exist." $$
"searched in:" <+> vcat ps))
-modtime path = getModificationTime path
-
gfImports opts file = importsOfModule `fmap` parseModHeader opts file
gfoImports gfo = fmap importsOfModule `fmap` liftIO (decodeModuleHeader gfo)
@@ -216,7 +216,7 @@ importsOfModule (m,mi) = (modName m,depModInfo mi [])
parseModHeader opts file =
do --ePutStrLn file
- (_,parsed) <- parseSource opts pModHeader =<< lift (BS.readFile file)
+ (_,parsed) <- parseSource opts pModHeader =<< liftIO (BS.readFile file)
case parsed of
Right mo -> return mo
Left (Pn l c,msg) ->
@@ -234,43 +234,44 @@ toUTF8 opts0 raw =
then return raw
else if coding=="CP1252" -- Latin1
then return . UTF8.fromString $ BS.unpack raw -- faster
- else lift $
- do --ePutStrLn $ "toUTF8 from "++coding
- 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)
+ else do --ePutStrLn $ "toUTF8 from "++coding
+ recodeToUTF8 coding raw
return (given,utf8)
---lift io = ioe (fmap Ok io `catch` (return . Bad . show))
-lift io = liftIO io
+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 :: (MonadIO m,ErrorMonad m) => FilePath -> m Options
getOptionsFromFile file = do
- s <- either (\_ -> raise $ "File " ++ file ++ " does not exist") return =<<
- liftIO (try $ BS.readFile file)
- opts <- getPragmas s
+ 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 "--#")) . BS.lines
+ 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 =
- liftIO $ do --ePutStrLn $ "getFilePath "++show paths++" "++show file
- get paths
+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)
+ 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)
diff --git a/src/compiler/GF/CompileInParallel.hs b/src/compiler/GF/CompileInParallel.hs
new file mode 100644
index 000000000..ef2d36042
--- /dev/null
+++ b/src/compiler/GF/CompileInParallel.hs
@@ -0,0 +1,218 @@
+module GF.CompileInParallel where
+import Control.Monad(join,ap,when,unless)
+import Control.Applicative
+import Control.Concurrent
+import System.FilePath
+import System.IO.Unsafe(unsafeInterleaveIO)
+import qualified GF.System.Directory as D
+import GF.System.Catch(catch)
+import Data.List(nub,isPrefixOf,intercalate,partition)
+import qualified Data.Map as M
+import GF.Compile.ReadFiles(getOptionsFromFile,findFile,gfImports,gfoImports)
+import GF.CompileOne(reuseGFO,useTheSource)
+import GF.Infra.Option
+import GF.Infra.UseIO
+import GF.Data.Operations
+import GF.Grammar.Grammar(emptySourceGrammar,prependModule,modules)
+import GF.Infra.Ident(identS)
+import GF.Text.Pretty
+import qualified Data.ByteString.Lazy as BS
+
+batchCompile jobs opts rootfiles0 =
+ do rootfiles <- mapM canonical rootfiles0
+ lib_dir <- canonical =<< getLibraryDirectory opts
+ filepaths <- mapM (getPathFromFile lib_dir opts) rootfiles
+ let groups = groupFiles lib_dir filepaths
+ n = length groups
+ when (n>1) $ ePutStrLn "Grammar mixes present and alltenses, dividing modules into two groups"
+ (ts,sgrs) <- unzip <$> mapM (batchCompile1 lib_dir) groups
+ return (maximum ts,sgrs)
+ where
+ groupFiles lib_dir filepaths =
+ if length groups>1 then groups else [(opts,filepaths)]
+ where
+ groups = filter (not.null.snd) [(opts_p,present),(opts_a,alltenses)]
+ (present,alltenses) = partition usesPresent filepaths
+ gfoDir = flag optGFODir opts
+ gfo = maybe "" id gfoDir
+ opts_p = setGFO "present"
+ opts_a = setGFO "alltenses"
+ setGFO d = addOptions opts
+ (modifyFlags $ \ f->f{optGFODir=Just (gfo</>d)})
+
+ usesPresent (_,paths) = take 1 libs==["present"]
+ where
+ libs = [p|path<-paths,
+ let (d,p0) = splitAt n path
+ p = dropSlash p0,
+ d==lib_dir,p `elem` all_modes]
+ n = length lib_dir
+
+ all_modes = ["alltenses","present"]
+
+ dropSlash ('/':p) = p
+ dropSlash p = p
+
+batchCompile1 lib_dir (opts,filepaths) =
+ do cwd <- D.getCurrentDirectory
+ let rel = relativeTo lib_dir cwd
+ prelude_dir = lib_dir</>"prelude"
+ gfoDir = flag optGFODir opts
+ maybe (return ()) (D.createDirectoryIfMissing True) gfoDir
+ prelude_files <- maybe [] id <$>
+ maybeIO (D.getDirectoryContents prelude_dir)
+ let fromPrelude f = lib_dir `isPrefixOf` f &&
+ takeFileName f `elem` prelude_files
+ ppPath ps = "-path="<>intercalate ":" (map rel ps)
+ logchan <- liftIO newChan
+ liftIO $ forkIO (mapM_ runIOE =<< getChanContents logchan)
+ let logStrLn = writeChan logchan . ePutStrLn
+ ok :: CollectOutput IOE a -> IO a
+ ok (CO m) = err bad good =<< appIOE m
+ where
+ good (o,r) = do writeChan logchan o; return r
+ bad e = do writeChan logchan (redPutStrLn e); fail "failed"
+ redPutStrLn s = do ePutStr "\ESC[31m";ePutStr s;ePutStrLn "\ESC[m"
+ sgr <- liftIO $ newMVar emptySourceGrammar
+ let extendSgr sgr m =
+ modifyMVar_ sgr $ \ gr ->
+ do let gr' = prependModule gr m
+-- logStrLn $ "Finished "++show (length (modules gr'))++" modules."
+ return gr'
+ fcache <- liftIO $ newIOCache $ \ _ (imp,Hide (f,ps)) ->
+ do (file,_,_) <- runIOE $ findFile gfoDir ps imp
+ return (file,(f,ps))
+ let find f ps imp =
+ do (file',(f',ps')) <- liftIO $ readIOCache fcache (imp,Hide (f,ps))
+ when (ps'/=ps) $
+ do (file,_,_) <- findFile gfoDir ps imp
+ unless (file==file' || any fromPrelude [file,file']) $
+ do eq <- liftIO $ (==) <$> BS.readFile file <*> BS.readFile file'
+ unless eq $
+ fail $ render $
+ hang ("Ambiguous import of"<+>imp<>":") 4
+ (hang (rel file<+>"from"<+>rel f) 4 (ppPath ps)
+ $$
+ hang (rel file'<+>"from"<+>rel f') 4 (ppPath ps'))
+ return file'
+ compile cache (file,paths) = readIOCache cache (file,Hide paths)
+ compile' cache (f,Hide ps) =
+ do let compileImport f = compile cache (f,ps)
+ findImports (f,ps) = mapM (find f ps) . nub . snd
+ =<< getImports opts f
+ tis <- parMapM compileImport =<< ok (findImports (f,ps))
+ let reuse gfo = do t <- D.getModificationTime gfo
+ gr <- readMVar sgr
+ r <- lazyIO $ ok (reuseGFO opts gr gfo)
+ return (t,snd r)
+ compileSrc f =
+ do gr <- readMVar sgr
+ (Just gfo,mo) <- ok (useTheSource opts gr f)
+ t <- D.getModificationTime gfo
+ return (t,mo)
+ (t,mo) <- if isGFO f
+ then reuse f
+ else do ts <- D.getModificationTime f
+ let gfo = gf2gfo' gfoDir f
+ to <- maybeIO (D.getModificationTime gfo)
+ if to>=Just (maximum (ts:tis))
+ then reuse gfo
+ else compileSrc f
+ extendSgr sgr mo
+ return (maximum (t:tis))
+ cache <- liftIO $ newIOCache compile'
+ ts <- liftIO $ parMapM (compile cache) filepaths
+ gr <- liftIO $ readMVar sgr
+ let cnc = identS (justModuleName (fst (last filepaths)))
+ return (maximum ts,(cnc,gr))
+
+parMapM f xs =
+ do vs <- mapM (const newEmptyMVar) xs
+ sequence_ [ forkIO (putMVar v =<< f x) | (v,x) <- zip vs xs]
+ mapM takeMVar vs
+
+lazyIO = unsafeInterleaveIO
+
+canonical path = liftIO $ D.canonicalizePath path `catch` const (return path)
+
+getPathFromFile lib_dir cmdline_opts file =
+ do --file <- getRealFile file
+ file_opts <- getOptionsFromFile file
+ let file_dir = dropFileName file
+ opts = addOptions (fixRelativeLibPaths file_dir lib_dir file_opts)
+ cmdline_opts
+ paths <- mapM canonical . nub . (file_dir :) =<< extendPathEnv opts
+ return (file,nub paths)
+
+getImports opts file =
+ if isGFO file then gfoImports' file else gfImports opts file
+ where
+ gfoImports' file = maybe bad return =<< gfoImports file
+ where bad = raise $ file++": bad .gfo file"
+
+relativeTo lib_dir cwd path =
+ if length librel<length cwdrel then librel else cwdrel
+ where
+ librel = "%"</>makeRelative lib_dir path
+ cwdrel = makeRelative cwd path
+
+--------------------------------------------------------------------------------
+
+data IOCache arg res
+ = IOCache { op::arg->IO res,
+ cache::MVar (M.Map arg (MVar res)) }
+
+newIOCache op =
+ do v <- newMVar M.empty
+ let cache = IOCache (op cache) v
+ return cache
+
+readIOCache (IOCache op cacheVar) arg =
+ join $ modifyMVar cacheVar $ \ cache ->
+ case M.lookup arg cache of
+ Nothing -> do v <- newEmptyMVar
+ let doit = do res <- op arg
+ putMVar v res
+ return res
+ return (M.insert arg v cache,doit)
+ Just v -> do return (cache,readMVar v)
+
+
+newtype Hide a = Hide {reveal::a}
+instance Eq (Hide a) where _ == _ = True
+instance Ord (Hide a) where compare _ _ = EQ
+
+--------------------------------------------------------------------------------
+
+newtype CollectOutput m a = CO {unCO::m (m (),a)}
+{-
+runCO (CO m) = do (o,x) <- m
+ o
+ return x
+-}
+instance Functor m => Functor (CollectOutput m) where
+ fmap f (CO m) = CO (fmap (fmap f) m)
+
+instance (Functor m,Monad m) => Applicative (CollectOutput m) where
+ pure = return
+ (<*>) = ap
+
+instance Monad m => Monad (CollectOutput m) where
+ return x = CO (return (return (),x))
+ CO m >>= f = CO $ do (o1,x) <- m
+ let CO m2 = f x
+ (o2,y) <- m2
+ return (o1>>o2,y)
+instance MonadIO m => MonadIO (CollectOutput m) where
+ liftIO io = CO $ do x <- liftIO io
+ return (return (),x)
+
+instance Output m => Output (CollectOutput m) where
+ ePutStr s = CO (return (ePutStr s,()))
+ ePutStrLn s = CO (return (ePutStrLn s,()))
+ putStrLnE s = CO (return (putStrLnE s,()))
+ putStrE s = CO (return (putStrE s,()))
+
+instance ErrorMonad m => ErrorMonad (CollectOutput m) where
+ raise e = CO (raise e)
+ handle (CO m) h = CO $ handle m (unCO . h)
diff --git a/src/compiler/GF/CompileOne.hs b/src/compiler/GF/CompileOne.hs
index 5310a7ebb..0a6fcb56a 100644
--- a/src/compiler/GF/CompileOne.hs
+++ b/src/compiler/GF/CompileOne.hs
@@ -1,8 +1,7 @@
module GF.CompileOne(OneOutput,CompiledModule,
- compileOne --, CompileSource, compileSourceModule
+ compileOne,reuseGFO,useTheSource
+ --, CompileSource, compileSourceModule
) where
-import Prelude hiding (catch)
-import GF.System.Catch
-- The main compiler passes
import GF.Compile.GetGrammar(getSourceModule)
@@ -19,7 +18,7 @@ import GF.Grammar.Printer(ppModule,TermPrintQual(..))
import GF.Grammar.Binary(decodeModule,encodeModule)
import GF.Infra.Option
-import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,liftIO,ePutStrLn,putPointE,putStrE)
+import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,liftIO,Output(..),putPointE)
import GF.Infra.CheckM(runCheck')
import GF.Data.Operations(liftErr,(+++))
@@ -33,27 +32,13 @@ type CompiledModule = SourceModule
-- | Compile a given source file (or just load a .gfo file),
-- given a 'SourceGrammar' containing everything it depends on.
-compileOne :: Options -> SourceGrammar -> FullPath -> IOE OneOutput
+--compileOne :: Options -> SourceGrammar -> FullPath -> IOE OneOutput
compileOne opts srcgr file =
if isGFO file
then reuseGFO opts srcgr file
else do b1 <- doesFileExist file
- if b1 then useTheSource
+ if b1 then useTheSource opts srcgr file
else reuseGFO opts srcgr (gf2gfo opts file)
- where
- -- | For gf source, do full compilation and generate code
- useTheSource =
- do sm <- putpOpt ("- parsing" +++ file)
- ("- compiling" +++ file ++ "... ")
- (getSourceModule opts file)
- idump opts Source sm
- cwd <- getCurrentDirectory
- compileSourceModule opts cwd (Just file) srcgr sm
-
- putpOpt v m act
- | verbAtLeast opts Verbose = putPointE Normal opts v act
- | verbAtLeast opts Normal = putStrE m >> act
- | otherwise = putPointE Verbose opts v act
-- | For compiled gf, read the file and update environment
-- also undo common subexp optimization, to enable normal computations
@@ -76,9 +61,24 @@ reuseGFO opts srcgr file =
return (Just file,sm)
+-- | For gf source, do full compilation and generate code
+--useTheSource :: Options -> SourceGrammar -> FullPath -> IOE OneOutput
+useTheSource opts srcgr file =
+ do sm <- putpOpt ("- parsing" +++ file)
+ ("- compiling" +++ file ++ "... ")
+ (getSourceModule opts file)
+ idump opts Source sm
+ cwd <- getCurrentDirectory
+ compileSourceModule opts cwd (Just file) srcgr sm
+ where
+ putpOpt v m act
+ | verbAtLeast opts Verbose = putPointE Normal opts v act
+ | verbAtLeast opts Normal = putStrE m >> act
+ | otherwise = putPointE Verbose opts v act
+
type CompileSource = SourceGrammar -> SourceModule -> IOE OneOutput
-compileSourceModule :: Options -> FilePath -> Maybe FilePath -> CompileSource
+--compileSourceModule :: Options -> FilePath -> Maybe FilePath -> CompileSource
compileSourceModule opts cwd mb_gfFile gr =
if flag optTagsOnly opts
then generateTags <=< ifComplete middle <=< frontend
@@ -128,7 +128,7 @@ compileSourceModule opts cwd mb_gfFile gr =
maybeM f = maybe (return ()) f
-writeGFO :: Options -> FilePath -> SourceModule -> IOE ()
+--writeGFO :: Options -> FilePath -> SourceModule -> IOE ()
writeGFO opts file mo =
putPointE Normal opts (" write file" +++ file) $
liftIO $ encodeModule file mo2
@@ -139,7 +139,7 @@ writeGFO opts file mo =
notAnyInd x = case x of AnyInd{} -> False; _ -> True
-- to output an intermediate stage
-intermOut :: Options -> Dump -> Doc -> IOE ()
+--intermOut :: Options -> Dump -> Doc -> IOE ()
intermOut opts d doc
| dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
| otherwise = return ()
@@ -148,9 +148,8 @@ idump opts pass = intermOut opts (Dump pass) . ppModule Internal
warnOut opts warnings
| null warnings = return ()
- | otherwise = liftIO $ ePutStrLn ws `catch` oops
+ | otherwise = do ePutStr "\ESC[34m";ePutStr ws;ePutStrLn "\ESC[m"
where
- oops _ = ePutStrLn "" -- prevent crash on character encoding problem
ws = if flag optVerbosity opts == Normal
then '\n':warnings
else warnings
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index 88767c72e..15feda1d0 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -172,8 +172,8 @@ data Flags = Flags {
optTagsOnly :: Bool,
optHeuristicFactor :: Maybe Double,
optMetaProb :: Maybe Double,
- optMetaToknProb :: Maybe Double{-,
- optNewComp :: Bool-}
+ optMetaToknProb :: Maybe Double,
+ optJobs :: Maybe (Maybe String)
}
deriving (Show)
@@ -284,7 +284,8 @@ defaultFlags = Flags {
optTagsOnly = False,
optHeuristicFactor = Nothing,
optMetaProb = Nothing,
- optMetaToknProb = Nothing
+ optMetaToknProb = Nothing,
+ optJobs = Nothing
}
-- | Option descriptions
@@ -297,6 +298,7 @@ optDescr =
Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 2.",
Option ['q','s'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.",
Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.",
+ Option ['j'] ["jobs"] (OptArg jobs "N") "Compile N modules in parallel with -batch (default 1).",
Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
Option [] ["server"] (OptArg modeServer "port") $
@@ -387,6 +389,7 @@ optDescr =
ms = mode . ModeServer
readPort p = maybe err ms (readMaybe p)
where err = fail $ "Bad server port: "++p
+ jobs mv = set $ \ o -> o { optJobs = Just mv }
verbosity mv = case mv of
Nothing -> set $ \o -> o { optVerbosity = Verbose }
Just v -> case readMaybe v >>= toEnumBounded of
diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs
index a0a36ad52..6de68bc44 100644
--- a/src/compiler/GF/Infra/UseIO.hs
+++ b/src/compiler/GF/Infra/UseIO.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS -cpp #-}
----------------------------------------------------------------------
-- |
-- Module : UseIO
@@ -22,7 +21,7 @@ import GF.Infra.Option
import GF.System.Catch
import Paths_gf(getDataDir)
-import System.Directory
+import GF.System.Directory
import System.FilePath
import System.IO
import System.IO.Error(isUserError,ioeGetErrorString)
@@ -36,24 +35,9 @@ import Control.Monad
import Control.Monad.Trans(MonadIO(..))
import Control.Exception(evaluate)
---putShow' :: Show a => (c -> a) -> c -> IO ()
---putShow' f = putStrLn . show . length . show . f
-
-putIfVerb :: MonadIO io => Options -> String -> io ()
-putIfVerb opts msg =
- when (verbAtLeast opts Verbose) $ liftIO $ putStrLn msg
-
-putIfVerbW :: MonadIO io => Options -> String -> io ()
-putIfVerbW opts msg =
- when (verbAtLeast opts Verbose) $ liftIO $ putStr (' ' : msg)
-{-
-errOptIO :: Options -> a -> Err a -> IO a
-errOptIO os e m = case m of
- Ok x -> return x
- Bad k -> do
- putIfVerb os k
- return e
--}
+--putIfVerb :: MonadIO io => Options -> String -> io ()
+putIfVerb opts msg = when (verbAtLeast opts Verbose) $ putStrLnE msg
+
type FileName = String
type InitPath = String -- ^ the directory portion of a pathname
type FullPath = String
@@ -68,8 +52,8 @@ getLibraryDirectory opts =
Nothing -> liftIO $ catch (getEnv gfLibraryPath)
(\ex -> fmap (</> "lib") getDataDir)
-getGrammarPath :: FilePath -> IO [FilePath]
-getGrammarPath lib_dir = do
+getGrammarPath :: MonadIO io => FilePath -> io [FilePath]
+getGrammarPath lib_dir = liftIO $ do
catch (fmap splitSearchPath $ getEnv gfGrammarPathVar)
(\_ -> return [lib_dir </> "alltenses",lib_dir </> "prelude"]) -- e.g. GF_GRAMMAR_PATH
@@ -110,15 +94,14 @@ getSubdirs dir = do
justModuleName :: FilePath -> String
justModuleName = dropExtension . takeFileName
-isGFO :: FilePath -> Bool
+isGF,isGFO :: FilePath -> Bool
+isGF = (== ".gf") . takeExtensions
isGFO = (== ".gfo") . takeExtensions
-gfoFile :: FilePath -> FilePath
+gfFile,gfoFile :: FilePath -> FilePath
+gfFile f = addExtension f "gf"
gfoFile f = addExtension f "gfo"
-gfFile :: FilePath -> FilePath
-gfFile f = addExtension f "gf"
-
gf2gfo :: Options -> FilePath -> FilePath
gf2gfo = gf2gfo' . flag optGFODir
@@ -143,6 +126,8 @@ newtype IOE a = IOE { appIOE :: IO (Err a) }
ioe :: IO (Err a) -> IOE a
ioe = IOE
+runIOE m = err fail return =<< appIOE m
+
instance MonadIO IOE where liftIO io = ioe (io >>= return . return)
instance ErrorMonad IOE where
@@ -162,11 +147,11 @@ instance Monad IOE where
appIOE $ err raise f x -- f :: a -> IOE a
fail = raise
-maybeIO io = either (const Nothing) Just `fmap` liftIO (try io)
-
useIOE :: a -> IOE a -> IO a
useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return
+maybeIO io = either (const Nothing) Just `fmap` liftIO (try io)
+
--foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String)
foldIOE f s xs = case xs of
[] -> return (s,Nothing)
@@ -180,27 +165,42 @@ die :: String -> IO a
die s = do hPutStrLn stderr s
exitFailure
-ePutStr, ePutStrLn, putStrE, putStrLnE :: MonadIO m => String -> m ()
-ePutStr s = liftIO $ hPutStr stderr s
-ePutStrLn s = liftIO $ hPutStrLn stderr s
-putStrLnE s = liftIO $ putStrLn s >> hFlush stdout
-putStrE s = liftIO $ putStr s >> hFlush stdout
+class Monad m => Output m where
+ ePutStr, ePutStrLn, putStrE, putStrLnE :: String -> m ()
+
+instance Output IO where
+ ePutStr s = hPutStr stderr s `catch` oops
+ where oops _ = return () -- prevent crash on character encoding problem
+ ePutStrLn s = hPutStrLn stderr s `catch` oops
+ where oops _ = ePutStrLn "" -- prevent crash on character encoding problem
+ putStrLnE s = putStrLn s >> hFlush stdout
+ putStrE s = putStr s >> hFlush stdout
-putPointE :: MonadIO m => Verbosity -> Options -> String -> m a -> m a
+instance Output IOE where
+ ePutStr = liftIO . ePutStr
+ ePutStrLn = liftIO . ePutStrLn
+ putStrLnE = liftIO . putStrLnE
+ putStrE = liftIO . putStrE
+
+--putPointE :: Verbosity -> Options -> String -> IO a -> IO a
putPointE v opts msg act = do
when (verbAtLeast opts v) $ putStrE msg
- t1 <- liftIO $ getCPUTime
- a <- act >>= liftIO . evaluate
- t2 <- liftIO $ getCPUTime
+ (t,a) <- timeIt act
if flag optShowCPUTime opts
- then do let msec = (t2 - t1) `div` 1000000000
+ then do let msec = t `div` 1000000000
putStrLnE (printf " %5d msec" msec)
else when (verbAtLeast opts v) $ putStrLnE ""
return a
+timeIt act =
+ do t1 <- liftIO $ getCPUTime
+ a <- liftIO . evaluate =<< act
+ t2 <- liftIO $ getCPUTime
+ return (t2-t1,a)
+
-- * File IO
writeUTF8File :: FilePath -> String -> IO ()
diff --git a/src/compiler/GF/System/Directory.hs b/src/compiler/GF/System/Directory.hs
index 3cd8a8ef6..306c5fbcb 100644
--- a/src/compiler/GF/System/Directory.hs
+++ b/src/compiler/GF/System/Directory.hs
@@ -4,10 +4,14 @@ module GF.System.Directory(module GF.System.Directory,module D) where
import Control.Monad.Trans(MonadIO(..))
import qualified System.Directory as D
import System.Directory as D
- hiding (doesDirectoryExist,doesFileExist,getModificationTime,
- getCurrentDirectory,getDirectoryContents,removeFile)
+ hiding (canonicalizePath,createDirectoryIfMissing,
+ doesDirectoryExist,doesFileExist,getModificationTime,
+ getCurrentDirectory,getDirectoryContents,getPermissions,
+ removeFile)
import Data.Time.Compat
+canonicalizePath path = liftIO $ D.canonicalizePath path
+createDirectoryIfMissing b = liftIO . D.createDirectoryIfMissing b
doesDirectoryExist path = liftIO $ D.doesDirectoryExist path
doesFileExist path = liftIO $ D.doesFileExist path
getModificationTime path = liftIO $ fmap toUTCTime (D.getModificationTime path)
@@ -15,5 +19,6 @@ getDirectoryContents path = liftIO $ D.getDirectoryContents path
getCurrentDirectory :: MonadIO io => io FilePath
getCurrentDirectory = liftIO D.getCurrentDirectory
+getPermissions path = liftIO $ D.getPermissions path
removeFile path = liftIO $ D.removeFile path \ No newline at end of file
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 05:00:37 +0000