{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}
module GF.Infra.SIO(
SIO,MonadSIO(..),
runSIO,hRunSIO,captureSIO,
getCPUTime,getCurrentDirectory,getLibraryDirectory,
newStdGen,print,putStr,putStrLn,
importGrammar,importSource,
#ifdef C_RUNTIME
readPGF2,
#endif
putStrLnFlush,runInterruptibly,lazySIO,
restricted,restrictedSystem
) where
import Prelude hiding (putStr,putStrLn,print)
import Control.Applicative(Applicative(..))
import Control.Monad(liftM,ap)
import Control.Monad.Trans(MonadTrans(..))
import System.IO(hPutStr,hFlush,stdout)
import GF.System.Catch(try)
import System.Process(system)
import System.Environment(getEnv)
import Control.Concurrent.Chan(newChan,writeChan,getChanContents)
import GF.Infra.Concurrency(lazyIO)
import GF.Infra.UseIO(Output(..))
import qualified System.CPUTime as IO(getCPUTime)
import qualified System.Directory as IO(getCurrentDirectory)
import qualified System.Random as IO(newStdGen)
import qualified GF.Infra.UseIO as IO(getLibraryDirectory)
import qualified GF.System.Signal as IO(runInterruptibly)
import qualified GF.Command.Importing as GF(importGrammar, importSource)
#ifdef C_RUNTIME
import qualified PGF2
#endif
import qualified Control.Monad.Fail as Fail
type PutStr = String -> IO ()
newtype SIO a = SIO {SIO a -> PutStr -> IO a
unS::PutStr->IO a}
instance Functor SIO where fmap :: (a -> b) -> SIO a -> SIO b
fmap = (a -> b) -> SIO a -> SIO b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative SIO where
pure :: a -> SIO a
pure = a -> SIO a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: SIO (a -> b) -> SIO a -> SIO b
(<*>) = SIO (a -> b) -> SIO a -> SIO b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad SIO where
return :: a -> SIO a
return a
x = (PutStr -> IO a) -> SIO a
forall a. (PutStr -> IO a) -> SIO a
SIO (IO a -> PutStr -> IO a
forall a b. a -> b -> a
const (a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x))
SIO PutStr -> IO a
m1 >>= :: SIO a -> (a -> SIO b) -> SIO b
>>= a -> SIO b
xm2 = (PutStr -> IO b) -> SIO b
forall a. (PutStr -> IO a) -> SIO a
SIO ((PutStr -> IO b) -> SIO b) -> (PutStr -> IO b) -> SIO b
forall a b. (a -> b) -> a -> b
$ \ PutStr
h -> PutStr -> IO a
m1 PutStr
h IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ a
x -> SIO b -> PutStr -> IO b
forall a. SIO a -> PutStr -> IO a
unS (a -> SIO b
xm2 a
x) PutStr
h
instance Fail.MonadFail SIO where
fail :: String -> SIO a
fail = IO a -> SIO a
forall a. IO a -> SIO a
lift0 (IO a -> SIO a) -> (String -> IO a) -> String -> SIO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
instance Output SIO where
ePutStr :: String -> SIO ()
ePutStr = IO () -> SIO ()
forall a. IO a -> SIO a
lift0 (IO () -> SIO ()) -> PutStr -> String -> SIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PutStr
forall (m :: * -> *). Output m => String -> m ()
ePutStr
ePutStrLn :: String -> SIO ()
ePutStrLn = IO () -> SIO ()
forall a. IO a -> SIO a
lift0 (IO () -> SIO ()) -> PutStr -> String -> SIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PutStr
forall (m :: * -> *). Output m => String -> m ()
ePutStrLn
putStrLnE :: String -> SIO ()
putStrLnE = String -> SIO ()
putStrLnFlush
putStrE :: String -> SIO ()
putStrE = String -> SIO ()
putStr
class MonadSIO m where liftSIO :: SIO a -> m a
instance MonadSIO SIO where liftSIO :: SIO a -> SIO a
liftSIO = SIO a -> SIO a
forall a. a -> a
id
instance (MonadTrans t,Monad m,MonadSIO m) => MonadSIO (t m) where
liftSIO :: SIO a -> t m a
liftSIO = m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> t m a) -> (SIO a -> m a) -> SIO a -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SIO a -> m a
forall (m :: * -> *) a. MonadSIO m => SIO a -> m a
liftSIO
runSIO :: SIO a -> IO a
runSIO = Handle -> SIO a -> IO a
forall a. Handle -> SIO a -> IO a
hRunSIO Handle
stdout
hRunSIO :: Handle -> SIO a -> IO a
hRunSIO Handle
h SIO a
sio = SIO a -> PutStr -> IO a
forall a. SIO a -> PutStr -> IO a
unS SIO a
sio (\String
s->Handle -> PutStr
hPutStr Handle
h String
sIO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>Handle -> IO ()
hFlush Handle
h)
captureSIO :: SIO a -> IO (String,a)
captureSIO :: SIO a -> IO (String, a)
captureSIO SIO a
sio = do Chan (Maybe String)
ch <- IO (Chan (Maybe String))
forall a. IO (Chan a)
newChan
a
result <- SIO a -> PutStr -> IO a
forall a. SIO a -> PutStr -> IO a
unS SIO a
sio (Chan (Maybe String) -> Maybe String -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Maybe String)
ch (Maybe String -> IO ()) -> (String -> Maybe String) -> PutStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just)
Chan (Maybe String) -> Maybe String -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Maybe String)
ch Maybe String
forall a. Maybe a
Nothing
String
output <- ([Maybe String] -> String) -> IO [Maybe String] -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe String] -> String
forall a. [Maybe [a]] -> [a]
takeJust (Chan (Maybe String) -> IO [Maybe String]
forall a. Chan a -> IO [a]
getChanContents Chan (Maybe String)
ch)
(String, a) -> IO (String, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
output,a
result)
where
takeJust :: [Maybe [a]] -> [a]
takeJust (Just [a]
xs:[Maybe [a]]
ys) = [a]
xs[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[Maybe [a]] -> [a]
takeJust [Maybe [a]]
ys
takeJust [Maybe [a]]
_ = []
restricted :: IO a -> SIO a
restricted IO a
io = (PutStr -> IO a) -> SIO a
forall a. (PutStr -> IO a) -> SIO a
SIO (IO a -> PutStr -> IO a
forall a b. a -> b -> a
const (IO a -> IO a
forall b. IO b -> IO b
restrictedIO IO a
io))
restrictedSystem :: String -> SIO ExitCode
restrictedSystem = IO ExitCode -> SIO ExitCode
forall a. IO a -> SIO a
restricted (IO ExitCode -> SIO ExitCode)
-> (String -> IO ExitCode) -> String -> SIO ExitCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ExitCode
system
restrictedIO :: IO b -> IO b
restrictedIO IO b
io =
(IOError -> IO b)
-> (String -> IO b) -> Either IOError String -> IO b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO b -> IOError -> IO b
forall a b. a -> b -> a
const IO b
io) (IO b -> String -> IO b
forall a b. a -> b -> a
const (IO b -> String -> IO b) -> IO b -> String -> IO b
forall a b. (a -> b) -> a -> b
$ String -> IO b
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
message) (Either IOError String -> IO b)
-> IO (Either IOError String) -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String -> IO (Either IOError String)
forall a. IO a -> IO (Either IOError a)
try (String -> IO String
getEnv String
"GF_RESTRICTED")
where
message :: String
message =
String
"This operation is not allowed when GF is running in restricted mode."
lift0 :: IO a -> SIO a
lift0 IO a
io = (PutStr -> IO a) -> SIO a
forall a. (PutStr -> IO a) -> SIO a
SIO ((PutStr -> IO a) -> SIO a) -> (PutStr -> IO a) -> SIO a
forall a b. (a -> b) -> a -> b
$ IO a -> PutStr -> IO a
forall a b. a -> b -> a
const IO a
io
lift1 :: (IO a -> IO a) -> SIO a -> SIO a
lift1 IO a -> IO a
f SIO a
io = (PutStr -> IO a) -> SIO a
forall a. (PutStr -> IO a) -> SIO a
SIO ((PutStr -> IO a) -> SIO a) -> (PutStr -> IO a) -> SIO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
f (IO a -> IO a) -> (PutStr -> IO a) -> PutStr -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SIO a -> PutStr -> IO a
forall a. SIO a -> PutStr -> IO a
unS SIO a
io
putStr :: String -> SIO ()
putStr = String -> SIO ()
putStrFlush
putStrFlush :: String -> SIO ()
putStrFlush String
s = (PutStr -> IO ()) -> SIO ()
forall a. (PutStr -> IO a) -> SIO a
SIO (PutStr -> PutStr
forall a b. (a -> b) -> a -> b
$ String
s)
putStrLn :: String -> SIO ()
putStrLn = String -> SIO ()
putStrLnFlush
putStrLnFlush :: String -> SIO ()
putStrLnFlush String
s = String -> SIO ()
putStr String
s SIO () -> SIO () -> SIO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> SIO ()
putStrFlush String
"\n"
print :: a -> SIO ()
print a
x = String -> SIO ()
putStrLn (a -> String
forall a. Show a => a -> String
show a
x)
getCPUTime :: SIO Integer
getCPUTime = IO Integer -> SIO Integer
forall a. IO a -> SIO a
lift0 IO Integer
IO.getCPUTime
getCurrentDirectory :: SIO String
getCurrentDirectory = IO String -> SIO String
forall a. IO a -> SIO a
lift0 IO String
IO.getCurrentDirectory
getLibraryDirectory :: Options -> SIO [String]
getLibraryDirectory = IO [String] -> SIO [String]
forall a. IO a -> SIO a
lift0 (IO [String] -> SIO [String])
-> (Options -> IO [String]) -> Options -> SIO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> IO [String]
forall (io :: * -> *). MonadIO io => Options -> io [String]
IO.getLibraryDirectory
newStdGen :: SIO StdGen
newStdGen = IO StdGen -> SIO StdGen
forall a. IO a -> SIO a
lift0 IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
IO.newStdGen
runInterruptibly :: SIO a -> SIO (Either SomeException a)
runInterruptibly = (IO a -> IO (Either SomeException a))
-> SIO a -> SIO (Either SomeException a)
forall a a. (IO a -> IO a) -> SIO a -> SIO a
lift1 IO a -> IO (Either SomeException a)
forall a. IO a -> IO (Either SomeException a)
IO.runInterruptibly
lazySIO :: SIO a -> SIO a
lazySIO = (IO a -> IO a) -> SIO a -> SIO a
forall a a. (IO a -> IO a) -> SIO a -> SIO a
lift1 IO a -> IO a
forall b. IO b -> IO b
lazyIO
importGrammar :: PGF -> Options -> [String] -> SIO PGF
importGrammar PGF
pgf Options
opts [String]
files = IO PGF -> SIO PGF
forall a. IO a -> SIO a
lift0 (IO PGF -> SIO PGF) -> IO PGF -> SIO PGF
forall a b. (a -> b) -> a -> b
$ PGF -> Options -> [String] -> IO PGF
GF.importGrammar PGF
pgf Options
opts [String]
files
importSource :: Options -> [String] -> SIO SourceGrammar
importSource Options
opts [String]
files = IO SourceGrammar -> SIO SourceGrammar
forall a. IO a -> SIO a
lift0 (IO SourceGrammar -> SIO SourceGrammar)
-> IO SourceGrammar -> SIO SourceGrammar
forall a b. (a -> b) -> a -> b
$ Options -> [String] -> IO SourceGrammar
GF.importSource Options
opts [String]
files
#ifdef C_RUNTIME
readPGF2 = lift0 . PGF2.readPGF
#endif