-- |
-- Copyright: (C) 2013 Amgen, Inc.
--
-- Interaction with an instance of R. The interface in this module allows for
-- instantiating an arbitrary number of concurrent R sessions, even though
-- currently the R library only allows for one global instance, for forward
-- compatibility.
--
-- The 'R' monad defined here serves to give static guarantees that an instance
-- is only ever used after it has been initialized and before it is finalized.
-- Doing otherwise should result in a type error. This is done in the same way
-- that the 'Control.Monad.ST' monad encapsulates side effects: by assigning
-- a rank-2 type to the only run function for the monad.
--
-- This module is intended to be imported qualified.

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeFamilies #-}

module Language.R.Instance
  ( -- * The R monad
    R
  , runRegion
  , unsafeRunRegion
  -- * R instance creation
  , Config(..)
  , defaultConfig
  , withEmbeddedR
  , initialize
  , finalize
  ) where

import           Control.Monad.Primitive (PrimMonad(..))
import           Control.Monad.R.Class
import           Control.Monad.ST.Unsafe (unsafeSTToIO)
import qualified Data.Semigroup as Sem
import           Data.Monoid
import           Data.Default.Class (Default(..))
import qualified Foreign.R as R
import qualified Foreign.R.Embedded as R
#ifndef mingw32_HOST_OS
import qualified Foreign.R.EventLoop as R
#endif
import           Foreign.C.String
import           Language.R.Globals

import Control.Applicative
import Control.Concurrent.MVar
    ( newMVar
    , withMVar
    , MVar
    )
import Control.DeepSeq ( NFData, deepseq )
import Control.Exception
    ( bracket
    , bracket_
    , uninterruptibleMask_
    )
