----------------------------------------------------------------------
-- |
-- 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(-- ** Files and IO
                      module GF.Infra.UseIO,
                      -- *** Reused
                      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 System.Cmd
import Text.Printf
--import Control.Applicative(Applicative(..))
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 :: MonadIO io => Options -> String -> io ()
putIfVerb :: Options -> String -> f ()
putIfVerb Options
opts String
msg = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
Verbose) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ String -> f ()
forall (m :: * -> *). Output m => String -> m ()
putStrLnE String
msg

-- *** GF files path and library path manipulation

type FileName = String
type InitPath = String -- ^ the directory portion of a pathname
type FullPath = String

gfLibraryPath :: String
gfLibraryPath    = String
"GF_LIB_PATH"
gfGrammarPathVar :: String
gfGrammarPathVar = String
"GF_GRAMMAR_PATH"

getLibraryDirectory :: MonadIO io => Options -> io [FilePath]
getLibraryDirectory :: Options -> io [String]
getLibraryDirectory Options
opts =
  case (Flags -> Maybe [String]) -> Options -> Maybe [String]
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe [String]
optGFLibPath Options
opts of
    Just [String]
path -> [String] -> io [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
path
    Maybe [String]
Nothing   -> (String -> [String]) -> io String -> io [String]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> [String]
splitSearchPath (io String -> io [String]) -> io String -> io [String]
forall a b. (a -> b) -> a -> b
$ IO String -> io String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> (IOError -> IO String) -> IO String
forall a. IO a -> (IOError -> IO a) -> IO a
catch (String -> IO String
getEnv String
gfLibraryPath)
                                                (\IOError
ex -> (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
</> String
"lib") IO String
getDataDir))

getGrammarPath :: MonadIO io => [FilePath] -> io [FilePath]
getGrammarPath :: [String] -> io [String]
getGrammarPath [String]
lib_dirs = IO [String] -> io [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> io [String]) -> IO [String] -> io [String]
forall a b. (a -> b) -> a -> b
$ do
  IO [String] -> (IOError -> IO [String]) -> IO [String]
forall a. IO a -> (IOError -> IO a) -> IO a
catch ((String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
splitSearchPath (IO String -> IO [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IO String
getEnv String
gfGrammarPathVar) 
        (\IOError
_ -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String
lib_dir String -> String -> String
</> String
"alltenses", String
lib_dir String -> String -> String
</> String
"prelude"]
                               | String
lib_dir <- [String]
lib_dirs ])     -- e.g. GF_GRAMMAR_PATH

-- | extends the search path with the
-- 'gfLibraryPath' and 'gfGrammarPathVar'
-- environment variables. Returns only existing paths.
extendPathEnv :: MonadIO io => Options -> io [FilePath]
extendPathEnv :: Options -> io [String]
extendPathEnv Options
opts = IO [String] -> io [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> io [String]) -> IO [String] -> io [String]
forall a b. (a -> b) -> a -> b
$ do
  let opt_path :: [String]
opt_path = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Flags -> [String]) -> Options -> [String]
forall a. (Flags -> a) -> Options -> a
flag Flags -> [String]
optLibraryPath Options
opts         -- e.g. paths given as options
  [String]
lib_dirs <- Options -> IO [String]
forall (io :: * -> *). MonadIO io => Options -> io [String]
getLibraryDirectory Options
opts                  -- e.g. GF_LIB_PATH
  [String]
grm_path <- [String] -> IO [String]
forall (io :: * -> *). MonadIO io => [String] -> io [String]
getGrammarPath [String]
lib_dirs                   -- e.g. GF_GRAMMAR_PATH
  let paths :: [String]
paths = [String]
opt_path [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
lib_dirs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
grm_path
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
Verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"extendPathEnv: opt_path is "String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
opt_path)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
Verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"extendPathEnv: lib_dirs is "String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
lib_dirs)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
Verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"extendPathEnv: grm_path is "String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
grm_path)
  [String]
