reintroduce the compiler API

src/compiler/api/GF/System/Catch.hs

@@ -0,0 +1,7 @@
+-- | Backwards compatible 'catch' and 'try'
+module GF.System.Catch where
+import qualified System.IO.Error as S
+
+-- ** Backwards compatible try and catch
+catch = S.catchIOError
+try = S.tryIOError

src/compiler/api/GF/System/Concurrency.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+-- | A variant of 'Control.Concurrent.setNumCapabilities' that automatically
+-- detects the number of processors in the system.
+module GF.System.Concurrency(
+  -- * Controlling parallelism
+  setNumCapabilities,getNumberOfProcessors) where
+import qualified Control.Concurrent as C
+import Foreign.C.Types(CInt(..))
+
+
+
+
+-- | Set parallelism to a given number, or use the number of processors.
+-- Returns 'False' if compiled with GHC<7.6 and the desired number of threads
+-- hasn't already been set with @+RTS -N/n/ -RTS@.
+setNumCapabilities opt_n =
+  do n <- maybe getNumberOfProcessors return opt_n
+     C.setNumCapabilities n
+     return True
+
+-- | Returns the number of processors in the system.
+getNumberOfProcessors = fmap fromEnum c_getNumberOfProcessors
+
+-- | According to comments in cabal-install cbits/getnumprocessors.c
+-- this function is part of the RTS of GHC>=6.12.
+foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt

src/compiler/api/GF/System/Console.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE CPP #-}
+module GF.System.Console(
+    -- ** Console IO
+    -- *** Changing which character encoding to use for console IO
+    setConsoleEncoding,changeConsoleEncoding,
+    -- *** Console colors
+    TermColors(..),getTermColors
+) where
+import System.IO
+import Control.Monad(guard)
+import Control.Monad.Trans(MonadIO(..))
+#ifdef mingw32_HOST_OS
+import System.Win32.Console
+import System.Win32.NLS
+#else
+import System.Console.Terminfo
+#endif
+
+-- | Set the console encoding (for Windows, has no effect on Unix-like systems)
+setConsoleEncoding =
+#ifdef mingw32_HOST_OS
+    do codepage <- getACP
+       setCP codepage
+       setEncoding ("CP"++show codepage)
+#endif
+       return () :: IO ()
+
+changeConsoleEncoding code =
+    do
+#ifdef mingw32_HOST_OS
+       maybe (return ()) setCP (readCP code)
+#endif
+       setEncoding code
+
+setEncoding code =
+    do enc <- mkTextEncoding code
+       hSetEncoding stdin  enc
+       hSetEncoding stdout enc
+       hSetEncoding stderr enc
+
+#ifdef mingw32_HOST_OS
+setCP codepage =
+    do setConsoleCP codepage
+       setConsoleOutputCP codepage
+
+readCP code =
+       case code of
+         'C':'P':c -> case reads c of
+                        [(cp,"")] -> Just cp
+                        _         -> Nothing
+         "UTF-8"   -> Just 65001
+         _         -> Nothing
+#endif
+
+data TermColors = TermColors { redFg,blueFg,restore :: String } deriving Show
+noTermColors = TermColors "" "" ""
+
+getTermColors :: MonadIO m => m TermColors
+#ifdef mingw32_HOST_OS
+getTermColors = return noTermColors
+#else
+getTermColors =
+    liftIO $
+    do term <- setupTermFromEnv
+       return $ maybe noTermColors id $ getCapability term $
+         do n <- termColors
+            guard (n>=8)
+            fg <- setForegroundColor
+            restore <- restoreDefaultColors
+            return $ TermColors (fg Red) (fg Blue) restore
+#endif

src/compiler/api/GF/System/Directory.hs

@@ -0,0 +1,25 @@
+-- | Isolate backwards incompatible library changes to 'getModificationTime'
+-- and provide lifted versions of some directory operations
+module GF.System.Directory(module GF.System.Directory,module D) where
+import Control.Monad.Trans(MonadIO(..))
+import qualified System.Directory as D
+import System.Directory as D
+       hiding (canonicalizePath,createDirectoryIfMissing,
+               doesDirectoryExist,doesFileExist,getModificationTime,
+               getCurrentDirectory,getDirectoryContents,getPermissions,
+               removeFile,renameFile)
+--import Data.Time.Compat
+
+canonicalizePath path = liftIO $ D.canonicalizePath path
+createDirectoryIfMissing b = liftIO . D.createDirectoryIfMissing b
+doesDirectoryExist path = liftIO $ D.doesDirectoryExist path
+doesFileExist path = liftIO $ D.doesFileExist path
+getModificationTime path = liftIO $ {-fmap toUTCTime-} (D.getModificationTime path)
+getDirectoryContents path = liftIO $ D.getDirectoryContents path
+
+getCurrentDirectory :: MonadIO io => io FilePath
+getCurrentDirectory = liftIO D.getCurrentDirectory
+getPermissions path = liftIO $ D.getPermissions path
+
+removeFile path = liftIO $ D.removeFile path
+renameFile path = liftIO . D.renameFile path

