module GF.Infra.UseIO(
module GF.Infra.UseIO,
MonadIO(..),liftErr) where
import Prelude hiding (catch)
import GF.Data.Operations
import GF.Infra.Option
import GF.System.Catch
import Paths_gf(getDataDir)
import GF.System.Directory
import System.FilePath
import System.IO
import System.IO.Error(isUserError,ioeGetErrorString)
import System.Environment
import System.Exit
import System.CPUTime
import Text.Printf
import Control.Monad(when,liftM,foldM)
import Control.Monad.Trans(MonadIO(..))
import Control.Monad.State(StateT,lift)
import Control.Exception(evaluate)
import Data.List (nub)
putIfVerb opts msg = when (verbAtLeast opts Verbose) $ putStrLnE msg
type FileName = String
type InitPath = String
type FullPath = String
gfLibraryPath = "GF_LIB_PATH"
gfGrammarPathVar = "GF_GRAMMAR_PATH"
getLibraryDirectory :: MonadIO io => Options -> io [FilePath]
getLibraryDirectory opts =
case flag optGFLibPath opts of
Just path -> return path
Nothing -> liftM splitSearchPath $ liftIO (catch (getEnv gfLibraryPath)
(\ex -> fmap (</> "lib") getDataDir))
getGrammarPath :: MonadIO io => [FilePath] -> io [FilePath]
getGrammarPath lib_dirs = liftIO $ do
catch (fmap splitSearchPath $ getEnv gfGrammarPathVar)
(\_ -> return $ concat [[lib_dir </> "alltenses", lib_dir </> "prelude"]
| lib_dir <- lib_dirs ])
extendPathEnv :: MonadIO io => Options -> io [FilePath]
extendPathEnv opts = liftIO $ do
let opt_path = nub $ flag optLibraryPath opts
lib_dirs <- getLibraryDirectory opts
grm_path <- getGrammarPath lib_dirs
let paths = opt_path ++ lib_dirs ++ grm_path
when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: opt_path is "++ show opt_path)
when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: lib_dirs is "++ show lib_dirs)
when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: grm_path is "++ show grm_path)
ps <- liftM (nub . concat) $ mapM allSubdirs (nub paths)
mapM canonicalizePath ps
where
allSubdirs :: FilePath -> IO [FilePath]
allSubdirs [] = return [[]]
allSubdirs p = case last p of
'*' -> do let path = init p
fs <- getSubdirs path
let starpaths = [path </> f | f <- fs]
when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: allSubdirs: * found "++show starpaths)
return starpaths
_ -> do exists <- doesDirectoryExist p
if exists
then do
when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: allSubdirs: found path "++show p)
return [p]
else do when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: allSubdirs: ignore path "++ show p)
return []
getSubdirs :: FilePath -> IO [FilePath]
getSubdirs dir = do
fs <- catch (getDirectoryContents dir) (const $ return [])
foldM (\fs f -> do let fpath = dir </> f
p <- getPermissions fpath
if searchable p && not (take 1 f==".")
then return (fpath:fs)
else return fs ) [] fs
justModuleName :: FilePath -> String
justModuleName = dropExtension . takeFileName
isGF,isGFO :: FilePath -> Bool
isGF = (== ".gf") . takeExtensions
isGFO = (== ".gfo") . takeExtensions
gfFile,gfoFile :: FilePath -> FilePath
gfFile f = addExtension f "gf"
gfoFile f = addExtension f "gfo"
gf2gfo :: Options -> FilePath -> FilePath
gf2gfo = gf2gfo' . flag optGFODir
gf2gfo' gfoDir file = maybe (gfoFile (dropExtension file))
(\dir -> dir </> gfoFile (takeBaseName file))
gfoDir
splitInModuleSearchPath :: String -> [FilePath]
splitInModuleSearchPath s = case break isPathSep s of
(f,_:cs) -> f : splitInModuleSearchPath cs
(f,_) -> [f]
where
isPathSep :: Char -> Bool
isPathSep c = c == ':' || c == ';'
type IOE a = IO a
tryIOE :: IOE a -> IO (Err a)
tryIOE ioe = handle (fmap Ok ioe) (return . Bad)
instance ErrorMonad IO where
raise = fail
handle m h = catch m $ \ e -> if isUserError e
then h (ioeGetErrorString e)
else ioError e
useIOE :: a -> IOE a -> IO a
useIOE a ioe = handle ioe (\s -> putStrLn s >> return a)
maybeIO io = either (const Nothing) Just `fmap` liftIO (try io)
die :: String -> IO a
die s = do hPutStrLn stderr s
exitFailure
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 ()
ePutStrLn s = hPutStrLn stderr s `catch` oops
where oops _ = ePutStrLn ""
putStrLnE s = putStrLn s >> hFlush stdout
putStrE s = putStr s >> hFlush stdout
instance Output m => Output (StateT s m) where
ePutStr = lift . ePutStr
ePutStrLn = lift . ePutStrLn
putStrE = lift . putStrE
putStrLnE = lift . putStrLnE
putPointE v opts msg act = do
when (verbAtLeast opts v) $ putStrE msg
(t,a) <- timeIt act
if flag optShowCPUTime opts
then do let msec = t `div` 1000000000
putStrLnE (printf " %5d msec" msec)
else when (verbAtLeast opts v) $ putStrLnE ""
return a
ioErrorText e = if isUserError e
then ioeGetErrorString e
else show e
timeIt act =
do t1 <- liftIO $ getCPUTime
a <- liftIO . evaluate =<< act
t2 <- liftIO $ getCPUTime
return (t2t1,a)
writeUTF8File :: FilePath -> String -> IO ()
writeUTF8File fpath content =
withFile fpath WriteMode $ \ h -> do hSetEncoding h utf8
hPutStr h content
readBinaryFile path = hGetContents =<< openBinaryFile path ReadMode
writeBinaryFile path s = withBinaryFile path WriteMode (flip hPutStr s)