reintroduce the compiler API

src/compiler/api/GF/Infra/SIO.hs

@@ -0,0 +1,145 @@
+-- | Shell IO: a monad that can restrict acesss to arbitrary IO and has the
+-- ability to capture output that normally would be sent to stdout.
+{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}
+module GF.Infra.SIO(
+       -- * The SIO monad
+       SIO,MonadSIO(..),
+       -- * Running SIO operations
+       runSIO,hRunSIO,captureSIO,
+       -- * Unrestricted, safe operations
+       -- ** From the standard libraries
+       getCPUTime,getCurrentDirectory,getLibraryDirectory,
+       newStdGen,print,putStr,putStrLn,
+       -- ** Specific to GF
+       importGrammar,importSource, link,
+       putStrLnFlush,runInterruptibly,
+       modifyPGF, checkoutPGF,
+       startTransaction, commitTransaction, rollbackTransaction,
+       inTransaction,
+       -- * Restricted accesss to arbitrary (potentially unsafe) IO operations
+       -- | If the environment variable GF_RESTRICTED is defined, these
+       -- operations will fail. Otherwise, they will be executed normally.
+       -- Output to stdout will /not/ be captured or redirected.
+       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 System.IO.Error(isUserError,ioeGetErrorString)
+import GF.System.Catch(try)
+import System.Process(system)
+import System.Environment(getEnv)
+import Control.Concurrent.Chan(newChan,writeChan,getChanContents)
+import GF.Infra.UseIO(Output(..))
+import GF.Data.Operations(ErrorMonad(..))
+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)
+import qualified GF.Compile as GF(link)
+import qualified Control.Monad.Fail as Fail
+import qualified PGF2.Transactions as PGFT
+import Control.Exception
+
+-- * The SIO monad
+
+type PutStr = String -> IO ()
+newtype SIO a = SIO {unS::PutStr->IO a}
+
+instance Functor SIO where fmap = liftM
+
+instance Applicative SIO where
+  pure = return
+  (<*>) = ap
+
+instance Monad SIO where
+  return x = SIO (const (return x))
+  SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h
+
+instance Fail.MonadFail SIO where
+  fail = lift0 . fail
+
+instance Output SIO where
+  ePutStr = lift0 . ePutStr
+  ePutStrLn = lift0 . ePutStrLn
+  putStrLnE = putStrLnFlush
+  putStrE = putStr
+
+instance ErrorMonad SIO where
+  raise = fail
+  handle m h = SIO $ \putStr ->
+                 catch (unS m putStr) $
+                    \e -> if isUserError e
+                            then unS (h (ioeGetErrorString e)) putStr
+                            else ioError e
+
+class {- Monad m => -} MonadSIO m where liftSIO :: SIO a -> m a
+-- ^ If the Monad m superclass is included, then the generic instance
+-- for monad transformers below would require UndecidableInstances
+
+instance MonadSIO SIO where liftSIO = id
+
+instance (MonadTrans t,Monad m,MonadSIO m) => MonadSIO (t m) where
+  liftSIO = lift . liftSIO
+
+-- * Running SIO operations
+
+-- | Run normally
+runSIO           = hRunSIO stdout
+
+-- | Redirect 'stdout' to the given handle
+hRunSIO h sio    = unS sio (\s->hPutStr h s>>hFlush h)
+
+-- | Capture 'stdout'
+captureSIO :: SIO a -> IO (String,a)
+captureSIO sio   = do ch <- newChan
+                      result <- unS sio (writeChan ch . Just)
+                      writeChan ch Nothing
+                      output <- fmap takeJust (getChanContents ch)
+                      return (output,result)
+                   where
+                     takeJust (Just xs:ys) = xs++takeJust ys
+                     takeJust _ = []
+
+-- * Restricted accesss to arbitrary (potentially unsafe) IO operations
+
+restricted io    = SIO (const (restrictedIO io))
+restrictedSystem = restricted . system
+
+restrictedIO io =
+    either (const io) (const $ fail message) =<< GF.System.Catch.try (getEnv "GF_RESTRICTED")
+  where
+    message =
+      "This operation is not allowed when GF is running in restricted mode."
+
+-- * Unrestricted, safe IO operations
+
+lift0 io         = SIO $ const io
+lift1 f io       = SIO $ f . unS io
+
+putStr           = putStrFlush
+putStrFlush s    = SIO ($ s)
+putStrLn         = putStrLnFlush
+putStrLnFlush s  = putStr s >> putStrFlush "\n"
+print x          = putStrLn (show x)
+
+getCPUTime           = lift0   IO.getCPUTime
+getCurrentDirectory  = lift0   IO.getCurrentDirectory
+getLibraryDirectory  = lift0 . IO.getLibraryDirectory
+newStdGen            = lift0   IO.newStdGen
+runInterruptibly     = lift1   IO.runInterruptibly
+
+importGrammar readNGF pgf opts files = lift0 $ GF.importGrammar readNGF pgf opts files
+importSource      opts files = lift0 $ GF.importSource      opts files
+link opts pgf src = lift0 $ GF.link opts pgf src
+
+modifyPGF   gr t = lift0 (PGFT.modifyPGF gr t)
+checkoutPGF gr = lift0 (PGFT.checkoutPGF gr)
+startTransaction gr = lift0 (PGFT.startTransaction gr)
+commitTransaction tr = lift0 (PGFT.commitTransaction tr)
+rollbackTransaction tr = lift0 (PGFT.rollbackTransaction tr)
+inTransaction tr f = lift0 (PGFT.inTransaction tr f)