-- |
-- Copyright: 2013 (C) Amgen, Inc
--
-- Wrappers for low-level R functions.

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# Language GADTs #-}
{-# Language ViewPatterns #-}

module Language.R
  ( module Foreign.R
  , module Foreign.R.Type
  , module Language.R.Instance
  , module Language.R.Globals
  , module Language.R.GC
  , module Language.R.Literal
  -- * Evaluation
  , eval
  , eval_
  , evalEnv
  , install
  , cancel
  -- * Exceptions
  , throwR
  , throwRMessage
  -- * Deprecated
  , parseFile
  , parseText
  , string
  , strings
  ) where

import           Control.Memory.Region
import qualified Data.Vector.SEXP as Vector
import Control.Monad.R.Class
import Foreign.R
  ( SEXP
  , SomeSEXP(..)
  , typeOf
  , asTypeOf
  , cast
  , unSomeSEXP
  , unsafeCoerce
  )
import qualified Foreign.R as R
import qualified Foreign.R.Parse as R
import qualified Foreign.R.Error as R
import           Foreign.R.Type
import           Language.R.GC
import           Language.R.Globals
import           Language.R.HExp
import           Language.R.Instance
import           {-# SOURCE #-} Language.R.Internal
import           Language.R.Literal

import Control.Applicative
import Control.Exception ( throwIO )
import Control.Monad ( (>=>), when, unless, forM, void )
import Data.ByteString as B
import Data.ByteString.Char8 as C8 ( pack, unpack )
import Data.Singletons (sing)
import Foreign
  ( alloca
  , castPtr
  , peek
  , poke
  )
import Foreign.C.String ( withCString, peekCString )
import Prelude

-- NOTE: In this module, cannot use quasiquotations, since we are lower down in
-- the dependency hierarchy.

-- | Parse and then evaluate expression.
parseEval :: ByteString -> IO (SomeSEXP V)
parseEval :: ByteString -> IO (SomeSEXP V)
parseEval ByteString
txt = forall a. ByteString -> (CString -> IO a) -> IO a
useAsCString ByteString
txt forall a b. (a -> b) -> a -> b
$ \CString
ctxt ->
  forall (a :: SEXPTYPE) s b.
IO (SEXP V a) -> (SEXP s a -> IO b) -> IO b
R.withProtected (CString -> IO (SEXP V 'String)
R.mkString CString
ctxt) forall a b. (a -> b) -> a -> b
$ \SEXP V 'String
rtxt ->
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr CInt
status -> do
      forall (a :: SEXPTYPE) s b.
IO (SEXP V a) -> (SEXP s a -> IO b) -> IO b
R.withProtected (forall (a :: SEXPTYPE) s.
In a '[ 'Nil, 'String] =>
SEXP s 'String -> Int -> Ptr CInt -> SEXP s a -> IO (SEXP s 'Expr)
R.parseVector SEXP V 'String
rtxt Int
1 Ptr CInt
status (forall t s (a :: SEXPTYPE). (t <= s) => SEXP s a -> SEXP t a
R.release SEXP G 'Nil
nilValue)) forall a b. (a -> b) -> a -> b
$ \SEXP Any 'Expr
exprs -> do
        Int
rc <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
status
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ParseStatus
R.PARSE_OK forall a. Eq a => a -> a -> Bool
== forall a. Enum a => Int -> a
toEnum Int
rc) forall a b. (a -> b) -> a -> b
$
          forall a. NFData a => (forall s. R s a) -> IO a
runRegion forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadR m => String -> m a
throwRMessage forall a b. (a -> b) -> a -> b
$ String
"Parse error in: " forall a. [a] -> [a] -> [a]
++ ByteString -> String
C8.unpack ByteString
txt
        SomeSEXP SEXP Any a
expr <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ forall a b. Ptr a -> Ptr b
castPtr forall a b. (a -> b) -> a -> b
$ forall s (a :: SEXPTYPE). SEXP s a -> Ptr ()
R.unsafeSEXPToVectorPtr SEXP Any 'Expr
exprs
        forall a. NFData a => (forall s. R s a) -> IO a
runRegion forall a b. (a -> b) -> a -> b
$ do
          SomeSEXP SEXP s a
val <- forall (m :: * -> *) s (a :: SEXPTYPE).
MonadR m =>
SEXP s a -> m (SomeSEXP (Region m))
eval SEXP Any a
expr
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP (forall t s (a :: SEXPTYPE). (t <= s) => SEXP s a -> SEXP t a
R.release SEXP s a
val)

-- | Parse file and perform some actions on parsed file.
--
-- This function uses continuation because this is an easy way to make
-- operations GC-safe.
parseFile :: FilePath -> (SEXP s 'R.Expr -> IO a) -> IO a
{-# DEPRECATED parseFile "Use [r| parse(file=\"path/to/file\") |] instead." #-}
parseFile :: forall s a. String -> (SEXP s 'Expr -> IO a) -> IO a
parseFile String
fl SEXP s 'Expr -> IO a
f = do
    forall a. String -> (CString -> IO a) -> IO a
withCString String
fl forall a b. (a -> b) -> a -> b
$ \CString
cfl ->
      forall (a :: SEXPTYPE) s b.
IO (SEXP V a) -> (SEXP s a -> IO b) -> IO b
R.withProtected (CString -> IO (SEXP V 'String)
R.mkString CString
cfl) forall a b. (a -> b) -> a -> b
$ \SEXP Any 'String
rfl ->
        forall s (a :: SEXPTYPE). ByteString -> SEXP s a -> IO (SomeSEXP V)
r1 (String -> ByteString
C8.pack String
"parse") SEXP Any 'String
rfl forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(R.SomeSEXP SEXP V a
s) ->
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall s (a :: SEXPTYPE) (b :: SEXPTYPE). SEXP s a -> SEXP s b
R.unsafeCoerce SEXP V a
s) forall (a :: SEXPTYPE) s b.
IO (SEXP V a) -> (SEXP s a -> IO b) -> IO b
`R.withProtected` SEXP s 'Expr -> IO a
f

parseText
  :: String -- ^ Text to parse
  -> Bool   -- ^ Whether to annotate the AST with source locations.
  -> IO (R.SEXP V 'R.Expr)
{-# DEPRECATED parseText "Use [r| parse(text=...) |] instead." #-}
parseText :: String -> Bool -> IO (SEXP V 'Expr)
parseText String
txt Bool
b = do
    SomeSEXP V
s <- ByteString -> IO (SomeSEXP V)
parseEval forall a b. (a -> b) -> a -> b
$ String -> ByteString
C8.pack forall a b. (a -> b) -> a -> b
$
         String
"parse(text=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
txt forall a. [a] -> [a] -> [a]
++ String
", keep.source=" forall a. [a] -> [a] -> [a]
++ String
keep forall a. [a] -> [a] -> [a]
++ String
")"
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall {k} (a :: k). SingI a => Sing a
sing :: R.SSEXPTYPE 'R.Expr) forall (a :: SEXPTYPE) s. SSEXPTYPE a -> SomeSEXP s -> SEXP s a
`R.cast` SomeSEXP V
s
  where
    keep :: String
keep | Bool
b         = String
"TRUE"
         | Bool
otherwise = String
"FALSE"

-- | Internalize a symbol name.
install :: MonadR m => String -> m (SEXP V 'R.Symbol)
install :: forall (m :: * -> *). MonadR m => String -> m (SEXP V 'Symbol)
install = forall (m :: * -> *) a. MonadR m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (SEXP V 'Symbol)
installIO

{-# DEPRECATED string, strings "Use mkSEXP instead" #-}

-- | Create an R character string from a Haskell string.
string :: String -> IO (SEXP V 'R.Char)
string :: String -> IO (SEXP V 'Char)
string String
str = forall a. String -> (CString -> IO a) -> IO a
withCString String
str CString -> IO (SEXP V 'Char)
R.mkChar

-- | Create an R string vector from a Haskell string.
strings :: String -> IO (SEXP V 'R.String)
strings :: String -> IO (SEXP V 'String)
strings String
str = forall a. String -> (CString -> IO a) -> IO a
withCString String
str CString -> IO (SEXP V 'String)
R.mkString

-- | Evaluate a (sequence of) expression(s) in the given environment, returning the
-- value of the last.
evalEnv :: MonadR m => SEXP s a -> SEXP s 'R.Env -> m (SomeSEXP (Region m))
evalEnv :: forall (m :: * -> *) s (a :: SEXPTYPE).
MonadR m =>
SEXP s a -> SEXP s 'Env -> m (SomeSEXP (Region m))
evalEnv (forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Language.R.HExp.Expr Int32
_ Vector 'Expr (SomeSEXP V)
v) SEXP s 'Env
rho = forall (m :: * -> *).
MonadR m =>
SomeSEXP V -> m (SomeSEXP (Region m))
acquireSome forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
    forall (m :: * -> *) a. MonadR m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr CInt
p -> do
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(SomeSEXP SEXP V a
s) -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (a :: SEXPTYPE). SEXP s a -> IO (SEXP G a)
R.protect SEXP V a
s) (forall (ty :: SEXPTYPE) a. SVECTOR ty a => Vector ty a -> [a]
Vector.toList Vector 'Expr (SomeSEXP V)
v)
      SomeSEXP V
x <- forall a. [a] -> a
Prelude.last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (ty :: SEXPTYPE) a. SVECTOR ty a => Vector ty a -> [a]
Vector.toList Vector 'Expr (SomeSEXP V)
v) (\(SomeSEXP SEXP V a
s) -> do
          SomeSEXP V
z <- forall s (a :: SEXPTYPE).
SEXP s a -> SEXP s 'Env -> Ptr CInt -> IO (SomeSEXP V)
R.tryEvalSilent SEXP V a
s (forall t s (a :: SEXPTYPE). (t <= s) => SEXP s a -> SEXP t a
R.release SEXP s 'Env
rho) Ptr CInt
p
          CInt
e <- forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
p
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
e forall a. Eq a => a -> a -> Bool
/= CInt
0) forall a b. (a -> b) -> a -> b
$ forall a. NFData a => (forall s. R s a) -> IO a
runRegion forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. MonadR m => SEXP s 'Env -> m a
throwR SEXP s 'Env
rho
          forall (m :: * -> *) a. Monad m => a -> m a
return SomeSEXP V
z)
      Int -> IO ()
R.unprotect (forall (ty :: SEXPTYPE) a. SVECTOR ty a => Vector ty a -> Int
Vector.length Vector 'Expr (SomeSEXP V)
v)
      forall (m :: * -> *) a. Monad m => a -> m a
return SomeSEXP V
x
evalEnv SEXP s a
x SEXP s 'Env
rho = forall (m :: * -> *).
MonadR m =>
SomeSEXP V -> m (SomeSEXP (Region m))
acquireSome forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
    forall (m :: * -> *) a. MonadR m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr CInt
p -> forall (a :: SEXPTYPE) s b.
IO (SEXP V a) -> (SEXP s a -> IO b) -> IO b
R.withProtected (forall (m :: * -> *) a. Monad m => a -> m a
return (forall t s (a :: SEXPTYPE). (t <= s) => SEXP s a -> SEXP t a
R.release SEXP s a
x)) forall a b. (a -> b) -> a -> b
$ \SEXP Any a
_ -> do
      SomeSEXP V
v <- forall s (a :: SEXPTYPE).
SEXP s a -> SEXP s 'Env -> Ptr CInt -> IO (SomeSEXP V)
R.tryEvalSilent SEXP s a
x SEXP s 'Env
rho Ptr CInt
p
      CInt
e <- forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
p
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
e forall a. Eq a => a -> a -> Bool
/= CInt
0) forall a b. (a -> b) -> a -> b
$ forall a. NFData a => (forall s. R s a) -> IO a
runRegion forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. MonadR m => SEXP s 'Env -> m a
throwR SEXP s 'Env
rho
      forall (m :: * -> *) a. Monad m => a -> m a
return SomeSEXP V
v

-- | Evaluate a (sequence of) expression(s) in the global environment.
eval :: MonadR m => SEXP s a -> m (SomeSEXP (Region m))
eval :: forall (m :: * -> *) s (a :: SEXPTYPE).
MonadR m =>
SEXP s a -> m (SomeSEXP (Region m))
eval SEXP s a
x = forall (m :: * -> *) s (a :: SEXPTYPE).
MonadR m =>
SEXP s a -> SEXP s 'Env -> m (SomeSEXP (Region m))
evalEnv SEXP s a
x (forall t s (a :: SEXPTYPE). (t <= s) => SEXP s a -> SEXP t a
R.release SEXP G 'Env
globalEnv)

-- | Silent version of 'eval' function that discards it's result.
eval_ :: MonadR m => SEXP s a -> m ()
eval_ :: forall (m :: * -> *) s (a :: SEXPTYPE).
MonadR m =>
SEXP s a -> m ()
eval_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) s (a :: SEXPTYPE).
MonadR m =>
SEXP s a -> m (SomeSEXP (Region m))
eval

-- | Throw an R error as an exception.
throwR :: MonadR m => R.SEXP s 'R.Env   -- ^ Environment in which to find error.
       -> m a
throwR :: forall (m :: * -> *) s a. MonadR m => SEXP s 'Env -> m a
throwR SEXP s 'Env
env = forall (m :: * -> *) s. MonadR m => SEXP s 'Env -> m String
getErrorMessage SEXP s 'Env
env forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadR m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> RError
R.RError

-- | Cancel any ongoing R computation in the current process. After interruption
-- an 'RError' exception will be raised.
--
-- This call is safe to run in any thread. If there is no R computation running,
-- the next computaion will be immediately cancelled. Note that R will only
-- interrupt computations at so-called "safe points" (in particular, not in the
-- middle of a C call).
cancel :: IO ()
cancel :: IO ()
cancel = forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
R.interruptsPending CInt
1

-- | Throw an R exception with specified message.
throwRMessage :: MonadR m => String -> m a
throwRMessage :: forall (m :: * -> *) a. MonadR m => String -> m a
throwRMessage = forall (m :: * -> *) a. MonadR m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> RError
R.RError

-- | Read last error message.
getErrorMessage :: MonadR m => R.SEXP s 'R.Env -> m String
getErrorMessage :: forall (m :: * -> *) s. MonadR m => SEXP s 'Env -> m String
getErrorMessage SEXP s 'Env
e = forall (m :: * -> *) a. MonadR m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ do
  forall (a :: SEXPTYPE) s b.
IO (SEXP V a) -> (SEXP s a -> IO b) -> IO b
R.withProtected (forall a. String -> (CString -> IO a) -> IO a
withCString String
"geterrmessage" ((CString -> IO (SEXP V 'Symbol)
R.install forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall s (a :: SEXPTYPE). SEXP s a -> IO (SEXP V 'Lang)
R.lang1))) forall a b. (a -> b) -> a -> b
$ \SEXP Any 'Lang
f -> do
    forall (a :: SEXPTYPE) s b.
IO (SEXP V a) -> (SEXP s a -> IO b) -> IO b
R.withProtected (forall (m :: * -> *) a. Monad m => a -> m a
return (forall t s (a :: SEXPTYPE). (t <= s) => SEXP s a -> SEXP t a
R.release SEXP s 'Env
e)) forall a b. (a -> b) -> a -> b
$ \SEXP Any 'Env
env -> do
      CString -> IO String
peekCString
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. SEXP s 'Char -> IO CString
R.char
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Storable a => Ptr a -> IO a
peek
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. SEXP s 'String -> IO (Ptr (SEXP s 'Char))
R.string forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: SEXPTYPE) s. SSEXPTYPE a -> SomeSEXP s -> SEXP s a
R.cast (forall {k} (a :: k). SingI a => Sing a
sing :: R.SSEXPTYPE 'R.String)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (a :: SEXPTYPE).
SEXP s a -> SEXP s 'Env -> IO (SomeSEXP V)
R.eval SEXP Any 'Lang
f SEXP Any 'Env
env