gf-core/src/compiler/GF/Infra/UseIO.hs

{-# OPTIONS -cpp #-}
----------------------------------------------------------------------
-- |
-- Module      : UseIO
-- Maintainer  : AR
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/08/08 09:01:25 $ 
-- > CVS $Author: peb $
-- > CVS $Revision: 1.17 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

module GF.Infra.UseIO where

import Prelude hiding (catch)

import GF.Data.Operations
import GF.Infra.Option
import GF.System.Catch
import Paths_gf(getDataDir)

import System.Directory
import System.FilePath
import System.IO
import System.IO.Error(isUserError,ioeGetErrorString)
import System.Environment
import System.Exit
import System.CPUTime
--import System.Cmd
import Text.Printf
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 :: Options -> String -> IO ()
putIfVerb opts msg =
      when (verbAtLeast opts Verbose) $ putStrLn msg

putIfVerbW :: Options -> String -> IO ()
putIfVerbW opts msg =
      when (verbAtLeast opts Verbose) $ 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

type FileName = String
type InitPath = String
type FullPath = String

gfLibraryPath    = "GF_LIB_PATH"
gfGrammarPathVar = "GF_GRAMMAR_PATH"

getLibraryDirectory :: Options -> IO FilePath
getLibraryDirectory opts =
  case flag optGFLibPath opts of
    Just path -> return path
    Nothing   -> catch
                   (getEnv gfLibraryPath)
                   (\ex -> getDataDir >>= \path -> return (path </> "lib"))

getGrammarPath :: FilePath -> IO [FilePath]
getGrammarPath lib_dir = do
  catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) 
        (\_ -> return [lib_dir </> "alltenses",lib_dir </> "prelude"])     -- e.g. GF_GRAMMAR_PATH

-- | extends the search path with the
-- 'gfLibraryPath' and 'gfGrammarPathVar'
-- environment variables. Returns only existing paths.
extendPathEnv :: Options -> IO [FilePath]
extendPathEnv opts = do
  opt_path <- return $ flag optLibraryPath opts         -- e.g. paths given as options
  lib_dir  <- getLibraryDirectory opts                  -- e.g. GF_LIB_PATH
  grm_path <- getGrammarPath lib_dir                   -- e.g. GF_GRAMMAR_PATH
  let paths = opt_path ++ [lib_dir] ++ grm_path
  ps <- liftM concat $ mapM allSubdirs 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
                return [path </> f | f <- fs]
      _   -> do exists <- doesDirectoryExist p
                if exists
                  then return [p]
                  else 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

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 == ';'

--

putStrFlush :: String -> IO ()
putStrFlush s = putStr s >> hFlush stdout

putStrLnFlush :: String -> IO ()
putStrLnFlush s = putStrLn s >> hFlush stdout

-- * IO monad with error; adapted from state monad

newtype IOE a = IOE { appIOE :: IO (Err a) }

ioe :: IO (Err a) -> IOE a
ioe = IOE

ioeIO :: IO a -> IOE a
ioeIO io = ioe (io >>= return . return)

ioeErr :: Err a -> IOE a
ioeErr = ioe . return 

ioeErrIn :: String -> IOE a -> IOE a
ioeErrIn msg (IOE ioe) = IOE (fmap (errIn msg) ioe)

instance Functor IOE where fmap = liftM

instance  Monad IOE where
  return a    = ioe (return (return a))
  IOE c >>= f = IOE $ do 
                  x <- c          -- Err a
                  appIOE $ err ioeBad f x         -- f :: a -> IOE a
  fail = ioeBad

instance MonadIO IOE where liftIO = ioeIO

ioeBad :: String -> IOE a
ioeBad = ioe . return . Bad

useIOE :: a -> IOE a -> IO a
useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return 

foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String)
foldIOE f s xs = case xs of
  [] -> return (s,Nothing)
  x:xx -> do
    ev <- ioeIO $ appIOE (f s x) 
    case ev of 
      Ok v  -> foldIOE f v xx
      Bad m -> return $ (s, Just m)

die :: String -> IO a
die s = do hPutStrLn stderr s
           exitFailure

putStrLnE :: String -> IOE ()
putStrLnE = ioeIO . putStrLnFlush 

putStrE :: String -> IOE ()
putStrE = ioeIO . putStrFlush 

putPointE :: Verbosity -> Options -> String -> IOE a -> IOE a
putPointE v opts msg act = do
  when (verbAtLeast opts v) $ ioeIO $ putStrFlush msg

  t1 <- ioeIO $ getCPUTime
  a <- act >>= ioeIO . evaluate
  t2 <- ioeIO $ getCPUTime

  if flag optShowCPUTime opts
      then do let msec = (t2 - t1) `div` 1000000000
              putStrLnE (printf " %5d msec" msec)
      else when (verbAtLeast opts v) $ putStrLnE ""

  return a

-- * File IO

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)

-- | Because GHC adds the confusing text "user error" for failures caused by
-- calls to fail.
ioErrorText e = if isUserError e
                then ioeGetErrorString e
                else show e