diff options
Diffstat (limited to 'src/compiler/GF/Infra')
| -rw-r--r-- | src/compiler/GF/Infra/Option.hs | 9 | ||||
| -rw-r--r-- | src/compiler/GF/Infra/UseIO.hs | 78 |
2 files changed, 45 insertions, 42 deletions
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 () |