diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/R/collectAntis.R b/R/collectAntis.R new file mode 100644 --- /dev/null +++ b/R/collectAntis.R @@ -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)))))) diff --git a/cbits/missing_r.h b/cbits/missing_r.h --- a/cbits/missing_r.h +++ b/cbits/missing_r.h @@ -7,13 +7,6 @@ #include #include -#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); diff --git a/inline-r.cabal b/inline-r.cabal --- a/inline-r.cabal +++ b/inline-r.cabal @@ -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 diff --git a/src/Data/Vector/SEXP.hs b/src/Data/Vector/SEXP.hs --- a/src/Data/Vector/SEXP.hs +++ b/src/Data/Vector/SEXP.hs @@ -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 diff --git a/src/Foreign/R.hs b/src/Foreign/R.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/R.hs @@ -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 +-- 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 "" +C.include "" +C.include "" + +-------------------------------------------------------------------------------- +-- 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) diff --git a/src/Foreign/R.hsc b/src/Foreign/R.hsc deleted file mode 100644 --- a/src/Foreign/R.hsc +++ /dev/null @@ -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 - -C.context (C.baseCtx <> rCtx) -C.include "" -C.include "" -C.include "" - --------------------------------------------------------------------------------- --- 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) diff --git a/src/Foreign/R/Context.hsc b/src/Foreign/R/Context.hsc --- a/src/Foreign/R/Context.hsc +++ b/src/Foreign/R/Context.hsc @@ -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 -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 |]) ] diff --git a/src/Foreign/R/Encoding.hsc b/src/Foreign/R/Encoding.hsc new file mode 100644 --- /dev/null +++ b/src/Foreign/R/Encoding.hsc @@ -0,0 +1,31 @@ +-- | Character encodings. + +#include + +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" diff --git a/src/Foreign/R/Internal.hs b/src/Foreign/R/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/R/Internal.hs @@ -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 diff --git a/src/Foreign/R/Internal.hsc b/src/Foreign/R/Internal.hsc deleted file mode 100644 --- a/src/Foreign/R/Internal.hsc +++ /dev/null @@ -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 -#include -#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 diff --git a/src/Foreign/R/Parse.hsc b/src/Foreign/R/Parse.hsc --- a/src/Foreign/R/Parse.hsc +++ b/src/Foreign/R/Parse.hsc @@ -9,9 +9,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ForeignFunctionInterface #-} -#if __GLASGOW_HASKELL__ >= 710 -{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} -#endif #include #include diff --git a/src/Foreign/R/Type.hsc b/src/Foreign/R/Type.hsc --- a/src/Foreign/R/Type.hsc +++ b/src/Foreign/R/Type.hsc @@ -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 #-} -- | diff --git a/src/Language/R/Debug.hs b/src/Language/R/Debug.hs --- a/src/Language/R/Debug.hs +++ b/src/Language/R/Debug.hs @@ -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) diff --git a/src/Language/R/HExp.hs b/src/Language/R/HExp.hs new file mode 100644 --- /dev/null +++ b/src/Language/R/HExp.hs @@ -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 . +type role HExp phantom nominal +data HExp :: * -> SEXPTYPE -> * where + -- Primitive types. The field names match those of . + -- | 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 + -- . + -- | 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." diff --git a/src/Language/R/HExp.hs-boot b/src/Language/R/HExp.hs-boot deleted file mode 100644 --- a/src/Language/R/HExp.hs-boot +++ /dev/null @@ -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 -> * diff --git a/src/Language/R/HExp.hsc b/src/Language/R/HExp.hsc deleted file mode 100644 --- a/src/Language/R/HExp.hsc +++ /dev/null @@ -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 -#include - -#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 . - 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 - -- . - -- 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." diff --git a/src/Language/R/Internal/FunWrappers.hs b/src/Language/R/Internal/FunWrappers.hs --- a/src/Language/R/Internal/FunWrappers.hs +++ b/src/Language/R/Internal/FunWrappers.hs @@ -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 ) diff --git a/src/Language/R/Literal.hs b/src/Language/R/Literal.hs --- a/src/Language/R/Literal.hs +++ b/src/Language/R/Literal.hs @@ -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. diff --git a/src/Language/R/QQ.hs b/src/Language/R/QQ.hs --- a/src/Language/R/QQ.hs +++ b/src/Language/R/QQ.hs @@ -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 diff --git a/tests/Test/Event.hs b/tests/Test/Event.hs --- a/tests/Test/Event.hs +++ b/tests/Test/Event.hs @@ -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 diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -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 ()