inline-r 0.8.0.1 → 0.9.0.0
raw patch · 26 files changed
+1211/−1037 lines, 26 files
Files
- CHANGELOG.md +51/−0
- cbits/missing_r.h +7/−0
- inline-r.cabal +12/−12
- src/Foreign/R.chs +10/−252
- src/Foreign/R/EventLoop.chs +0/−129
- src/Foreign/R/EventLoop.hsc +129/−0
- src/Foreign/R/Internal.hsc +327/−0
- src/Foreign/R/Type.hsc +20/−3
- src/H/Prelude.hs +13/−53
- src/H/Prelude/Interactive.hs +18/−8
- src/Language/R.hs +40/−24
- src/Language/R/Globals.hs +13/−3
- src/Language/R/HExp.chs +0/−512
- src/Language/R/HExp.hsc +514/−0
- src/Language/R/Instance.hs +9/−5
- src/Language/R/Internal.hs +5/−3
- src/Language/R/Literal.hs +1/−1
- src/Language/R/QQ.hs +28/−13
- tests/Test/FunPtr.hs +0/−1
- tests/Test/GC.hs +0/−1
- tests/Test/Regions.hs +0/−1
- tests/Test/Vector.hs +1/−3
- tests/bench-qq.hs +0/−1
- tests/test-qq.hs +12/−8
- tests/test-shootout.hs +1/−2
- tests/tests.hs +0/−2
+ CHANGELOG.md view
@@ -0,0 +1,51 @@+# Change Log++## 0.9.0 - 2016-06-20++* Breaking change: Rewrite of the `H.Prelude` module API.+* Reexport more modules from Language.R.+* Windows support for inline-r and H.+* Partially move away from c2hs internally: too many bugs on Windows.+* Export `PrintR` type class.+* Loosen the constraints of a few `HExp` constructors.+* Deprecate `parseFile`, `parseText`, `string` and `strings`.++## 0.8.0 - 2016-01-24++### Changed++* Rewritten R quasiquoter. Compile times now much faster than before+ for large quasiquotes.+* Assignments are now local by default. Use <<- to assign in global+ environment.++### Added++* vector-0.11 compatibility.+* Included in LTS-5.+* Vectors can now be sliced starting from arbitrary indexes. Slices+ were previously restricted to 0-based slices.++### Fixed++* Memory tests are now --enable-strict-barrier clean.+* Remove memory leak when allocating new vectors via+ `Data.Vector.SEXP` API.++## 0.7.3.0 - 2015-12-08++* Skip R's own signal handlers during init. They would otherwise+ interfere with signal delivery e.g. regarding socket conditions.+* stack --nix support.++## 0.7.2.0 - 2015-11-24++* OS X El Capitan support.++## 0.7.1.0 - 2015-09-14++* Fix vector copying.++## 0.7.0.0 - 2015-09-07++* First public release.
cbits/missing_r.h view
@@ -7,6 +7,13 @@ #include <Rinternals.h> #include <R_ext/Rdynload.h> +#define GCGEN(x) ((x)->sxpinfo.gcgen)+#define GCCLS(x) ((x)->sxpinfo.gccls)+#define SET_GCGEN(x, v) (((x)->sxpinfo.gcgen)=(v))+#define SET_GCCLS(x, v) (((x)->sxpinfo.gccls)=(v))+#define SET_MARK(x, v) (((x)->sxpinfo.mark)=(v))++ /* Create a variadic R function given any function pointer. */ SEXP funPtrToSEXP(DL_FUNC pf);
inline-r.cabal view
@@ -1,5 +1,5 @@ name: inline-r-version: 0.8.0.1+version: 0.9.0.0 license: BSD3 license-file: LICENSE copyright: Copyright (c) 2013-2015 Amgen, Inc.@@ -15,9 +15,11 @@ For up to date Haddock documentation, please see <http://www.stackage.org/package/inline-r>. +homepage: https://tweag.github.io/HaskellR cabal-version: >=1.10 -extra-source-files: cbits/missing_r.h+extra-source-files: CHANGELOG.md+ cbits/missing_r.h tests/shootout/binarytrees.R tests/shootout/fasta.R tests/shootout/knucleotide.R@@ -47,15 +49,14 @@ Foreign.R Foreign.R.Constraints Foreign.R.Embedded- Foreign.R.EventLoop Foreign.R.Error+ Foreign.R.Internal Foreign.R.Parse Foreign.R.Type H.Prelude H.Prelude.Interactive Language.R Language.R.Debug- Language.R.Event Language.R.GC Language.R.Globals Language.R.HExp@@ -65,6 +66,9 @@ Language.R.Internal Language.R.Internal.FunWrappers Language.R.Internal.FunWrappers.TH+ if !os(windows)+ exposed-modules: Foreign.R.EventLoop+ Language.R.Event other-modules: Control.Monad.R.Class Control.Monad.R.Internal Data.Vector.SEXP.Mutable.Internal@@ -100,16 +104,9 @@ , hsc2hs if os(windows) extra-libraries: R- cpp-options: -DH_ARCH_WINDOWS- cc-options: -DH_ARCH_WINDOWS else build-depends: unix >= 2.6 pkgconfig-depends: libR >= 3.0- cpp-options: -DH_ARCH_UNIX- cc-options: -DH_ARCH_UNIX- if os(darwin)- cpp-options: -DH_ARCH_UNIX_DARWIN- cc-options: -DH_ARCH_UNIX_DARWIN -- XXX -fcontext-stack=32 required on GHC >= 7.8 to allow foreign -- export function -wrappers of high arities. ghc-options: -Wall -fcontext-stack=32@@ -135,8 +132,9 @@ , tasty-quickcheck >= 0.4.1 , temporary >= 1.2 , text >= 0.11- , unix >= 2.5 , vector+ if !os(windows)+ build-depends: unix >= 2.5 other-modules: Test.GC Test.FunPtr Test.Constraints@@ -179,6 +177,8 @@ ghc-options: -Wall -threaded -O0 hs-source-dirs: tests default-language: Haskell2010+ if os(windows)+ buildable: False benchmark bench-qq main-is: bench-qq.hs
src/Foreign/R.chs view
@@ -40,9 +40,6 @@ module Foreign.R ( module Foreign.R.Type -- * Internal R structures- , SEXPTYPE(..)- , R.Logical(..)- , R.PairList , SEXP(..) , SomeSEXP(..) , unSomeSEXP@@ -154,8 +151,9 @@ import Control.Memory.Region import {-# SOURCE #-} Language.R.HExp (HExp)-import qualified Foreign.R.Type as R-import Foreign.R.Type (SEXPTYPE, SSEXPTYPE)+import Foreign.R.Internal hiding (SEXP0)+import Foreign.R.Type+import Foreign.R.Type as R import Control.Applicative import Control.DeepSeq (NFData(..))@@ -169,116 +167,31 @@ import Data.Typeable (Typeable) #endif import Foreign (Ptr, castPtr, plusPtr, Storable(..))-#ifdef H_ARCH_WINDOWS-import Foreign (nullPtr)-#endif import Foreign.C import Prelude hiding (asTypeOf, length) #define USE_RINTERNALS #include <R.h>-#include <Rinterface.h> #include <Rinternals.h> #include <R_ext/Memory.h> #include "missing_r.h" --- XXX temp workaround due to R bug: doesn't export R_CHAR when USE_RINTERNALS--- is defined.-#c-const char *(R_CHAR)(SEXP x);-#endc ------------------------------------------------------------------------------------ R data structures -------------------------------------------------------------------------------------data SEXPREC---- | 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` ())- -- | 'SEXP' with no type index. This type and 'sexp' / 'unsexp' -- are purely an artifact of c2hs (which doesn't support indexing a Ptr with an -- arbitrary type in a @#pointer@ hook). {#pointer SEXP as SEXP0 -> SEXPREC #} --- | 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---- | 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--cUIntToEnum :: Enum a => CUInt -> a-cUIntToEnum = toEnum . cIntConv--cUIntFromSingEnum :: SSEXPTYPE a -> CUInt-cUIntFromSingEnum = cIntConv . fromEnum . fromSing--cIntFromEnum :: Enum a => a -> CInt-cIntFromEnum = cIntConv . fromEnum+-- XXX temp workaround due to R bug: doesn't export R_CHAR when USE_RINTERNALS+-- is defined.+#c+const char *(R_CHAR)(SEXP x);+#endc -------------------------------------------------------------------------------- -- 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 $ cUIntToEnum <$> {#get SEXP->sxpinfo.type #} (unsexp s)- -- | read CAR object value {#fun CAR as car { unsexp `SEXP s a' } -> `SomeSEXP s' somesexp #} @@ -288,55 +201,7 @@ -- | read object`s Tag {# fun TAG as tag { unsexp `SEXP s a' } -> `SomeSEXP s' somesexp #} --- XXX: add better constraint --- | Set CAR field of object, when object is viewed as a cons cell.-setCar :: SEXP s a -> SEXP s b -> IO ()-setCar s s' = {#set SEXP->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' = {#set SEXP->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' = {#set SEXP->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---------------------------------------------------------------------------------- -- Environment functions -- -------------------------------------------------------------------------------- @@ -379,10 +244,6 @@ -- Vector accessor functions -- -------------------------------------------------------------------------------- --- | Length of the vector.-length :: R.IsVector a => SEXP s a -> IO Int-length s = fromIntegral <$> {#get VECSEXP->vecsxp.length #} (unsexp s)- -- | Read True Length vector field. {#fun TRUELENGTH as trueLength `R.IsVector a' => { unsexp `SEXP s a' } -> `CInt' id #} @@ -401,10 +262,10 @@ {#fun RAW as raw { unsexp `SEXP s R.Raw' } -> `Ptr CChar' castPtr #} -- XXX Workaround c2hs syntax limitations.-type Logical = 'R.Logical+type RLogical = 'R.Logical -- | Read logical vector data.-{#fun LOGICAL as logical { unsexp `SEXP s Logical' } -> `Ptr R.Logical' castPtr #}+{#fun LOGICAL as logical { unsexp `SEXP s RLogical' } -> `Ptr R.Logical' castPtr #} -- | Read complex vector data. {#fun COMPLEX as complex { unsexp `SEXP s R.Complex' }@@ -414,14 +275,6 @@ {#fun STRING_PTR as string { unsexp `SEXP s R.String'} -> `Ptr (SEXP s R.Char)' castPtr #} --- | Extract the data pointer from a vector.-unsafeSEXPToVectorPtr :: SEXP s a -> Ptr ()-unsafeSEXPToVectorPtr s = (unsexp s) `plusPtr` {#sizeof SEXPREC_ALIGN #}---- | Inverse of 'vectorPtr'.-unsafeVectorPtrToSEXP :: Ptr a -> SomeSEXP s-unsafeVectorPtrToSEXP s = SomeSEXP $ sexp $ s `plusPtr` (-{#sizeof SEXPREC_ALIGN #})- {# fun VECTOR_ELT as indexVector `R.IsGenericVector a' => { unsexp `SEXP s a', `Int' } -> `SomeSEXP s' somesexp #}@@ -558,101 +411,6 @@ {#fun R_MakeWeakRef as mkWeakRef { unsexp `SEXP s a', unsexp `SEXP s b', unsexp `SEXP s c', cIntFromEnum `Bool' } -> `SEXP V R.WeakRef' sexp #}------------------------------------------------------------------------------------- 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--------------------------------------------------------------------------------------- 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 <$> {#get SEXP->sxpinfo.type #} s)- <*> ((/=0) <$> {#get SEXP->sxpinfo.obj #} s)- <*> (fromIntegral <$> {#get SEXP->sxpinfo.named #} s)- <*> (fromIntegral <$> {#get SEXP->sxpinfo.gp #} s)- <*> ((/=0) <$> {#get SEXP->sxpinfo.mark #} s)- <*> ((/=0) <$> {#get SEXP->sxpinfo.debug #} s)- <*> ((/=0) <$> {#get SEXP->sxpinfo.trace #} s)- <*> ((/=0) <$> {#get SEXP->sxpinfo.spare #} s)- <*> (fromIntegral <$> {#get SEXP->sxpinfo.gcgen #} s)- <*> (fromIntegral <$> {#get SEXP->sxpinfo.gccls #} s)- where- s = unsexp ts---- | Write a new header.-pokeInfo :: SEXP s a -> SEXPInfo -> IO ()-pokeInfo (unsexp -> s) i = do- {#set SEXP->sxpinfo.type #} s (fromIntegral.fromEnum $ infoType i)- {#set SEXP->sxpinfo.obj #} s (if infoObj i then 1 else 0)- {#set SEXP->sxpinfo.named #} s (fromIntegral $ infoNamed i)- {#set SEXP->sxpinfo.gp #} s (fromIntegral $ infoGp i)- {#set SEXP->sxpinfo.mark #} s (if infoMark i then 1 else 0)- {#set SEXP->sxpinfo.debug #} s (if infoDebug i then 1 else 0)- {#set SEXP->sxpinfo.trace #} s (if infoTrace i then 1 else 0)- {#set SEXP->sxpinfo.spare #} s (if infoSpare i then 1 else 0)- {#set SEXP->sxpinfo.gcgen #} s (fromIntegral $ infoGcGen i)- {#set SEXP->sxpinfo.gccls #} s (fromIntegral $ infoGcCls i)---- | Set the GC mark.-mark :: Bool -> SEXP s a -> IO ()-mark b ts = {#set SEXP->sxpinfo.mark #} (unsexp ts) (if b then 1 else 0)--named :: Int -> SEXP s a -> IO ()-named v ts = {#set SEXP->sxpinfo.named #} (unsexp ts) (fromIntegral v)------------------------------------------------------------------------------------ Attribute header -------------------------------------------------------------------------------------- | Get the attribute list from the given object.-getAttribute :: SEXP s a -> IO (SEXP s b)-getAttribute s = sexp . castPtr <$> ({#get SEXP->attrib #} (unsexp s))---- | Set the attribute list.-setAttribute :: SEXP s a -> SEXP s b -> IO ()-setAttribute s v = {#set SEXP->attrib #} (unsexp s) (castPtr $ unsexp v) ------------------------------------------------------------------------------- -- Encoding --
− src/Foreign/R/EventLoop.chs
@@ -1,129 +0,0 @@--- |--- Copyright: (C) 2015 Tweag I/O Limited.------ Bindings for @<R/R_ext/eventloop.h>@, for building event loops.--{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}--module Foreign.R.EventLoop- ( InputHandler(..)- , inputHandlers- , polledEvents- , pollingPeriod- , graphicsPolledEvents- , graphicsPollingPeriod- , checkActivity- , runHandlers- , addInputHandler- , removeInputHandler- ) where--import Control.Applicative-import Foreign (FunPtr, Ptr, Storable(..), castPtr)-import Foreign.C-import Foreign.Marshal.Utils (with)-import System.Posix.Types (Fd(..))-import Prelude -- Silence AMP warning.--#include <R_ext/eventloop.h>---- | R input handler chain. Each input handler points to the next. This view of--- input handlers is /shallow/, in the sense that the 'Storable' instance only--- unmarshalls the first element in the chain at any one time. A shallow view--- allows 'peek' and 'poke' to be inlinable.-data InputHandler = InputHandler- { -- | The input handler callback.- inputHandlerCallback :: FunPtr (Ptr () -> IO ())- -- | Undocumented and currently unused.- , inputHandlerActivity :: CInt- -- | Whether this input handler is activated or deactivated.- , inputHandlerActive :: CInt- -- | The file descriptor ahssociated with this handler.- , inputHandlerFD :: Fd- -- | Callbacks can optionally be passed in arbitrary data.- , inputHandlerUserData :: Ptr ()- -- | The next input handler in the chain.- , inputHandlerNext :: Ptr InputHandler- } deriving (Eq, Show)-{#pointer *InputHandler as InputHandler nocode#}--instance Storable InputHandler where- sizeOf _ = {#sizeof InputHandler#}- alignment _ = {#alignof InputHandler#}- peek hptr = InputHandler <$>- {#get InputHandler->handler#} hptr <*>- {#get InputHandler->activity#} hptr <*>- {#get InputHandler->active#} hptr <*>- (Fd <$> {#get InputHandler->fileDescriptor#} hptr) <*>- {#get InputHandler->userData#} hptr <*>- (castPtr <$> {#get InputHandler->next#} hptr)- poke hptr InputHandler{..} = do- {#set InputHandler->handler#} hptr inputHandlerCallback- {#set InputHandler->activity#} hptr inputHandlerActivity- {#set InputHandler->active#} hptr inputHandlerActive- {#set InputHandler->fileDescriptor#} hptr (case inputHandlerFD of Fd fd -> fd)- {#set InputHandler->userData#} hptr inputHandlerUserData- {#set InputHandler->next#} hptr (castPtr inputHandlerNext)---- | @R_PolledEvents@ global variable.-foreign import ccall "&R_PolledEvents" polledEvents :: Ptr (FunPtr (IO ()))---- | @R_wait_usec@ global variable.-foreign import ccall "&R_wait_usec" pollingPeriod :: Ptr CInt---- | @R_PolledEvents@ global variable.-foreign import ccall "&Rg_PolledEvents" graphicsPolledEvents :: Ptr (FunPtr (IO ()))---- | @R_wait_usec@ global variable.-foreign import ccall "&Rg_wait_usec" graphicsPollingPeriod :: Ptr CInt---- | Input handlers used in event loops.-foreign import ccall "&R_InputHandlers" inputHandlers :: Ptr (Ptr InputHandler)--data FdSet--foreign import ccall unsafe "R_checkActivity" checkActivity- :: CInt- -> CInt- -> IO (Ptr FdSet)--foreign import ccall "R_runHandlers" runHandlers- :: Ptr InputHandler- -> Ptr FdSet- -> IO ()--foreign import ccall "addInputHandler" addInputHandler_- :: Ptr InputHandler- -> Fd- -> FunPtr (Ptr () -> IO ())- -> CInt- -> IO (Ptr InputHandler)---- | Create and register a new 'InputHandler'. The given file descriptor should--- be open in non-blocking read mode. Make sure to dispose of the callback using--- 'freeHaskellFunPtr' after calling 'removeInputHandler' where appropriate.-addInputHandler- :: Ptr InputHandler- -> Fd- -> FunPtr (Ptr () -> IO ())- -> Int- -> IO (Ptr InputHandler)-addInputHandler ihptr fd f activity = do- addInputHandler_ ihptr fd f (fromIntegral activity)--foreign import ccall "removeInputHandler" removeInputHandler_- :: Ptr (Ptr InputHandler)- -> Ptr InputHandler- -> IO CInt---- | Remove an input handler from an input handler chain. Returns 'True' if the--- handler was successfully removed, 'False' otherwise.-removeInputHandler :: Ptr InputHandler -> Ptr InputHandler -> IO Bool-removeInputHandler handlers ih =- with handlers $ \handlersptr -> do- rc <- removeInputHandler_ handlersptr ih- case rc of- 0 -> return $ False- 1 -> return $ True- _ -> error "removeInputHandler: unexpected result."
+ src/Foreign/R/EventLoop.hsc view
@@ -0,0 +1,129 @@+-- |+-- Copyright: (C) 2015 Tweag I/O Limited.+--+-- Bindings for @<R/R_ext/eventloop.h>@, for building event loops.++{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module Foreign.R.EventLoop+ ( InputHandler(..)+ , inputHandlers+ , polledEvents+ , pollingPeriod+ , graphicsPolledEvents+ , graphicsPollingPeriod+ , checkActivity+ , runHandlers+ , addInputHandler+ , removeInputHandler+ ) where++import Control.Applicative+import Foreign (FunPtr, Ptr, Storable(..), castPtr)+import Foreign.C+import Foreign.Marshal.Utils (with)+import System.Posix.Types (Fd(..))+import Prelude -- Silence AMP warning.++#include <R_ext/eventloop.h>+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)++-- | R input handler chain. Each input handler points to the next. This view of+-- input handlers is /shallow/, in the sense that the 'Storable' instance only+-- unmarshalls the first element in the chain at any one time. A shallow view+-- allows 'peek' and 'poke' to be inlinable.+data InputHandler = InputHandler+ { -- | The input handler callback.+ inputHandlerCallback :: FunPtr (Ptr () -> IO ())+ -- | Undocumented and currently unused.+ , inputHandlerActivity :: CInt+ -- | Whether this input handler is activated or deactivated.+ , inputHandlerActive :: CInt+ -- | The file descriptor ahssociated with this handler.+ , inputHandlerFD :: Fd+ -- | Callbacks can optionally be passed in arbitrary data.+ , inputHandlerUserData :: Ptr ()+ -- | The next input handler in the chain.+ , inputHandlerNext :: Ptr InputHandler+ } deriving (Eq, Show)++instance Storable InputHandler where+ sizeOf _ = #{size InputHandler}+ alignment _ = #{alignment InputHandler}+ peek hptr = InputHandler <$>+ #{peek InputHandler, handler} hptr <*>+ #{peek InputHandler, activity} hptr <*>+ #{peek InputHandler, active} hptr <*>+ (Fd <$> #{peek InputHandler, fileDescriptor} hptr) <*>+ #{peek InputHandler, userData} hptr <*>+ (castPtr <$> #{peek InputHandler, next} hptr)+ poke hptr InputHandler{..} = do+ #{poke InputHandler, handler} hptr inputHandlerCallback+ #{poke InputHandler, activity} hptr inputHandlerActivity+ #{poke InputHandler, active} hptr inputHandlerActive+ #{poke InputHandler, fileDescriptor} hptr (case inputHandlerFD of Fd fd -> fd)+ #{poke InputHandler, userData} hptr inputHandlerUserData+ #{poke InputHandler, next} hptr (castPtr inputHandlerNext)++-- | @R_PolledEvents@ global variable.+foreign import ccall "&R_PolledEvents" polledEvents :: Ptr (FunPtr (IO ()))++-- | @R_wait_usec@ global variable.+foreign import ccall "&R_wait_usec" pollingPeriod :: Ptr CInt++-- | @R_PolledEvents@ global variable.+foreign import ccall "&Rg_PolledEvents" graphicsPolledEvents :: Ptr (FunPtr (IO ()))++-- | @R_wait_usec@ global variable.+foreign import ccall "&Rg_wait_usec" graphicsPollingPeriod :: Ptr CInt++-- | Input handlers used in event loops.+foreign import ccall "&R_InputHandlers" inputHandlers :: Ptr (Ptr InputHandler)++data FdSet++foreign import ccall unsafe "R_checkActivity" checkActivity+ :: CInt+ -> CInt+ -> IO (Ptr FdSet)++foreign import ccall "R_runHandlers" runHandlers+ :: Ptr InputHandler+ -> Ptr FdSet+ -> IO ()++foreign import ccall "addInputHandler" addInputHandler_+ :: Ptr InputHandler+ -> Fd+ -> FunPtr (Ptr () -> IO ())+ -> CInt+ -> IO (Ptr InputHandler)++-- | Create and register a new 'InputHandler'. The given file descriptor should+-- be open in non-blocking read mode. Make sure to dispose of the callback using+-- 'freeHaskellFunPtr' after calling 'removeInputHandler' where appropriate.+addInputHandler+ :: Ptr InputHandler+ -> Fd+ -> FunPtr (Ptr () -> IO ())+ -> Int+ -> IO (Ptr InputHandler)+addInputHandler ihptr fd f activity = do+ addInputHandler_ ihptr fd f (fromIntegral activity)++foreign import ccall "removeInputHandler" removeInputHandler_+ :: Ptr (Ptr InputHandler)+ -> Ptr InputHandler+ -> IO CInt++-- | Remove an input handler from an input handler chain. Returns 'True' if the+-- handler was successfully removed, 'False' otherwise.+removeInputHandler :: Ptr InputHandler -> Ptr InputHandler -> IO Bool+removeInputHandler handlers ih =+ with handlers $ \handlersptr -> do+ rc <- removeInputHandler_ handlersptr ih+ case rc of+ 0 -> return $ False+ 1 -> return $ True+ _ -> error "removeInputHandler: unexpected result."
+ src/Foreign/R/Internal.hsc view
@@ -0,0 +1,327 @@+-- |+-- 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 to+-- sidestep issues in c2hs. https://github.com/haskell/c2hs/issues/168+--++{-# 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 Control.Applicative+import Control.DeepSeq (NFData(..))+import Control.Monad.Primitive ( unsafeInlineIO )+import Data.Singletons (fromSing)+#if __GLASGOW_HASKELL__ < 710+import Data.Typeable (Typeable)+#endif+import Foreign (Ptr, castPtr, plusPtr, Storable(..))+import Foreign.C+import Prelude hiding (asTypeOf, length)++#define USE_RINTERNALS+#include <R.h>+#include <Rinternals.h>+#include "missing_r.h"+++--------------------------------------------------------------------------------+-- R data structures --+--------------------------------------------------------------------------------++data {-# CTYPE "SEXPREC" #-} SEXPREC++-- | 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` ())++type SEXP0 = Ptr SEXPREC++-- | 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++-- | 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++----------------------------------------------------------------------------------+-- 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 --+-------------------------------------------------------------------------------++-- | Get the attribute list from the given object.+getAttribute :: SEXP s a -> IO (SEXP s b)+getAttribute s = sexp <$> cATTRIB (unsexp s)++-- | Set the attribute list.+setAttribute :: SEXP s a -> SEXP s b -> IO ()+setAttribute s v = cSET_ATTRIB (unsexp s) (castPtr $ unsexp v)++foreign import capi unsafe "Rinternals.h ATTRIB" cATTRIB :: SEXP0 -> IO SEXP0+foreign import capi unsafe "Rinternals.h SET_ATTRIB" cSET_ATTRIB :: SEXP0 -> SEXP0 -> IO ()+
src/Foreign/R/Type.hsc view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-}@@ -5,11 +6,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE CPP #-}+ #if __GLASGOW_HASKELL__ >= 710 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} #endif-+{-# OPTIONS_GHC -fno-warn-unused-binds #-} -- | -- Copyright: (C) 2013 Amgen, Inc.@@ -30,7 +31,18 @@ -- functions whose result type depends on the value of one of its arguments. See -- e.g. 'Foreign.R.allocVector'. -module Foreign.R.Type where+module Foreign.R.Type+ ( SEXPTYPE(..)+ , SSEXPTYPE+ , Sing(..)+ , Logical(..)+ , PairList+ , IsVector+ , IsGenericVector+ , IsList+ , IsPairList+ , IsExpression+ ) where #include <Rinternals.h> @@ -209,3 +221,8 @@ -- | @IsPairList a@ holds iff R's @is.pairlist()@ returns @TRUE@. type IsPairList (a :: SEXPTYPE) = (SingI a, a :∈ [List, Nil])++-- | Constraint synonym grouping all expression forms into one class. According+-- to R internals, an expression is usually a 'Lang', but can sometimes also be+-- an 'Expr' or a 'Symbol'.+type IsExpression (a :: SEXPTYPE) = (SingI a, a :∈ [Lang, Expr, Symbol])
src/H/Prelude.hs view
@@ -1,13 +1,9 @@ -- |--- Copyright: (C) 2013 Amgen, Inc.+-- | Copyright: (C) 2013 Amgen, Inc.+--+-- DEPRECATED: use "Language.R" instead. {-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# Language GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# Language ViewPatterns #-} module H.Prelude ( module Language.R.Instance@@ -15,63 +11,27 @@ , module Foreign.R.Error -- * Language.R functions , module Language.R+-- Not supported on Windows.+#ifndef mingw32_HOST_OS , module Language.R.Event+#endif+ , module Language.R.HExp , module Language.R.Literal+ , module Language.R.QQ -- * Globals , module Language.R.Globals- , Show(..) ) where -import Control.Memory.Region import Control.Monad.R.Class-import qualified Foreign.R as R-import Foreign.R (SEXP, SomeSEXP(..)) import Language.R.HExp-import Language.R.Internal (r1)-import qualified Data.Vector.SEXP as Vector -- Reexported modules.-import Language.R+import Language.R hiding (SEXPTYPE(..))+#ifndef mingw32_HOST_OS import Language.R.Event (refresh)+#endif import Language.R.Globals-import Language.R.Literal import Language.R.Instance+import Language.R.Literal+import Language.R.QQ import Foreign.R.Error--import qualified Data.Text.Lazy.IO as Text-import qualified Data.Text as Text-import qualified Data.Text.Lazy as Text.Lazy-import Data.Text.Lazy (Text)--import Control.Monad ((>=>))-import Foreign.C (withCString)-import System.IO.Unsafe (unsafePerformIO)--import Prelude hiding (Show(..), print)--class Show a where- -- | Equivalent of R's @deparse()@.- show :: a -> Text-- -- | Make this a class method to allow matching R's @print()@ behaviour, whose- -- output is subtly different from @deparse()@.- print :: MonadR m => a -> m ()- print = io . Text.putStrLn . show--instance Show (SEXP s a) where- show s =- unsafePerformIO $- withCString "quote" $ R.install >=> \quote ->- R.lang2 quote (R.release s) >>= r1 "deparse" >>= \(SomeSEXP slang) ->- return .- Text.Lazy.fromChunks .- map (Text.pack . Vector.toString . vector) .- Vector.toList .- vector $- (R.unsafeCoerce (R.release slang) :: SEXP V 'R.String)-- print = io . R.printValue--instance Show (R.SomeSEXP s) where- show s = R.unSomeSEXP s show- print s = R.unSomeSEXP s print
src/H/Prelude/Interactive.hs view
@@ -9,13 +9,14 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module H.Prelude.Interactive ( module H.Prelude+ , PrintR(..) , p , printQuote ) where +import qualified Foreign.R as R import H.Prelude hiding (withEmbeddedR)-import qualified H.Prelude as H instance MonadR IO where io = id@@ -23,13 +24,22 @@ getExecContext = return ExecContext unsafeRunWithExecContext = const --- | A form of the 'print' function that is more convenient in an--- interactive session.-p :: (MonadR m, H.Show a) => m a -> m ()-p = (>>= H.print)+class PrintR a where+ printR :: MonadR m => a -> m () --- | A form of the 'print' function that that is more convenient in an--- interactive session.+instance PrintR (SEXP s a) where+ printR = io . R.printValue++instance PrintR (R.SomeSEXP s) where+ printR s = R.unSomeSEXP s printR++-- | A form of the 'printR' function that is more convenient in an interactive+-- session.+p :: (MonadR m, PrintR a) => m a -> m ()+p = (>>= printR)++-- | A form of the 'printR' function that is more convenient in an interactive+-- session. {-# DEPRECATED printQuote "Use 'p' instead." #-}-printQuote :: (MonadR m, H.Show a) => m a -> m ()+printQuote :: (MonadR m, PrintR a) => m a -> m () printQuote = p
src/Language/R.hs view
@@ -9,48 +9,61 @@ {-# Language ViewPatterns #-} module Language.R- ( parseFile- , parseText- , install- , string- , strings+ ( module Foreign.R+ , module Foreign.R.Type+ , module Language.R.Instance+ , module Language.R.Globals+ , module Language.R.GC+ , module Language.R.Literal+ -- * Evaluation , eval , eval_ , evalEnv- -- * R global constants- -- $ghci-bug- , module Language.R.Instance+ , install -- * Exceptions , throwR , throwRMessage- -- * Memory management- , module Language.R.GC+ -- * Deprecated+ , parseFile+ , parseText+ , string+ , strings ) where import Control.Memory.Region import qualified Data.Vector.SEXP as Vector import Control.Monad.R.Class-import Foreign.R (SEXP, SomeSEXP(..))+import Foreign.R+ ( SEXP+ , SomeSEXP(..)+ , typeOf+ , asTypeOf+ , cast+ , unSomeSEXP+ , unsafeCoerce+ ) import qualified Foreign.R as R import qualified Foreign.R.Parse as R import qualified Foreign.R.Error as R+import Foreign.R.Type import Language.R.GC import Language.R.Globals import Language.R.HExp import Language.R.Instance import {-# SOURCE #-} Language.R.Internal+import Language.R.Literal import Control.Applicative import Control.Exception ( throwIO ) import Control.Monad ( (>=>), when, unless, forM, void ) import Data.ByteString as B import Data.ByteString.Char8 as C8 ( pack, unpack )-import Foreign- ( alloca- , castPtr- , peek- ) import Data.Singletons (sing)+import Foreign+ ( alloca+ , castPtr+ , peek+ ) import Foreign.C.String ( withCString, peekCString ) import Prelude @@ -75,19 +88,19 @@ -- -- This function uses continuation because this is an easy way to make -- operations GC-safe.------ This function is not safe to use inside GHCi. parseFile :: FilePath -> (SEXP s 'R.Expr -> IO a) -> IO a+{-# DEPRECATED parseFile "Use [r| parse(file=\"path/to/file\") |] instead." #-} parseFile fl f = do withCString fl $ \cfl -> R.withProtected (R.mkString cfl) $ \rfl -> r1 (C8.pack "parse") rfl >>= \(R.SomeSEXP s) -> return (R.unsafeCoerce s) `R.withProtected` f -parseText :: String -- ^ Text to parse- -> Bool -- ^ Whether to annotate the- -- AST with source locations.- -> IO (R.SEXP V 'R.Expr)+parseText+ :: String -- ^ Text to parse+ -> Bool -- ^ Whether to annotate the AST with source locations.+ -> IO (R.SEXP V 'R.Expr)+{-# DEPRECATED parseText "Use [r| parse(text=...) |] instead." #-} parseText txt b = do s <- parseEval $ C8.pack $ "parse(text=" ++ show txt ++ ", keep.source=" ++ keep ++ ")"@@ -96,9 +109,12 @@ keep | b = "TRUE" | otherwise = "FALSE" +-- | Internalize a symbol name. install :: MonadR m => String -> m (SEXP V 'R.Symbol) install = io . installIO +{-# DEPRECATED string, strings "Use mkSEXP instead" #-}+ -- | Create an R character string from a Haskell string. string :: String -> IO (SEXP V 'R.Char) string str = withCString str R.mkChar@@ -110,7 +126,7 @@ -- | Evaluate a (sequence of) expression(s) in the given environment, returning the -- value of the last. evalEnv :: MonadR m => SEXP s a -> SEXP s 'R.Env -> m (SomeSEXP (Region m))-evalEnv (hexp -> Expr _ v) rho = acquireSome =<< do+evalEnv (hexp -> Language.R.HExp.Expr _ v) rho = acquireSome =<< do io $ alloca $ \p -> do mapM_ (\(SomeSEXP s) -> void $ R.protect s) (Vector.toList v) x <- Prelude.last <$> forM (Vector.toList v) (\(SomeSEXP s) -> do@@ -131,7 +147,7 @@ eval :: MonadR m => SEXP s a -> m (SomeSEXP (Region m)) eval x = evalEnv x (R.release globalEnv) --- | Silent version of 'evalIO' function that discards it's result.+-- | Silent version of 'eval' function that discards it's result. eval_ :: MonadR m => SEXP s a -> m () eval_ = void . eval
src/Language/R/Globals.hs view
@@ -18,8 +18,10 @@ , unboundValue -- * R Internal constants , isRInteractive- , inputHandlers , signalHandlersPtr+#ifndef mingw32_HOST_OS+ , inputHandlers+#endif -- * R global constants -- $ghci-bug , pokeRVariables@@ -38,7 +40,9 @@ import Foreign.C.Types (CInt) import Foreign.R (SEXP) import qualified Foreign.R as R+#ifndef mingw32_HOST_OS import qualified Foreign.R.EventLoop as R+#endif import System.IO.Unsafe (unsafePerformIO) -- $ghci-bug@@ -59,8 +63,10 @@ , Ptr (SEXP G 'R.Symbol) , Ptr (SEXP G 'R.Symbol) , Ptr CInt- , Ptr (Ptr R.InputHandler) , Ptr CInt+#ifndef mingw32_HOST_OS+ , Ptr (Ptr R.InputHandler)+#endif ) -- | Stores R variables in a static location. This makes the variables'@@ -77,8 +83,10 @@ , unboundValuePtr , missingArgPtr , isRInteractive- , inputHandlersPtr , signalHandlersPtr+#ifndef mingw32_HOST_OS+ , inputHandlersPtr+#endif ) = unsafePerformIO $ peek rVariables >>= deRefStablePtr -- | Special value to which all symbols unbound in the current environment@@ -106,5 +114,7 @@ globalEnv :: SEXP G 'R.Env globalEnv = unsafePerformIO $ peek globalEnvPtr +#ifndef mingw32_HOST_OS inputHandlers :: Ptr R.InputHandler inputHandlers = unsafePerformIO $ peek inputHandlersPtr+#endif
− src/Language/R/HExp.chs
@@ -1,512 +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 #-}--#if __GLASGOW_HASKELL__ >= 710--- XXX necessary for c2hs.-{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}-#else-{-# OPTIONS_GHC -fno-warn-orphans #-}-#endif--- Necessary for c2hs < 0.26 compat.-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-module Language.R.HExp- ( HExp(..)- , (===)- , hexp- , unhexp- , vector- ) where--import Control.Applicative-import Control.Monad.R.Class-import qualified Foreign.R as R-import qualified Foreign.R.Type as R-import Foreign.R (SEXP, SEXPREC, 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 c2hs < 0.26-import Foreign (castPtr)-import Unsafe.Coerce (unsafeCoerce)--- Fixes redundant import warning >= 7.10 without CPP-import Prelude--#define USE_RINTERNALS-#include <R.h>-#include <Rinternals.h>--{#pointer *SEXPREC as SEXP0 -> SEXPREC #}---- 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.-#if __GLASGOW_HASKELL__ >= 708-type role HExp phantom nominal-#endif-data HExp :: * -> SEXPTYPE -> * where- -- Primitive types. The field names match those of <RInternals.h>.- Nil :: HExp s R.Nil- -- Fields: pname, value, internal.- Symbol :: SEXP s R.Char- -> SEXP s a- -> SEXP s b- -> 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.IsPairList a, c :∈ [R.Env, R.Nil])- => SEXP s a- -> SEXP s b- -> SEXP s c- -> HExp s R.Promise- -- Derived types. These types don't have their own 'struct' declaration in- -- <Rinternals.h>.- -- Fields: function, args.- Lang :: (a :∈ [R.Symbol, R.Lang], 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 s R.Char Word8)- -> HExp s R.Char- Logical :: {-# UNPACK #-} !(Vector.Vector s 'R.Logical R.Logical)- -> HExp s 'R.Logical- Int :: {-# UNPACK #-} !(Vector.Vector s R.Int Int32)- -> HExp s R.Int- Real :: {-# UNPACK #-} !(Vector.Vector s R.Real Double)- -> HExp s R.Real- Complex :: {-# UNPACK #-} !(Vector.Vector s R.Complex (Complex Double))- -> HExp s R.Complex- String :: {-# UNPACK #-} !(Vector.Vector s R.String (SEXP s 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 s R.Vector (SomeSEXP s))- -> HExp s R.Vector- -- Fields: truelength, content.- Expr :: {-# UNPACK #-} !Int32- -> {-# UNPACK #-} !(Vector.Vector s R.Expr (SomeSEXP s))- -> 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 s R.Raw Word8)- -> HExp s R.Raw- -- Fields: tagval.- S4 :: SEXP s a- -> HExp s R.S4--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---- XXX Orphan instance. Could find a better place to put it.--- this #ifdef is not correct as it should be MIN_VERSION_base,--- so this one will not work in non GHC compilers.-#if __GLASGOW_HASKELL__ < 710-instance (Fractional a, Real a, Storable a) => Storable (Complex a) where- sizeOf _ = {#sizeof Rcomplex #}- alignment _ = {#alignof Rcomplex #}- poke cptr (r :+ i) = do- {#set Rcomplex->r #} cptr (realToFrac r)- {#set Rcomplex->i #} cptr (realToFrac i)- peek cptr =- (:+) <$> (realToFrac <$> {#get Rcomplex->r #} cptr)- <*> (realToFrac <$> {#get Rcomplex->i #} cptr)-#endif--instance Storable (HExp s a) where- sizeOf _ = {#sizeof SEXPREC #}- alignment _ = {#alignof 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 <$> (R.sexp <$> {#get SEXP->u.symsxp.pname #} sptr)- <*> (R.sexp <$> {#get SEXP->u.symsxp.value #} sptr)- <*> (R.sexp <$> {#get SEXP->u.symsxp.internal #} sptr)- R.List -> coerce $- List <$> (R.sexp <$> {#get SEXP->u.listsxp.carval #} sptr)- <*> (coerceAny <$> R.sexp <$> {#get SEXP->u.listsxp.cdrval #} sptr)- <*> (coerceAny <$> R.sexp <$> {#get SEXP->u.listsxp.tagval #} sptr)- R.Env -> coerce $- Env <$> (coerceAny <$> R.sexp <$> {#get SEXP->u.envsxp.frame #} sptr)- <*> (coerceAny <$> R.sexp <$> {#get SEXP->u.envsxp.enclos #} sptr)- <*> (coerceAny <$> R.sexp <$> {#get SEXP->u.envsxp.hashtab #} sptr)- R.Closure -> coerce $- Closure <$> (coerceAny <$> R.sexp <$> {#get SEXP->u.closxp.formals #} sptr)- <*> (R.sexp <$> {#get SEXP->u.closxp.body #} sptr)- <*> (R.sexp <$> {#get SEXP->u.closxp.env #} sptr)- R.Promise -> coerce $- Promise <$> (coerceAny <$> R.sexp <$> {#get SEXP->u.promsxp.value #} sptr)- <*> (R.sexp <$> {#get SEXP->u.promsxp.expr #} sptr)- <*> (coerceAny <$> R.sexp <$> {#get SEXP->u.promsxp.env #} sptr)- R.Lang -> coerce $- Lang <$> (coerceAny <$> R.sexp <$> {#get SEXP->u.listsxp.carval #} sptr)- <*> (coerceAny <$> R.sexp <$> {#get SEXP->u.listsxp.cdrval #} sptr)- R.Special -> coerce $- Special <$> (fromIntegral <$> {#get SEXP->u.primsxp.offset #} sptr)- R.Builtin -> coerce $- Builtin <$> (fromIntegral <$> {#get SEXP->u.primsxp.offset #} sptr)- 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 <$> {#get VECSEXP->vecsxp.truelength #} sptr)- <*> pure (Vector.unsafeFromSEXP (unsafeCoerce s))- R.Expr -> coerce $- Expr <$> (fromIntegral <$> {#get VECSEXP->vecsxp.truelength #} sptr)- <*> pure (Vector.unsafeFromSEXP (unsafeCoerce s))- R.Bytecode -> coerce $ return Bytecode- R.ExtPtr -> coerce $- ExtPtr <$> (castPtr <$> {#get SEXP->u.listsxp.carval #} sptr)- <*> (R.sexp <$> {#get SEXP->u.listsxp.cdrval #} sptr)- <*> (R.sexp <$> {#get SEXP->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 <$> {# get SEXP->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- {#set SEXP->u.symsxp.pname #} s (R.unsexp pname)- {#set SEXP->u.symsxp.value #} s (R.unsexp value)- {#set SEXP->u.symsxp.internal#} s (R.unsexp internal)- List carval cdrval tagval -> do- {#set SEXP->u.listsxp.carval #} s (R.unsexp carval)- {#set SEXP->u.listsxp.cdrval #} s (R.unsexp cdrval)- {#set SEXP->u.listsxp.tagval #} s (R.unsexp tagval)- Env frame enclos hashtab -> do- {#set SEXP->u.envsxp.frame #} s (R.unsexp frame)- {#set SEXP->u.envsxp.enclos #} s (R.unsexp enclos)- {#set SEXP->u.envsxp.hashtab #} s (R.unsexp hashtab)- Closure formals body env -> do- {#set SEXP->u.closxp.formals #} s (R.unsexp formals)- {#set SEXP->u.closxp.body #} s (R.unsexp body)- {#set SEXP->u.closxp.env #} s (R.unsexp env)- Promise value expr env -> do- {#set SEXP->u.promsxp.value #} s (R.unsexp value)- {#set SEXP->u.promsxp.expr #} s (R.unsexp expr)- {#set SEXP->u.promsxp.env #} s (R.unsexp env)- Lang carval cdrval -> do- {#set SEXP->u.listsxp.carval #} s (R.unsexp carval)- {#set SEXP->u.listsxp.cdrval #} s (R.unsexp cdrval)- Special offset -> do- {#set SEXP->u.primsxp.offset #} s (fromIntegral offset)- Builtin offset -> do- {#set SEXP->u.primsxp.offset #} s (fromIntegral offset)- 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- {# set SEXP-> 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 s a (Vector.ElemRep s a)-vector (hexp -> Char vec) = vec-vector (hexp -> Logical vec) = vec-vector (hexp -> Int vec) = vec-vector (hexp -> Real vec) = vec-vector (hexp -> Complex vec) = vec-vector (hexp -> String vec) = vec-vector (hexp -> Vector _ vec) = vec-vector (hexp -> Expr _ vec) = vec-vector s = violation "vector" $ show (R.typeOf s) ++ " unexpected vector type."
+ src/Language/R/HExp.hsc view
@@ -0,0 +1,514 @@+-- |+-- 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 #-}++#if __GLASGOW_HASKELL__ >= 710+-- XXX necessary for c2hs.+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}+#else+{-# OPTIONS_GHC -fno-warn-orphans #-}+#endif+-- Necessary for c2hs < 0.26 compat.+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+module Language.R.HExp+ ( HExp(..)+ , (===)+ , hexp+ , unhexp+ , vector+ ) where++import Control.Applicative+import Control.Monad.R.Class+import qualified Foreign.R as R+import qualified Foreign.R.Type 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 c2hs < 0.26+import Foreign (castPtr)+import Unsafe.Coerce (unsafeCoerce)+-- Fixes redundant import warning >= 7.10 without CPP+import Prelude++#define USE_RINTERNALS+#include <R.h>+#include <Rinternals.h>+++#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)++-- Use explicit UNPACK pragmas rather than -funbox-strict-fields in order to get+-- warnings if a field is not unpacked when we expect it to.++-- | A view of R's internal 'SEXP' structure as an algebraic datatype. Because+-- this is in fact a GADT, the use of named record fields is not possible here.+-- Named record fields give rise to functions for whom it is not possible to+-- assign a reasonable type (existentially quantified type variables would+-- escape).+--+-- Note further that Haddock does not currently support constructor comments+-- when using the GADT syntax.+#if __GLASGOW_HASKELL__ >= 708+type role HExp phantom nominal+#endif+data HExp :: * -> SEXPTYPE -> * where+ -- Primitive types. The field names match those of <RInternals.h>.+ Nil :: HExp s R.Nil+ -- Fields: pname (is Nil for R_UnboundValue), value, internal.+ Symbol :: (a :∈ [R.Char, R.Nil])+ => SEXP s a+ -> SEXP s b+ -> SEXP s c+ -> HExp s R.Symbol+ -- Fields: carval, cdrval, tagval.+ List :: (R.IsPairList b, c :∈ [R.Symbol, R.Nil])+ => SEXP s a+ -> SEXP s b+ -> SEXP s c+ -> HExp s R.List+ -- Fields: frame, enclos, hashtab.+ Env :: (R.IsPairList a, b :∈ [R.Env, R.Nil], c :∈ [R.Vector, R.Nil])+ => SEXP s a+ -> SEXP s b+ -> SEXP s c+ -> HExp s R.Env+ -- Fields: formals, body, env.+ Closure :: (R.IsPairList a)+ => SEXP s a+ -> SEXP s b+ -> SEXP s R.Env+ -> HExp s R.Closure+ -- Fields: value, expr, env.+ -- Once an promise has been evaluated, the environment is set to NULL.+ Promise :: (R.IsExpression b, c :∈ [R.Env, R.Nil])+ => SEXP s a+ -> SEXP s b+ -> SEXP s c+ -> HExp s R.Promise+ -- Derived types. These types don't have their own 'struct' declaration in+ -- <Rinternals.h>.+ -- Fields: function, args.+ Lang :: (R.IsExpression a, R.IsPairList b)+ => SEXP s a+ -> SEXP s b+ -> HExp s R.Lang+ -- Fields: offset.+ Special :: {-# UNPACK #-} !Int32+ -> HExp s R.Special+ -- Fields: offset.+ Builtin :: {-# UNPACK #-} !Int32+ -> HExp s R.Builtin+ Char :: {-# UNPACK #-} !(Vector.Vector s R.Char Word8)+ -> HExp s R.Char+ Logical :: {-# UNPACK #-} !(Vector.Vector s 'R.Logical R.Logical)+ -> HExp s 'R.Logical+ Int :: {-# UNPACK #-} !(Vector.Vector s R.Int Int32)+ -> HExp s R.Int+ Real :: {-# UNPACK #-} !(Vector.Vector s R.Real Double)+ -> HExp s R.Real+ Complex :: {-# UNPACK #-} !(Vector.Vector s R.Complex (Complex Double))+ -> HExp s R.Complex+ String :: {-# UNPACK #-} !(Vector.Vector s R.String (SEXP s 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 s R.Vector (SomeSEXP s))+ -> HExp s R.Vector+ -- Fields: truelength, content.+ Expr :: {-# UNPACK #-} !Int32+ -> {-# UNPACK #-} !(Vector.Vector s R.Expr (SomeSEXP s))+ -> 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 s R.Raw Word8)+ -> HExp s R.Raw+ -- Fields: tagval.+ S4 :: SEXP s a+ -> HExp s R.S4++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++-- XXX Orphan instance. Could find a better place to put it.+-- this #ifdef is not correct as it should be MIN_VERSION_base,+-- so this one will not work in non GHC compilers.+#if __GLASGOW_HASKELL__ < 710+instance (Fractional a, Real a, Storable a) => Storable (Complex a) where+ sizeOf _ = {#sizeof Rcomplex #}+ alignment _ = {#alignof Rcomplex #}+ poke cptr (r :+ i) = do+ #{poke Rcomplex, r} cptr (realToFrac r)+ #{poke Rcomplex, i} cptr (realToFrac i)+ peek cptr =+ (:+) <$> (realToFrac <$> (#{peek Rcomplex, r} cptr :: IO CDouble))+ <*> (realToFrac <$> (#{peek Rcomplex, i} cptr :: IO CDouble))+#endif++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 s a (Vector.ElemRep s a)+vector (hexp -> Char vec) = vec+vector (hexp -> Logical vec) = vec+vector (hexp -> Int vec) = vec+vector (hexp -> Real vec) = vec+vector (hexp -> Complex vec) = vec+vector (hexp -> String vec) = vec+vector (hexp -> Vector _ vec) = vec+vector (hexp -> Expr _ vec) = vec+vector s = violation "vector" $ show (R.typeOf s) ++ " unexpected vector type."
src/Language/R/Instance.hs view
@@ -44,7 +44,9 @@ import Data.Default.Class (Default(..)) import qualified Foreign.R as R import qualified Foreign.R.Embedded as R+#ifndef mingw32_HOST_OS import qualified Foreign.R.EventLoop as R+#endif import Foreign.C.String import Language.R.Globals @@ -73,7 +75,7 @@ import System.IO.Unsafe ( unsafePerformIO ) import System.Process ( readProcess ) import System.SetEnv-#ifdef H_ARCH_UNIX+#ifndef mingw32_HOST_OS import Control.Exception ( onException ) import System.IO ( hPutStrLn, stderr ) import System.Posix.Resource@@ -205,8 +207,8 @@ -- to achieve this. initialize :: Config -> IO () initialize Config{..} = do-#ifdef H_ARCH_UNIX-#ifdef H_ARCH_UNIX_DARWIN+#ifndef mingw32_HOST_OS+#ifdef darwin_HOST_OS -- NOTE: OS X does not allow removing the stack size limit completely, -- instead forcing a hard limit of just under 64MB. let stackLimit = ResourceLimit 67104768@@ -218,7 +220,7 @@ "Language.R.Interpreter: " ++ "Cannot increase stack size limit." ++ "Try increasing your stack size limit manually:"-#ifdef H_ARCH_UNIX_DARWIN+#ifdef darwin_HOST_OS ++ "$ launchctl limit stack 67104768" ++ "$ ulimit -s 65532" #else@@ -240,8 +242,10 @@ , R.unboundValue , R.missingArg , R.isRInteractive- , R.inputHandlers , R.signalHandlers+#ifndef mingw32_HOST_OS+ , R.inputHandlers+#endif ) populateEnv args <- (:) <$> maybe getProgName return (getLast configProgName)
src/Language/R/Internal.hs view
@@ -1,17 +1,19 @@ {-# LANGUAGE DataKinds #-} {-# Language ViewPatterns #-} -module Language.R.Internal (r1, r2, installIO) where+module Language.R.Internal+ ( r1+ , r2+ , installIO+ ) where import Control.Memory.Region import qualified Foreign.R as R-import Foreign.R (SEXP, SomeSEXP) import Language.R import Data.ByteString as B import Foreign.C.String ( withCString ) --- | Helper inVoid :: R V z -> R V z inVoid = id {-# INLINE inVoid #-}
src/Language/R/Literal.hs view
@@ -41,7 +41,7 @@ import Foreign.R.Type ( IsVector, SSEXPTYPE ) import Foreign.R ( SEXP, SomeSEXP(..) ) import Internal.Error-import Language.R.Internal (r1)+import {-# SOURCE #-} Language.R.Internal (r1) import Language.R.Globals (nilValue) import Language.R.HExp import Language.R.Instance
src/Language/R/QQ.hs view
@@ -22,10 +22,13 @@ import Control.Monad.R.Class import qualified Data.Vector.SEXP as Vector import qualified Foreign.R as R+import qualified Foreign.R.Parse as R import Foreign.R (SEXP, SomeSEXP(..))-import qualified H.Prelude as H+import Foreign.R.Error import Internal.Error-import Language.R (parseText, eval)+import Language.R (eval)+import Language.R.Globals (nilValue, globalEnv)+import Language.R.GC (automaticSome) import Language.R.HExp import Language.R.Instance import Language.R.Literal (mkSEXPIO)@@ -36,9 +39,13 @@ import qualified Language.Haskell.TH.Lib as TH import Control.Concurrent (MVar, newMVar, withMVar)+import Control.Exception (throwIO)+import Control.Monad (unless) 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) -------------------------------------------------------------------------------@@ -63,7 +70,7 @@ -- TODO some of the above invariants can be checked statically. Do so. rsafe :: QuasiQuoter rsafe = QuasiQuoter- { quoteExp = \txt -> [| unsafePerformIO $ runRegion $ H.automaticSome =<< eval =<< $(expQQ txt) |]+ { quoteExp = \txt -> [| unsafePerformIO $ runRegion $ automaticSome =<< eval =<< $(expQQ txt) |] , quotePat = unimplemented "quotePat" , quoteType = unimplemented "quoteType" , quoteDec = unimplemented "quoteDec"@@ -75,10 +82,18 @@ qqLock = unsafePerformIO $ newMVar () {-# NOINLINE qqLock #-} -parse :: String -> Q (R.SEXP V 'R.Expr)-parse txt = runIO $ do- H.initialize H.defaultConfig- withMVar qqLock $ \_ -> parseText txt False+parse :: String -> IO (R.SEXP V 'R.Expr)+parse txt = do+ initialize defaultConfig+ withMVar qqLock $ \_ ->+ withCString txt $ \ctxt ->+ R.withProtected (R.mkString ctxt) $ \rtxt ->+ alloca $ \status -> do+ R.withProtected (R.parseVector rtxt (-1) status (R.release nilValue)) $ \exprs -> do+ rc <- fromIntegral <$> peek status+ unless (R.PARSE_OK == toEnum rc) $+ throwIO . RError $ "Parse error in: " ++ txt+ return exprs antiSuffix :: String antiSuffix = "_hs"@@ -93,11 +108,11 @@ -- | Traverse 'R.SEXP' structure and find all occurences of antiquotations. collectAntis :: R.SEXP s a -> Set (SEXP s 'R.Char)-collectAntis (hexp -> Symbol name _ _)+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 name _ _) sxb))+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)@@ -118,12 +133,12 @@ -- @ expQQ :: String -> Q TH.Exp expQQ input = do- expr <- parse input+ expr <- runIO $ parse input let antis = [x | (hexp -> Char (Vector.toString -> x)) <- Set.toList (collectAntis expr)] args = map (TH.dyn . chop) antis closure = "function(" ++ intercalate "," antis ++ "){" ++ input ++ "}"- z = [| return (R.release H.nilValue) |]+ z = [| return (R.release nilValue) |] vars <- mapM (\_ -> TH.newName "x") antis -- Abstract over antis using fresh vars, to avoid captures with names bound -- internally (such as 'f' below).@@ -131,9 +146,9 @@ [| do -- Memoize the runtime parsing of the generated closure (provided the -- compiler notices that it can let-float to top-level). let sx = unsafePerformIO $ do- exprs <- parseText closure False+ exprs <- parse closure SomeSEXP e <- R.indexVector exprs 0- clos <- R.eval e (R.release H.globalEnv)+ clos <- R.eval e (R.release globalEnv) R.unSomeSEXP clos R.preserveObject return clos io $ case sx of
tests/Test/FunPtr.hs view
@@ -19,7 +19,6 @@ import qualified Foreign.R as R import qualified Foreign.R.Type as SingR import qualified Language.R.Internal as R (r2)-import Language.R.QQ import Test.Tasty hiding (defaultMain) import Test.Tasty.HUnit
tests/Test/GC.hs view
@@ -9,7 +9,6 @@ import H.Prelude import qualified Foreign.R as R import qualified Foreign.R.Type as SingR-import Language.R.QQ import Control.Exception (bracket) import Test.Tasty hiding (defaultMain)
tests/Test/Regions.hs view
@@ -9,7 +9,6 @@ import H.Prelude import qualified Foreign.R as R-import Language.R.QQ import Test.Tasty hiding (defaultMain) import Test.Tasty.HUnit
tests/Test/Vector.hs view
@@ -36,9 +36,7 @@ import qualified Data.Vector.Fusion.Stream as S #endif import qualified Foreign.R as R-import H.Prelude hiding (Show)-import Language.R.QQ-import Language.R.HExp (HExp(..), hexp)+import H.Prelude import Test.Tasty import Test.Tasty.QuickCheck import Test.Tasty.HUnit
tests/bench-qq.hs view
@@ -13,7 +13,6 @@ import Foreign.R as R import Language.R as R import H.Prelude as H-import Language.R.QQ import Control.Applicative import Control.Monad (void)
tests/test-qq.hs view
@@ -13,9 +13,7 @@ module Main where import qualified Foreign.R as R-import Foreign.R (SEXP) import H.Prelude as H-import Language.R.QQ import qualified Data.Vector.SEXP as SVector import qualified Data.Vector.SEXP.Mutable as SMVector import Control.Memory.Region@@ -24,7 +22,6 @@ import Control.Monad.Trans (liftIO) import Data.Int import Data.Singletons (sing)-import qualified Data.Text.Lazy as Text import Test.Tasty.HUnit hiding ((@=?)) import Prelude -- Silence AMP warning @@ -34,9 +31,10 @@ hFib n = (`R.asTypeOf` n) <$> [r| hFib_hs(n_hs - 1L) + hFib_hs(n_hs - 2L) |] -- | Version of '(@=?)' that works in the R monad.-(@=?) :: H.Show a => String -> a -> R s ()+(@=?) :: Literal a b => String -> a -> R s () expected @=? actual = liftIO $ do- assertEqual "" expected (Text.unpack (H.show actual))+ let actualstr = cast SString [rsafe| deparse(actual_hs) |]+ assertEqual "" expected (fromSEXP actualstr) main :: IO () main = H.withEmbeddedR H.defaultConfig $ H.runRegion $ do@@ -99,9 +97,6 @@ apply n m = [r| n_hs(m_hs) |] ("29L" @=?) =<< [r| apply_hs(foo5_hs, 28L ) |] - sym <- H.install "blah"- ("blah" @=?) sym- -- test Vector literal instance v1 <- do x <- SMVector.new 3 :: R s (SMVector.MVector s 'R.Int Int32)@@ -115,5 +110,14 @@ let utf8string = "abcd çéõßø" io . assertEqual "" utf8string =<< fromSEXP <$> R.cast (sing :: R.SSEXPTYPE 'R.String) <$> [r| utf8string_hs |]+++ -- Disable gctorture, otherwise test takes too long to execute.+ _ <- [r| gctorture2(0) |]+ let x = ([1] :: [Double])+ ("3" @=?) =<< [r| suppressMessages(require("Matrix"))+ v <- x_hs + 1+ v <- v + 1+ v |] return ()
tests/test-shootout.hs view
@@ -12,8 +12,7 @@ import Test.Scripts -import H.Prelude as H hiding (show)-import Language.R.QQ+import H.Prelude as H import Control.Monad (forM) import Control.Memory.Region
tests/tests.hs view
@@ -21,12 +21,10 @@ import qualified Test.Vector import H.Prelude-import Language.R.HExp import qualified Foreign.R as R import qualified Language.R.Instance as R ( initialize , defaultConfig )-import Language.R.QQ import Test.Tasty import Test.Tasty.HUnit