import Control.Monad.Catch ( MonadCatch, MonadMask, MonadThrow )
#if MIN_VERSION_base(4,9,0)
import Control.Monad.Fail
#endif
import Control.Monad.Reader
import Data.IORef (IORef, newIORef, readIORef, modifyIORef')
import Foreign
    ( Ptr
    , allocaArray
    )
import Foreign.C.Types ( CInt(..) )
import Foreign.Storable (Storable(..))
import System.Environment ( getProgName, lookupEnv )
import System.IO.Unsafe   ( unsafePerformIO )
import System.Process     ( readProcess )
import System.SetEnv
#ifndef mingw32_HOST_OS
import Control.Exception ( onException )
import System.IO ( hPutStrLn, stderr )
import System.Posix.Resource
#endif
import Prelude

-- | The 'R' monad, for sequencing actions interacting with a single instance of
-- the R interpreter, much as the 'IO' monad sequences actions interacting with
-- the real world. The 'R' monad embeds the 'IO' monad, so all 'IO' actions can
-- be lifted to 'R' actions.
newtype R s a = R { R s a -> ReaderT (IORef Int) IO a
unR :: ReaderT (IORef Int) IO a }
  deriving (Functor (R s)
a -> R s a
Functor (R s) =>
(forall a. a -> R s a)
-> (forall a b. R s (a -> b) -> R s a -> R s b)
-> (forall a b c. (a -> b -> c) -> R s a -> R s b -> R s c)
-> (forall a b. R s a -> R s b -> R s b)
-> (forall a b. R s a -> R s b -> R s a)
-> Applicative (R s)
R s a -> R s b -> R s b
R s a -> R s b -> R s a
R s (a -> b) -> R s a -> R s b
(a -> b -> c) -> R s a -> R s b -> R s c
forall s. Functor (R s)
forall a. a -> R s a
forall s a. a -> R s a
forall a b. R s a -> R s b -> R s a
forall a b. R s a -> R s b -> R s b
forall a b. R s (a -> b) -> R s a -> R s b
forall s a b. R s a -> R s b -> R s a
forall s a b. R s a -> R s b -> R s b
forall s a b. R s (a -> b) -> R s a -> R s b
forall a b c. (a -> b -> c) -> R s a -> R s b -> R s c
forall s a b c. (a -> b -> c) -> R s a -> R s b -> R s c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: R s a -> R s b -> R s a
$c<* :: forall s a b. R s a -> R s b -> R s a
*> :: R s a -> R s b -> R s b
$c*> :: forall s a b. R s a -> R s b -> R s b
liftA2 :: (a -> b -> c) -> R s a -> R s b -> R s c
$cliftA2 :: forall s a b c. (a -> b -> c) -> R s a -> R s b -> R s c
<*> :: R s (a -> b) -> R s a -> R s b
$c<*> :: forall s a b. R s (a -> b) -> R s a -> R s b
pure :: a -> R s a
$cpure :: forall s a. a -> R s a
$cp1Applicative :: forall s. Functor (R s)
Applicative, a -> R s b -> R s a
(a -> b) -> R s a -> R s b
(forall a b. (a -> b) -> R s a -> R s b)
-> (forall a b. a -> R s b -> R s a) -> Functor (R s)
forall a b. a -> R s b -> R s a
forall a b. (a -> b) -> R s a -> R s b
forall s a b. a -> R s b -> R s a
forall s a b. (a -> b) -> R s a -> R s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> R s b -> R s a
$c<$ :: forall s a b. a -> R s b -> R s a
fmap :: (a -> b) -> R s a -> R s b
$cfmap :: forall s a b. (a -> b) -> R s a -> R s b
Functor, Applicative (R s)
a -> R s a
Applicative (R s) =>
(forall a b. R s a -> (a -> R s b) -> R s b)
-> (forall a b. R s a -> R s b -> R s b)
-> (forall a. a -> R s a)
-> Monad (R s)
R s a -> (a -> R s b) -> R s b
R s a -> R s b -> R s b
forall s. Applicative (R s)
forall a. a -> R s a
forall s a. a -> R s a
forall a b. R s a -> R s b -> R s b
forall a b. R s a -> (a -> R s b) -> R s b
forall s a b. R s a -> R s b -> R s b
forall s a b. R s a -> (a -> R s b) -> R s b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> R s a
$creturn :: forall s a. a -> R s a
>> :: R s a -> R s b -> R s b
$c>> :: forall s a b. R s a -> R s b -> R s b
>>= :: R s a -> (a -> R s b) -> R s b
$c>>= :: forall s a b. R s a -> (a -> R s b) -> R s b
$cp1Monad :: forall s. Applicative (R s)
Monad, Monad (R s)
Monad (R s) => (forall a. IO a -> R s a) -> MonadIO (R s)
IO a -> R s a
forall s. Monad (R s)
forall a. IO a -> R s a
forall s a. IO a -> R s a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> R s a
$cliftIO :: forall s a. IO a -> R s a
$cp1MonadIO :: forall s. Monad (R s)
MonadIO, MonadThrow (R s)
MonadThrow (R s) =>
(forall e a. Exception e => R s a -> (e -> R s a) -> R s a)
-> MonadCatch (R s)
R s a -> (e -> R s a) -> R s a
forall s. MonadThrow (R s)
forall e a. Exception e => R s a -> (e -> R s a) -> R s a
forall s e a. Exception e => R s a -> (e -> R s a) -> R s a
forall (m :: * -> *).
MonadThrow m =>
(forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: R s a -> (e -> R s a) -> R s a
$ccatch :: forall s e a. Exception e => R s a -> (e -> R s a) -> R s a
$cp1MonadCatch :: forall s. MonadThrow (R s)
MonadCatch, MonadCatch (R s)
MonadCatch (R s) =>
(forall b. ((forall a. R s a -> R s a) -> R s b) -> R s b)
-> (forall b. ((forall a. R s a -> R s a) -> R s b) -> R s b)
-> (forall a b c.
    R s a -> (a -> ExitCase b -> R s c) -> (a -> R s b) -> R s (b, c))
-> MonadMask (R s)
R s a -> (a -> ExitCase b -> R s c) -> (a -> R s b) -> R s (b, c)
((forall a. R s a -> R s a) -> R s b) -> R s b
((forall a. R s a -> R s a) -> R s b) -> R s b
forall s. MonadCatch (R s)
forall b. ((forall a. R s a -> R s a) -> R s b) -> R s b
forall s b. ((forall a. R s a -> R s a) -> R s b) -> R s b
forall a b c.
R s a -> (a -> ExitCase b -> R s c) -> (a -> R s b) -> R s (b, c)
forall s a b c.
R s a -> (a -> ExitCase b -> R s c) -> (a -> R s b) -> R s (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: R s a -> (a -> ExitCase b -> R s c) -> (a -> R s b) -> R s (b, c)
$cgeneralBracket :: forall s a b c.
R s a -> (a -> ExitCase b -> R s c) -> (a -> R s b) -> R s (b, c)
uninterruptibleMask :: ((forall a. R s a -> R s a) -> R s b) -> R s b
$cuninterruptibleMask :: forall s b. ((forall a. R s a -> R s a) -> R s b) -> R s b
mask :: ((forall a. R s a -> R s a) -> R s b) -> R s b
$cmask :: forall s b. ((forall a. R s a -> R s a) -> R s b) -> R s b
$cp1MonadMask :: forall s. MonadCatch (R s)
MonadMask, Monad (R s)
e -> R s a
Monad (R s) =>
(forall e a. Exception e => e -> R s a) -> MonadThrow (R s)
forall s. Monad (R s)
forall e a. Exception e => e -> R s a
forall s e a. Exception e => e -> R s a
forall (m :: * -> *).
Monad m =>
(forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> R s a
$cthrowM :: forall s e a. Exception e => e -> R s a
$cp1MonadThrow :: forall s. Monad (R s)
MonadThrow)

#if MIN_VERSION_base(4,9,0)
instance MonadFail (R s) where
  fail :: String -> R s a
fail s :: String
s = ReaderT (IORef Int) IO a -> R s a
forall s a. ReaderT (IORef Int) IO a -> R s a
R (ReaderT (IORef Int) IO a -> R s a)
-> ReaderT (IORef Int) IO a -> R s a
forall a b. (a -> b) -> a -> b
$ (IORef Int -> IO a) -> ReaderT (IORef Int) IO a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((IORef Int -> IO a) -> ReaderT (IORef Int) IO a)
-> (IORef Int -> IO a) -> ReaderT (IORef Int) IO a
forall a b. (a -> b) -> a -> b
$ \_ -> String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
Control.Monad.Fail.fail String
s
#endif

instance PrimMonad (R s) where
  type PrimState (R s) = s
  primitive :: (State# (PrimState (R s)) -> (# State# (PrimState (R s)), a #))
-> R s a
primitive f :: State# (PrimState (R s)) -> (# State# (PrimState (R s)), a #)
f = ReaderT (IORef Int) IO a -> R s a
forall s a. ReaderT (IORef Int) IO a -> R s a
R (ReaderT (IORef Int) IO a -> R s a)
-> ReaderT (IORef Int) IO a -> R s a
forall a b. (a -> b) -> a -> b
$ IO a -> ReaderT (IORef Int) IO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> ReaderT (IORef Int) IO a)
-> IO a -> ReaderT (IORef Int) IO a
forall a b. (a -> b) -> a -> b
$ ST s a -> IO a
forall s a. ST s a -> IO a
unsafeSTToIO (ST s a -> IO a) -> ST s a -> IO a
forall a b. (a -> b) -> a -> b
$ (State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #))
-> ST s a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #)
State# (PrimState (R s)) -> (# State# (PrimState (R s)), a #)
f

instance MonadR (R s) where
  io :: IO a -> R s a
io m :: IO a
m = ReaderT (IORef Int) IO a -> R s a
forall s a. ReaderT (IORef Int) IO a -> R s a
R (ReaderT (IORef Int) IO a -> R s a)
-> ReaderT (IORef Int) IO a -> R s a
forall a b. (a -> b) -> a -> b
$ (IORef Int -> IO a) -> ReaderT (IORef Int) IO a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((IORef Int -> IO a) -> ReaderT (IORef Int) IO a)
-> (IORef Int -> IO a) -> ReaderT (IORef Int) IO a
forall a b. (a -> b) -> a -> b
$ \_ -> IO a
m
  acquire :: SEXP s a -> R s (SEXP (Region (R s)) a)
acquire s :: SEXP s a
s = ReaderT (IORef Int) IO (SEXP s a) -> R s (SEXP (Region (R s)) a)
forall s a. ReaderT (IORef Int) IO a -> R s a
R (ReaderT (IORef Int) IO (SEXP s a) -> R s (SEXP (Region (R s)) a))
-> ReaderT (IORef Int) IO (SEXP s a) -> R s (SEXP (Region (R s)) a)
forall a b. (a -> b) -> a -> b
$ (IORef Int -> IO (SEXP s a)) -> ReaderT (IORef Int) IO (SEXP s a)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((IORef Int -> IO (SEXP s a)) -> ReaderT (IORef Int) IO (SEXP s a))
-> (IORef Int -> IO (SEXP s a))
-> ReaderT (IORef Int) IO (SEXP s a)
forall a b. (a -> b) -> a -> b
$ \cnt :: IORef Int
cnt -> IO (SEXP s a) -> IO (SEXP s a)
forall a. IO a -> IO a
uninterruptibleMask_ (IO (SEXP s a) -> IO (SEXP s a)) -> IO (SEXP s a) -> IO (SEXP s a)
forall a b. (a -> b) -> a -> b
$ do
    SEXP s a
x <- SEXP G a -> SEXP s a
forall t s (a :: SEXPTYPE). (t <= s) => SEXP s a -> SEXP t a
R.release (SEXP G a -> SEXP s a) -> IO (SEXP G a) -> IO (SEXP s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SEXP s a -> IO (SEXP G a)
forall s (a :: SEXPTYPE). SEXP s a -> IO (SEXP G a)
R.protect SEXP s a
s
    IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
cnt Int -> Int
forall a. Enum a => a -> a
succ
    SEXP s a -> IO (SEXP s a)
forall (m :: * -> *) a. Monad m => a -> m a
return SEXP s a
x
  newtype ExecContext (R s) = ExecContext (IORef Int)
  getExecContext :: R s (ExecContext (R s))
getExecContext = ReaderT (IORef Int) IO (ExecContext (R s))
-> R s (ExecContext (R s))
forall s a. ReaderT (IORef Int) IO a -> R s a
R (ReaderT (IORef Int) IO (ExecContext (R s))
 -> R s (ExecContext (R s)))
-> ReaderT (IORef Int) IO (ExecContext (R s))
-> R s (ExecContext (R s))
forall a b. (a -> b) -> a -> b
$ (IORef Int -> IO (ExecContext (R s)))
-> ReaderT (IORef Int) IO (ExecContext (R s))
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((IORef Int -> IO (ExecContext (R s)))
 -> ReaderT (IORef Int) IO (ExecContext (R s)))
-> (IORef Int -> IO (ExecContext (R s)))
-> ReaderT (IORef Int) IO (ExecContext (R s))
forall a b. (a -> b) -> a -> b
$ \ref :: IORef Int
ref -> ExecContext (R s) -> IO (ExecContext (R s))
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef Int -> ExecContext (R s)
forall s. IORef Int -> ExecContext (R s)
ExecContext IORef Int
ref)
  unsafeRunWithExecContext :: R s a -> ExecContext (R s) -> IO a
unsafeRunWithExecContext m :: R s a
m (ExecContext ref) = ReaderT (IORef Int) IO a -> IORef Int -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (R s a -> ReaderT (IORef Int) IO a
forall s a. R s a -> ReaderT (IORef Int) IO a
unR R s a
m) IORef Int
ref

-- | Initialize a new instance of R, execute actions that interact with the
-- R instance and then finalize the instance. This is typically called at the
-- very beginning of the @main@ function of the program.
--
-- > main = withEmbeddedR $ do {...}
--
-- Note that R does not currently support reinitialization after finalization,
-- so this function should be called only once during the lifetime of the
-- program (see @src/unix/system.c:Rf_initialize()@ in the R source code).
withEmbeddedR :: Config -> IO a -> IO a
withEmbeddedR :: Config -> IO a -> IO a
withEmbeddedR config :: Config
config = IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (Config -> IO ()
initialize Config
config) IO ()
finalize

-- | Run an R action in the global R instance from the IO monad. This action
-- provides no static guarantees that the R instance was indeed initialized and
-- has not yet been finalized. Make sure to call it within the scope of
-- `withEmbeddedR`.
--
-- @runRegion m@ fully evaluates the result of action @m@, to ensure that no
-- thunks hold onto resources in a way that would extrude the scope of the
-- region. This means that the result must be first-order data (i.e. not
-- a function).
--
-- @throws@ 'Foreign.R.Error'. Generaly any R function may throw @RError@ that
-- is safe to be cached and computation can proceed. However @RError@ will cancel
-- entire R block. So in order to catch exception in more fine grained way one
-- has to use function @tryCatch@ inside R block.
runRegion :: NFData a => (forall s. R s a) -> IO a
runRegion :: (forall s. R s a) -> IO a
runRegion r :: forall s. R s a
r = R Any a -> IO a
forall a s. NFData a => R s a -> IO a
unsafeRunRegion R Any a
forall s. R s a
r

unsafeRunRegion :: NFData a => R s a -> IO a
unsafeRunRegion :: R s a -> IO a
unsafeRunRegion r :: R s a
r =
  IO (IORef Int)
-> (IORef Int -> IO ()) -> (IORef Int -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef 0)
          (Int -> IO ()
R.unprotect (Int -> IO ()) -> (IORef Int -> IO Int) -> IORef Int -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef)
          (\d :: IORef Int
d -> do
             a
x <- ReaderT (IORef Int) IO a -> IORef Int -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (R s a -> ReaderT (IORef Int) IO a
forall s a. R s a -> ReaderT (IORef Int) IO a
unR R s a
r) IORef Int
d
             a
x a -> IO a -> IO a
forall a b. NFData a => a -> b -> b
`deepseq` a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x)

-- | Configuration options for the R runtime. Configurations form monoids, so
-- arguments can be accumulated left-to-right through monoidal composition.
data Config = Config
  { -- | Program name. If 'Nothing' then the value of 'getProgName' will be
    -- used.
    Config -> Last String
configProgName :: Last String
    -- | Command-line arguments.
  , Config -> [String]
configArgs :: [String]

    -- | Set to 'True' if you're happy to let R install its own signal handlers
    -- during initialization. By default R sets following signal handlers:
    --
    --  * SIGPIPE - ignore signal;
    --  * SIGUSR1 - save workspace and terminate program;
    --  * SIGUSR2 - terminate program without saving workspace;
    --  * SIGINT  - cancel execution of the current function.
    --
    -- *N.B.* When program is terminated, haskell runtime will not have any chances
    -- to run any exception handlers or finalizers.
  , Config -> Last Bool
configSignalHandlers :: Last Bool
  }

instance Default Config where
  def :: Config
def = Config
defaultConfig

instance Sem.Semigroup Config where
  <> :: Config -> Config -> Config
(<>) cfg1 :: Config
cfg1 cfg2 :: Config
cfg2 = Config :: Last String -> [String] -> Last Bool -> Config
Config
      { configProgName :: Last String
configProgName = Config -> Last String
configProgName Config
cfg1 Last String -> Last String -> Last String
forall a. Semigroup a => a -> a -> a
<> Config -> Last String
configProgName Config
cfg2
      , configArgs :: [String]
configArgs = Config -> [String]
configArgs Config
cfg1 [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> Config -> [String]
configArgs Config
cfg2
      , configSignalHandlers :: Last Bool
configSignalHandlers =  Config -> Last Bool
configSignalHandlers Config
cfg1 Last Bool -> Last Bool -> Last Bool
forall a. Semigroup a => a -> a -> a
<> Config -> Last Bool
configSignalHandlers Config
cfg2
      }

instance Monoid Config where
  mempty :: Config
mempty = Config
defaultConfig
  mappend :: Config -> Config -> Config
mappend = Config -> Config -> Config
forall a. Semigroup a => a -> a -> a
(<>)

-- | Default argument to pass to 'initialize'.
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Last String -> [String] -> Last Bool -> Config
Config (Maybe String -> Last String
forall a. Maybe a -> Last a
Last Maybe String
forall a. Maybe a
Nothing) ["--vanilla", "--silent"] (Maybe Bool -> Last Bool
forall a. Maybe a -> Last a
Last (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False))

-- | Populate environment with @R_HOME@ variable if it does not exist.
populateEnv :: IO ()
populateEnv :: IO ()
populateEnv = do
    Maybe String
mh <- String -> IO (Maybe String)
lookupEnv "R_HOME"
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String
mh Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
forall a. Maybe a
Nothing) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> String -> IO ()
setEnv "R_HOME" (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> String
forall a. [a] -> a
head ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) (String -> [String] -> String -> IO String
readProcess "R" ["-e","cat(R.home())","--quiet","--slave"] "")

-- | A static address that survives GHCi reloadings which indicates
-- whether R has been initialized.
foreign import ccall "missing_r.h &isRInitialized" isRInitializedPtr :: Ptr CInt

-- | Allocate and initialize a new array of elements.
newCArray :: Storable a
          => [a]                                  -- ^ Array elements
          -> (Ptr a -> IO r)                      -- ^ Continuation
          -> IO r
newCArray :: [a] -> (Ptr a -> IO r) -> IO r
newCArray xs :: [a]
xs k :: Ptr a -> IO r
k =
    Int -> (Ptr a -> IO r) -> IO r
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) ((Ptr a -> IO r) -> IO r) -> (Ptr a -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr a
ptr -> do
      (Int -> a -> IO ()) -> [Int] -> [a] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Ptr a -> Int -> a -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
ptr) [0..] [a]
xs
      Ptr a -> IO r
k Ptr a
ptr

-- | An MVar to make an atomic step of checking whether R is initialized and
-- initializing it if needed.
initLock :: MVar ()
initLock :: MVar ()
initLock = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO (IO (MVar ()) -> MVar ()) -> IO (MVar ()) -> MVar ()
forall a b. (a -> b) -> a -> b
$ () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
{-# NOINLINE initLock #-}

-- Note [Concurrent initialization]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- In 'initialize' we check a first time if R is initialized. This test is fast
-- since it happens without taking an MVar. If R needs initialization, after
-- taking the MVar we check again if R is initialized to avoid concurrent
-- threads from initializing R multiple times. The user is not expected to call
-- initialize multiple times concurrently, but there is nothing stopping the
-- compiler from doing so when compiling quasiquotes.

-- | Create a new embedded instance of the R interpreter. Only works from the
-- main thread of the program. That is, from the same thread of execution that
-- the program's @main@ function is running on. In GHCi, use @-fno-ghci-sandbox@
-- to achieve this.
initialize :: Config -> IO ()
initialize :: Config -> IO ()
initialize Config{..} = do
#ifndef mingw32_HOST_OS
#if defined(darwin_HOST_OS) || defined(freebsd_HOST_OS)
    -- NOTE: OS X and FreeBSD does not allow removing the stack size limit completely,
    -- instead forcing a hard limit of just under 64MB.
    let stackLimit :: ResourceLimit
stackLimit = Integer -> ResourceLimit
ResourceLimit 67104768
#else
    let stackLimit = ResourceLimitUnknown
#endif
    Resource -> ResourceLimits -> IO ()
setResourceLimit Resource
ResourceStackSize (ResourceLimit -> ResourceLimit -> ResourceLimits
ResourceLimits ResourceLimit
stackLimit ResourceLimit
stackLimit)
      IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` (Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                       "Language.R.Interpreter: "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Cannot increase stack size limit."
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Try increasing your stack size limit manually:"
#ifdef darwin_HOST_OS
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ "$ launchctl limit stack 67104768"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ "$ ulimit -s 65532"
#elif defined(freebsd_HOST_OS)
                       ++ "$ ulimit -s 67104768"
#else
                       ++ "$ ulimit -s unlimited"
#endif
                    )
#endif
    Bool
initialized <- (CInt -> Bool) -> IO CInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
==1) (IO CInt -> IO Bool) -> IO CInt -> IO Bool
forall a b. (a -> b) -> a -> b
$ Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
isRInitializedPtr
    -- See note [Concurrent initialization]
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
initialized (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
initLock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Bool
initialized2 <- (CInt -> Bool) -> IO CInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
==1) (IO CInt -> IO Bool) -> IO CInt -> IO Bool
forall a b. (a -> b) -> a -> b
$ Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
isRInitializedPtr
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
initialized2 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ mdo
        -- Grab addresses of R global variables
        RVariables -> IO ()
pokeRVariables
          ( Ptr (SEXP G 'Env)
R.baseEnv
          , Ptr (SEXP G 'Env)
R.emptyEnv
          , Ptr (SEXP G 'Env)
R.globalEnv
          , Ptr (SEXP G 'Nil)
R.nilValue
          , Ptr (SEXP G 'Symbol)
R.unboundValue
          , Ptr (SEXP G 'Symbol)
R.missingArg
          , Ptr CInt
R.isRInteractive
          , Ptr CInt
R.signalHandlers
#ifndef mingw32_HOST_OS
          , Ptr (Ptr InputHandler)
R.inputHandlers
#endif
          )
        IO ()
populateEnv
        [String]
args <- (:) (String -> [String] -> [String])
-> IO String -> IO ([String] -> [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getProgName String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Last String -> Maybe String
forall a. Last a -> Maybe a
getLast Last String
configProgName)
                    IO ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String]
configArgs
        [CString]
argv <- (String -> IO CString) -> [String] -> IO [CString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO CString
newCString [String]
args
        let argc :: Int
argc = [CString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CString]
argv
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> (Bool -> Bool) -> Maybe Bool -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Bool -> Bool
forall a. a -> a
id (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Last Bool -> Maybe Bool
forall a. Last a -> Maybe a
getLast Last Bool
configSignalHandlers) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
signalHandlersPtr 0
        [CString] -> (Ptr CString -> IO ()) -> IO ()
forall a r. Storable a => [a] -> (Ptr a -> IO r) -> IO r
newCArray [CString]
argv ((Ptr CString -> IO ()) -> IO ())
-> (Ptr CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Ptr CString -> IO ()
R.initEmbeddedR Int
argc
        Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
isRInteractive 0
        Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
isRInitializedPtr 1

-- | Finalize an R instance.
finalize :: IO ()
finalize :: IO ()
finalize = do
    Int -> IO ()
R.endEmbeddedR 0
    Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
isRInitializedPtr 0