inline-r 0.10.5 → 1.0.0
raw patch · 22 files changed
+1368/−1488 lines, 22 filesdep +heredocdep +singletons-thdep ~aesondep ~bytestringdep ~containers
Dependencies added: heredoc, singletons-th
Dependency ranges changed: aeson, bytestring, containers, criterion, data-default-class, deepseq, directory, filepath, ieee754, inline-c, mtl, pretty, primitive, process, quickcheck-assertions, reflection, setenv, silently, singletons, strict, tasty, tasty-expected-failure, tasty-golden, tasty-hunit, tasty-quickcheck, template-haskell, temporary, text, th-lift, th-orphans, transformers, unix, vector
Files
- CHANGELOG.md +12/−0
- R/collectAntis.R +15/−0
- cbits/missing_r.h +0/−7
- inline-r.cabal +79/−69
- src/Data/Vector/SEXP.hs +6/−10
- src/Foreign/R.hs +489/−0
- src/Foreign/R.hsc +0/−507
- src/Foreign/R/Context.hsc +15/−6
- src/Foreign/R/Encoding.hsc +31/−0
- src/Foreign/R/Internal.hs +249/−0
- src/Foreign/R/Internal.hsc +0/−342
- src/Foreign/R/Parse.hsc +0/−3
- src/Foreign/R/Type.hsc +0/−3
- src/Language/R/Debug.hs +2/−4
- src/Language/R/HExp.hs +387/−0
- src/Language/R/HExp.hs-boot +0/−10
- src/Language/R/HExp.hsc +0/−490
- src/Language/R/Internal/FunWrappers.hs +1/−1
- src/Language/R/Literal.hs +5/−6
- src/Language/R/QQ.hs +47/−27
- tests/Test/Event.hs +2/−1
- tests/tests.hs +28/−2
CHANGELOG.md view
@@ -1,5 +1,17 @@ # Change Log +## 1.0.0 - 2022-11-11+* Support for R >= 4.2.+* Support for GHC 9 and GHC 9.2.+* Breaking change: remove `unhexp`, `pokeInfo`, `mark` and `named`.+* Breaking change: `HExp` no longer has a `Storable` instance.+* Breaking change: some fields of SEXPInfo have been removed.+* Breaking change: `Special` and `Primitive` constructors of `HExp` no+ longer carry any information. R-4.2 makes these forms completely+ opaque.+* Process quasiquotes using an instance of the R interpreter in+ a separate process. This improves support on macOS.+ ## 0.10.5 - 2020-11-16 * Support aeson >= 2
+ R/collectAntis.R view
@@ -0,0 +1,15 @@+go <- function(e) {+ ty <- typeof(e)+ if (ty %in% c("language", "expression")) {+ lapply(e, go)+ }+ else if (ty == "symbol") {+ as.character(e)+ }+ else+ character(0)+}++cat(grep(pattern = "_hs$", value = TRUE,+ unique(unlist(recursive = TRUE,+ go(parse(file = input_file))))))
cbits/missing_r.h view
@@ -7,13 +7,6 @@ #include <Rinternals.h> #include <R_ext/Rdynload.h> -#define GCGEN(x) ((x)->sxpinfo.gcgen)-#define GCCLS(x) ((x)->sxpinfo.gccls)-#define SET_GCGEN(x, v) (((x)->sxpinfo.gcgen)=(v))-#define SET_GCCLS(x, v) (((x)->sxpinfo.gccls)=(v))-#define SET_MARK(x, v) (((x)->sxpinfo.mark)=(v))-- /* Create a variadic R function given any function pointer. */ SEXP funPtrToSEXP(DL_FUNC pf);
inline-r.cabal view
@@ -1,5 +1,5 @@ name: inline-r-version: 0.10.5+version: 1.0.0 license: BSD3 license-file: LICENSE copyright: Copyright (c) 2013-2015 Amgen, Inc.@@ -34,6 +34,7 @@ tests/shootout/fannkuchredux.R tests/R/fib.R tests/R/fib-benchmark.R+ ./R/collectAntis.R extra-tmp-files: inline-r.buildinfo source-repository head@@ -50,6 +51,7 @@ Foreign.R.Constraints Foreign.R.Context Foreign.R.Embedded+ Foreign.R.Encoding Foreign.R.Error Foreign.R.Internal Foreign.R.Parse@@ -75,32 +77,39 @@ Control.Monad.R.Internal Data.Vector.SEXP.Mutable.Internal Internal.Error- build-depends: base >= 4.7 && < 5- , aeson >= 0.6- , bytestring >= 0.10- , containers >= 0.5- , data-default-class- , deepseq >= 1.3- , exceptions >= 0.6 && < 1.1- , mtl >= 2.1- , pretty >= 1.1- , primitive >= 0.5- , process >= 1.2- , reflection >= 2- , setenv >= 0.1.1- , singletons >= 0.9 && < 3- , template-haskell >= 2.8- , text >= 0.11- , th-lift >= 0.6- , th-orphans >= 0.8- , transformers >= 0.3- , vector >= 0.10 && < 0.13+ build-depends: base >=4.7 && <5+ , aeson >=0.6 && <2.2+ , bytestring >=0.10 && <0.12+ , containers >=0.5 && <0.7+ , data-default-class >=0.1.2.0 && <0.2+ , deepseq >=1.3 && <1.5+ , exceptions >=0.6 && <1.1+ , heredoc >=0.2 && <0.3+ , mtl >=2.1 && <2.3+ , pretty >=1.1 && <1.2+ , primitive >=0.5 && <0.8+ , process >=1.2 && <1.7+ , reflection >=2 && <2.2+ , setenv >=0.1.1 && <0.2+ , template-haskell >=2.8 && <2.20+ , temporary >=1.2 && <1.4+ , text >=0.11 && <2.1+ , th-lift >=0.6 && <0.9+ , th-orphans >=0.8 && <0.14+ , transformers >=0.3 && <0.6+ , vector >=0.10 && <0.14 if impl(ghc < 8.2.1) build-depends: inline-c >=0.5.6.1 && <0.6 else build-depends:- inline-c >=0.6+ inline-c >=0.6 && <0.10+ if impl(ghc <9)+ build-depends: singletons >=2.7 && <3+ else+ build-depends:+ singletons >=3 && <3.1,+ singletons-th >=3 && <3.2 hs-source-dirs: src includes: cbits/missing_r.h c-sources: cbits/missing_r.c@@ -112,36 +121,40 @@ if os(windows) extra-libraries: R else- build-depends: unix >= 2.6+ build-depends: unix >= 2.6 && <2.8 pkgconfig-depends: libR >= 3.0 -- XXX -fcontext-stack=32 required on GHC >= 7.8 to allow foreign -- export function -wrappers of high arities.- ghc-options: -Wall -freduction-depth=32+ ghc-options: -freduction-depth=32+ --- We don't use ticks for promoted constructors, because we use+ --- promoted constructors heavily and because they confuse hsc2hs.+ ghc-options: -Wall -fno-warn-unticked-promoted-constructors test-suite tests main-is: tests.hs type: exitcode-stdio-1.0 build-depends: inline-r- , base >= 4.6 && < 5- , bytestring >= 0.10- , directory >= 1.2- , filepath >= 1.3- , ieee754 >= 0.7- , mtl >= 2.0- , process >= 1.2- , quickcheck-assertions >= 0.1.1- , singletons >= 0.10- , strict >= 0.3.2- , tasty >= 0.11- , tasty-expected-failure >= 0.11- , tasty-golden >= 2.3- , tasty-hunit >= 0.4.1- , tasty-quickcheck >= 0.4.1- , temporary >= 1.2- , text >= 0.11- , vector+ , base >=4.6 && <5+ , bytestring >=0.10 && <0.12+ , directory >=1.2 && <1.4+ , filepath >=1.3 && <1.5+ , heredoc >=0.2 && <0.3+ , ieee754 >=0.7 && <0.9+ , mtl >=2.0 && <2.3+ , process >=1.2 && <1.7+ , quickcheck-assertions >=0.1.1 && <0.4+ , singletons >=0.10 && <3.1+ , strict >=0.3.2 && <0.5+ , tasty >=0.11 && <1.5+ , tasty-expected-failure >=0.11 && <0.13+ , tasty-golden >=2.3 && <2.4+ , tasty-hunit >=0.4.1 && <0.11+ , tasty-quickcheck >=0.4.1 && <0.11+ , temporary >=1.2 && <1.4+ , text >=0.11 && <2.1+ , vector >=0.12.3.1 && <0.14 if !os(windows)- build-depends: unix >= 2.5+ build-depends: unix >=2.5 && <2.8 other-modules: Test.GC Test.FunPtr Test.Constraints@@ -149,9 +162,6 @@ Test.Regions Test.Vector Test.Matcher- -- Adding -j4 causes quasiquoters to be compiled concurrently- -- in tests, which helps testing for race conditions when- -- trying to initialize R from multiple threads. ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010@@ -160,12 +170,12 @@ main-is: test-qq.hs type: exitcode-stdio-1.0 build-depends: inline-r- , base >= 4.6 && < 5- , mtl >= 2.0- , process >= 1.2- , tasty-hunit >= 0.4.1- , singletons >= 0.9- , text >= 0.11+ , base >=4.6 && <5+ , mtl >=2.0 && <2.3+ , process >=1.2 && <1.7+ , tasty-hunit >=0.4.1 && <0.11+ , singletons >=0.9 && <3.1+ , text >=0.11 && <2.1 ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010@@ -175,13 +185,13 @@ type: exitcode-stdio-1.0 other-modules: Test.Scripts build-depends: inline-r- , base >= 4.6 && < 5- , filepath >= 1.3- , process >= 1.2- , silently >= 1.2- , tasty >= 0.3- , tasty-hunit >= 0.4.1- , template-haskell >= 2.8+ , base >=4.6 && <5+ , filepath >=1.3 && <1.5+ , process >=1.2 && <1.7+ , silently >=1.2 && <1.3+ , tasty >=0.3 && <1.5+ , tasty-hunit >=0.4.1 && <0.11+ , template-haskell >=2.8 && <2.20 ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010@@ -192,11 +202,11 @@ main-is: bench-qq.hs type: exitcode-stdio-1.0 build-depends: inline-r- , base >= 4.6 && < 5- , criterion >= 0.8- , filepath >= 1.3- , process >= 1.2- , template-haskell >= 2.8+ , base >=4.6 && <5+ , criterion >=0.8 && <1.7+ , filepath >=1.3 && <1.5+ , process >=1.2 && <1.7+ , template-haskell >=2.8 && <2.20 ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010@@ -205,11 +215,11 @@ main-is: bench-hexp.hs type: exitcode-stdio-1.0 build-depends: inline-r- , base >= 4.6 && < 5- , criterion >= 0.8- , primitive >= 0.5- , vector >= 0.10- , singletons+ , base >=4.6 && <5+ , criterion >=0.8 && <1.7+ , primitive >=0.5 && <0.8+ , vector >=0.10 && <0.14+ , singletons >=2.7 && <3.1 ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010
src/Data/Vector/SEXP.hs view
@@ -264,7 +264,7 @@ import Data.Vector.SEXP.Mutable (MVector) import qualified Data.Vector.SEXP.Mutable as Mutable import qualified Data.Vector.SEXP.Mutable.Internal as Mutable-import Foreign.R ( SEXP(..) )+import Foreign.R ( SEXP(..), SEXP0(..) ) import qualified Foreign.R as R import Foreign.R.Type ( SEXPTYPE(Char) ) @@ -301,9 +301,7 @@ import qualified GHC.Foreign as GHC import qualified GHC.ForeignPtr as GHC import GHC.IO.Encoding.UTF8-#if __GLASGOW_HASKELL__ >= 708 import qualified GHC.Exts as Exts-#endif import System.IO.Unsafe import Prelude@@ -326,21 +324,21 @@ ) import qualified Prelude -newtype ForeignSEXP (ty::SEXPTYPE) = ForeignSEXP (ForeignPtr ())+newtype ForeignSEXP (ty::SEXPTYPE) = ForeignSEXP (ForeignPtr R.SEXPREC) -- | Create a 'ForeignSEXP' from 'SEXP'. foreignSEXP :: PrimMonad m => SEXP s ty -> m (ForeignSEXP ty)-foreignSEXP sx@(SEXP ptr) =+foreignSEXP sx@(SEXP (SEXP0 ptr)) = unsafePrimToPrim $ mask_ $ do R.preserveObject sx- ForeignSEXP <$> GHC.newConcForeignPtr (castPtr ptr) (R.releaseObject sx)+ ForeignSEXP <$> GHC.newConcForeignPtr ptr (R.releaseObject sx) withForeignSEXP :: ForeignSEXP ty -> (SEXP V ty -> IO r) -> IO r withForeignSEXP (ForeignSEXP fptr) f =- withForeignPtr fptr $ \ptr -> f (SEXP (castPtr ptr))+ withForeignPtr fptr $ \ptr -> f (SEXP (SEXP0 ptr)) -- | Immutable vectors. The second type paramater is a phantom parameter -- reflecting at the type level the tag of the vector when viewed as a 'SEXP'.@@ -403,13 +401,11 @@ {-# INLINE elemseq #-} elemseq _ = seq -#if __GLASGOW_HASKELL__ >= 708 instance SVECTOR ty a => Exts.IsList (Vector ty a) where type Item (Vector ty a) = a fromList = fromList fromListN = fromListN toList = toList-#endif -- | Return Pointer of the first element of the vector storage. unsafeToPtr :: Storable a => Vector ty a -> Ptr a@@ -447,7 +443,7 @@ -- copying. The immutable vector must not be used after this operation. unsafeToSEXP :: SVECTOR ty a => Vector ty a -> SEXP s ty unsafeToSEXP (Vector (ForeignSEXP fsx) _ _) = unsafePerformIO $ -- XXX- withForeignPtr fsx $ return . R.sexp . castPtr+ withForeignPtr fsx $ return . R.sexp . SEXP0 -- | /O(n)/ Convert a character vector into a 'String'. toString :: Vector 'Char Word8 -> String
+ src/Foreign/R.hs view
@@ -0,0 +1,489 @@+-- |+-- Copyright: (C) 2013 Amgen, Inc.+--+-- Low-level bindings to core R datatypes and functions. Nearly all structures+-- allocated internally in R are instances of a 'SEXPREC'. A pointer to+-- a 'SEXPREC' is called a 'SEXP'.+--+-- To allow for precise typing of bindings to primitive R functions, we index+-- 'SEXP's by 'SEXPTYPE', which classifies the /form/ of a 'SEXP' (see+-- "Foreign.R.Type"). A function accepting 'SEXP' arguments of any type should+-- leave the type index uninstantiated. A function returning a 'SEXP' result of+-- unknown type should use 'SomeSEXP'. (More precisely, unknown types in+-- /negative/ position should be /universally/ quantified and unknown types in+-- /positive/ position should be /existentially/ quantified).+--+-- Bindings to R functions that allocate or are blocking use safe ccall's, so+-- garbage collection of the Haskell heap can happen concurrently. See the+-- <https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#foreign-imports-and-multi-threading+-- GHC User's Guide> for more.+--+-- This module is intended to be imported qualified.++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++-- Warns about some sanity checks like IsVector, that has no methods and are+-- not used.+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++module Foreign.R+ ( module Foreign.R.Type+ -- * Internal R structures+ , SEXP(..)+ , SomeSEXP(..)+ , unSomeSEXP+ -- * Casts and coercions+ -- $cast-coerce+ , cast+ , asTypeOf+ , unsafeCoerce+ -- * Node creation+ , allocSEXP+ , allocList+ , allocVector+ , allocVectorProtected+ , install+ , mkString+ , mkChar+ , CEType(..)+ , mkCharCE+ , mkCharLenCE+ , mkWeakRef+ -- * Node attributes+ , typeOf+ , isS4+ , setAttributes+ , getAttribute+ , getAttributes+ -- * Node accessor functions+ -- ** Lists+ , cons+ , lcons+ , car+ , cdr+ , tag+ , setCar+ , setCdr+ , setTag+ -- ** Environments+ , envFrame+ , envEnclosing+ , envHashtab+ -- ** Closures+ , closureFormals+ , closureBody+ , closureEnv+ -- ** Promises+ , promiseCode+ , promiseEnv+ , promiseValue+ -- ** Symbols+ , symbolPrintName+ , symbolValue+ , symbolInternal+ -- ** Vectors+ , length+ , trueLength+ , char+ , real+ , integer+ , logical+ , complex+ , raw+ , string+ , unsafeSEXPToVectorPtr+ , readVector+ , writeVector+ -- * Evaluation+ , eval+ , tryEval+ , tryEvalSilent+ , lang1+ , lang2+ , lang3+ , findFun+ , findVar+ -- * GC functions+ , protect+ , unprotect+ , unprotectPtr+ , preserveObject+ , releaseObject+ , gc+ -- * Globals+ , isRInteractive+ , nilValue+ , unboundValue+ , missingArg+ , baseEnv+ , emptyEnv+ , globalEnv+ , signalHandlers+ , interruptsPending+ -- * Communication with runtime+ , printValue+ -- * Low level info header access+ , SEXPInfo(..)+ , peekInfo+ -- * Internal types and functions+ --+ -- | Should not be used in user code. These exports are only needed for+ -- binding generation tools.+ , SEXPREC+ , SEXP0(..)+ , sexp+ , unsexp+ , release+ , unsafeRelease+ , unsafeReleaseSome+ , withProtected+ -- * Deprecated+ , indexVector+ ) where++import Control.Memory.Region+import Foreign.R.Internal+import Foreign.R.Type+import Foreign.R.Type as R++import Control.Applicative+import Control.Exception (bracket)+import Data.Complex+import Data.Int (Int32)+import Foreign (Ptr, castPtr)+import Foreign.C+import Foreign.R.Context (rCtx, SEXP0(..), SEXPREC)+import Foreign.R.Encoding+import qualified Language.C.Inline as C+-- Use unsafe only for non-blocking, non-allocating functions.+import qualified Language.C.Inline.Unsafe as CU+import Prelude hiding (asTypeOf, length)++C.context (C.baseCtx <> rCtx)+C.include "<Rinternals.h>"+C.include "<stdlib.h>"+C.include "<stdint.h>"++--------------------------------------------------------------------------------+-- Generic accessor functions --+--------------------------------------------------------------------------------++-- | read CAR object value+car :: SEXP s a -> IO (SomeSEXP s)+car (unsexp -> s) = somesexp <$> [CU.exp| SEXP { CAR( $(SEXP s) ) } |]++-- | Set the CAR value and return it.+setCar :: SEXP s a -> SEXP s b -> IO (SEXP s b)+setCar (unsexp -> s) (unsexp -> s') = sexp <$> [CU.exp| SEXP { SETCAR( $(SEXP s), $(SEXP s') ) } |]++-- | read CDR object+cdr :: SEXP s a -> IO (SomeSEXP s)+cdr (unsexp -> s) = somesexp <$> [CU.exp| SEXP { CAR( $(SEXP s) ) } |]++-- | Set the CDR value and return it.+setCdr :: SEXP s a -> SEXP s b -> IO (SEXP s b)+setCdr (unsexp -> s) (unsexp -> s') = sexp <$> [CU.exp| SEXP { SETCDR( $(SEXP s), $(SEXP s') ) } |]++-- | read object`s Tag+tag :: SEXP s a -> IO (SomeSEXP s)+tag (unsexp -> s) = somesexp <$> [CU.exp| SEXP { TAG( $(SEXP s) ) } |]++setTag :: SEXP s a -> SEXP s b -> IO ()+setTag (unsexp -> s) (unsexp -> s') = [CU.exp| void { SET_TAG( $(SEXP s), $(SEXP s') ) } |]++--------------------------------------------------------------------------------+-- Environment functions --+--------------------------------------------------------------------------------++envFrame :: (SEXP s 'R.Env) -> IO (SEXP s R.PairList)+envFrame (unsexp -> s) = sexp <$> [CU.exp| SEXP { FRAME( $(SEXP s) ) } |]++-- | Enclosing environment.+envEnclosing :: SEXP s 'R.Env -> IO (SEXP s 'R.Env)+envEnclosing (unsexp -> s) = sexp <$> [CU.exp| SEXP { ENCLOS( $(SEXP s) ) } |]++-- | Hash table associated with the environment, used for faster name lookups.+envHashtab :: SEXP s 'R.Env -> IO (SEXP s 'R.Vector)+envHashtab (unsexp -> s) = sexp <$> [CU.exp| SEXP { HASHTAB( $(SEXP s) ) } |]++--------------------------------------------------------------------------------+-- Closure functions --+--------------------------------------------------------------------------------++-- | Closure formals (aka the actual arguments).+closureFormals :: SEXP s 'R.Closure -> IO (SEXP s R.PairList)+closureFormals (unsexp -> s) = sexp <$> [CU.exp| SEXP { FORMALS( $(SEXP s) ) }|]++-- | The code of the closure.+closureBody :: SEXP s 'R.Closure -> IO (SomeSEXP s)+closureBody (unsexp -> s) = somesexp <$> [CU.exp| SEXP { BODY( $(SEXP s) ) } |]++-- | The environment of the closure.+closureEnv :: SEXP s 'R.Closure -> IO (SEXP s 'R.Env)+closureEnv (unsexp -> s) = sexp <$> [CU.exp| SEXP { CLOENV( $(SEXP s) ) }|]++--------------------------------------------------------------------------------+-- Promise functions --+--------------------------------------------------------------------------------++-- | The code of a promise.+promiseCode :: SEXP s 'R.Promise -> IO (SomeSEXP s)+promiseCode (unsexp -> s) = somesexp <$> [CU.exp| SEXP { PRCODE( $(SEXP s) )}|]++-- | The environment in which to evaluate the promise.+promiseEnv :: SEXP s 'R.Promise -> IO (SomeSEXP s)+promiseEnv (unsexp -> s) = somesexp <$> [CU.exp| SEXP { PRENV( $(SEXP s) )}|]++-- | The value of the promise, if it has already been forced.+promiseValue :: SEXP s 'R.Promise -> IO (SomeSEXP s)+promiseValue (unsexp -> s) = somesexp <$> [CU.exp| SEXP { PRVALUE( $(SEXP s) )}|]++--------------------------------------------------------------------------------+-- Vector accessor functions --+--------------------------------------------------------------------------------++-- | Length of the vector.+length :: R.IsVector a => SEXP s a -> IO CInt+length (unsexp -> s) = [CU.exp| int { LENGTH( $(SEXP s) ) }|]++-- | Read True Length vector field.+trueLength :: R.IsVector a => SEXP s a -> IO CInt+trueLength (unsexp -> s) = [CU.exp| int { TRUELENGTH( $(SEXP s) ) }|]++-- | Read character vector data+char :: SEXP s 'R.Char -> IO CString+char (unsexp -> s) = castPtr <$> [CU.exp| const char* { CHAR($(SEXP s))}|]+-- XXX: check if we really need Word8 here, maybe some better handling of+-- encoding++-- | Read real vector data.+real :: SEXP s 'R.Real -> IO (Ptr Double)+real (unsexp -> s) = castPtr <$> [CU.exp| double* { REAL( $(SEXP s)) }|]++-- | Read integer vector data.+integer :: SEXP s 'R.Int -> IO (Ptr Int32)+integer (unsexp -> s) = [CU.exp| int32_t* { INTEGER( $(SEXP s) )}|]++-- | Read raw data.+raw :: SEXP s 'R.Raw -> IO (Ptr CChar)+raw (unsexp -> s) = [CU.exp| char* { RAW($(SEXP s)) } |]++-- | Read logical vector data.+logical :: SEXP s 'R.Logical -> IO (Ptr R.Logical)+logical (unsexp -> s) = castPtr <$>+ [CU.exp| int* { LOGICAL($(SEXP s)) } |]++-- | Read complex vector data.+complex :: SEXP s 'R.Complex -> IO (Ptr (Complex Double))+complex (unsexp -> s) = [CU.exp| Rcomplex* { COMPLEX($(SEXP s)) }|]++-- | Read string vector data.+string :: SEXP s 'R.String -> IO (Ptr (SEXP s 'R.Char))+string (unsexp -> s) = castPtr <$>+ [CU.exp| SEXP* { STRING_PTR($(SEXP s)) }|]++readVector :: R.IsGenericVector a => SEXP s a -> Int -> IO (SomeSEXP s)+readVector (unsexp -> s) (fromIntegral -> n) = somesexp <$>+ [CU.exp| SEXP { VECTOR_ELT( $(SEXP s), $(int n) ) } |]++indexVector :: IsGenericVector a => SEXP s a -> Int -> IO (SomeSEXP s)+{-# DEPRECATED indexVector "Use readVector instead." #-}+indexVector = readVector++writeVector :: R.IsGenericVector a => SEXP s a -> Int -> SEXP s b -> IO (SEXP s a)+writeVector (unsexp -> a) (fromIntegral -> n) (unsexp -> b) = sexp <$>+ [CU.exp| SEXP { SET_VECTOR_ELT($(SEXP a),$(int n), $(SEXP b)) } |]++-- | Extract the data pointer from a vector.+unsafeSEXPToVectorPtr :: SEXP s a -> Ptr ()+unsafeSEXPToVectorPtr (unsexp -> s) =+ [C.pure| void * { DATAPTR( $(SEXP s) ) } |]++--------------------------------------------------------------------------------+-- Symbol accessor functions --+--------------------------------------------------------------------------------++-- | Read a name from symbol.+symbolPrintName :: SEXP s 'R.Symbol -> IO (SomeSEXP s)+symbolPrintName (unsexp -> s) = somesexp <$> [CU.exp| SEXP { PRINTNAME( $(SEXP s)) } |]++-- | Read value from symbol.+symbolValue :: SEXP s 'R.Symbol -> IO (SomeSEXP s)+symbolValue (unsexp -> s) = somesexp <$> [CU.exp| SEXP { SYMVALUE( $(SEXP s)) } |]++-- | Read internal value from symbol.+symbolInternal :: SEXP s 'R.Symbol -> IO (SomeSEXP s)+symbolInternal (unsexp -> s) = somesexp <$> [CU.exp| SEXP { INTERNAL( $(SEXP s)) }|]++--------------------------------------------------------------------------------+-- Value contruction --+--------------------------------------------------------------------------------++-- | Initialize a new string vector.+mkString :: CString -> IO (SEXP V 'R.String)+mkString value = sexp <$> [C.exp| SEXP { Rf_mkString($(char * value)) } |]++-- | Initialize a new character vector (aka a string).+mkChar :: CString -> IO (SEXP V 'R.Char)+mkChar value = sexp <$> [C.exp| SEXP { Rf_mkChar($(char * value)) } |]++-- | Create Character value with specified encoding+mkCharCE :: CEType -> CString -> IO (SEXP V 'R.Char)+mkCharCE (cIntFromEnum -> ce) value = sexp <$> + [C.exp| SEXP { Rf_mkCharCE($(char * value), $(int ce)) } |]++mkCharLenCE :: CEType -> CString -> Int -> IO (SEXP V 'R.Char)+mkCharLenCE (cIntFromEnum -> ce) value (fromIntegral -> len) = sexp <$>+ [C.exp| SEXP { Rf_mkCharLenCE($(char * value), $(int len), $(int ce)) } |]++-- | Intern a string @name@ into the symbol table.+--+-- If @name@ is not found, it is added to the symbol table. The symbol+-- corresponding to the string @name@ is returned.+install :: CString -> IO (SEXP V 'R.Symbol)+install name = sexp <$>+ [C.exp| SEXP { Rf_install($(char * name)) }|]++-- | Allocate a 'SEXP'.+allocSEXP :: SSEXPTYPE a -> IO (SEXP V a)+allocSEXP (cUIntFromSingEnum -> s) = sexp <$>+ [C.exp| SEXP { Rf_allocSExp( $(unsigned int s) ) }|]++-- | Allocate a pairlist of 'SEXP's, chained together.+allocList :: Int -> IO (SEXP V 'R.List)+allocList (fromIntegral -> n) = sexp <$> [C.exp| SEXP {Rf_allocList($(int n))} |]++-- | Allocate Vector.+allocVector :: R.IsVector a => SSEXPTYPE a -> Int -> IO (SEXP V a)+allocVector (cUIntFromSingEnum -> p) (fromIntegral -> n) = sexp <$>+ [C.exp| SEXP {Rf_allocVector( $(unsigned int p), $(int n)) } |]++allocVectorProtected :: (R.IsVector a) => SSEXPTYPE a -> Int -> IO (SEXP s a)+allocVectorProtected ty n = fmap release (protect =<< allocVector ty n)++-- | Allocate a so-called cons cell, in essence a pair of 'SEXP' pointers.+cons :: SEXP s a -> SEXP s b -> IO (SEXP V 'R.List)+cons (unsexp -> a) (unsexp -> b) = sexp <$>+ [C.exp| SEXP { Rf_cons($(SEXP a), $(SEXP b)) }|]++-- | Allocate a so-called cons cell of language objects, in essence a pair of+-- 'SEXP' pointers.+lcons :: SEXP s a -> SEXP s b -> IO (SEXP V 'R.Lang)+lcons (unsexp -> a) (unsexp -> b) = sexp <$>+ [C.exp| SEXP { Rf_lcons($(SEXP a), $(SEXP b)) } |]+++printValue :: SEXP s a -> IO ()+printValue (unsexp -> s) =+ [C.exp| void { Rf_PrintValue($(SEXP s)) }|]++--------------------------------------------------------------------------------+-- Garbage collection --+--------------------------------------------------------------------------------++-- | Protect a 'SEXP' from being garbage collected by R. It is in particular+-- necessary to do so for objects that are not yet pointed by any other object,+-- e.g. when constructing a tree bottom-up rather than top-down.+--+-- To avoid unbalancing calls to 'protect' and 'unprotect', do not use these+-- functions directly but use 'Language.R.withProtected' instead.+protect :: SEXP s a -> IO (SEXP G a)+protect (unsexp -> s) = sexp <$> + [CU.exp| SEXP { Rf_protect($(SEXP s)) }|]++-- | @unprotect n@ unprotects the last @n@ objects that were protected.+unprotect :: Int -> IO ()+unprotect (fromIntegral -> i) =+ [CU.exp| void { Rf_unprotect($(int i)) } |]++-- | Unprotect a specific object, referred to by pointer.+unprotectPtr :: SEXP G a -> IO ()+unprotectPtr (unsexp -> s) =+ [CU.exp| void { Rf_unprotect_ptr($(SEXP s)) }|]++-- | Invoke an R garbage collector sweep.+gc :: IO ()+gc = [C.exp| void { R_gc() }|]++-- | Preserve an object accross GCs.+preserveObject :: SEXP s a -> IO ()+preserveObject (unsexp -> s) =+ [CU.exp| void { R_PreserveObject( $(SEXP s) )} |]++-- | Allow GC to remove an preserved object.+releaseObject :: SEXP s a -> IO ()+releaseObject (unsexp -> s) =+ [CU.exp| void { R_ReleaseObject( $(SEXP s) )} |]++--------------------------------------------------------------------------------+-- Evaluation --+--------------------------------------------------------------------------------++-- | Evaluate any 'SEXP' to its value.+eval :: SEXP s a -> SEXP s 'R.Env -> IO (SomeSEXP V)+eval (unsexp -> expr) (unsexp -> env) = somesexp <$>+ [C.exp| SEXP { Rf_eval($(SEXP expr), $(SEXP env)) }|]++-- | Try to evaluate expression.+tryEval :: SEXP s a -> SEXP s 'R.Env -> Ptr CInt -> IO (SomeSEXP V)+tryEval (unsexp -> expr) (unsexp -> env) retCode = somesexp <$>+ [C.exp| SEXP { R_tryEval($(SEXP expr), $(SEXP env), $(int* retCode)) }|]++-- | Try to evaluate without printing error/warning messages to stdout.+tryEvalSilent :: SEXP s a -> SEXP s 'R.Env -> Ptr CInt -> IO (SomeSEXP V)+tryEvalSilent (unsexp -> expr) (unsexp -> env) retCode = somesexp <$>+ [C.exp| SEXP { R_tryEvalSilent($(SEXP expr), $(SEXP env), $(int* retCode)) }|]++-- | Construct a nullary function call.+lang1 :: SEXP s a -> IO (SEXP V 'R.Lang)+lang1 (unsexp -> s) = sexp <$>+ [C.exp| SEXP {Rf_lang1($(SEXP s)) }|]++-- | Construct unary function call.+lang2 :: SEXP s a -> SEXP s b -> IO (SEXP V 'R.Lang)+lang2 (unsexp -> f) (unsexp -> x) = sexp <$>+ [C.exp| SEXP {Rf_lang2($(SEXP f), $(SEXP x)) }|]++-- | Construct a binary function call.+lang3 :: SEXP s a -> SEXP s b -> SEXP s c -> IO (SEXP V 'R.Lang)+lang3 (unsexp -> f) (unsexp -> x) (unsexp -> y) = sexp <$>+ [C.exp| SEXP {Rf_lang3($(SEXP f), $(SEXP x), $(SEXP y)) }|]++-- | Find a function by name.+findFun :: SEXP s a -> SEXP s 'R.Env -> IO (SomeSEXP s)+findFun (unsexp -> a) (unsexp -> env) = somesexp <$>+ [CU.exp| SEXP { Rf_findFun($(SEXP a), $(SEXP env)) }|]++-- | Find a variable by name.+findVar :: SEXP s a -> SEXP s 'R.Env -> IO (SEXP s 'R.Symbol)+findVar (unsexp -> a) (unsexp -> env) = sexp <$>+ [CU.exp| SEXP {Rf_findVar($(SEXP a), $(SEXP env))}|]++mkWeakRef :: SEXP s a -> SEXP s b -> SEXP s c -> Bool -> IO (SEXP V 'R.WeakRef)+mkWeakRef (unsexp -> a) (unsexp -> b) (unsexp -> c) (cIntFromEnum -> t) = sexp <$>+ [C.exp| SEXP {R_MakeWeakRef($(SEXP a), $(SEXP b), $(SEXP c), $(int t))}|]++-- | Perform an action with resource while protecting it from the garbage+-- collection. This function is a safer alternative to 'R.protect' and+-- 'R.unprotect', guaranteeing that a protected resource gets unprotected+-- irrespective of the control flow, much like 'Control.Exception.bracket_'.+withProtected :: IO (SEXP V a) -- Action to acquire resource+ -> (SEXP s a -> IO b) -- Action+ -> IO b+withProtected create f =+ bracket+ (do { x <- create; _ <- protect x; return x })+ (const $ unprotect 1)+ (f . unsafeRelease)
− src/Foreign/R.hsc
@@ -1,507 +0,0 @@--- |--- Copyright: (C) 2013 Amgen, Inc.------ Low-level bindings to core R datatypes and functions. Nearly all structures--- allocated internally in R are instances of a 'SEXPREC'. A pointer to--- a 'SEXPREC' is called a 'SEXP'.------ To allow for precise typing of bindings to primitive R functions, we index--- 'SEXP's by 'SEXPTYPE', which classifies the /form/ of a 'SEXP' (see--- "Foreign.R.Type"). A function accepting 'SEXP' arguments of any type should--- leave the type index uninstantiated. A function returning a 'SEXP' result of--- unknown type should use 'SomeSEXP'. (More precisely, unknown types in--- /negative/ position should be /universally/ quantified and unknown types in--- /positive/ position should be /existentially/ quantified).------ This module is intended to be imported qualified.--{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE DeriveDataTypeable #-}-#endif-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}---- Warns about some sanity checks like IsVector, that has no methods and are--- not used.-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}--module Foreign.R- ( module Foreign.R.Type- -- * Internal R structures- , SEXP(..)- , SomeSEXP(..)- , unSomeSEXP- -- * Casts and coercions- -- $cast-coerce- , cast- , asTypeOf- , unsafeCoerce- -- * Node creation- , allocSEXP- , allocList- , allocVector- , allocVectorProtected- , install- , mkString- , mkChar- , CEType(..)- , mkCharCE- , mkCharLenCE- , mkWeakRef- -- * Node attributes- , typeOf- , isS4- , setAttributes- , getAttribute- , getAttributes- -- * Node accessor functions- -- ** Lists- , cons- , lcons- , car- , cdr- , tag- , setCar- , setCdr- , setTag- -- ** Environments- , envFrame- , envEnclosing- , envHashtab- -- ** Closures- , closureFormals- , closureBody- , closureEnv- -- ** Promises- , promiseCode- , promiseEnv- , promiseValue- -- ** Symbols- , symbolPrintName- , symbolValue- , symbolInternal- -- ** Vectors- , length- , trueLength- , char- , real- , integer- , logical- , complex- , raw- , string- , unsafeSEXPToVectorPtr- , unsafeVectorPtrToSEXP- , readVector- , writeVector- -- * Evaluation- , eval- , tryEval- , tryEvalSilent- , lang1- , lang2- , lang3- , findFun- , findVar- -- * GC functions- , protect- , unprotect- , unprotectPtr- , preserveObject- , releaseObject- , gc- -- * Globals- , isRInteractive- , nilValue- , unboundValue- , missingArg- , baseEnv- , emptyEnv- , globalEnv- , signalHandlers- , interruptsPending- -- * Communication with runtime- , printValue- -- * Low level info header access- , SEXPInfo(..)- , peekInfo- , pokeInfo- , mark- , named- -- * Internal types and functions- --- -- | Should not be used in user code. These exports are only needed for- -- binding generation tools.- , SEXPREC- , SEXP0- , sexp- , unsexp- , release- , unsafeRelease- , unsafeReleaseSome- , withProtected- -- * Deprecated- , indexVector- ) where--import Control.Memory.Region-#if __GLASGOW_HASKELL__ < 804-import Data.Monoid ((<>))-#endif-import Foreign.R.Internal-import Foreign.R.Type-import Foreign.R.Type as R--import Control.Applicative-import Control.Exception (bracket)-import Data.Complex-import Data.Int (Int32)-#if __GLASGOW_HASKELL__ < 710-import Data.Typeable (Typeable)-#endif-import Foreign (Ptr, castPtr)-import Foreign.C-import Foreign.R.Context (rCtx, SEXP0, SEXPREC)-import qualified Language.C.Inline as C-import Prelude hiding (asTypeOf, length)--#define USE_RINTERNALS-#include <Rinternals.h>--C.context (C.baseCtx <> rCtx)-C.include "<Rinternals.h>"-C.include "<stdlib.h>"-C.include "<stdint.h>"------------------------------------------------------------------------------------- Generic accessor functions --------------------------------------------------------------------------------------- | read CAR object value-car :: SEXP s a -> IO (SomeSEXP s)-car (unsexp -> s) = somesexp <$> [C.exp| SEXP { CAR( $(SEXP s) ) } |]---- | read CDR object-cdr :: SEXP s a -> IO (SomeSEXP s)-cdr (unsexp -> s) = somesexp <$> [C.exp| SEXP { CAR( $(SEXP s) ) } |]---- | read object`s Tag-tag :: SEXP s a -> IO (SomeSEXP s)-tag (unsexp -> s) = somesexp <$> [C.exp| SEXP { TAG( $(SEXP s) ) } |]------------------------------------------------------------------------------------- Environment functions -------------------------------------------------------------------------------------envFrame :: (SEXP s 'R.Env) -> IO (SEXP s R.PairList)-envFrame (unsexp -> s) = sexp <$> [C.exp| SEXP { FRAME( $(SEXP s) ) } |]---- | Enclosing environment.-envEnclosing :: SEXP s 'R.Env -> IO (SEXP s 'R.Env)-envEnclosing (unsexp -> s) = sexp <$> [C.exp| SEXP { ENCLOS( $(SEXP s) ) } |]---- | Hash table associated with the environment, used for faster name lookups.-envHashtab :: SEXP s 'R.Env -> IO (SEXP s 'R.Vector)-envHashtab (unsexp -> s) = sexp <$> [C.exp| SEXP { HASHTAB( $(SEXP s) ) } |]------------------------------------------------------------------------------------- Closure functions --------------------------------------------------------------------------------------- | Closure formals (aka the actual arguments).-closureFormals :: SEXP s 'R.Closure -> IO (SEXP s R.PairList)-closureFormals (unsexp -> s) = sexp <$> [C.exp| SEXP { FORMALS( $(SEXP s) ) }|]---- | The code of the closure.-closureBody :: SEXP s 'R.Closure -> IO (SomeSEXP s)-closureBody (unsexp -> s) = somesexp <$> [C.exp| SEXP { BODY( $(SEXP s) ) } |]---- | The environment of the closure.-closureEnv :: SEXP s 'R.Closure -> IO (SEXP s 'R.Env)-closureEnv (unsexp -> s) = sexp <$> [C.exp| SEXP { CLOENV( $(SEXP s) ) }|]------------------------------------------------------------------------------------- Promise functions --------------------------------------------------------------------------------------- | The code of a promise.-promiseCode :: SEXP s 'R.Promise -> IO (SomeSEXP s)-promiseCode (unsexp -> s) = somesexp <$> [C.exp| SEXP { PRCODE( $(SEXP s) )}|]---- | The environment in which to evaluate the promise.-promiseEnv :: SEXP s 'R.Promise -> IO (SomeSEXP s)-promiseEnv (unsexp -> s) = somesexp <$> [C.exp| SEXP { PRENV( $(SEXP s) )}|]---- | The value of the promise, if it has already been forced.-promiseValue :: SEXP s 'R.Promise -> IO (SomeSEXP s)-promiseValue (unsexp -> s) = somesexp <$> [C.exp| SEXP { PRVALUE( $(SEXP s) )}|]------------------------------------------------------------------------------------- Vector accessor functions --------------------------------------------------------------------------------------- | Read True Length vector field.-trueLength :: R.IsVector a => SEXP s a -> IO CInt-trueLength (unsexp -> s) = [C.exp| int { TRUELENGTH( $(SEXP s) ) }|]---- | Read character vector data-char :: SEXP s 'R.Char -> IO CString-char (unsexp -> s) = castPtr <$> [C.exp| const char* { CHAR($(SEXP s))}|]--- XXX: check if we really need Word8 here, maybe some better handling of--- encoding---- | Read real vector data.-real :: SEXP s 'R.Real -> IO (Ptr Double)-real (unsexp -> s) = castPtr <$> [C.exp| double* { REAL( $(SEXP s)) }|]---- | Read integer vector data.-integer :: SEXP s 'R.Int -> IO (Ptr Int32)-integer (unsexp -> s) = [C.exp| int32_t* { INTEGER( $(SEXP s) )}|]---- | Read raw data.-raw :: SEXP s 'R.Raw -> IO (Ptr CChar)-raw (unsexp -> s) = [C.exp| char* { RAW($(SEXP s)) } |]---- | Read logical vector data.-logical :: SEXP s 'R.Logical -> IO (Ptr R.Logical)-logical (unsexp -> s) = castPtr <$>- [C.exp| int* { LOGICAL($(SEXP s)) } |]---- | Read complex vector data.-complex :: SEXP s 'R.Complex -> IO (Ptr (Complex Double))-complex (unsexp -> s) = [C.exp| Rcomplex* { COMPLEX($(SEXP s)) }|]---- | Read string vector data.-string :: SEXP s 'R.String -> IO (Ptr (SEXP s 'R.Char))-string (unsexp -> s) = castPtr <$>- [C.exp| SEXP* { STRING_PTR($(SEXP s)) }|]--readVector :: R.IsGenericVector a => SEXP s a -> Int -> IO (SomeSEXP s)-readVector (unsexp -> s) (fromIntegral -> n) = somesexp <$>- [C.exp| SEXP { VECTOR_ELT( $(SEXP s), $(int n) ) } |]--indexVector :: IsGenericVector a => SEXP s a -> Int -> IO (SomeSEXP s)-{-# DEPRECATED indexVector "Use readVector instead." #-}-indexVector = readVector--writeVector :: R.IsGenericVector a => SEXP s a -> Int -> SEXP s b -> IO (SEXP s a)-writeVector (unsexp -> a) (fromIntegral -> n) (unsexp -> b) = sexp <$>- [C.exp| SEXP { SET_VECTOR_ELT($(SEXP a),$(int n), $(SEXP b)) } |]------------------------------------------------------------------------------------- Symbol accessor functions --------------------------------------------------------------------------------------- | Read a name from symbol.-symbolPrintName :: SEXP s 'R.Symbol -> IO (SEXP s a)-symbolPrintName (unsexp -> s) = sexp <$> [C.exp| SEXP { PRINTNAME( $(SEXP s)) } |]---- | Read value from symbol.-symbolValue :: SEXP s 'R.Symbol -> IO (SEXP s a)-symbolValue (unsexp -> s) = sexp <$> [C.exp| SEXP { SYMVALUE( $(SEXP s)) } |]---- | Read internal value from symbol.-symbolInternal :: SEXP s 'R.Symbol -> IO (SEXP s a)-symbolInternal (unsexp -> s) = sexp <$> [C.exp| SEXP { INTERNAL( $(SEXP s)) }|]------------------------------------------------------------------------------------- Value contruction --------------------------------------------------------------------------------------- | Initialize a new string vector.-mkString :: CString -> IO (SEXP V 'R.String)-mkString value = sexp <$> [C.exp| SEXP { Rf_mkString($(char * value)) } |]---- | Initialize a new character vector (aka a string).-mkChar :: CString -> IO (SEXP V 'R.Char)-mkChar value = sexp <$> [C.exp| SEXP { Rf_mkChar($(char * value)) } |]---- | Create Character value with specified encoding-mkCharCE :: CEType -> CString -> IO (SEXP V 'R.Char)-mkCharCE (cIntFromEnum -> ce) value = sexp <$> - [C.exp| SEXP { Rf_mkCharCE($(char * value), $(int ce)) } |]--mkCharLenCE :: CEType -> CString -> Int -> IO (SEXP V 'R.Char)-mkCharLenCE (cIntFromEnum -> ce) value (fromIntegral -> len) = sexp <$>- [C.exp| SEXP { Rf_mkCharLenCE($(char * value), $(int len), $(int ce)) } |]---- | Intern a string @name@ into the symbol table.------ If @name@ is not found, it is added to the symbol table. The symbol--- corresponding to the string @name@ is returned.-install :: CString -> IO (SEXP V 'R.Symbol)-install name = sexp <$>- [C.exp| SEXP { Rf_install($(char * name)) }|]---- | Allocate a 'SEXP'.-allocSEXP :: SSEXPTYPE a -> IO (SEXP V a)-allocSEXP (cUIntFromSingEnum -> s) = sexp <$>- [C.exp| SEXP { Rf_allocSExp( $(unsigned int s) ) }|]---- | Allocate a pairlist of 'SEXP's, chained together.-allocList :: Int -> IO (SEXP V 'R.List)-allocList (fromIntegral -> n) = sexp <$> [C.exp| SEXP {Rf_allocList($(int n))} |]---- | Allocate Vector.-allocVector :: R.IsVector a => SSEXPTYPE a -> Int -> IO (SEXP V a)-allocVector (cUIntFromSingEnum -> p) (fromIntegral -> n) = sexp <$>- [C.exp| SEXP {Rf_allocVector( $(unsigned int p), $(int n)) } |]--allocVectorProtected :: (R.IsVector a) => SSEXPTYPE a -> Int -> IO (SEXP s a)-allocVectorProtected ty n = fmap release (protect =<< allocVector ty n)---- | Allocate a so-called cons cell, in essence a pair of 'SEXP' pointers.-cons :: SEXP s a -> SEXP s b -> IO (SEXP V 'R.List)-cons (unsexp -> a) (unsexp -> b) = sexp <$>- [C.exp| SEXP { Rf_cons($(SEXP a), $(SEXP b)) }|]---- | Allocate a so-called cons cell of language objects, in essence a pair of--- 'SEXP' pointers.-lcons :: SEXP s a -> SEXP s b -> IO (SEXP V 'R.Lang)-lcons (unsexp -> a) (unsexp -> b) = sexp <$>- [C.exp| SEXP { Rf_lcons($(SEXP a), $(SEXP b)) } |]---printValue :: SEXP s a -> IO ()-printValue (unsexp -> s) =- [C.exp| void { Rf_PrintValue($(SEXP s)) }|]------------------------------------------------------------------------------------- Garbage collection --------------------------------------------------------------------------------------- | Protect a 'SEXP' from being garbage collected by R. It is in particular--- necessary to do so for objects that are not yet pointed by any other object,--- e.g. when constructing a tree bottom-up rather than top-down.------ To avoid unbalancing calls to 'protect' and 'unprotect', do not use these--- functions directly but use 'Language.R.withProtected' instead.-protect :: SEXP s a -> IO (SEXP G a)-protect (unsexp -> s) = sexp <$> - [C.exp| SEXP { Rf_protect($(SEXP s)) }|]---- | @unprotect n@ unprotects the last @n@ objects that were protected.-unprotect :: Int -> IO ()-unprotect (fromIntegral -> i) =- [C.exp| void { Rf_unprotect($(int i)) } |]---- | Unprotect a specific object, referred to by pointer.-unprotectPtr :: SEXP G a -> IO ()-unprotectPtr (unsexp -> s) =- [C.exp| void { Rf_unprotect_ptr($(SEXP s)) }|]---- | Invoke an R garbage collector sweep.-gc :: IO ()-gc = [C.exp| void { R_gc() }|]---- | Preserve an object accross GCs.-preserveObject :: SEXP s a -> IO ()-preserveObject (unsexp -> s) =- [C.exp| void { R_PreserveObject( $(SEXP s) )} |]---- | Allow GC to remove an preserved object.-releaseObject :: SEXP s a -> IO ()-releaseObject (unsexp -> s) =- [C.exp| void { R_ReleaseObject( $(SEXP s) )} |]------------------------------------------------------------------------------------- Evaluation --------------------------------------------------------------------------------------- | Evaluate any 'SEXP' to its value.-eval :: SEXP s a -> SEXP s 'R.Env -> IO (SomeSEXP V)-eval (unsexp -> expr) (unsexp -> env) = somesexp <$>- [C.exp| SEXP { Rf_eval($(SEXP expr), $(SEXP env)) }|]---- | Try to evaluate expression.-tryEval :: SEXP s a -> SEXP s 'R.Env -> Ptr CInt -> IO (SomeSEXP V)-tryEval (unsexp -> expr) (unsexp -> env) retCode = somesexp <$>- [C.exp| SEXP { R_tryEval($(SEXP expr), $(SEXP env), $(int* retCode)) }|]---- | Try to evaluate without printing error/warning messages to stdout.-tryEvalSilent :: SEXP s a -> SEXP s 'R.Env -> Ptr CInt -> IO (SomeSEXP V)-tryEvalSilent (unsexp -> expr) (unsexp -> env) retCode = somesexp <$>- [C.exp| SEXP { R_tryEvalSilent($(SEXP expr), $(SEXP env), $(int* retCode)) }|]---- | Construct a nullary function call.-lang1 :: SEXP s a -> IO (SEXP V 'R.Lang)-lang1 (unsexp -> s) = sexp <$>- [C.exp| SEXP {Rf_lang1($(SEXP s)) }|]---- | Construct unary function call.-lang2 :: SEXP s a -> SEXP s b -> IO (SEXP V 'R.Lang)-lang2 (unsexp -> f) (unsexp -> x) = sexp <$>- [C.exp| SEXP {Rf_lang2($(SEXP f), $(SEXP x)) }|]---- | Construct a binary function call.-lang3 :: SEXP s a -> SEXP s b -> SEXP s c -> IO (SEXP V 'R.Lang)-lang3 (unsexp -> f) (unsexp -> x) (unsexp -> y) = sexp <$>- [C.exp| SEXP {Rf_lang3($(SEXP f), $(SEXP x), $(SEXP y)) }|]---- | Find a function by name.-findFun :: SEXP s a -> SEXP s 'R.Env -> IO (SomeSEXP s)-findFun (unsexp -> a) (unsexp -> env) = somesexp <$>- [C.exp| SEXP { Rf_findFun($(SEXP a), $(SEXP env)) }|]---- | Find a variable by name.-findVar :: SEXP s a -> SEXP s 'R.Env -> IO (SEXP s 'R.Symbol)-findVar (unsexp -> a) (unsexp -> env) = sexp <$>- [C.exp| SEXP {Rf_findVar($(SEXP a), $(SEXP env))}|]--mkWeakRef :: SEXP s a -> SEXP s b -> SEXP s c -> Bool -> IO (SEXP V 'R.WeakRef)-mkWeakRef (unsexp -> a) (unsexp -> b) (unsexp -> c) (cIntFromEnum -> t) = sexp <$>- [C.exp| SEXP {R_MakeWeakRef($(SEXP a), $(SEXP b), $(SEXP c), $(int t))}|]------------------------------------------------------------------------------------ Encoding -------------------------------------------------------------------------------------- | Content encoding.-data CEType- = CE_Native- | CE_UTF8- | CE_Latin1- | CE_Bytes- | CE_Symbol- | CE_Any- deriving (Eq, Show)--instance Enum CEType where- fromEnum CE_Native = #const CE_NATIVE- fromEnum CE_UTF8 = #const CE_UTF8- fromEnum CE_Latin1 = #const CE_LATIN1- fromEnum CE_Bytes = #const CE_BYTES- fromEnum CE_Symbol = #const CE_SYMBOL- fromEnum CE_Any = #const CE_ANY- toEnum i = case i of- (#const CE_NATIVE) -> CE_Native- (#const CE_UTF8) -> CE_UTF8- (#const CE_LATIN1) -> CE_Latin1- (#const CE_BYTES) -> CE_Bytes- (#const CE_SYMBOL) -> CE_Symbol- (#const CE_ANY) -> CE_Any- _ -> error "CEType.fromEnum: unknown tag"---- | Perform an action with resource while protecting it from the garbage--- collection. This function is a safer alternative to 'R.protect' and--- 'R.unprotect', guaranteeing that a protected resource gets unprotected--- irrespective of the control flow, much like 'Control.Exception.bracket_'.-withProtected :: IO (SEXP V a) -- Action to acquire resource- -> (SEXP s a -> IO b) -- Action- -> IO b-withProtected create f =- bracket- (do { x <- create; _ <- protect x; return x })- (const $ unprotect 1)- (f . unsafeRelease)
src/Foreign/R/Context.hsc view
@@ -1,6 +1,8 @@+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE TemplateHaskell #-}+ -- | -- Copyright: 2018 (C) Tweag I/O Limited. --@@ -8,7 +10,7 @@ module Foreign.R.Context ( rCtx , SEXPREC- , SEXP0+ , SEXP0(..) , Logical(..) ) where @@ -23,10 +25,17 @@ #include <Rinternals.h> -data {-# CTYPE "SEXPREC" #-} SEXPREC+data SEXPREC -type SEXP0 = Ptr SEXPREC+newtype {-# CTYPE "SEXP" #-} SEXP0 = SEXP0 { unSEXP0 :: Ptr SEXPREC }+ deriving ( Eq+ , Ord+ , Storable+ ) +instance Show SEXP0 where+ show (SEXP0 ptr) = show ptr+ -- | R uses three-valued logic. data {-# CTYPE "Logical" #-} Logical = FALSE | TRUE@@ -54,6 +63,6 @@ rCtx = mempty { ctxTypesTable = Map.fromList tytabs } where tytabs =- [ (TypeName "SEXP", [t| Ptr SEXPREC |])+ [ (TypeName "SEXP", [t| SEXP0 |]) , (TypeName "Rcomplex", [t| Complex Double |]) ]
+ src/Foreign/R/Encoding.hsc view
@@ -0,0 +1,31 @@+-- | Character encodings.++#include <Rinternals.h>++module Foreign.R.Encoding where++-- | Content encoding.+data CEType+ = CE_Native+ | CE_UTF8+ | CE_Latin1+ | CE_Bytes+ | CE_Symbol+ | CE_Any+ deriving (Eq, Show)++instance Enum CEType where+ fromEnum CE_Native = #const CE_NATIVE+ fromEnum CE_UTF8 = #const CE_UTF8+ fromEnum CE_Latin1 = #const CE_LATIN1+ fromEnum CE_Bytes = #const CE_BYTES+ fromEnum CE_Symbol = #const CE_SYMBOL+ fromEnum CE_Any = #const CE_ANY+ toEnum i = case i of+ (#const CE_NATIVE) -> CE_Native+ (#const CE_UTF8) -> CE_UTF8+ (#const CE_LATIN1) -> CE_Latin1+ (#const CE_BYTES) -> CE_Bytes+ (#const CE_SYMBOL) -> CE_Symbol+ (#const CE_ANY) -> CE_Any+ _ -> error "CEType.fromEnum: unknown tag"
+ src/Foreign/R/Internal.hs view
@@ -0,0 +1,249 @@+-- |+-- Copyright: (C) 2013 Amgen, Inc.+--+-- Low-level bindings to core R datatypes and functions which depend on+-- computing offsets of C struct field. We use hsc2hs for this purpose.++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Foreign.R.Internal where++import Control.Memory.Region+import Foreign.R.Type+import Foreign.R.Type as R+import Foreign.R.Context (SEXP0(..))++import Control.Applicative+import Control.DeepSeq (NFData(..))+import Control.Monad.Primitive ( unsafeInlineIO )+import Data.Singletons (fromSing)+import Foreign (Ptr, castPtr, Storable(..))+import Foreign.C+import Prelude hiding (asTypeOf, length)+++--------------------------------------------------------------------------------+-- R data structures --+--------------------------------------------------------------------------------++-- | The basic type of all R expressions, classified by the form of the+-- expression, and the memory region in which it has been allocated.+newtype SEXP s (a :: SEXPTYPE) = SEXP { unSEXP :: SEXP0 }+ deriving ( Eq+ , Ord+ , Storable+ )++instance Show (SEXP s a) where+ show (SEXP ptr) = show ptr++instance NFData (SEXP s a) where+ rnf = (`seq` ())++-- | Add a type index to the pointer.+sexp :: SEXP0 -> SEXP s a+sexp = SEXP++-- | Remove the type index from the pointer.+unsexp :: SEXP s a -> SEXP0+unsexp = unSEXP++-- | Like 'sexp' but for 'SomeSEXP'.+somesexp :: SEXP0 -> SomeSEXP s+somesexp = SomeSEXP . sexp++-- | Release object into another region. Releasing is safe so long as the target+-- region is "smaller" than the source region, in the sense of+-- '(Control.Memory.Region.<=)'.+release :: (t <= s) => SEXP s a -> SEXP t a+release = unsafeRelease++unsafeRelease :: SEXP s a -> SEXP r a+unsafeRelease = sexp . unsexp++unsafeReleaseSome :: SomeSEXP s -> SomeSEXP g+unsafeReleaseSome (SomeSEXP x) = SomeSEXP (unsafeRelease x)++-- | A 'SEXP' of unknown form.+data SomeSEXP s = forall a. SomeSEXP {-# UNPACK #-} !(SEXP s a)++instance Show (SomeSEXP s) where+ show s = unSomeSEXP s show++instance Storable (SomeSEXP s) where+ sizeOf _ = sizeOf (undefined :: SEXP s a)+ alignment _ = alignment (undefined :: SEXP s a)+ peek ptr = SomeSEXP <$> peek (castPtr ptr)+ poke ptr (SomeSEXP s) = poke (castPtr ptr) s++instance NFData (SomeSEXP s) where+ rnf = (`seq` ())++-- | Deconstruct a 'SomeSEXP'. Takes a continuation since otherwise the+-- existentially quantified variable hidden inside 'SomeSEXP' would escape.+unSomeSEXP :: SomeSEXP s -> (forall a. SEXP s a -> r) -> r+unSomeSEXP (SomeSEXP s) k = k s++cIntConv :: (Integral a, Integral b) => a -> b+cIntConv = fromIntegral++cIntToEnum :: Enum a => CInt -> a+cIntToEnum = toEnum . cIntConv++cUIntFromSingEnum :: SSEXPTYPE a -> CUInt+cUIntFromSingEnum = cIntConv . fromEnum . fromSing++cIntFromEnum :: Enum a => a -> CInt+cIntFromEnum = cIntConv . fromEnum++-- | Return the \"type\" tag (aka the form tag) of the given 'SEXP'. This+-- function is pure because the type of an object does not normally change over+-- the lifetime of the object.+typeOf :: SEXP s a -> SEXPTYPE+typeOf s = unsafeInlineIO $ cIntToEnum <$> cTYPEOF (unsexp s)++foreign import ccall unsafe "TYPEOF" cTYPEOF :: SEXP0 -> IO CInt++--------------------------------------------------------------------------------+-- Coercion functions --+--------------------------------------------------------------------------------++-- $cast-coerce+--+-- /Coercions/ have no runtime cost, but are completely unsafe. Use with+-- caution, only when you know that a 'SEXP' is of the target type. /Casts/ are+-- safer, but introduce a runtime type check. The difference between the two is+-- akin to the difference between a C-style typecasts and C++-style+-- @dynamic_cast@'s.++unsafeCast :: SEXPTYPE -> SomeSEXP s -> SEXP s b+unsafeCast ty (SomeSEXP s)+ | ty == typeOf s = unsafeCoerce s+ | otherwise =+ error $ "cast: Dynamic type cast failed. Expected: " ++ show ty +++ ". Actual: " ++ show (typeOf s) ++ "."++-- | Cast the type of a 'SEXP' into another type. This function is partial: at+-- runtime, an error is raised if the source form tag does not match the target+-- form tag.+cast :: SSEXPTYPE a -> SomeSEXP s -> SEXP s a+cast ty s = unsafeCast (fromSing ty) s++-- | Cast form of first argument to that of the second argument.+asTypeOf :: SomeSEXP s -> SEXP s a -> SEXP s a+asTypeOf s s' = typeOf s' `unsafeCast` s++-- | Unsafe coercion from one form to another. This is unsafe, in the sense that+-- using this function improperly could cause code to crash in unpredictable+-- ways. Contrary to 'cast', it has no runtime cost since it does not introduce+-- any dynamic check at runtime.+unsafeCoerce :: SEXP s a -> SEXP s b+unsafeCoerce = sexp . unsexp++--------------------------------------------------------------------------------+-- Global variables --+--------------------------------------------------------------------------------++foreign import ccall "&R_Interactive" isRInteractive :: Ptr CInt++-- | Global nil value. Constant throughout the lifetime of the R instance.+foreign import ccall "&R_NilValue" nilValue :: Ptr (SEXP G R.Nil)++-- | Unbound marker. Constant throughout the lifetime of the R instance.+foreign import ccall "&R_UnboundValue" unboundValue :: Ptr (SEXP G R.Symbol)++-- | Missing argument marker. Constant throughout the lifetime of the R instance.+foreign import ccall "&R_MissingArg" missingArg :: Ptr (SEXP G R.Symbol)++-- | The base environment.+foreign import ccall "&R_BaseEnv" baseEnv :: Ptr (SEXP G R.Env)++-- | The empty environment.+foreign import ccall "&R_EmptyEnv" emptyEnv :: Ptr (SEXP G R.Env)++-- | Global environment.+foreign import ccall "&R_GlobalEnv" globalEnv :: Ptr (SEXP G R.Env)++-- | Signal handler switch+foreign import ccall "&R_SignalHandlers" signalHandlers :: Ptr CInt++-- | Flag that shows if computation should be interrupted.+foreign import ccall "&R_interrupts_pending" interruptsPending :: Ptr CInt++----------------------------------------------------------------------------------+-- Structure header --+----------------------------------------------------------------------------------++-- | Info header for the SEXP data structure.+data SEXPInfo = SEXPInfo+ { infoType :: SEXPTYPE -- ^ Type of the SEXP.+ , infoObj :: Bool -- ^ Is this an object with a class attribute.+ , infoNamed :: Int -- ^ Control copying information.+ , infoGp :: Int -- ^ General purpose data.+ , infoMark :: Bool -- ^ Mark object as 'in use' in GC.+ , infoDebug :: Bool -- ^ Debug marker.+ , infoTrace :: Bool -- ^ Trace marker.+ , infoSpare :: Bool -- ^ Alignment (not in use).+ } deriving ( Show )++-- | Extract the header from the given 'SEXP'.+peekInfo :: SEXP s a -> IO SEXPInfo+peekInfo ts =+ SEXPInfo+ <$> (toEnum.fromIntegral <$> cTYPEOF s)+ <*> ((/=0) <$> cOBJECT s)+ <*> (fromIntegral <$> cNAMED s)+ <*> (fromIntegral <$> cLEVELS s)+ <*> ((/=0) <$> cMARK s)+ <*> ((/=0) <$> cRDEBUG s)+ <*> ((/=0) <$> cRTRACE s)+ <*> ((/=0) <$> cRSTEP s)+ where+ s = unsexp ts++-- These accessors are necessary because hsc2hs cannot determine the offset of+-- C struct bit-fields. https://ghc.haskell.org/trac/ghc/ticket/12149+foreign import ccall unsafe "OBJECT" cOBJECT :: SEXP0 -> IO CInt+foreign import ccall unsafe "NAMED" cNAMED :: SEXP0 -> IO CInt+foreign import ccall unsafe "LEVELS" cLEVELS :: SEXP0 -> IO CInt+foreign import ccall unsafe "MARK" cMARK :: SEXP0 -> IO CInt+foreign import ccall unsafe "RDEBUG" cRDEBUG :: SEXP0 -> IO CInt+foreign import ccall unsafe "RTRACE" cRTRACE :: SEXP0 -> IO CInt+foreign import ccall unsafe "RSTEP" cRSTEP :: SEXP0 -> IO CInt++-------------------------------------------------------------------------------+-- Attribute header --+-------------------------------------------------------------------------------++-- | Check if object is an S4 object.+--+-- This is a function call so it will be more precise than using 'typeOf'.+isS4 :: SEXP s ty -> Bool+isS4 s = (>0) $ cisS4 (unsexp s)++-- | Get the attribute list from the given object.+getAttributes :: SEXP s a -> IO (SEXP s b)+getAttributes s = sexp <$> cAttrib (unsexp s)++-- | Get attribute with the given name.+getAttribute :: SEXP s a -- ^ Value+ -> SEXP s2 b -- ^ Attribute name+ -> SEXP s c+getAttribute a b = sexp $ cgetAttrib (unsexp a) (unsexp b)+++-- | Set the attribute list.+setAttributes :: SEXP s a -> SEXP s b -> IO ()+setAttributes s v = csetAttrib (unsexp s) (unsexp v)++foreign import ccall unsafe "Rinternals.h ATTRIB" cAttrib :: SEXP0 -> IO SEXP0+foreign import ccall unsafe "Rinternals.h SET_ATTRIB" csetAttrib :: SEXP0 -> SEXP0 -> IO ()+foreign import ccall unsafe "Rinternals.h Rf_getAttrib" cgetAttrib :: SEXP0 -> SEXP0 -> SEXP0+foreign import ccall unsafe "Rinternals.h Rf_isS4" cisS4 :: SEXP0 -> Int
− src/Foreign/R/Internal.hsc
@@ -1,342 +0,0 @@--- |--- Copyright: (C) 2013 Amgen, Inc.------ Low-level bindings to core R datatypes and functions which depend on--- computing offsets of C struct field. We use hsc2hs for this purpose.--{-# LANGUAGE CApiFFI #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE DeriveDataTypeable #-}-#endif-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-#if __GLASGOW_HASKELL__ >= 710--- We don't use ticks in this module, because they confuse hsc2hs.-{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}-#endif-module Foreign.R.Internal where--import Control.Memory.Region-import {-# SOURCE #-} Language.R.HExp (HExp)-import Foreign.R.Type-import Foreign.R.Type as R-import Foreign.R.Context (SEXP0)--import Control.Applicative-import Control.DeepSeq (NFData(..))-import Control.Monad.Primitive ( unsafeInlineIO )-import Data.Singletons (fromSing)-#if __GLASGOW_HASKELL__ < 710-import Data.Typeable (Typeable)-#endif-import Foreign (Ptr, castPtr, plusPtr, Storable(..))-import Foreign.C-import Prelude hiding (asTypeOf, length)--#define USE_RINTERNALS-#include <R.h>-#include <Rinternals.h>-#include "missing_r.h"-------------------------------------------------------------------------------------- R data structures --------------------------------------------------------------------------------------- | The basic type of all R expressions, classified by the form of the--- expression, and the memory region in which it has been allocated.-newtype SEXP s (a :: SEXPTYPE) = SEXP { unSEXP :: Ptr (HExp s a) }- deriving ( Eq- , Ord- , Storable-#if __GLASGOW_HASKELL__ < 710- , Typeable-#endif- )--instance Show (SEXP s a) where- show (SEXP ptr) = show ptr--instance NFData (SEXP s a) where- rnf = (`seq` ())---- | Add a type index to the pointer.-sexp :: SEXP0 -> SEXP s a-sexp = SEXP . castPtr---- | Remove the type index from the pointer.-unsexp :: SEXP s a -> SEXP0-unsexp = castPtr . unSEXP---- | Like 'sexp' but for 'SomeSEXP'.-somesexp :: SEXP0 -> SomeSEXP s-somesexp = SomeSEXP . sexp---- | Release object into another region. Releasing is safe so long as the target--- region is "smaller" than the source region, in the sense of--- '(Control.Memory.Region.<=)'.-release :: (t <= s) => SEXP s a -> SEXP t a-release = unsafeRelease--unsafeRelease :: SEXP s a -> SEXP r a-unsafeRelease = sexp . unsexp--unsafeReleaseSome :: SomeSEXP s -> SomeSEXP g-unsafeReleaseSome (SomeSEXP x) = SomeSEXP (unsafeRelease x)---- | A 'SEXP' of unknown form.-data SomeSEXP s = forall a. SomeSEXP {-# UNPACK #-} !(SEXP s a)--instance Show (SomeSEXP s) where- show s = unSomeSEXP s show--instance Storable (SomeSEXP s) where- sizeOf _ = sizeOf (undefined :: SEXP s a)- alignment _ = alignment (undefined :: SEXP s a)- peek ptr = SomeSEXP <$> peek (castPtr ptr)- poke ptr (SomeSEXP s) = poke (castPtr ptr) s--instance NFData (SomeSEXP s) where- rnf = (`seq` ())---- | Deconstruct a 'SomeSEXP'. Takes a continuation since otherwise the--- existentially quantified variable hidden inside 'SomeSEXP' would escape.-unSomeSEXP :: SomeSEXP s -> (forall a. SEXP s a -> r) -> r-unSomeSEXP (SomeSEXP s) k = k s--cIntConv :: (Integral a, Integral b) => a -> b-cIntConv = fromIntegral--cIntToEnum :: Enum a => CInt -> a-cIntToEnum = toEnum . cIntConv--cUIntFromSingEnum :: SSEXPTYPE a -> CUInt-cUIntFromSingEnum = cIntConv . fromEnum . fromSing--cIntFromEnum :: Enum a => a -> CInt-cIntFromEnum = cIntConv . fromEnum------------------------------------------------------------------------------------- Generic accessor functions --------------------------------------------------------------------------------------- | Return the \"type\" tag (aka the form tag) of the given 'SEXP'. This--- function is pure because the type of an object does not normally change over--- the lifetime of the object.-typeOf :: SEXP s a -> SEXPTYPE-typeOf s = unsafeInlineIO $ cIntToEnum <$> cTYPEOF (unsexp s)--foreign import capi unsafe "TYPEOF" cTYPEOF :: SEXP0 -> IO CInt---- | Set CAR field of object, when object is viewed as a cons cell.-setCar :: SEXP s a -> SEXP s b -> IO ()-setCar s s' = #{poke SEXPREC, u.listsxp.carval} (unsexp s) (castPtr $ unsexp s')---- | Set CDR field of object, when object is viewed as a cons cell.-setCdr :: SEXP s a -> SEXP s b -> IO ()-setCdr s s' = #{poke SEXPREC, u.listsxp.cdrval} (unsexp s) (castPtr $ unsexp s')---- | Set TAG field of object, when object is viewed as a cons cell.-setTag :: SEXP s a -> SEXP s b -> IO ()-setTag s s' = #{poke SEXPREC, u.listsxp.tagval} (unsexp s) (castPtr $ unsexp s')------------------------------------------------------------------------------------- Coercion functions --------------------------------------------------------------------------------------- $cast-coerce------ /Coercions/ have no runtime cost, but are completely unsafe. Use with--- caution, only when you know that a 'SEXP' is of the target type. /Casts/ are--- safer, but introduce a runtime type check. The difference between the two is--- akin to the difference between a C-style typecasts and C++-style--- @dynamic_cast@'s.--unsafeCast :: SEXPTYPE -> SomeSEXP s -> SEXP s b-unsafeCast ty (SomeSEXP s)- | ty == typeOf s = unsafeCoerce s- | otherwise =- error $ "cast: Dynamic type cast failed. Expected: " ++ show ty ++- ". Actual: " ++ show (typeOf s) ++ "."---- | Cast the type of a 'SEXP' into another type. This function is partial: at--- runtime, an error is raised if the source form tag does not match the target--- form tag.-cast :: SSEXPTYPE a -> SomeSEXP s -> SEXP s a-cast ty s = unsafeCast (fromSing ty) s---- | Cast form of first argument to that of the second argument.-asTypeOf :: SomeSEXP s -> SEXP s a -> SEXP s a-asTypeOf s s' = typeOf s' `unsafeCast` s---- | Unsafe coercion from one form to another. This is unsafe, in the sense that--- using this function improperly could cause code to crash in unpredictable--- ways. Contrary to 'cast', it has no runtime cost since it does not introduce--- any dynamic check at runtime.-unsafeCoerce :: SEXP s a -> SEXP s b-unsafeCoerce = sexp . castPtr . unsexp------------------------------------------------------------------------------------- Vector accessor functions --------------------------------------------------------------------------------------- | Length of the vector.-length :: R.IsVector a => SEXP s a -> IO Int-length s = fromIntegral <$>- (#{peek VECTOR_SEXPREC, vecsxp.length} (unsexp s) :: IO CInt)---- | Extract the data pointer from a vector.-unsafeSEXPToVectorPtr :: SEXP s a -> Ptr ()-unsafeSEXPToVectorPtr s = (unsexp s) `plusPtr` #{size SEXPREC_ALIGN}---- | Inverse of 'vectorPtr'.-unsafeVectorPtrToSEXP :: Ptr a -> SomeSEXP s-unsafeVectorPtrToSEXP s = SomeSEXP $ sexp $ s `plusPtr` (- #{size SEXPREC_ALIGN})------------------------------------------------------------------------------------- Global variables -------------------------------------------------------------------------------------foreign import ccall "&R_Interactive" isRInteractive :: Ptr CInt---- | Global nil value. Constant throughout the lifetime of the R instance.-foreign import ccall "&R_NilValue" nilValue :: Ptr (SEXP G R.Nil)---- | Unbound marker. Constant throughout the lifetime of the R instance.-foreign import ccall "&R_UnboundValue" unboundValue :: Ptr (SEXP G R.Symbol)---- | Missing argument marker. Constant throughout the lifetime of the R instance.-foreign import ccall "&R_MissingArg" missingArg :: Ptr (SEXP G R.Symbol)---- | The base environment.-foreign import ccall "&R_BaseEnv" baseEnv :: Ptr (SEXP G R.Env)---- | The empty environment.-foreign import ccall "&R_EmptyEnv" emptyEnv :: Ptr (SEXP G R.Env)---- | Global environment.-foreign import ccall "&R_GlobalEnv" globalEnv :: Ptr (SEXP G R.Env)---- | Signal handler switch-foreign import ccall "&R_SignalHandlers" signalHandlers :: Ptr CInt---- | Flag that shows if computation should be interrupted.-foreign import ccall "&R_interrupts_pending" interruptsPending :: Ptr CInt--------------------------------------------------------------------------------------- Structure header ----------------------------------------------------------------------------------------- | Info header for the SEXP data structure.-data SEXPInfo = SEXPInfo- { infoType :: SEXPTYPE -- ^ Type of the SEXP.- , infoObj :: Bool -- ^ Is this an object with a class attribute.- , infoNamed :: Int -- ^ Control copying information.- , infoGp :: Int -- ^ General purpose data.- , infoMark :: Bool -- ^ Mark object as 'in use' in GC.- , infoDebug :: Bool -- ^ Debug marker.- , infoTrace :: Bool -- ^ Trace marker.- , infoSpare :: Bool -- ^ Alignment (not in use).- , infoGcGen :: Int -- ^ GC Generation.- , infoGcCls :: Int -- ^ GC Class of node.- } deriving ( Show )---- | Extract the header from the given 'SEXP'.-peekInfo :: SEXP s a -> IO SEXPInfo-peekInfo ts =- SEXPInfo- <$> (toEnum.fromIntegral <$> cTYPEOF s)- <*> ((/=0) <$> cOBJECT s)- <*> (fromIntegral <$> cNAMED s)- <*> (fromIntegral <$> cLEVELS s)- <*> ((/=0) <$> cMARK s)- <*> ((/=0) <$> cRDEBUG s)- <*> ((/=0) <$> cRTRACE s)- <*> ((/=0) <$> cRSTEP s)- <*> (fromIntegral <$> cGCGEN s)- <*> (fromIntegral <$> cGCCLS s)- where- s = unsexp ts---- These accessors are necessary because hsc2hs cannot determine the offset of--- C struct bit-fields. https://ghc.haskell.org/trac/ghc/ticket/12149-foreign import capi unsafe "OBJECT" cOBJECT :: SEXP0 -> IO CInt-foreign import capi unsafe "NAMED" cNAMED :: SEXP0 -> IO CInt-foreign import capi unsafe "LEVELS" cLEVELS :: SEXP0 -> IO CInt-foreign import capi unsafe "MARK" cMARK :: SEXP0 -> IO CInt-foreign import capi unsafe "RDEBUG" cRDEBUG :: SEXP0 -> IO CInt-foreign import capi unsafe "RTRACE" cRTRACE :: SEXP0 -> IO CInt-foreign import capi unsafe "RSTEP" cRSTEP :: SEXP0 -> IO CInt-foreign import capi unsafe "missing_r.h GCGEN" cGCGEN :: SEXP0 -> IO CInt-foreign import capi unsafe "missing_r.h GCCLS" cGCCLS :: SEXP0 -> IO CInt---- | Write a new header.-pokeInfo :: SEXP s a -> SEXPInfo -> IO ()-pokeInfo (unsexp -> s) i = do- cSET_TYPEOF s (fromIntegral.fromEnum $ infoType i)- cSET_OBJECT s (if infoObj i then 1 else 0)- cSET_NAMED s (fromIntegral $ infoNamed i)- cSETLEVELS s (fromIntegral $ infoGp i)- cSET_MARK s (if infoMark i then 1 else 0)- cSET_RDEBUG s (if infoDebug i then 1 else 0)- cSET_RTRACE s (if infoTrace i then 1 else 0)- cSET_RSTEP s (if infoSpare i then 1 else 0)- cSET_GCGEN s (fromIntegral $ infoGcGen i)- cSET_GCCLS s (fromIntegral $ infoGcCls i)--foreign import capi unsafe "SET_TYPEOF" cSET_TYPEOF :: SEXP0 -> CInt -> IO ()-foreign import capi unsafe "SET_OBJECT" cSET_OBJECT :: SEXP0 -> CInt -> IO ()-foreign import capi unsafe "SET_NAMED" cSET_NAMED :: SEXP0 -> CInt -> IO ()-foreign import capi unsafe "SETLEVELS" cSETLEVELS :: SEXP0 -> CInt -> IO ()-foreign import capi unsafe "SET_MARK" cSET_MARK :: SEXP0 -> CInt -> IO ()-foreign import capi unsafe "SET_RDEBUG" cSET_RDEBUG :: SEXP0 -> CInt -> IO ()-foreign import capi unsafe "SET_RTRACE" cSET_RTRACE :: SEXP0 -> CInt -> IO ()-foreign import capi unsafe "SET_RSTEP" cSET_RSTEP :: SEXP0 -> CInt -> IO ()-foreign import capi unsafe "missing_r.h SET_GCGEN" cSET_GCGEN :: SEXP0 -> CInt -> IO ()-foreign import capi unsafe "missing_r.h SET_GCCLS" cSET_GCCLS :: SEXP0 -> CInt -> IO ()---- | Set the GC mark.-mark :: Bool -> SEXP s a -> IO ()-mark b ts = cSET_MARK (unsexp ts) (if b then 1 else 0)--named :: Int -> SEXP s a -> IO ()-named v ts = cSET_NAMED (unsexp ts) (fromIntegral v)------------------------------------------------------------------------------------ Attribute header -------------------------------------------------------------------------------------- | Check if object is an S4 object.------ This is a function call so it will be more precise than using 'typeOf'.-isS4 :: SEXP s ty -> Bool-isS4 s = (>0) $ cisS4 (unsexp s)---- | Get the attribute list from the given object.-getAttributes :: SEXP s a -> IO (SEXP s b)-getAttributes s = sexp <$> cAttrib (unsexp s)---- | Get attribute with the given name.-getAttribute :: SEXP s a -- ^ Value- -> SEXP s2 b -- ^ Attribute name- -> SEXP s c-getAttribute a b = sexp $ cgetAttrib (unsexp a) (unsexp b)----- | Set the attribute list.-setAttributes :: SEXP s a -> SEXP s b -> IO ()-setAttributes s v = csetAttrib (unsexp s) (castPtr $ unsexp v)--foreign import capi unsafe "Rinternals.h ATTRIB" cAttrib :: SEXP0 -> IO SEXP0-foreign import capi unsafe "Rinternals.h SET_ATTRIB" csetAttrib :: SEXP0 -> SEXP0 -> IO ()-foreign import capi unsafe "Rinternals.h Rf_getAttrib" cgetAttrib :: SEXP0 -> SEXP0 -> SEXP0-foreign import capi unsafe "Rinternals.h Rf_isS4" cisS4 :: SEXP0 -> Int
src/Foreign/R/Parse.hsc view
@@ -9,9 +9,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ForeignFunctionInterface #-}-#if __GLASGOW_HASKELL__ >= 710-{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}-#endif #include <Rinternals.h> #include <R_ext/Parse.h>
src/Foreign/R/Type.hsc view
@@ -11,9 +11,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 710-{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}-#endif {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- |
src/Language/R/Debug.hs view
@@ -51,8 +51,6 @@ , "debug" .= R.infoDebug x , "trace" .= R.infoTrace x , "spare" .= R.infoSpare x- , "gcgen" .= R.infoGcGen x- , "gccls" .= R.infoGcCls x ] instance ToJSON a => ToJSON (Complex a) where@@ -90,8 +88,8 @@ , "value" .= if R.unsexp j == R.unsexp h then "loop" else toJSON j , "internal" .= k ]- go (hexp -> Special i) = object ["index" .= i]- go (hexp -> Builtin i) = object ["index" .= i]+ go (hexp -> Special) = object ["index" .= A.String "unknown"]+ go (hexp -> Builtin) = object ["index" .= A.String "unknown"] go (hexp -> Char v) = A.String (T.pack (Vector.toString v)) go (hexp -> Int v) = A.Array (vector v) go (hexp -> Real v) = A.Array (vector v)
+ src/Language/R/HExp.hs view
@@ -0,0 +1,387 @@+-- |+-- Copyright: (C) 2013 Amgen, Inc.+--+-- Provides a /shallow/ view of a 'SEXP' R value as an algebraic datatype. This+-- is useful to define functions over R values in Haskell with pattern matching.+-- For example:+--+-- @+-- toPair :: SEXP a -> (SomeSEXP, SomeSEXP)+-- toPair (hexp -> List _ (Just car) (Just cdr)) = (SomeSEXP car, SomeSEXP cdr)+-- toPair (hexp -> Lang car (Just cdr)) = (SomeSEXP car, SomeSEXP cdr)+-- toPair s = error $ "Cannot extract pair from object of type " ++ typeOf s+-- @+--+-- (See 'Foreign.R.SomeSEXP' for why we need to use it here.)+--+-- The view is said to be 'shallow' because it only unfolds the head of the+-- R value into an algebraic datatype. In this way, functions producing views+-- can be written non-recursively, hence inlined at all call sites and+-- simplified away. When produced by a view function in a pattern match,+-- allocation of the view can be compiled away and hence producing a view can be+-- done at no runtime cost. In fact, pattern matching on a view in this way is+-- more efficient than using the accessor functions defined in "Foreign.R",+-- because we avoid the overhead of calling one or more FFI functions entirely.+--+-- 'HExp' is the /view/ and 'hexp' is the /view function/ that projects 'SEXP's+-- into 'HExp' views.++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module Language.R.HExp+ ( HExp(..)+ , (===)+ , hexp+ , vector+ ) where++import Control.Applicative+import Control.Memory.Region (V)+import qualified Foreign.R as R+import Foreign.R (SEXP, SomeSEXP(..), SEXPTYPE)+import Foreign.R.Constraints+import Internal.Error++import qualified Data.Vector.SEXP as Vector++import Control.Monad (guard, void)+import Control.Monad.Primitive ( unsafeInlineIO )+import Data.Int (Int32)+import Data.Word (Word8)+import Data.Complex+import Data.Maybe (isJust)+import Data.Type.Equality (TestEquality(..), (:~:)(Refl))+import GHC.Ptr (Ptr(..))+import Foreign.Storable+import Foreign (castPtr)+import Unsafe.Coerce (unsafeCoerce)+-- Fixes redundant import warning >= 7.10 without CPP+import Prelude+++-- Use explicit UNPACK pragmas rather than -funbox-strict-fields in order to get+-- warnings if a field is not unpacked when we expect it to.++-- | A view of R's internal 'SEXP' structure as an algebraic datatype. Because+-- this is in fact a GADT, the use of named record fields is not possible here.+-- Named record fields give rise to functions for whom it is not possible to+-- assign a reasonable type (existentially quantified type variables would+-- escape).+--+-- See <https://cran.r-project.org/doc/manuals/r-release/R-ints.html#SEXPTYPEs>.+type role HExp phantom nominal+data HExp :: * -> SEXPTYPE -> * where+ -- Primitive types. The field names match those of <RInternals.h>.+ -- | The NULL value (@NILSXP@).+ Nil :: HExp s 'R.Nil+ -- | A symbol (@SYMSXP@).+ Symbol :: (a :∈ ['R.Char, 'R.Nil])+ => SEXP s a -- ^ the name (is 'Nil' for 'H.unboundValue')+ -> SEXP s b -- ^ the value. Many symbols have their value set to 'H.unboundValue'.+ -> SEXP s c -- ^ «internal»: if the symbol's value is a @.Internal@ function,+ -- this is a pointer to the appropriate 'SEXP'.+ -> HExp s 'R.Symbol+ -- | A list (@LISTSXP@).+ List :: (R.IsPairList b, c :∈ ['R.Symbol, 'R.Nil])+ => SEXP s a -- ^ CAR+ -> SEXP s b -- ^ CDR (usually a 'List' or 'Nil')+ -> SEXP s c -- ^ TAG (a 'Symbol' or 'Nil')+ -> HExp s 'R.List+ -- | An environment (@ENVSXP@).+ Env :: (R.IsPairList a, b :∈ ['R.Env, 'R.Nil], c :∈ ['R.Vector, 'R.Nil])+ => SEXP s a -- ^ the frame: a tagged pairlist with tag the symbol and CAR the bound value+ -> SEXP s b -- ^ the enclosing environment+ -> SEXP s c -- ^ the hash table+ -> HExp s 'R.Env+ -- | A closure (@CLOSXP@).+ Closure :: (R.IsPairList a)+ => SEXP s a -- ^ formals (a pairlist)+ -> SEXP s b -- ^ the body+ -> SEXP s 'R.Env -- ^ the environment+ -> HExp s 'R.Closure+ -- | A promise (@PROMSXP@).+ Promise :: (R.IsExpression b, c :∈ ['R.Env, 'R.Nil])+ => SEXP s a -- ^ the value+ -> SEXP s b -- ^ the expression+ -> SEXP s c -- ^ the environment. Once the promise has been+ -- evaluated, the environment is set to NULL.+ -> HExp s 'R.Promise+ -- Derived types. These types don't have their own 'struct' declaration in+ -- <Rinternals.h>.+ -- | Language objects (@LANGSXP@) are calls (including formulae and so on).+ -- Internally they are pairlists with first element a reference to the+ -- function to be called with remaining elements the actual arguments for+ -- the call (and with the tags if present giving the specified argument+ -- names). Although this is not enforced, many places in the R code assume+ -- that the pairlist is of length one or more, often without checking.+ Lang :: (R.IsExpression a, R.IsPairList b)+ => SEXP s a -- ^ CAR: the function (perhaps via a symbol or language object)+ -> SEXP s b -- ^ CDR: the argument list with tags for named arguments+ -> HExp s 'R.Lang+ -- | A special (built-in) function call (@SPECIALSXP@). It carries an offset+ -- into the table of primitives but for our purposes is opaque.+ Special :: HExp s 'R.Special+ -- | A @BUILTINSXP@. This is similar to 'Special', except the arguments to a 'Builtin'+ -- are always evaluated.+ Builtin :: HExp s 'R.Builtin+ -- | An internal character string (@CHARSXP@).+ Char :: {-# UNPACK #-} !(Vector.Vector 'R.Char Word8)+ -> HExp s 'R.Char+ -- | A logical vector (@LGLSXP@).+ Logical :: {-# UNPACK #-} !(Vector.Vector 'R.Logical R.Logical)+ -> HExp s 'R.Logical+ -- | An integer vector (@INTSXP@).+ Int :: {-# UNPACK #-} !(Vector.Vector 'R.Int Int32)+ -> HExp s 'R.Int+ -- | A numeric vector (@REALSXP@).+ Real :: {-# UNPACK #-} !(Vector.Vector 'R.Real Double)+ -> HExp s 'R.Real+ -- | A complex vector (@CPLXSXP@).+ Complex :: {-# UNPACK #-} !(Vector.Vector 'R.Complex (Complex Double))+ -> HExp s 'R.Complex+ -- | A character vector (@STRSXP@).+ String :: {-# UNPACK #-} !(Vector.Vector 'R.String (SEXP V 'R.Char))+ -> HExp s 'R.String+ -- | A special type of @LISTSXP@ for the value bound to a @...@ symbol+ DotDotDot :: (R.IsPairList a)+ => SEXP s a -- ^ a pairlist of promises+ -> HExp s 'R.List+ -- | A list/generic vector (@VECSXP@).+ Vector :: {-# UNPACK #-} !Int32 -- ^ true length+ -> {-# UNPACK #-} !(Vector.Vector 'R.Vector (SomeSEXP V))+ -> HExp s 'R.Vector+ -- | An expression vector (@EXPRSXP@).+ Expr :: {-# UNPACK #-} !Int32 -- ^ true length+ -> {-# UNPACK #-} !(Vector.Vector 'R.Expr (SomeSEXP V))+ -> HExp s 'R.Expr+ -- | A ‘byte-code’ object generated by R (@BCODESXP@).+ Bytecode :: HExp s 'R.Bytecode -- TODO+ -- | An external pointer (@EXTPTRSXP@)+ ExtPtr :: (c :∈ ['R.Symbol, 'R.Nil])+ => Ptr () -- ^ the pointer+ -> SEXP s b -- ^ the protection value (an R object which if alive protects this object)+ -> SEXP s c -- ^ a tag+ -> HExp s 'R.ExtPtr+ -- | A weak reference (@WEAKREFSXP@).+ WeakRef :: ( a :∈ ['R.Env, 'R.ExtPtr, 'R.Nil]+ , c :∈ ['R.Closure, 'R.Builtin, 'R.Special, 'R.Nil]+ , d :∈ ['R.WeakRef, 'R.Nil] )+ => SEXP s a -- ^ the key+ -> SEXP s b -- ^ the value+ -> SEXP s c -- ^ the finalizer+ -> SEXP s d -- ^ the next entry in the weak references list+ -> HExp s 'R.WeakRef+ -- | A raw vector (@RAWSXP@).+ Raw :: {-# UNPACK #-} !(Vector.Vector 'R.Raw Word8)+ -> HExp s 'R.Raw+ -- | An S4 class which does not consist solely of a simple type such as an atomic vector or function (@S4SXP@).+ S4 :: (a :∈ ['R.Symbol, 'R.Nil])+ => SEXP s a -- ^ the tag+ -> HExp s 'R.S4++-- 'Im a hack++instance Eq (HExp s a) where+ (==) = (===)++-- | Heterogeneous equality.+(===) :: TestEquality f => f a -> f b -> Bool+x === y = isJust $ testEquality x y++-- | Wrapper for partially applying a type synonym.+newtype E s a = E (SEXP s a)++instance TestEquality (E s) where+ testEquality (E x@(hexp -> t1)) (E y@(hexp -> t2)) =+ (guard (R.unsexp x == R.unsexp y) >> return (unsafeCoerce Refl)) <|>+ testEquality t1 t2++instance TestEquality (HExp s) where+ testEquality Nil Nil = return Refl+ testEquality (Symbol pname1 value1 internal1) (Symbol pname2 value2 internal2) = do+ void $ testEquality (E pname1) (E pname2)+ void $ testEquality (E value1) (E value2)+ void $ testEquality (E internal1) (E internal2)+ return Refl+ testEquality (List carval1 cdrval1 tagval1) (List carval2 cdrval2 tagval2) = do+ void $ testEquality (E carval1) (E carval2)+ void $ testEquality (E cdrval1) (E cdrval2)+ void $ testEquality (E tagval1) (E tagval2)+ return Refl+ testEquality (Env frame1 enclos1 hashtab1) (Env frame2 enclos2 hashtab2) = do+ void $ testEquality (E frame1) (E frame2)+ void $ testEquality (E enclos1) (E enclos2)+ void $ testEquality (E hashtab1) (E hashtab2)+ return Refl+ testEquality (Closure formals1 body1 env1) (Closure formals2 body2 env2) = do+ void $ testEquality (E formals1) (E formals2)+ void $ testEquality (E body1) (E body2)+ void $ testEquality (E env1) (E env2)+ return Refl+ testEquality (Promise value1 expr1 env1) (Promise value2 expr2 env2) = do+ void $ testEquality (E value1) (E value2)+ void $ testEquality (E expr1) (E expr2)+ void $ testEquality (E env1) (E env2)+ return Refl+ testEquality (Lang carval1 cdrval1) (Lang carval2 cdrval2) = do+ void $ testEquality (E carval1) (E carval2)+ void $ testEquality (E cdrval1) (E cdrval2)+ return Refl+ -- Not comparable+ testEquality Special Special = Nothing+ -- Not comparable+ testEquality Builtin Builtin = Nothing+ testEquality (Char vec1) (Char vec2) = do+ guard $ vec1 == vec2+ return Refl+ testEquality (Int vec1) (Int vec2) = do+ guard $ vec1 == vec2+ return Refl+ testEquality (Real vec1) (Real vec2) = do+ guard $ vec1 == vec2+ return Refl+ testEquality (String vec1) (String vec2) = do+ guard $ vec1 == vec2+ return Refl+ testEquality (Complex vec1) (Complex vec2) = do+ guard $ vec1 == vec2+ return Refl+ testEquality (DotDotDot pairlist1) (DotDotDot pairlist2) = do+ void $ testEquality (E pairlist1) (E pairlist2)+ return Refl+ testEquality (Vector truelength1 vec1) (Vector truelength2 vec2) = do+ let eq (SomeSEXP s1) (SomeSEXP s2) = isJust $ testEquality (E s1) (E s2)+ guard $ truelength1 == truelength2+ guard $ and $ zipWith eq (Vector.toList vec1) (Vector.toList vec2)+ return Refl+ testEquality (Expr truelength1 vec1) (Expr truelength2 vec2) = do+ let eq (SomeSEXP s1) (SomeSEXP s2) = isJust $ testEquality (E s1) (E s2)+ guard $ truelength1 == truelength2+ guard $ and $ zipWith eq (Vector.toList vec1) (Vector.toList vec2)+ return Refl+ testEquality Bytecode Bytecode = return Refl+ testEquality (ExtPtr pointer1 protectionValue1 tagval1) (ExtPtr pointer2 protectionValue2 tagval2) = do+ guard $ castPtr pointer1 == castPtr pointer2+ void $ testEquality (E protectionValue1) (E protectionValue2)+ void $ testEquality (E tagval1) (E tagval2)+ return Refl+ testEquality (WeakRef key1 value1 finalizer1 next1) (WeakRef key2 value2 finalizer2 next2) = do+ void $ testEquality (E key1) (E key2)+ void $ testEquality (E value1) (E value2)+ void $ testEquality (E finalizer1) (E finalizer2)+ void $ testEquality (E next1) (E next2)+ return Refl+ testEquality (Raw vec1) (Raw vec2) = do+ guard $ vec1 == vec2+ return Refl+ testEquality (S4 tagval1) (S4 tagval2) = do+ void $ testEquality (E tagval1) (E tagval2)+ return Refl+ testEquality _ _ = Nothing++{-# INLINE peekHExp #-}+peekHExp :: forall s a. SEXP s a -> IO (HExp s a)+peekHExp s = do+ let coerce :: IO (HExp s b) -> IO (HExp s c)+ coerce = unsafeCoerce++ -- (:∈) constraints are impossible to respect in 'peekHExp', because+ -- R doesn't tell us statically the form of the SEXPREC referred to by+ -- a pointer. So in this function only, we pretend all constrained+ -- fields actually always contain fields of form ANYSXP. This has no+ -- operational significance - it's only a way to bypass what's+ -- impossible to prove.+ coerceAny :: SEXP s b -> SEXP s 'R.Any -- '+ coerceAny = R.unsafeCoerce++ coerceAnySome :: SomeSEXP s -> SEXP s 'R.Any -- '+ coerceAnySome (SomeSEXP s1) = coerceAny s1++ su :: forall b. SEXP s b+ su = R.unsafeCoerce s++ case R.typeOf s of+ R.Nil -> coerce $ return Nil+ R.Symbol -> coerce $+ Symbol <$> (coerceAnySome <$> R.symbolPrintName su)+ <*> (coerceAnySome <$> R.symbolValue su)+ <*> (coerceAnySome <$> R.symbolInternal su)+ R.List -> coerce $+ List <$> (coerceAnySome <$> R.car su)+ <*> (coerceAnySome <$> R.cdr su)+ <*> (coerceAnySome <$> R.tag su)+ R.Env -> coerce $+ Env <$> (coerceAny <$> R.envFrame su)+ <*> (coerceAny <$> R.envEnclosing su)+ <*> (coerceAny <$> R.envHashtab su)+ R.Closure -> coerce $+ Closure <$> (coerceAny <$> R.closureFormals su)+ <*> (coerceAnySome <$> R.closureBody su)+ <*> R.closureEnv su+ R.Promise -> coerce $+ Promise <$> (coerceAnySome <$> R.promiseValue su)+ <*> (coerceAnySome <$> R.promiseCode su)+ <*> (coerceAnySome <$> R.promiseEnv su)+ R.Lang -> coerce $+ Lang <$> (coerceAnySome <$> R.car su)+ <*> (coerceAnySome <$> R.cdr su)+ R.Special -> coerce $ return Special+ R.Builtin -> coerce $ return Builtin+ R.Char -> unsafeCoerce $ Char (Vector.unsafeFromSEXP su)+ R.Logical -> unsafeCoerce $ Logical (Vector.unsafeFromSEXP su)+ R.Int -> unsafeCoerce $ Int (Vector.unsafeFromSEXP su)+ R.Real -> unsafeCoerce $ Real (Vector.unsafeFromSEXP su)+ R.Complex -> unsafeCoerce $ Complex (Vector.unsafeFromSEXP su)+ R.String -> unsafeCoerce $ String (Vector.unsafeFromSEXP su)+ R.DotDotDot -> unimplemented $ "peekHExp: " ++ show (R.typeOf s)+ R.Vector -> coerce $+ Vector <$> (fromIntegral <$> R.trueLength (coerceAny su))+ <*> pure (Vector.unsafeFromSEXP su)+ R.Expr -> coerce $+ Expr <$> (fromIntegral <$> R.trueLength (coerceAny su))+ <*> pure (Vector.unsafeFromSEXP su)+ R.Bytecode -> coerce $ return Bytecode+ R.ExtPtr -> coerce $+ ExtPtr <$> ((\(R.SomeSEXP (R.SEXP (R.SEXP0 ptr))) -> castPtr ptr) <$> R.car s)+ <*> (coerceAnySome <$> R.cdr s)+ <*> (coerceAnySome <$> R.tag s)+ R.WeakRef -> coerce $+ WeakRef <$> (coerceAny <$> R.sexp <$>+ peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 0)+ <*> (R.sexp <$>+ peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 1)+ <*> (coerceAny <$> R.sexp <$>+ peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 2)+ <*> (coerceAny <$> R.sexp <$>+ peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 3)+ R.Raw -> unsafeCoerce $ Raw (Vector.unsafeFromSEXP su)+ R.S4 -> coerce $+ S4 <$> (coerceAnySome <$> R.tag su)+ _ -> unimplemented $ "peekHExp: " ++ show (R.typeOf s)++-- | A view function projecting a view of 'SEXP' as an algebraic datatype, that+-- can be analyzed through pattern matching.+hexp :: SEXP s a -> HExp s a+hexp = unsafeInlineIO . peekHExp+{-# INLINE hexp #-}++-- | Project the vector out of 'SEXP's.+vector :: R.IsVector a => SEXP s a -> Vector.Vector a (Vector.ElemRep V a)+vector (hexp -> Char vec) = vec+vector (hexp -> Logical vec) = vec+vector (hexp -> Int vec) = vec+vector (hexp -> Real vec) = vec+vector (hexp -> Complex vec) = vec+vector (hexp -> String vec) = vec+vector (hexp -> Vector _ vec) = vec+vector (hexp -> Expr _ vec) = vec+vector s = violation "vector" $ show (R.typeOf s) ++ " unexpected vector type."
− src/Language/R/HExp.hs-boot
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE RoleAnnotations #-}-module Language.R.HExp where--import Foreign.R.Type (SEXPTYPE)--type role HExp phantom nominal-data HExp :: * -> SEXPTYPE -> *
− src/Language/R/HExp.hsc
@@ -1,490 +0,0 @@--- |--- Copyright: (C) 2013 Amgen, Inc.------ Provides a /shallow/ view of a 'SEXP' R value as an algebraic datatype. This--- is useful to define functions over R values in Haskell with pattern matching.--- For example:------ @--- toPair :: SEXP a -> (SomeSEXP, SomeSEXP)--- toPair (hexp -> List _ (Just car) (Just cdr)) = (SomeSEXP car, SomeSEXP cdr)--- toPair (hexp -> Lang car (Just cdr)) = (SomeSEXP car, SomeSEXP cdr)--- toPair s = error $ "Cannot extract pair from object of type " ++ typeOf s--- @------ (See 'Foreign.R.SomeSEXP' for why we need to use it here.)------ The view is said to be 'shallow' because it only unfolds the head of the--- R value into an algebraic datatype. In this way, functions producing views--- can be written non-recursively, hence inlined at all call sites and--- simplified away. When produced by a view function in a pattern match,--- allocation of the view can be compiled away and hence producing a view can be--- done at no runtime cost. In fact, pattern matching on a view in this way is--- more efficient than using the accessor functions defined in "Foreign.R",--- because we avoid the overhead of calling one or more FFI functions entirely.------ 'HExp' is the /view/ and 'hexp' is the /view function/ that projects 'SEXP's--- into 'HExp' views.--{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE PolyKinds #-}-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE RoleAnnotations #-}-#endif-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ViewPatterns #-}--module Language.R.HExp- ( HExp(..)- , (===)- , hexp- , unhexp- , vector- ) where--import Control.Applicative-import Control.Memory.Region (V)-import Control.Monad.R.Class-import qualified Foreign.R as R-import Foreign.R (SEXP, SomeSEXP(..), SEXPTYPE, withProtected)-import Foreign.R.Constraints-import Internal.Error-import qualified Language.R.Globals as H--import qualified Data.Vector.SEXP as Vector--import Control.Monad ((<=<), guard, void)-import Control.Monad.Primitive ( unsafeInlineIO )-import Data.Int (Int32)-import Data.Word (Word8)-import Data.Complex-import Data.Maybe (isJust)-import Data.Type.Equality (TestEquality(..), (:~:)(Refl))-import GHC.Ptr (Ptr(..))-import Foreign.Storable-import Foreign.C -- for hsc2hs-import Foreign (castPtr)-import Unsafe.Coerce (unsafeCoerce)--- Fixes redundant import warning >= 7.10 without CPP-import Prelude--#define USE_RINTERNALS-#include <R.h>-#include <Rinternals.h>--#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)---- Use explicit UNPACK pragmas rather than -funbox-strict-fields in order to get--- warnings if a field is not unpacked when we expect it to.---- | A view of R's internal 'SEXP' structure as an algebraic datatype. Because--- this is in fact a GADT, the use of named record fields is not possible here.--- Named record fields give rise to functions for whom it is not possible to--- assign a reasonable type (existentially quantified type variables would--- escape).------ Note further that Haddock does not currently support constructor comments--- when using the GADT syntax.-type role HExp phantom nominal-data HExp :: * -> SEXPTYPE -> * where- -- Primitive types. The field names match those of <RInternals.h>.- Nil :: HExp s 'R.Nil- -- Fields: pname (is Nil for R_UnboundValue), value, internal.- Symbol :: (a :∈ ['R.Char, 'R.Nil])- => SEXP s a- -> SEXP s b- -> SEXP s c- -> HExp s 'R.Symbol- -- Fields: carval, cdrval, tagval.- List :: (R.IsPairList b, c :∈ ['R.Symbol, 'R.Nil])- => SEXP s a- -> SEXP s b- -> SEXP s c- -> HExp s 'R.List- -- Fields: frame, enclos, hashtab.- Env :: (R.IsPairList a, b :∈ ['R.Env, 'R.Nil], c :∈ ['R.Vector, 'R.Nil])- => SEXP s a- -> SEXP s b- -> SEXP s c- -> HExp s 'R.Env- -- Fields: formals, body, env.- Closure :: (R.IsPairList a)- => SEXP s a- -> SEXP s b- -> SEXP s 'R.Env- -> HExp s 'R.Closure- -- Fields: value, expr, env.- -- Once an promise has been evaluated, the environment is set to NULL.- Promise :: (R.IsExpression b, c :∈ ['R.Env, 'R.Nil])- => SEXP s a- -> SEXP s b- -> SEXP s c- -> HExp s 'R.Promise- -- Derived types. These types don't have their own 'struct' declaration in- -- <Rinternals.h>.- -- Fields: function, args.- Lang :: (R.IsExpression a, R.IsPairList b)- => SEXP s a- -> SEXP s b- -> HExp s 'R.Lang- -- Fields: offset.- Special :: {-# UNPACK #-} !Int32- -> HExp s 'R.Special- -- Fields: offset.- Builtin :: {-# UNPACK #-} !Int32- -> HExp s 'R.Builtin- Char :: {-# UNPACK #-} !(Vector.Vector 'R.Char Word8)- -> HExp s 'R.Char- Logical :: {-# UNPACK #-} !(Vector.Vector 'R.Logical R.Logical)- -> HExp s 'R.Logical- Int :: {-# UNPACK #-} !(Vector.Vector 'R.Int Int32)- -> HExp s 'R.Int- Real :: {-# UNPACK #-} !(Vector.Vector 'R.Real Double)- -> HExp s 'R.Real- Complex :: {-# UNPACK #-} !(Vector.Vector 'R.Complex (Complex Double))- -> HExp s 'R.Complex- String :: {-# UNPACK #-} !(Vector.Vector 'R.String (SEXP V 'R.Char))- -> HExp s 'R.String- -- Fields: pairlist of promises.- DotDotDot :: (R.IsPairList a)- => SEXP s a- -> HExp s 'R.List- -- Fields: truelength, content.- Vector :: {-# UNPACK #-} !Int32- -> {-# UNPACK #-} !(Vector.Vector 'R.Vector (SomeSEXP V))- -> HExp s 'R.Vector- -- Fields: truelength, content.- Expr :: {-# UNPACK #-} !Int32- -> {-# UNPACK #-} !(Vector.Vector 'R.Expr (SomeSEXP V))- -> HExp s 'R.Expr- Bytecode :: HExp s 'R.Bytecode -- TODO- -- Fields: pointer, protectionValue, tagval- ExtPtr :: Ptr ()- -> SEXP s b- -> SEXP s 'R.Symbol- -> HExp s 'R.ExtPtr- -- Fields: key, value, finalizer, next.- WeakRef :: ( a :∈ ['R.Env, 'R.ExtPtr, 'R.Nil]- , c :∈ ['R.Closure, 'R.Builtin, 'R.Special, 'R.Nil]- , d :∈ ['R.WeakRef, 'R.Nil] )- => SEXP s a- -> SEXP s b- -> SEXP s c- -> SEXP s d- -> HExp s 'R.WeakRef- Raw :: {-# UNPACK #-} !(Vector.Vector 'R.Raw Word8)- -> HExp s 'R.Raw- -- Fields: tagval.- S4 :: SEXP s a- -> HExp s 'R.S4---- 'Im a hack--instance Eq (HExp s a) where- (==) = (===)---- | Heterogeneous equality.-(===) :: TestEquality f => f a -> f b -> Bool-x === y = isJust $ testEquality x y---- | Wrapper for partially applying a type synonym.-newtype E s a = E (SEXP s a)--instance TestEquality (E s) where- testEquality (E x@(hexp -> t1)) (E y@(hexp -> t2)) =- (guard (R.unsexp x == R.unsexp y) >> return (unsafeCoerce Refl)) <|>- testEquality t1 t2--instance TestEquality (HExp s) where- testEquality Nil Nil = return Refl- testEquality (Symbol pname1 value1 internal1) (Symbol pname2 value2 internal2) = do- void $ testEquality (E pname1) (E pname2)- void $ testEquality (E value1) (E value2)- void $ testEquality (E internal1) (E internal2)- return Refl- testEquality (List carval1 cdrval1 tagval1) (List carval2 cdrval2 tagval2) = do- void $ testEquality (E carval1) (E carval2)- void $ testEquality (E cdrval1) (E cdrval2)- void $ testEquality (E tagval1) (E tagval2)- return Refl- testEquality (Env frame1 enclos1 hashtab1) (Env frame2 enclos2 hashtab2) = do- void $ testEquality (E frame1) (E frame2)- void $ testEquality (E enclos1) (E enclos2)- void $ testEquality (E hashtab1) (E hashtab2)- return Refl- testEquality (Closure formals1 body1 env1) (Closure formals2 body2 env2) = do- void $ testEquality (E formals1) (E formals2)- void $ testEquality (E body1) (E body2)- void $ testEquality (E env1) (E env2)- return Refl- testEquality (Promise value1 expr1 env1) (Promise value2 expr2 env2) = do- void $ testEquality (E value1) (E value2)- void $ testEquality (E expr1) (E expr2)- void $ testEquality (E env1) (E env2)- return Refl- testEquality (Lang carval1 cdrval1) (Lang carval2 cdrval2) = do- void $ testEquality (E carval1) (E carval2)- void $ testEquality (E cdrval1) (E cdrval2)- return Refl- testEquality (Special offset1) (Special offset2) = do- guard $ offset1 == offset2- return Refl- testEquality (Builtin offset1) (Builtin offset2) = do- guard $ offset1 == offset2- return Refl- testEquality (Char vec1) (Char vec2) = do- guard $ vec1 == vec2- return Refl- testEquality (Int vec1) (Int vec2) = do- guard $ vec1 == vec2- return Refl- testEquality (Real vec1) (Real vec2) = do- guard $ vec1 == vec2- return Refl- testEquality (String vec1) (String vec2) = do- guard $ vec1 == vec2- return Refl- testEquality (Complex vec1) (Complex vec2) = do- guard $ vec1 == vec2- return Refl- testEquality (DotDotDot pairlist1) (DotDotDot pairlist2) = do- void $ testEquality (E pairlist1) (E pairlist2)- return Refl- testEquality (Vector truelength1 vec1) (Vector truelength2 vec2) = do- let eq (SomeSEXP s1) (SomeSEXP s2) = isJust $ testEquality (E s1) (E s2)- guard $ truelength1 == truelength2- guard $ and $ zipWith eq (Vector.toList vec1) (Vector.toList vec2)- return Refl- testEquality (Expr truelength1 vec1) (Expr truelength2 vec2) = do- let eq (SomeSEXP s1) (SomeSEXP s2) = isJust $ testEquality (E s1) (E s2)- guard $ truelength1 == truelength2- guard $ and $ zipWith eq (Vector.toList vec1) (Vector.toList vec2)- return Refl- testEquality Bytecode Bytecode = return Refl- testEquality (ExtPtr pointer1 protectionValue1 tagval1) (ExtPtr pointer2 protectionValue2 tagval2) = do- guard $ castPtr pointer1 == castPtr pointer2- void $ testEquality (E protectionValue1) (E protectionValue2)- void $ testEquality (E tagval1) (E tagval2)- return Refl- testEquality (WeakRef key1 value1 finalizer1 next1) (WeakRef key2 value2 finalizer2 next2) = do- void $ testEquality (E key1) (E key2)- void $ testEquality (E value1) (E value2)- void $ testEquality (E finalizer1) (E finalizer2)- void $ testEquality (E next1) (E next2)- return Refl- testEquality (Raw vec1) (Raw vec2) = do- guard $ vec1 == vec2- return Refl- testEquality (S4 tagval1) (S4 tagval2) = do- void $ testEquality (E tagval1) (E tagval2)- return Refl- testEquality _ _ = Nothing--instance Storable (HExp s a) where- sizeOf _ = #{size SEXPREC}- alignment _ = #{alignment SEXPREC}- poke = pokeHExp- peek = peekHExp . R.SEXP- {-# INLINE peek #-}--{-# INLINE peekHExp #-}-peekHExp :: SEXP s a -> IO (HExp s a)-peekHExp s = do- let coerce :: IO (HExp s a) -> IO (HExp s b)- coerce = unsafeCoerce-- -- (:∈) constraints are impossible to respect in 'peekHExp', because- -- R doesn't tell us statically the form of the SEXPREC referred to by- -- a pointer. So in this function only, we pretend all constrained- -- fields actually always contain fields of form ANYSXP. This has no- -- operational significance - it's only a way to bypass what's- -- impossible to prove.- coerceAny :: SEXP s a -> SEXP s 'R.Any -- '- coerceAny = R.unsafeCoerce-- sptr = R.unsexp s-- case R.typeOf s of- R.Nil -> coerce $ return Nil- R.Symbol -> coerce $- Symbol <$> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.symsxp.pname} sptr)- <*> (R.sexp <$> #{peek SEXPREC, u.symsxp.value} sptr)- <*> (R.sexp <$> #{peek SEXPREC, u.symsxp.internal} sptr)- R.List -> coerce $- List <$> (R.sexp <$> #{peek SEXPREC, u.listsxp.carval} sptr)- <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.listsxp.cdrval} sptr)- <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.listsxp.tagval} sptr)- R.Env -> coerce $- Env <$> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.envsxp.frame} sptr)- <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.envsxp.enclos} sptr)- <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.envsxp.hashtab} sptr)- R.Closure -> coerce $- Closure <$> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.closxp.formals} sptr)- <*> (R.sexp <$> #{peek SEXPREC, u.closxp.body} sptr)- <*> (R.sexp <$> #{peek SEXPREC, u.closxp.env} sptr)- R.Promise -> coerce $- Promise <$> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.promsxp.value} sptr)- <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.promsxp.expr} sptr)- <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.promsxp.env} sptr)- R.Lang -> coerce $- Lang <$> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.listsxp.carval} sptr)- <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.listsxp.cdrval} sptr)- R.Special -> coerce $- Special <$> (fromIntegral <$> (#{peek SEXPREC, u.primsxp.offset} sptr :: IO CInt))- R.Builtin -> coerce $- Builtin <$> (fromIntegral <$> (#{peek SEXPREC, u.primsxp.offset} sptr :: IO CInt))- R.Char -> unsafeCoerce $ Char (Vector.unsafeFromSEXP (unsafeCoerce s))- R.Logical -> unsafeCoerce $ Logical (Vector.unsafeFromSEXP (unsafeCoerce s))- R.Int -> unsafeCoerce $ Int (Vector.unsafeFromSEXP (unsafeCoerce s))- R.Real -> unsafeCoerce $ Real (Vector.unsafeFromSEXP (unsafeCoerce s))- R.Complex -> unsafeCoerce $ Complex (Vector.unsafeFromSEXP (unsafeCoerce s))- R.String -> unsafeCoerce $ String (Vector.unsafeFromSEXP (unsafeCoerce s))- R.DotDotDot -> unimplemented $ "peekHExp: " ++ show (R.typeOf s)- R.Vector -> coerce $- Vector <$> (fromIntegral <$> (#{peek VECTOR_SEXPREC, vecsxp.truelength} sptr :: IO CInt))- <*> pure (Vector.unsafeFromSEXP (unsafeCoerce s))- R.Expr -> coerce $- Expr <$> (fromIntegral <$> (#{peek VECTOR_SEXPREC, vecsxp.truelength} sptr :: IO CInt))- <*> pure (Vector.unsafeFromSEXP (unsafeCoerce s))- R.Bytecode -> coerce $ return Bytecode- R.ExtPtr -> coerce $- ExtPtr <$> (castPtr <$> #{peek SEXPREC, u.listsxp.carval} sptr)- <*> (R.sexp <$> #{peek SEXPREC, u.listsxp.cdrval} sptr)- <*> (R.sexp <$> #{peek SEXPREC, u.listsxp.tagval} sptr)- R.WeakRef -> coerce $- WeakRef <$> (coerceAny <$> R.sexp <$>- peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 0)- <*> (R.sexp <$>- peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 1)- <*> (coerceAny <$> R.sexp <$>- peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 2)- <*> (coerceAny <$> R.sexp <$>- peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 3)- R.Raw -> unsafeCoerce $ Raw (Vector.unsafeFromSEXP (unsafeCoerce s))- R.S4 -> coerce $- S4 <$> (R.sexp <$> #{peek SEXPREC, u.listsxp.tagval} sptr)- _ -> unimplemented $ "peekHExp: " ++ show (R.typeOf s)--pokeHExp :: Ptr (HExp s a) -> HExp s a -> IO ()-pokeHExp s h = do- case h of- Nil -> return ()- Symbol pname value internal -> do- #{poke SEXPREC, u.symsxp.pname} s (R.unsexp pname)- #{poke SEXPREC, u.symsxp.value} s (R.unsexp value)- #{poke SEXPREC, u.symsxp.internal} s (R.unsexp internal)- List carval cdrval tagval -> do- #{poke SEXPREC, u.listsxp.carval} s (R.unsexp carval)- #{poke SEXPREC, u.listsxp.cdrval} s (R.unsexp cdrval)- #{poke SEXPREC, u.listsxp.tagval} s (R.unsexp tagval)- Env frame enclos hashtab -> do- #{poke SEXPREC, u.envsxp.frame} s (R.unsexp frame)- #{poke SEXPREC, u.envsxp.enclos} s (R.unsexp enclos)- #{poke SEXPREC, u.envsxp.hashtab} s (R.unsexp hashtab)- Closure formals body env -> do- #{poke SEXPREC, u.closxp.formals} s (R.unsexp formals)- #{poke SEXPREC, u.closxp.body} s (R.unsexp body)- #{poke SEXPREC, u.closxp.env} s (R.unsexp env)- Promise value expr env -> do- #{poke SEXPREC, u.promsxp.value} s (R.unsexp value)- #{poke SEXPREC, u.promsxp.expr} s (R.unsexp expr)- #{poke SEXPREC, u.promsxp.env} s (R.unsexp env)- Lang carval cdrval -> do- #{poke SEXPREC, u.listsxp.carval} s (R.unsexp carval)- #{poke SEXPREC, u.listsxp.cdrval} s (R.unsexp cdrval)- Special offset -> do- #{poke SEXPREC, u.primsxp.offset} s (fromIntegral offset :: CInt)- Builtin offset -> do- #{poke SEXPREC, u.primsxp.offset} s (fromIntegral offset :: CInt)- Char _vc -> unimplemented "pokeHExp"- Logical _vt -> unimplemented "pokeHExp"- Int _vt -> unimplemented "pokeHExp"- Real _vt -> unimplemented "pokeHExp"- String _vt -> unimplemented "pokeHExp"- Complex _vt -> unimplemented "pokeHExp"- Vector _v _ -> unimplemented "pokeHExp"- Bytecode -> unimplemented "pokeHExp"- ExtPtr _ _ _ -> unimplemented "pokeHExp"- WeakRef _ _ _ _ -> unimplemented "pokeHExp"- Raw _ -> unimplemented "pokeHExp"- S4 _ -> unimplemented "pokeHExp"- DotDotDot _ -> unimplemented "pokeHExp"- Expr _ _ -> unimplemented "pokeHExp"---- | A view function projecting a view of 'SEXP' as an algebraic datatype, that--- can be analyzed through pattern matching.-hexp :: SEXP s a -> HExp s a-hexp = unsafeInlineIO . peek . R.unSEXP-{-# INLINE hexp #-}---- | Inverse hexp view to the real structure, note that for scalar types--- hexp will allocate new SEXP, and @unhexp . hexp@ is not an identity function.--- however for vector types it will return original SEXP.-unhexp :: MonadR m => HExp (Region m) a -> m (SEXP (Region m) a)-unhexp Nil = return $ R.release H.nilValue-unhexp s@(Symbol{}) = io $- withProtected (R.allocSEXP R.SSymbol)- (\x -> poke (R.unSEXP x) s >> return x)-unhexp (List carval cdrval tagval) = acquire <=< io $ do- rc <- R.protect carval- rd <- R.protect cdrval- rt <- R.protect tagval- z <- R.cons rc rd- #{poke SEXPREC, u.listsxp.tagval} (R.unsexp z) (R.unsexp rt)- R.unprotect 3- return z-unhexp (Lang carval cdrval) = acquire <=< io $ do- carval' <- R.protect carval- cdrval' <- R.protect cdrval- x <- R.allocSEXP R.SLang- R.setCar x (R.release carval')- R.setCdr x (R.release cdrval')- R.unprotect 2- return x-unhexp s@(Env{}) = io $- withProtected (R.allocSEXP R.SEnv)- (\x -> poke (R.unSEXP x) s >> return x)-unhexp s@(Closure{}) = io $- withProtected (R.allocSEXP R.SClosure)- (\x -> poke (R.unSEXP x) s >> return x)-unhexp s@(Special{}) = io $- withProtected (R.allocSEXP R.SSpecial)- (\x -> poke (R.unSEXP x) s >> return x)-unhexp s@(Builtin{}) = io $- withProtected (R.allocSEXP R.SBuiltin)- (\x -> poke (R.unSEXP x) s >> return x)-unhexp s@(Promise{}) = io $- withProtected (R.allocSEXP R.SPromise)- (\x -> poke (R.unSEXP x) s >> return x)-unhexp (Bytecode{}) = unimplemented "unhexp"-unhexp (Real vt) = return $ Vector.unsafeToSEXP vt-unhexp (Logical vt) = return $ Vector.unsafeToSEXP vt-unhexp (Int vt) = return $ Vector.unsafeToSEXP vt-unhexp (Complex vt) = return $ Vector.unsafeToSEXP vt-unhexp (Vector _ vt) = return $ Vector.unsafeToSEXP vt-unhexp (Char vt) = return $ Vector.unsafeToSEXP vt-unhexp (String vt) = return $ Vector.unsafeToSEXP vt-unhexp (Raw vt) = return $ Vector.unsafeToSEXP vt-unhexp S4{} = unimplemented "unhexp"-unhexp (Expr _ vt) = return $ Vector.unsafeToSEXP vt-unhexp WeakRef{} = error "unhexp does not support WeakRef, use Foreign.R.mkWeakRef instead."-unhexp DotDotDot{} = unimplemented "unhexp"-unhexp ExtPtr{} = unimplemented "unhexp"---- | Project the vector out of 'SEXP's.-vector :: R.IsVector a => SEXP s a -> Vector.Vector a (Vector.ElemRep V a)-vector (hexp -> Char vec) = vec-vector (hexp -> Logical vec) = vec-vector (hexp -> Int vec) = vec-vector (hexp -> Real vec) = vec-vector (hexp -> Complex vec) = vec-vector (hexp -> String vec) = vec-vector (hexp -> Vector _ vec) = vec-vector (hexp -> Expr _ vec) = vec-vector s = violation "vector" $ show (R.typeOf s) ++ " unexpected vector type."
src/Language/R/Internal/FunWrappers.hs view
@@ -8,7 +8,7 @@ module Language.R.Internal.FunWrappers where -import Foreign.R (SEXP0)+import Foreign.R (SEXP0(..)) import Language.R.Internal.FunWrappers.TH import Foreign ( FunPtr )
src/Language/R/Literal.hs view
@@ -54,7 +54,7 @@ import Data.Singletons ( Sing, SingI, fromSing, sing ) import Control.DeepSeq ( NFData )-import Control.Monad ( void, zipWithM_ )+import Control.Monad ( void, zipWithM_, (<=<) ) import Data.Int (Int32) import qualified Data.ByteString.Unsafe as B import Data.Complex (Complex)@@ -185,11 +185,10 @@ -- garbage collected. tag <- io $ withCString k R.install toPairList kvs >>= \case- SomeSEXP cdr@(hexp -> Nil) ->- fmap SomeSEXP $ unhexp $ List v cdr (R.unsafeRelease tag)- SomeSEXP cdr@(hexp -> List _ _ _) ->- fmap SomeSEXP $ unhexp $ List v cdr (R.unsafeRelease tag)- _ -> impossible "toPairList"+ SomeSEXP cdr -> acquireSome <=< io $ do+ l <- R.cons v cdr+ R.setTag l (R.unsafeRelease tag)+ return (SomeSEXP l) -- | Create an association list from a pairlist. R Pairlists are nil-terminated -- chains of nested cons cells, as in LISP.
src/Language/R/QQ.hs view
@@ -16,6 +16,7 @@ module Language.R.QQ ( r , rsafe+ , collectAntis ) where import Control.Memory.Region@@ -41,12 +42,18 @@ import Control.Concurrent (MVar, newMVar, takeMVar, putMVar) import Control.Exception (throwIO) import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO) import Data.List (intercalate, isSuffixOf) import qualified Data.Set as Set import Data.Set (Set) import Foreign (alloca, peek) import Foreign.C.String (withCString) import System.IO.Unsafe (unsafePerformIO)+import qualified Text.Heredoc as Heredoc+import qualified System.IO.Temp as Temp+import System.Process+import System.IO+import System.Exit ------------------------------------------------------------------------------- -- Compile time Quasi-Quoter --@@ -97,30 +104,41 @@ antiSuffix :: String antiSuffix = "_hs" -isAnti :: SEXP s 'R.Char -> Bool-isAnti (hexp -> Char (Vector.toString -> name)) = antiSuffix `isSuffixOf` name- -- | Chop antiquotation variable names to get the corresponding Haskell variable name. chop :: String -> String chop name = take (length name - length antiSuffix) name --- | Traverse 'R.SEXP' structure and find all occurences of antiquotations.-collectAntis :: R.SEXP s a -> Set (SEXP s 'R.Char)-collectAntis (hexp -> Symbol (R.unsafeCoerce -> name) _ _)- | isAnti name = Set.singleton name-collectAntis (hexp -> (List sxa sxb sxc)) = do- Set.unions [collectAntis sxa, collectAntis sxb, collectAntis sxc]-collectAntis (hexp -> (Lang (hexp -> Symbol (R.unsafeCoerce -> name) _ _) sxb))- | isAnti name = Set.insert name (collectAntis sxb)-collectAntis (hexp -> (Lang sxa sxb)) =- Set.union (collectAntis sxa) (collectAntis sxb)-collectAntis (hexp -> (Closure sxa sxb sxc)) =- Set.unions [collectAntis sxa, collectAntis sxb, collectAntis sxc]-collectAntis (hexp -> (Vector _ sxv)) =- Set.unions [collectAntis (R.unsafeRelease sx) | SomeSEXP sx <- Vector.toList sxv]-collectAntis (hexp -> (Expr _ sxv)) =- Set.unions [collectAntis (R.unsafeRelease sx) | SomeSEXP sx <- Vector.toList sxv]-collectAntis _ = Set.empty+-- | Find all occurences of antiquotations.+--+-- This function works by parsing the user's R code in a separate+-- R process. As a nice side-effect, it will detect and return any syntax+-- errors in the quasi-quoted R code.+--+-- This function is exposed only for testing; you probably don't need to+-- call it in the user code.+collectAntis+ :: String+ -- ^ the R code that may contain antiquotations, which are+ -- identifiers ending with 'antiSuffix'+ -> IO (Either String [String])+ -- ^ either an error message from R, or a list of unique antiquoted+ -- identifiers+collectAntis input = do+ -- Write our input to a temporary file. We could interpolate it into the+ -- R code below directly, but that would make it harder to disentangle+ -- syntax errors in the user's code from our wrapper code.+ Temp.withSystemTempFile "inline-r-.R" $ \input_file input_fh -> do+ hPutStr input_fh input+ hClose input_fh+ (code, stdout, stderr) <- readProcessWithExitCode "R" ["--slave"] $+ -- Note: --slave was recently renamed to --no-echo. --slave still works+ -- but is no longer documented. Using the old option name for now just+ -- in case the user have an older (pre-2020) version of R.+ "input_file <- \"" ++ input_file ++ "\"\n" +++ [Heredoc.there|R/collectAntis.R|]+ return $ case code of+ ExitSuccess -> Right $ words stdout+ ExitFailure{} -> Left stderr -- | An R quasiquote is syntactic sugar for a function that we -- generate, which closes over all antiquotation variables, and applies the@@ -131,11 +149,15 @@ -- @ expQQ :: String -> Q TH.Exp expQQ input = do- _ <- runIO $ takeMVar qqLock- expr <- runIO $ R.protect =<< parse input- let antis = [x | (hexp -> Char (Vector.toString -> x))- <- Set.toList (collectAntis expr)]- args = map (TH.dyn . chop) antis+ mb_antis <- liftIO $ collectAntis input+ antis <- case mb_antis of+ Right antis -> pure antis+ Left msg -> fail . unlines $+ [ "An error occurred while trying to parse the R code."+ , "The stderr of the R interpreter was:"+ , msg+ ]+ let args = map (TH.dyn . chop) antis closure = "function(" ++ intercalate "," antis ++ "){" ++ input ++ "}" z = [| return (R.release nilValue) |] vars <- mapM (\_ -> TH.newName "x") antis@@ -157,6 +179,4 @@ car <- mkSEXPIO $(TH.varE x) R.lcons car cdr |]) z vars) |]- runIO $ R.unprotect 1 -- Ptr expr- runIO $ putMVar qqLock () pure x
tests/Test/Event.hs view
@@ -39,12 +39,13 @@ f <- wrap $ \_ -> return () ref1 <- newIORef (0 :: Int) forIH_ inputHandlers $ \_ -> modifyIORef' ref1 (+1)- _ <- R.addInputHandler inputHandlers fd f 0+ ih <- R.addInputHandler inputHandlers fd f 0 ref2 <- newIORef 0 forIH_ inputHandlers $ \_ -> modifyIORef' ref2 (+1) n1 <- readIORef ref1 n2 <- readIORef ref2 n1 @?= n2 - 1+ (@?= True) =<< R.removeInputHandler inputHandlers ih freeHaskellFunPtr f , testCase "removeInputHandler decreases handler count" $ do
tests/tests.hs view
@@ -36,11 +36,12 @@ import Control.Exception (handle) import Control.Memory.Region import Control.Monad (void)-import Data.List (delete, find)+import Data.List import Data.Singletons (sing) import Data.Vector.SEXP (indexM) import Foreign hiding (void) import System.Environment (getArgs, lookupEnv, withArgs)+import qualified Text.Heredoc as Heredoc import Prelude -- Silence AMP warning inVoid :: R V z -> R V z@@ -82,7 +83,7 @@ R.SomeSEXP key <- [r| new.env() |] R.SomeSEXP val <- [r| new.env() |] True <- return $ R.typeOf val == R.Env- n <- unhexp Nil+ n <- io $ R.release <$> peek R.nilValue rf <- io $ R.mkWeakRef key val n True True <- case hexp rf of WeakRef a b c _ -> do@@ -112,6 +113,31 @@ void $ forkIO $ cancel handle (\RError{} -> return ()) (runRegion $ void $ [r| while(1){}; |])+ , testGroup "collectAntis"+ [ testCase "Succeeds on a simple expression" $ do+ result <- collectAntis "foo_hs + bar + baz_hs"+ case result of+ Left err -> assertFailure err+ Right ids -> sort ids @?=+ sort ["foo_hs", "baz_hs"]+ , testCase "Returns an error on invalid R code" $ do+ result <- collectAntis "foo_hs bar"+ case result of+ Left err -> assertBool "Unrecognized error message" $+ "unexpected symbol" `isInfixOf` err+ Right _ -> assertFailure "Unexpected success"+ , testCase "Succeeds on a more complicated expression and ignores symbols inside strings" $ do+ result <- collectAntis [Heredoc.here|+ function () {+ r <- fft(foo_hs) + bar_hs + "baz_hs"+ f(r, quux_hs)+ }+ |]+ case result of+ Left err -> assertFailure err+ Right ids -> sort ids @?=+ sort ["foo_hs", "bar_hs", "quux_hs"]+ ] ] main :: IO ()