content: -- |
  -- 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 ((<=<), 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
  
  -- | 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 { unR :: ReaderT (IORef Int) IO a }
    deriving (Applicative, Functor, Monad, MonadIO, MonadCatch, MonadMask, MonadThrow)
  
  #if MIN_VERSION_base(4,9,0)
  instance MonadFail (R s) where
    fail s = R $ ReaderT $ \_ -> Control.Monad.Fail.fail s
  #endif
  
  instance PrimMonad (R s) where
    type PrimState (R s) = s
    primitive f = R $ lift $ unsafeSTToIO $ primitive f
  
  instance MonadR (R s) where
    io m = R $ ReaderT $ \_ -> m
    acquire s = R $ ReaderT $ \cnt -> uninterruptibleMask_ $ do
      x <- R.release <$> R.protect s
      modifyIORef' cnt succ
      return x
    newtype ExecContext (R s) = ExecContext (IORef Int)
    getExecContext = R $ ReaderT $ \ref -> return (ExecContext ref)
    unsafeRunWithExecContext m (ExecContext ref) = runReaderT (unR m) 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 = bracket_ (initialize config) 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 r = unsafeRunRegion r
  
  unsafeRunRegion :: NFData a => R s a -> IO a
  unsafeRunRegion r =
    bracket (newIORef 0)
            (R.unprotect <=< readIORef)
            (\d -> do
               x <- runReaderT (unR r) d
               x `deepseq` return 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.
      configProgName :: Last String
      -- | Command-line arguments.
    , 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.
    , configSignalHandlers :: Last Bool
    }
  
  instance Default Config where
    def = defaultConfig
  
  instance Sem.Semigroup Config where
    (<>) cfg1 cfg2 = Config
        { configProgName = configProgName cfg1 <> configProgName cfg2
        , configArgs = configArgs cfg1 <> configArgs cfg2
        , configSignalHandlers =  configSignalHandlers cfg1 <> configSignalHandlers cfg2
        }
  
  instance Monoid Config where
    mempty = defaultConfig
    mappend = (<>)
  
  -- | Default argument to pass to 'initialize'.
  defaultConfig :: Config
  defaultConfig = Config (Last Nothing) ["--vanilla", "--silent"] (Last (Just False))
  
  -- | Populate environment with @R_HOME@ variable if it does not exist and
  -- @R_LIBS@ variable if it doesn't exist either.
  populateEnv :: IO ()
  populateEnv = do
      mh <- lookupEnv "R_HOME"
      when (mh == Nothing) $
        setEnv "R_HOME" =<< fmap (head . lines) (readProcess "R" ["-e","cat(R.home())","--quiet","--slave"] "")
  
      ml <- lookupEnv "R_LIBS"
      when (ml == Nothing) $
        setEnv "R_LIBS" =<< fmap (head .  lines) (readProcess "R" ["-e","cat(.libPaths(),sep=if (.Platform$OS.type == \"unix\") \":\" else \";\")","--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 xs k =
      allocaArray (length xs) $ \ptr -> do
        zipWithM_ (pokeElemOff ptr) [0..] xs
        k ptr
  
  -- | An MVar to make an atomic step of checking whether R is initialized and
  -- initializing it if needed.
  initLock :: MVar ()
  initLock = unsafePerformIO $ 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{..} = 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 67104768
  #else
      let stackLimit = ResourceLimitUnknown
  #endif
      setResourceLimit ResourceStackSize (ResourceLimits stackLimit stackLimit)
        `onException` (hPutStrLn stderr $
                         "Language.R.Interpreter: "
                         ++ "Cannot increase stack size limit."
                         ++ "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
                         ++ "$ ulimit -s unlimited"
  #endif
                      )
  #endif
      initialized <- fmap (==1) $ peek isRInitializedPtr
      -- See note [Concurrent initialization]
      unless initialized $ withMVar initLock $ const $ do
        initialized2 <- fmap (==1) $ peek isRInitializedPtr
        unless initialized2 $ mdo
          -- Grab addresses of R global variables
          pokeRVariables
            ( R.baseEnv
            , R.emptyEnv
            , R.globalEnv
            , R.nilValue
            , R.unboundValue
            , R.missingArg
            , R.isRInteractive
            , R.signalHandlers
  #ifndef mingw32_HOST_OS
            , R.inputHandlers
  #endif
            )
          populateEnv
          args <- (:) <$> maybe getProgName return (getLast configProgName)
                      <*> pure configArgs
          argv <- mapM newCString args
          let argc = length argv
          unless (maybe False id $ getLast configSignalHandlers) $
            poke signalHandlersPtr 0
          newCArray argv $ R.initEmbeddedR argc
          poke isRInteractive 0
          poke isRInitializedPtr 1
  
  -- | Finalize an R instance.
  finalize :: IO ()
  finalize = do
      R.endEmbeddedR 0
      poke isRInitializedPtr 0
  