{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeFamilies #-}
module Language.R.Instance
(
R
, runRegion
, unsafeRunRegion
, Config(..)
, defaultConfig
, withEmbeddedR
, initialize
, finalize
) where
import Control.Monad ((<=<), unless, when, zipWithM_)
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
newtype R s a = R { forall s a. R s a -> ReaderT (IORef Int) IO a
unR :: ReaderT (IORef Int) IO a }
deriving (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
<* :: forall a b. R s a -> R s b -> R s a
$c<* :: forall s a b. R s a -> R s b -> R s a
*> :: forall a b. R s a -> R s b -> R s b
$c*> :: forall s a b. R s a -> R s b -> R s b
liftA2 :: forall a b c. (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
<*> :: forall a b. 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 :: forall a. a -> R s a
$cpure :: forall s a. a -> R s a
Applicative, 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
<$ :: forall a b. a -> R s b -> R s a
$c<$ :: forall s a b. a -> R s b -> R s a
fmap :: forall a b. (a -> b) -> R s a -> R s b
$cfmap :: forall s a b. (a -> b) -> R s a -> R s b
Functor, 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 :: forall a. a -> R s a
$creturn :: forall s a. a -> R s a
>> :: forall a b. R s a -> R s b -> R s b
$c>> :: forall s a b. R s a -> R s b -> R s b
>>= :: forall a 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
Monad, 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 :: forall a. IO a -> R s a
$cliftIO :: forall s a. IO a -> R s a
MonadIO, 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 :: forall e a. Exception e => 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
MonadCatch, 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 :: forall a b c.
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 b. ((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 b. ((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
MonadMask, 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 :: forall e a. Exception e => e -> R s a
$cthrowM :: forall s e a. Exception e => e -> R s a
MonadThrow)
#if MIN_VERSION_base(4,9,0)
instance MonadFail (R s) where
fail :: forall a. String -> R s a
fail String
s = forall s a. ReaderT (IORef Int) IO a -> R s a
R forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \IORef Int
_ -> 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 :: forall a.
(State# (PrimState (R s)) -> (# State# (PrimState (R s)), a #))
-> R s a
primitive State# (PrimState (R s)) -> (# State# (PrimState (R s)), a #)
f = forall s a. ReaderT (IORef Int) IO a -> R s a
R forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s a. ST s a -> IO a
unsafeSTToIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive State# (PrimState (R s)) -> (# State# (PrimState (R s)), a #)
f
instance MonadR (R s) where
io :: forall a. IO a -> R s a
io IO a
m = forall s a. ReaderT (IORef Int) IO a -> R s a
R forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \IORef Int
_ -> IO a
m
acquire :: forall s (a :: SEXPTYPE).
(s ~ V) =>
SEXP s a -> R s (SEXP (Region (R s)) a)
acquire SEXP s a
s = forall s a. ReaderT (IORef Int) IO a -> R s a
R forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \IORef Int
cnt -> forall a. IO a -> IO a
uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ do
SEXP s a
x <- forall t s (a :: SEXPTYPE). (t <= s) => SEXP s a -> SEXP t a
R.release forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (a :: SEXPTYPE). SEXP s a -> IO (SEXP G a)
R.protect SEXP s a
s
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
cnt forall a. Enum a => a -> a
succ
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 = forall s a. ReaderT (IORef Int) IO a -> R s a
R forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \IORef Int
ref -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall s. IORef Int -> ExecContext (R s)
ExecContext IORef Int
ref)
unsafeRunWithExecContext :: forall a. R s a -> ExecContext (R s) -> IO a
unsafeRunWithExecContext R s a
m (ExecContext IORef Int
ref) = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall s a. R s a -> ReaderT (IORef Int) IO a
unR R s a
m) IORef Int
ref
withEmbeddedR :: Config -> IO a -> IO a
withEmbeddedR :: forall a. Config -> IO a -> IO a
withEmbeddedR Config
config = forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (Config -> IO ()
initialize Config
config) IO ()
finalize
runRegion :: NFData a => (forall s. R s a) -> IO a
runRegion :: forall a. NFData a => (forall s. R s a) -> IO a
runRegion forall s. R s a
r = forall a s. NFData a => R s a -> IO a
unsafeRunRegion forall s. R s a
r
unsafeRunRegion :: NFData a => R s a -> IO a
unsafeRunRegion :: forall a s. NFData a => R s a -> IO a
unsafeRunRegion R s a
r =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall a. a -> IO (IORef a)
newIORef Int
0)
(Int -> IO ()
R.unprotect forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. IORef a -> IO a
readIORef)
(\IORef Int
d -> do
a
x <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall s a. R s a -> ReaderT (IORef Int) IO a
unR R s a
r) IORef Int
d
a
x forall a b. NFData a => a -> b -> b
`deepseq` forall (m :: * -> *) a. Monad m => a -> m a
return a
x)
data Config = Config
{
Config -> Last String
configProgName :: Last String
, Config -> [String]
configArgs :: [String]
, Config -> Last Bool
configSignalHandlers :: Last Bool
}
instance Default Config where
def :: Config
def = Config
defaultConfig
instance Sem.Semigroup Config where
<> :: Config -> Config -> Config
(<>) Config
cfg1 Config
cfg2 = Config
{ configProgName :: Last String
configProgName = Config -> Last String
configProgName Config
cfg1 forall a. Semigroup a => a -> a -> a
<> Config -> Last String
configProgName Config
cfg2
, configArgs :: [String]
configArgs = Config -> [String]
configArgs Config
cfg1 forall a. Semigroup a => a -> a -> a
<> Config -> [String]
configArgs Config
cfg2
, configSignalHandlers :: Last Bool
configSignalHandlers = Config -> Last Bool
configSignalHandlers Config
cfg1 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 = forall a. Semigroup a => a -> a -> a
(<>)
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Last String -> [String] -> Last Bool -> Config
Config (forall a. Maybe a -> Last a
Last forall a. Maybe a
Nothing) [String
"--vanilla", String
"--silent"] (forall a. Maybe a -> Last a
Last (forall a. a -> Maybe a
Just Bool
False))
populateEnv :: IO ()
populateEnv :: IO ()
populateEnv = do
Maybe String
mh <- String -> IO (Maybe String)
lookupEnv String
"R_HOME"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String
mh forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
String -> String -> IO ()
setEnv String
"R_HOME" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) (String -> [String] -> String -> IO String
readProcess String
"R" [String
"-e",String
"cat(R.home())",String
"--quiet",String
"--slave"] String
"")
Maybe String
ml <- String -> IO (Maybe String)
lookupEnv String
"R_LIBS"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String
ml forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
String -> String -> IO ()
setEnv String
"R_LIBS" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) (String -> [String] -> String -> IO String
readProcess String
"R" [String
"-e",String
"cat(.libPaths(),sep=if (.Platform$OS.type == \"unix\") \":\" else \";\")",String
"--quiet",String
"--slave"] String
"")
foreign import ccall "missing_r.h &isRInitialized" isRInitializedPtr :: Ptr CInt
newCArray :: Storable a
=> [a]
-> (Ptr a -> IO r)
-> IO r
newCArray :: forall a r. Storable a => [a] -> (Ptr a -> IO r) -> IO r
newCArray [a]
xs Ptr a -> IO r
k =
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> do
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
ptr) [Int
0..] [a]
xs
Ptr a -> IO r
k Ptr a
ptr
initLock :: MVar ()
initLock :: MVar ()
initLock = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar ()
{-# NOINLINE initLock #-}
initialize :: Config -> IO ()
initialize :: Config -> IO ()
initialize Config{[String]
Last Bool
Last String
configSignalHandlers :: Last Bool
configArgs :: [String]
configProgName :: Last String
configSignalHandlers :: Config -> Last Bool
configArgs :: Config -> [String]
configProgName :: Config -> Last String
..} = do
#ifndef mingw32_HOST_OS
#if defined(darwin_HOST_OS) || defined(freebsd_HOST_OS)
let stackLimit = ResourceLimit 67104768
#else
let stackLimit :: ResourceLimit
stackLimit = ResourceLimit
ResourceLimitUnknown
#endif
Resource -> ResourceLimits -> IO ()
setResourceLimit Resource
ResourceStackSize (ResourceLimit -> ResourceLimit -> ResourceLimits
ResourceLimits ResourceLimit
stackLimit ResourceLimit
stackLimit)
forall a b. IO a -> IO b -> IO a
`onException` (Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$
String
"Language.R.Interpreter: "
forall a. [a] -> [a] -> [a]
++ String
"Cannot increase stack size limit."
forall a. [a] -> [a] -> [a]
++ String
"Try increasing your stack size limit manually:"
#ifdef darwin_HOST_OS
++ "$ launchctl limit stack 67104768"
++ "$ ulimit -s 65532"
#elif defined(freebsd_HOST_OS)
++ "$ ulimit -s 67104768"
#else
forall a. [a] -> [a] -> [a]
++ String
"$ ulimit -s unlimited"
#endif
)
#endif
Bool
initialized <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
==CInt
1) forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
isRInitializedPtr
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
initialized forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
initLock forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do
Bool
initialized2 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
==CInt
1) forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
isRInitializedPtr
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
initialized2 forall a b. (a -> b) -> a -> b
$ mdo
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 <- (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getProgName forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Last a -> Maybe a
getLast Last String
configProgName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [String]
configArgs
[CString]
argv <- 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [CString]
argv
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Last a -> Maybe a
getLast Last Bool
configSignalHandlers) forall a b. (a -> b) -> a -> b
$
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
signalHandlersPtr CInt
0
forall a r. Storable a => [a] -> (Ptr a -> IO r) -> IO r
newCArray [CString]
argv forall a b. (a -> b) -> a -> b
$ Int -> Ptr CString -> IO ()
R.initEmbeddedR Int
argc
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
isRInteractive CInt
0
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
isRInitializedPtr CInt
1
finalize :: IO ()
finalize :: IO ()
finalize = do
Int -> IO ()
R.endEmbeddedR Int
0
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
isRInitializedPtr CInt
0