src/compiler/api/GF/System/NoSignal.hs

@@ -0,0 +1,29 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.NoSignal
+-- Maintainer  : Bjorn Bringert
+-- Stability   : (stability)
+-- Portability : (portability)
+--
+-- > CVS $Date: 2005/11/11 11:12:50 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- Dummy implementation of signal handling.
+-----------------------------------------------------------------------------
+
+module GF.System.NoSignal where
+
+import Control.Exception (SomeException,catch)
+import Prelude hiding (catch)
+
+{-# NOINLINE runInterruptibly #-}
+runInterruptibly :: IO a -> IO (Either SomeException a)
+--runInterruptibly = fmap Right
+runInterruptibly a = 
+    p `catch` h
+  where p = a >>= \x -> return $! Right $! x
+        h e = return $ Left e
+
+blockInterrupt :: IO a -> IO a
+blockInterrupt = id

src/compiler/api/GF/System/Process.hs

@@ -0,0 +1,18 @@
+module GF.System.Process where
+import System.Process
+import System.IO(hGetContents,hClose,hPutStr)
+import Control.Concurrent(forkIO)
+import GF.System.Catch(try)
+
+-- | Feed some input to a shell process and read the output lazily
+readShellProcess :: String     -- ^ shell command
+                  -> String    -- ^ input to shell command
+                  -> IO String -- ^ output from shell command
+readShellProcess cmd input =
+  do (Just stdin,Just stdout,Nothing,ph) <-
+         createProcess (shell cmd){std_in=CreatePipe,std_out=CreatePipe}
+     forkIO $ do try $ hPutStr stdin input
+                 try $ hClose stdin
+                 waitForProcess ph
+                 return ()
+     hGetContents stdout

src/compiler/api/GF/System/Signal.hs

@@ -0,0 +1,27 @@
+{-# OPTIONS -cpp #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.Signal
+-- Maintainer  : Bjorn Bringert
+-- Stability   : (stability)
+-- Portability : (portability)
+--
+-- > CVS $Date: 2005/11/11 11:12:50 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.3 $
+--
+-- Import the right singal handling module.
+-----------------------------------------------------------------------------
+
+module GF.System.Signal (runInterruptibly,blockInterrupt) where
+
+#ifdef USE_INTERRUPT
+
+import GF.System.UseSignal (runInterruptibly,blockInterrupt)
+
+#else
+
+import GF.System.NoSignal (runInterruptibly,blockInterrupt)
+
+#endif

src/compiler/api/GF/System/UseSignal.hs

@@ -0,0 +1,72 @@
+{-# OPTIONS -cpp #-}
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.System.UseSignal
+-- Maintainer  : Bjorn Bringert
+-- Stability   : (stability)
+-- Portability : (portability)
+--
+-- > CVS $Date: 2005/11/11 11:12:50 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- Allows SIGINT (Ctrl-C) to interrupt computations.
+-----------------------------------------------------------------------------
+
+module GF.System.UseSignal where
+
+import Control.Concurrent (myThreadId, killThread)
+import Control.Exception (SomeException,catch)
+import Prelude hiding (catch)
+--import System.IO
+
+#ifdef mingw32_HOST_OS
+import GHC.ConsoleHandler
+
+myInstallHandler handler = installHandler handler
+myCatch  = Catch . const
+myIgnore = Ignore
+#else
+import System.Posix.Signals
+
+myInstallHandler handler = installHandler sigINT handler Nothing
+myCatch  = Catch
+myIgnore = Ignore
+#endif
+
+{-# NOINLINE runInterruptibly #-}
+
+-- | Run an IO action, and allow it to be interrupted
+--   by a SIGINT to the current process. Returns
+--   an exception if the process did not complete 
+--   normally.
+--   NOTES: 
+--   * This will replace any existing SIGINT
+--     handler during the action. After the computation 
+--     has completed the existing handler will be restored.
+--   * If the IO action is lazy (e.g. using readFile,
+--     unsafeInterleaveIO etc.) the lazy computation will
+--     not be interruptible, as it will be performed
+--     after the signal handler has been removed.
+runInterruptibly :: IO a -> IO (Either SomeException a)
+runInterruptibly a = 
+    do t <- myThreadId
+       oldH <- myInstallHandler (myCatch (killThread t))
+       x <- p `catch` h
+       myInstallHandler oldH
+       return x
+  where p = a >>= \x -> return $! Right $! x
+        h e = return $ Left e
+
+-- | Like 'runInterruptibly', but always returns (), whether
+--   the computation fails or not.
+runInterruptibly_ :: IO () -> IO ()
+runInterruptibly_ = fmap (either (const ()) id) . runInterruptibly
+
+-- | Run an action with SIGINT blocked.
+blockInterrupt :: IO a -> IO a
+blockInterrupt a = 
+    do oldH <- myInstallHandler myIgnore
+       x <- a
+       myInstallHandler oldH
+       return x