ps <- ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String])
-> ([[String]] -> [String]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (IO [[String]] -> IO [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
allSubdirs ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
paths)
  (String -> IO String) -> [String] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO String
forall (m :: * -> *). MonadIO m => String -> m String
canonicalizePath [String]
ps
  where
    allSubdirs :: FilePath -> IO [FilePath]
    allSubdirs :: String -> IO [String]
allSubdirs [] = [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [[]]
    allSubdirs String
p = case String -> Char
forall a. [a] -> a
last String
p of
      Char
'*' -> do let path :: String
path = String -> String
forall a. [a] -> [a]
init String
p
                [String]
fs <- String -> IO [String]
getSubdirs String
path
                let starpaths :: [String]
starpaths = [String
path String -> String -> String
</> String
f | String
f <- [String]
fs]
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
Verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"extendPathEnv: allSubdirs: * found "String -> String -> String
forall a. [a] -> [a] -> [a]
++[String] -> String
forall a. Show a => a -> String
show [String]
starpaths)
                [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
starpaths
      Char
_   -> do Bool
exists <- String -> IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesDirectoryExist String
p
                if Bool
exists
                  then do
                       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
Verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"extendPathEnv: allSubdirs: found path "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show String
p)
                       [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
p]
                  else do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
Verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"extendPathEnv: allSubdirs: ignore path "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
p)
                          [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []

getSubdirs :: FilePath -> IO [FilePath]
getSubdirs :: String -> IO [String]
getSubdirs String
dir = do
  [String]
fs  <- IO [String] -> (IOError -> IO [String]) -> IO [String]
forall a. IO a -> (IOError -> IO a) -> IO a
catch (String -> IO [String]
forall (m :: * -> *). MonadIO m => String -> m [String]
getDirectoryContents String
dir) (IO [String] -> IOError -> IO [String]
forall a b. a -> b -> a
const (IO [String] -> IOError -> IO [String])
-> IO [String] -> IOError -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
  ([String] -> String -> IO [String])
-> [String] -> [String] -> IO [String]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\[String]
fs String
f -> do let fpath :: String
fpath = String
dir String -> String -> String
</> String
f
                     Permissions
p <- String -> IO Permissions
forall (m :: * -> *). MonadIO m => String -> m Permissions
getPermissions String
fpath
                     if Permissions -> Bool
searchable Permissions
p Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 String
fString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
".")
                       then [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return (String
fpathString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
fs)
                       else [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return        [String]
fs ) [] [String]
fs

--------------------------------------------------------------------------------
justModuleName :: FilePath -> String
justModuleName :: String -> String
justModuleName = String -> String
dropExtension (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeFileName

isGF,isGFO :: FilePath -> Bool
isGF :: String -> Bool
isGF  = (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".gf")  (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtensions
isGFO :: String -> Bool
isGFO = (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".gfo") (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtensions

gfFile,gfoFile :: FilePath -> FilePath
gfFile :: String -> String
gfFile  String
f = String -> String -> String
addExtension String
f String
"gf"
gfoFile :: String -> String
gfoFile String
f = String -> String -> String
addExtension String
f String
"gfo"

gf2gfo :: Options -> FilePath -> FilePath
gf2gfo :: Options -> String -> String
gf2gfo = Maybe String -> String -> String
gf2gfo' (Maybe String -> String -> String)
-> (Options -> Maybe String) -> Options -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Flags -> Maybe String) -> Options -> Maybe String
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe String
optGFODir

gf2gfo' :: Maybe String -> String -> String
gf2gfo' Maybe String
gfoDir String
file = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> String
gfoFile (String -> String
dropExtension String
file))
                            (\String
dir -> String
dir String -> String -> String
</> String -> String
gfoFile (String -> String
takeBaseName String
file))
                            Maybe String
gfoDir
--------------------------------------------------------------------------------
splitInModuleSearchPath :: String -> [FilePath]
splitInModuleSearchPath :: String -> [String]
splitInModuleSearchPath String
s = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isPathSep String
s of
  (String
f,Char
_:String
cs) -> String
f String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
splitInModuleSearchPath String
cs
  (String
f,String
_)    -> [String
f]
  where
    isPathSep :: Char -> Bool
    isPathSep :: Char -> Bool
isPathSep Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';'

--

-- *** Error handling in the IO monad

-- | Was: @newtype IOE a = IOE { appIOE :: IO (Err a) }@
type IOE a = IO a

--ioe :: IO (Err a) -> IOE a
--ioe io = err fail return =<< io

-- | Catch exceptions caused by calls to 'raise' or 'fail' in the 'IO' monad.
-- To catch all 'IO' exceptions, use 'try' instead.
tryIOE :: IOE a -> IO (Err a)
tryIOE :: IOE a -> IO (Err a)
tryIOE IOE a
ioe = IO (Err a) -> (String -> IO (Err a)) -> IO (Err a)
forall (m :: * -> *) a.
ErrorMonad m =>
m a -> (String -> m a) -> m a
handle ((a -> Err a) -> IOE a -> IO (Err a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Err a
forall a. a -> Err a
Ok IOE a
ioe) (Err a -> IO (Err a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Err a -> IO (Err a)) -> (String -> Err a) -> String -> IO (Err a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err a
forall a. String -> Err a
Bad)

--runIOE :: IOE a -> IO a
--runIOE = id

-- instance MonadIO IOE where liftIO io = ioe (io >>= return . return)

-- | Make raise and handle mimic behaviour of the old IOE monad
instance ErrorMonad IO where
  raise :: String -> IO a
raise = String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  handle :: IO a -> (String -> IO a) -> IO a
handle IO a
m String -> IO a
h = IO a -> (IOError -> IO a) -> IO a
forall a. IO a -> (IOError -> IO a) -> IO a
catch IO a
m ((IOError -> IO a) -> IO a) -> (IOError -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ IOError
e -> if IOError -> Bool
isUserError IOError
e
                                then String -> IO a
h (IOError -> String
ioeGetErrorString IOError
e)
                                else IOError -> IO a
forall a. IOError -> IO a
ioError IOError
e
{-
-- Control.Monad.Fail import will become redundant in GHC 8.8+
import qualified Control.Monad.Fail as Fail

instance Functor IOE where fmap = liftM

instance Applicative IOE where
  pure = return
  (<*>) = ap

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

 #if !(MIN_VERSION_base(4,13,0))
  fail = raise
 #endif

instance Fail.MonadFail IOE where
  fail = raise


-}

-- | Print the error message and return a default value if the IO operation 'fail's
useIOE :: a -> IOE a -> IO a
useIOE :: a -> IOE a -> IOE a
useIOE a
a IOE a
ioe = IOE a -> (String -> IOE a) -> IOE a
forall (m :: * -> *) a.
ErrorMonad m =>
m a -> (String -> m a) -> m a
handle IOE a
ioe (\String
s -> String -> IO ()
putStrLn String
s IO () -> IOE a -> IOE a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IOE a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a)

maybeIO :: IO a -> f (Maybe a)
maybeIO IO a
io = (IOError -> Maybe a)
-> (a -> Maybe a) -> Either IOError a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> IOError -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Either IOError a -> Maybe a)
-> f (Either IOError a) -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO (Either IOError a) -> f (Either IOError a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO (Either IOError a)
forall a. IO a -> IO (Either IOError a)
try IO a
io)
{-
--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 <- liftIO $ appIOE (f s x) 
    case ev of 
      Ok v  -> foldIOE f v xx
      Bad m -> return $ (s, Just m)
-}
die :: String -> IO a
die :: String -> IO a
die String
s = do Handle -> String -> IO ()
hPutStrLn Handle
stderr String
s
           IO a
forall a. IO a
exitFailure

-- *** Diagnostic output

class Monad m => Output m where
  ePutStr, ePutStrLn, putStrE, putStrLnE :: String -> m ()

instance Output IO where
  ePutStr :: String -> IO ()
ePutStr   String
s = Handle -> String -> IO ()
hPutStr Handle
stderr String
s IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catch` IOError -> IO ()
forall (m :: * -> *) p. Monad m => p -> m ()
oops
    where oops :: p -> m ()
oops p
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- prevent crash on character encoding problem
  ePutStrLn :: String -> IO ()
ePutStrLn String
s = Handle -> String -> IO ()
hPutStrLn Handle
stderr String
s IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catch` IOError -> IO ()
forall (m :: * -> *) p. Output m => p -> m ()
oops
    where oops :: p -> m ()
oops p
_ = String -> m ()
forall (m :: * -> *). Output m => String -> m ()
ePutStrLn String
"" -- prevent crash on character encoding problem
  putStrLnE :: String -> IO ()
putStrLnE String
s = String -> IO ()
putStrLn String
s IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
  putStrE :: String -> IO ()
putStrE   String
s = String -> IO ()
putStr String
s IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
{-
instance Output IOE where
  ePutStr   = liftIO . ePutStr
  ePutStrLn = liftIO . ePutStrLn
  putStrLnE = liftIO . putStrLnE
  putStrE   = liftIO . putStrE
-}

instance Output m => Output (StateT s m) where
  ePutStr :: String -> StateT s m ()
ePutStr = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ())
-> (String -> m ()) -> String -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall (m :: * -> *). Output m => String -> m ()
ePutStr
  ePutStrLn :: String -> StateT s m ()
ePutStrLn = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ())
-> (String -> m ()) -> String -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall (m :: * -> *). Output m => String -> m ()
ePutStrLn
  putStrE :: String -> StateT s m ()
putStrE = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ())
-> (String -> m ()) -> String -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall (m :: * -> *). Output m => String -> m ()
putStrE
  putStrLnE :: String -> StateT s m ()
putStrLnE = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ())
-> (String -> m ()) -> String -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall (m :: * -> *). Output m => String -> m ()
putStrLnE

--putPointE :: Verbosity -> Options -> String -> IO a -> IO a
putPointE :: Verbosity -> Options -> String -> m b -> m b
putPointE Verbosity
v Options
opts String
msg m b
act = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
v) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: * -> *). Output m => String -> m ()
putStrE String
msg

  (Integer
t,b
a) <- m b -> m (Integer, b)
forall (m :: * -> *) b. MonadIO m => m b -> m (Integer, b)
timeIt m b
act

  if (Flags -> Bool) -> Options -> Bool
