{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}

-- |
-- Copyright: (C) 2013 Amgen, Inc.
--
-- Global variables used by the R interpreter. All are constant, but the values
-- of some of them may change over time (e.g. the global environment).

{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

module Language.R.Globals
  ( baseEnv
  , emptyEnv
  , globalEnv
  , nilValue
  , missingArg
  , unboundValue
  -- * R Internal constants
  , isRInteractive
  , signalHandlersPtr
#ifndef mingw32_HOST_OS
  , inputHandlers
#endif
  -- * R global constants
  -- $ghci-bug
  , pokeRVariables
  ) where

import Control.Memory.Region
import Control.Monad ((<=<))
import Foreign
    ( Ptr
    , StablePtr
    , deRefStablePtr
    , newStablePtr
    , peek
    , poke
    )
import Foreign.C.Types (CInt)
import Foreign.R (SEXP)
import qualified Foreign.R as R
#ifndef mingw32_HOST_OS
import qualified Foreign.R.EventLoop as R
#endif
import System.IO.Unsafe (unsafePerformIO)

-- $ghci-bug
-- The main reason to have all R constants referenced with a StablePtr
-- is that variables in shared libraries are linked incorrectly by GHCi with
-- loaded code.
--
-- The workaround is to grab all variables in the ghci session for the loaded
-- code to use them, that is currently done by the H.ghci script.
--
-- Upstream ticket: <https://ghc.haskell.org/trac/ghc/ticket/8549#ticket>

type RVariables =
    ( Ptr (SEXP G 'R.Env)
    , Ptr (SEXP G 'R.Env)
    , Ptr (SEXP G 'R.Env)
    , Ptr (SEXP G 'R.Nil)
    , Ptr (SEXP G 'R.Symbol)
    , Ptr (SEXP G 'R.Symbol)
    , Ptr CInt
    , Ptr CInt
#ifndef mingw32_HOST_OS
    , Ptr (Ptr R.InputHandler)
#endif
    )

-- | Stores R variables in a static location. This makes the variables'
-- addresses accesible after reloading in GHCi.
foreign import ccall "missing_r.h &" rVariables :: Ptr (StablePtr RVariables)

pokeRVariables :: RVariables -> IO ()
pokeRVariables :: RVariables -> IO ()
pokeRVariables = Ptr (StablePtr RVariables) -> StablePtr RVariables -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (StablePtr RVariables)
rVariables (StablePtr RVariables -> IO ())
-> (RVariables -> IO (StablePtr RVariables)) -> RVariables -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< RVariables -> IO (StablePtr RVariables)
forall a. a -> IO (StablePtr a)
newStablePtr

(  baseEnvPtr :: Ptr (SEXP G 'Env)
baseEnvPtr
 , emptyEnvPtr :: Ptr (SEXP G 'Env)
emptyEnvPtr
 , globalEnvPtr :: Ptr (SEXP G 'Env)
globalEnvPtr
 , nilValuePtr :: Ptr (SEXP G 'Nil)
nilValuePtr
 , unboundValuePtr :: Ptr (SEXP G 'Symbol)
unboundValuePtr
 , missingArgPtr :: Ptr (SEXP G 'Symbol)
missingArgPtr
 , isRInteractive :: Ptr CInt
isRInteractive
 , signalHandlersPtr :: Ptr CInt
signalHandlersPtr
#ifndef mingw32_HOST_OS
 , inputHandlersPtr :: Ptr (Ptr InputHandler)
inputHandlersPtr
#endif
 ) = IO RVariables -> RVariables
forall a. IO a -> a
unsafePerformIO (IO RVariables -> RVariables) -> IO RVariables -> RVariables
forall a b. (a -> b) -> a -> b
$ Ptr (StablePtr RVariables) -> IO (StablePtr RVariables)
forall a. Storable a => Ptr a -> IO a
peek Ptr (StablePtr RVariables)
rVariables IO (StablePtr RVariables)
-> (StablePtr RVariables -> IO RVariables) -> IO RVariables
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StablePtr RVariables -> IO RVariables
forall a. StablePtr a -> IO a
deRefStablePtr

-- | Special value to which all symbols unbound in the current environment
-- resolve to.
unboundValue :: SEXP G 'R.Symbol
unboundValue :: SEXP G 'Symbol
unboundValue = IO (SEXP G 'Symbol) -> SEXP G 'Symbol
forall a. IO a -> a
unsafePerformIO (IO (SEXP G 'Symbol) -> SEXP G 'Symbol)
-> IO (SEXP G 'Symbol) -> SEXP G 'Symbol
forall a b. (a -> b) -> a -> b
$ Ptr (SEXP G 'Symbol) -> IO (SEXP G 'Symbol)
forall a. Storable a => Ptr a -> IO a
peek Ptr (SEXP G 'Symbol)
unboundValuePtr

-- | R's @NULL@ value.
nilValue :: SEXP G 'R.Nil
nilValue :: SEXP G 'Nil
nilValue = IO (SEXP G 'Nil) -> SEXP G 'Nil
forall a. IO a -> a
unsafePerformIO (IO (SEXP G 'Nil) -> SEXP G 'Nil)
-> IO (SEXP G 'Nil) -> SEXP G 'Nil
forall a b. (a -> b) -> a -> b
$ Ptr (SEXP G 'Nil) -> IO (SEXP G 'Nil)
forall a. Storable a => Ptr a -> IO a
peek Ptr (SEXP G 'Nil)
nilValuePtr

-- | Value substituted for all missing actual arguments of a function call.
missingArg :: SEXP G 'R.Symbol
missingArg :: SEXP G 'Symbol
missingArg = IO (SEXP G 'Symbol) -> SEXP G 'Symbol
forall a. IO a -> a
unsafePerformIO (IO (SEXP G 'Symbol) -> SEXP G 'Symbol)
-> IO (SEXP G 'Symbol) -> SEXP G 'Symbol
forall a b. (a -> b) -> a -> b
$ Ptr (SEXP G 'Symbol) -> IO (SEXP G 'Symbol)
forall a. Storable a => Ptr a -> IO a
peek Ptr (SEXP G 'Symbol)
missingArgPtr

-- | The base environment.
baseEnv :: SEXP G 'R.Env
baseEnv :: SEXP G 'Env
baseEnv = IO (SEXP G 'Env) -> SEXP G 'Env
forall a. IO a -> a
unsafePerformIO (IO (SEXP G 'Env) -> SEXP G 'Env)
-> IO (SEXP G 'Env) -> SEXP G 'Env
forall a b. (a -> b) -> a -> b
$ Ptr (SEXP G 'Env) -> IO (SEXP G 'Env)
forall a. Storable a => Ptr a -> IO a
peek Ptr (SEXP G 'Env)
baseEnvPtr

-- | The empty environment.
emptyEnv :: SEXP G 'R.Env
emptyEnv :: SEXP G 'Env
emptyEnv = IO (SEXP G 'Env) -> SEXP G 'Env
forall a. IO a -> a
unsafePerformIO (IO (SEXP G 'Env) -> SEXP G 'Env)
-> IO (SEXP G 'Env) -> SEXP G 'Env
forall a b. (a -> b) -> a -> b
$ Ptr (SEXP G 'Env) -> IO (SEXP G 'Env)
forall a. Storable a => Ptr a -> IO a
peek Ptr (SEXP G 'Env)
emptyEnvPtr

-- | The global environment.
globalEnv :: SEXP G 'R.Env
globalEnv :: SEXP G 'Env
globalEnv = IO (SEXP G 'Env) -> SEXP G 'Env
forall a. IO a -> a
unsafePerformIO (IO (SEXP G 'Env) -> SEXP G 'Env)
-> IO (SEXP G 'Env) -> SEXP G 'Env
forall a b. (a -> b) -> a -> b
$ Ptr (SEXP G 'Env) -> IO (SEXP G 'Env)
forall a. Storable a => Ptr a -> IO a
peek Ptr (SEXP G 'Env)
globalEnvPtr

#ifndef mingw32_HOST_OS
inputHandlers :: Ptr R.InputHandler
inputHandlers :: Ptr InputHandler
inputHandlers = IO (Ptr InputHandler) -> Ptr InputHandler
forall a. IO a -> a
unsafePerformIO (IO (Ptr InputHandler) -> Ptr InputHandler)
-> IO (Ptr InputHandler) -> Ptr InputHandler
forall a b. (a -> b) -> a -> b
$ Ptr (Ptr InputHandler) -> IO (Ptr InputHandler)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr InputHandler)
inputHandlersPtr
#endif