forall a. (Flags -> a) -> Options -> a
flag Flags -> Bool
optShowCPUTime Options
opts
      then do let msec :: Integer
msec = Integer
t Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1000000000
              String -> m ()
forall (m :: * -> *). Output m => String -> m ()
putStrLnE (String -> Integer -> String
forall r. PrintfType r => String -> r
printf String
" %5d msec" Integer
msec)
      else Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
v) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: * -> *). Output m => String -> m ()
putStrLnE String
""

  b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
a

-- | Because GHC adds the confusing text "user error" for failures caused by
-- calls to 'fail'.
ioErrorText :: IOError -> String
ioErrorText IOError
e = if IOError -> Bool
isUserError IOError
e
                then IOError -> String
ioeGetErrorString IOError
e
                else IOError -> String
forall a. Show a => a -> String
show IOError
e

-- *** Timing

timeIt :: m b -> m (Integer, b)
timeIt m b
act =
  do Integer
t1 <- IO Integer -> m Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Integer -> m Integer) -> IO Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ IO Integer
getCPUTime
     b
a <- IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> (b -> IO b) -> b -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> IO b
forall a. a -> IO a
evaluate (b -> m b) -> m b -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m b
act
     Integer
t2 <- IO Integer -> m Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Integer -> m Integer) -> IO Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ IO Integer
getCPUTime
     (Integer, b) -> m (Integer, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
t2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
t1,b
a)

-- *** File IO

writeUTF8File :: FilePath -> String -> IO ()
writeUTF8File :: String -> String -> IO ()
writeUTF8File String
fpath String
content =
  String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fpath IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Handle
h -> do Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
                                       Handle -> String -> IO ()
hPutStr Handle
h String
content

readBinaryFile :: String -> IO String
readBinaryFile String
path = Handle -> IO String
hGetContents (Handle -> IO String) -> IO Handle -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IOMode -> IO Handle
openBinaryFile String
path IOMode
ReadMode
writeBinaryFile :: String -> String -> IO ()
writeBinaryFile String
path String
s = String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path IOMode
WriteMode ((Handle -> String -> IO ()) -> String -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> String -> IO ()
hPutStr String
s)