inline-r 0.9.0.2 → 0.9.1

raw patch · 23 files changed

+1073/−715 lines, 23 filesdep +inline-cdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: inline-c

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• inline-r.cabal +12/−4
• src/Foreign/R.c +254/−0
• src/Foreign/R.chs +0/−442
• src/Foreign/R.hsc +499/−0
• src/Foreign/R/Constraints.hs +1/−2
• src/Foreign/R/Context.hsc +59/−0
• src/Foreign/R/Embedded.chs +0/−26
• src/Foreign/R/Embedded.hsc +34/−0
• src/Foreign/R/Error.chs +0/−21
• src/Foreign/R/Error.hsc +21/−0
• src/Foreign/R/Internal.hsc +2/−7
• src/Foreign/R/Parse.chs +0/−45
• src/Foreign/R/Parse.hsc +69/−0
• src/Foreign/R/Type.hsc +1/−26
• src/Language/R/HExp.hs-boot +0/−4
• src/Language/R/HExp.hsc +43/−68
• src/Language/R/Literal.hs +4/−2
• src/Language/R/Matcher.hs +1/−1
• src/Language/R/QQ.hs +4/−2
• tests/Test/Matcher.hs +63/−0
• tests/Test/Parser.hs +0/−63
• tests/tests.hs +2/−2

@@ -1,5 +1,9 @@ # Change Log +## 0.9.1 - 2018-01-26+* Droped c2hs usage. Fixes installation on macOS.+* Fix QQ generation. Fixed possible resource free during QQ generation.+ ## 0.9.0.2 - 2016-10-23 * Fix build on ghc-8.2. * Introduce Matcher API.

@@ -1,5 +1,5 @@ name:                inline-r-version:             0.9.0.2+version:             0.9.1 license:             BSD3 license-file:        LICENSE copyright:           Copyright (c) 2013-2015 Amgen, Inc.@@ -48,6 +48,7 @@                        Data.Vector.SEXP.Mutable                        Foreign.R                        Foreign.R.Constraints+                       Foreign.R.Context                        Foreign.R.Embedded                        Foreign.R.Error                        Foreign.R.Internal@@ -94,6 +95,14 @@                      , th-orphans >= 0.8                      , transformers >= 0.3                      , vector >= 0.10 && < 0.13+  if impl(ghc < 8.2.1)+    build-depends:+      inline-c >=0.5.6.1 && <0.6+    c-sources:+      src/Foreign/R.c+  else+    build-depends:+      inline-c >=0.6 && <0.7   hs-source-dirs:      src   includes:            cbits/missing_r.h   c-sources:           cbits/missing_r.c@@ -101,8 +110,7 @@   default-language:    Haskell2010   other-extensions:    CPP                        ForeignFunctionInterface-  build-tools:         c2hs-                     , hsc2hs+  build-tools:         hsc2hs   if os(windows)     extra-libraries:   R   else@@ -142,7 +150,7 @@                        Test.Event                        Test.Regions                        Test.Vector-                       Test.Parser+                       Test.Matcher   -- Adding -j4 causes quasiquoters to be compiled concurrently   -- in tests, which helps testing for race conditions when   -- trying to initialize R from multiple threads.

@@ -0,0 +1,254 @@++#include <Rinternals.h>++#include <stdlib.h>++SEXP inline_c_Foreign_R_0_9ac4562d8ebe9f2d5b52142d8b99697816220748(SEXP s_inline_c_0) {+return ( CAR( s_inline_c_0 ) );+}+++SEXP inline_c_Foreign_R_1_9ac4562d8ebe9f2d5b52142d8b99697816220748(SEXP s_inline_c_0) {+return ( CAR( s_inline_c_0 ) );+}+++SEXP inline_c_Foreign_R_2_c4c0eada410b32434665934795b7db0755802aa0(SEXP s_inline_c_0) {+return ( TAG( s_inline_c_0 ) );+}+++SEXP inline_c_Foreign_R_3_cfa520d753fc0262696ca1a84e30b84cd0e8457c(SEXP s_inline_c_0) {+return ( FRAME( s_inline_c_0 ) );+}+++SEXP inline_c_Foreign_R_4_88a8e173a8634b579f1465e01765614d09169107(SEXP s_inline_c_0) {+return ( ENCLOS( s_inline_c_0 ) );+}+++SEXP inline_c_Foreign_R_5_f41ea2abb505e4001eca9f52e80c3cd86ca41452(SEXP s_inline_c_0) {+return ( HASHTAB( s_inline_c_0 ) );+}+++SEXP inline_c_Foreign_R_6_08304863ec80cca65182799dafb8bada5711f636(SEXP s_inline_c_0) {+return ( FORMALS( s_inline_c_0 ) );+}+++SEXP inline_c_Foreign_R_7_eeb3464221812c40270f1d0db6118803cf504819(SEXP s_inline_c_0) {+return ( BODY( s_inline_c_0 ) );+}+++SEXP inline_c_Foreign_R_8_00f7ebadb2693dcb69a30c64fbd07e5ce907738e(SEXP s_inline_c_0) {+return ( CLOENV( s_inline_c_0 ) );+}+++SEXP inline_c_Foreign_R_9_2b683ec3793cf9e95c1cd7634ca8b89d1efda6ac(SEXP s_inline_c_0) {+return ( PRVALUE( s_inline_c_0 ));+}+++SEXP inline_c_Foreign_R_10_3ed141c2f3da0f50478b9f565b29e0cf434fa5a6(SEXP s_inline_c_0) {+return ( PRENV( s_inline_c_0 ));+}+++SEXP inline_c_Foreign_R_11_311da71ae5bf546de0b07f93aa78461ad0d7ec57(SEXP s_inline_c_0) {+return ( PRCODE( s_inline_c_0 ));+}+++int inline_c_Foreign_R_12_8c5c1fd6560f4ce545f63bfe49820bc3d3659956(SEXP s_inline_c_0) {+return ( TRUELENGTH( s_inline_c_0 ) );+}+++const char * inline_c_Foreign_R_13_306a964504a2977974ccc1d13f083f8a0098a33a(SEXP s_inline_c_0) {+return ( CHAR(s_inline_c_0));+}+++double * inline_c_Foreign_R_14_e8baa047ffedb94c6e841341c90e5bf18b2df6cb(SEXP s_inline_c_0) {+return ( REAL( s_inline_c_0) );+}+++int32_t * inline_c_Foreign_R_15_ddf45047733520c72a3ead2cfd2a280fa3f90458(SEXP s_inline_c_0) {+return ( INTEGER( s_inline_c_0 ));+}+++char * inline_c_Foreign_R_16_4b3d17a51b6529b826e8c5bfa4cbeeee0fc23209(SEXP s_inline_c_0) {+return ( RAW(s_inline_c_0) );+}+++int * inline_c_Foreign_R_17_d580ef2b3a4306f2e3c98f5917b8b15e61487652(SEXP s_inline_c_0) {+return ( LOGICAL(s_inline_c_0) );+}+++Rcomplex * inline_c_Foreign_R_18_a78b3e677291a9c6faeeda3171886d1546a8fe2f(SEXP s_inline_c_0) {+return ( COMPLEX(s_inline_c_0) );+}+++SEXP * inline_c_Foreign_R_19_f8c583061f1f156cb2922c59012ee03d103d09f3(SEXP s_inline_c_0) {+return ( STRING_PTR(s_inline_c_0) );+}+++SEXP inline_c_Foreign_R_20_502f2e4c0c21d4e444b277c80f1f1a839fed21ee(SEXP s_inline_c_0, int n_inline_c_1) {+return ( VECTOR_ELT( s_inline_c_0, n_inline_c_1 ) );+}+++SEXP inline_c_Foreign_R_21_6044fb2a9fa0c80b919984361e609c76d51efd6a(SEXP a_inline_c_0, int n_inline_c_1, SEXP b_inline_c_2) {+return ( SET_VECTOR_ELT(a_inline_c_0,n_inline_c_1, b_inline_c_2) );+}+++SEXP inline_c_Foreign_R_22_bf5c65cd674a4ee46795158c4c25efe4adc3c31e(SEXP s_inline_c_0) {+return ( PRINTNAME( s_inline_c_0) );+}+++SEXP inline_c_Foreign_R_23_9cb109af6528d13922a4437aa08b9e300c57e067(SEXP s_inline_c_0) {+return ( SYMVALUE( s_inline_c_0) );+}+++SEXP inline_c_Foreign_R_24_77b9e12a6e8b49be6ad94bfc5a7556452bec26ee(SEXP s_inline_c_0) {+return ( INTERNAL( s_inline_c_0) );+}+++SEXP inline_c_Foreign_R_25_9d1497356b19a1672ff9d062c14e4a66cd940330(char * value_inline_c_0) {+return ( Rf_mkString(value_inline_c_0) );+}+++SEXP inline_c_Foreign_R_26_b499bcbe64ec29676b9eeb059ee2f1fd076b603c(char * value_inline_c_0) {+return ( Rf_mkChar(value_inline_c_0) );+}+++SEXP inline_c_Foreign_R_27_97cb6796cb20eebd3952787597b0a891de13baca(char * value_inline_c_0, int ce_inline_c_1) {+return ( Rf_mkCharCE(value_inline_c_0, ce_inline_c_1) );+}+++SEXP inline_c_Foreign_R_28_358ff488f4bb3977dfcb5baf80a86e83a33096b5(char * name_inline_c_0) {+return ( Rf_install(name_inline_c_0) );+}+++SEXP inline_c_Foreign_R_29_a7a3ad06904be40179e687c85320f64c64c3439b(unsigned s_inline_c_0) {+return ( Rf_allocSExp( s_inline_c_0 ) );+}+++SEXP inline_c_Foreign_R_30_96e76e88957819df4d68e77b0c4601c6b8d0d5ac(int n_inline_c_0) {+return (Rf_allocList(n_inline_c_0));+}+++SEXP inline_c_Foreign_R_31_2e3d3d510438d7b4472b0ec840c602625c28e895(unsigned p_inline_c_0, int n_inline_c_1) {+return (Rf_allocVector( p_inline_c_0, n_inline_c_1) );+}+++SEXP inline_c_Foreign_R_32_6df82e7267bd3132e472fd9fc5abef02f77c786c(SEXP a_inline_c_0, SEXP b_inline_c_1) {+return ( Rf_cons(a_inline_c_0, b_inline_c_1) );+}+++SEXP inline_c_Foreign_R_33_5d0e6900bd9d03c953baea8253edcba6c6243e0e(SEXP a_inline_c_0, SEXP b_inline_c_1) {+return ( Rf_lcons(a_inline_c_0, b_inline_c_1) );+}+++void inline_c_Foreign_R_34_a86150c5c5230395a66b5aa480799296d4686db4(SEXP s_inline_c_0) {+ Rf_PrintValue(s_inline_c_0) ;+}+++SEXP inline_c_Foreign_R_35_0a5c53e1aee56e0de60cb177f0edf14227ad665c(SEXP s_inline_c_0) {+return ( Rf_protect(s_inline_c_0) );+}+++void inline_c_Foreign_R_36_429a287fe0eefa7d81c06cf88e820974b383daf1(int i_inline_c_0) {+ Rf_unprotect(i_inline_c_0) ;+}+++void inline_c_Foreign_R_37_a5fa62b73e2ecddba7265a2be8cb3c0ffcee557f(SEXP s_inline_c_0) {+ Rf_unprotect_ptr(s_inline_c_0) ;+}+++void inline_c_Foreign_R_38_380434553ebc421919de5f6266f6b67c4ceb134d() {+ R_gc() ;+}+++void inline_c_Foreign_R_39_7b402e46bce46d9ab6f3d251ada670baff8e05a9(SEXP s_inline_c_0) {+ R_PreserveObject( s_inline_c_0 );+}+++void inline_c_Foreign_R_40_750ea415e41427d35ca1e926375a0d21d4d5f19b(SEXP s_inline_c_0) {+ R_ReleaseObject( s_inline_c_0 );+}+++SEXP inline_c_Foreign_R_41_ec6f426618ff7aa18237e2a78831c6bb81fc6368(SEXP expr_inline_c_0, SEXP env_inline_c_1) {+return ( Rf_eval(expr_inline_c_0, env_inline_c_1) );+}+++SEXP inline_c_Foreign_R_42_7a1331564f59685bfaf46bc9f47ca3560ae1e97d(SEXP expr_inline_c_0, SEXP env_inline_c_1, int * retCode_inline_c_2) {+return ( R_tryEval(expr_inline_c_0, env_inline_c_1, retCode_inline_c_2) );+}+++SEXP inline_c_Foreign_R_43_f7b5b859d36e6970dad17270944cadf4d42349be(SEXP expr_inline_c_0, SEXP env_inline_c_1, int * retCode_inline_c_2) {+return ( R_tryEvalSilent(expr_inline_c_0, env_inline_c_1, retCode_inline_c_2) );+}+++SEXP inline_c_Foreign_R_44_ece895f975aabfd0a332423a7b0410d03fa10a06(SEXP s_inline_c_0) {+return (Rf_lang1(s_inline_c_0) );+}+++SEXP inline_c_Foreign_R_45_3a6d98bf9d66e9c8887bcacbeff51cb644e48e1a(SEXP f_inline_c_0, SEXP x_inline_c_1) {+return (Rf_lang2(f_inline_c_0, x_inline_c_1) );+}+++SEXP inline_c_Foreign_R_46_c5c313abb017c03512777a01709c3d9fbf71fcac(SEXP f_inline_c_0, SEXP x_inline_c_1, SEXP y_inline_c_2) {+return (Rf_lang3(f_inline_c_0, x_inline_c_1, y_inline_c_2) );+}+++SEXP inline_c_Foreign_R_47_3613a760d00d0a7f584ac9bafcefbd2af7ebdf77(SEXP a_inline_c_0, SEXP env_inline_c_1) {+return ( Rf_findFun(a_inline_c_0, env_inline_c_1) );+}+++SEXP inline_c_Foreign_R_48_9600e44aa0ae956e1d299718d0827a67ffde9a6a(SEXP a_inline_c_0, SEXP env_inline_c_1) {+return (Rf_findVar(a_inline_c_0, env_inline_c_1));+}+++SEXP inline_c_Foreign_R_49_73c7bf706d49a8e678a17c1922d1ee6810212d45(SEXP a_inline_c_0, SEXP b_inline_c_1, SEXP c_inline_c_2, int t_inline_c_3) {+return (R_MakeWeakRef(a_inline_c_0, b_inline_c_1, c_inline_c_2, t_inline_c_3));+}+

@@ -1,442 +0,0 @@--- |--- Copyright: (C) 2013 Amgen, Inc.------ Low-level bindings to core R datatypes and functions. Nearly all structures--- allocated internally in R are instances of a 'SEXPREC'. A pointer to--- a 'SEXPREC' is called a 'SEXP'.------ To allow for precise typing of bindings to primitive R functions, we index--- 'SEXP's by 'SEXPTYPE', which classifies the /form/ of a 'SEXP' (see--- "Foreign.R.Type"). A function accepting 'SEXP' arguments of any type should--- leave the type index uninstantiated. A function returning a 'SEXP' result of--- unknown type should use 'SomeSEXP'. (More precisely, unknown types in--- /negative/ position should be /universally/ quantified and unknown types in--- /positive/ position should be /existentially/ quantified).------ This module is intended to be imported qualified.--{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE DeriveDataTypeable #-}-#endif-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}---- Necessary for c2hs < 0.26 compat.-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# OPTIONS_GHC -fno-warn-unused-matches #-}-#if __GLASGOW_HASKELL__ >= 710--- We don't use ticks in this module, because they confuse c2hs.-{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}-#endif-module Foreign.R-  ( module Foreign.R.Type-    -- * Internal R structures-  , SEXP(..)-  , SomeSEXP(..)-  , unSomeSEXP-    -- * Casts and coercions-    -- $cast-coerce-  , cast-  , asTypeOf-  , unsafeCoerce-    -- * Node creation-  , allocSEXP-  , allocList-  , allocVector-  , allocVectorProtected-  , install-  , mkString-  , mkChar-  , CEType(..)-  , mkCharCE-  , mkWeakRef-    -- * Node attributes-  , typeOf-  , isS4-  , setAttributes-  , getAttribute-  , getAttributes-    -- * Node accessor functions-    -- ** Lists-  , cons-  , lcons-  , car-  , cdr-  , tag-  , setCar-  , setCdr-  , setTag-    -- ** Environments-  , envFrame-  , envEnclosing-  , envHashtab-    -- ** Closures-  , closureFormals-  , closureBody-  , closureEnv-    -- ** Promises-  , promiseCode-  , promiseEnv-  , promiseValue-    -- ** Symbols-  , symbolPrintName-  , symbolValue-  , symbolInternal-    -- ** Vectors-  , length-  , trueLength-  , char-  , real-  , integer-  , logical-  , complex-  , raw-  , string-  , unsafeSEXPToVectorPtr-  , unsafeVectorPtrToSEXP-  , readVector-  , writeVector-    -- * Evaluation-  , eval-  , tryEval-  , tryEvalSilent-  , lang1-  , lang2-  , lang3-  , findFun-  , findVar-    -- * GC functions-  , protect-  , unprotect-  , unprotectPtr-  , preserveObject-  , releaseObject-  , gc-    -- * Globals-  , isRInteractive-  , nilValue-  , unboundValue-  , missingArg-  , baseEnv-  , emptyEnv-  , globalEnv-  , signalHandlers-  , interruptsPending-    -- * Communication with runtime-  , printValue-    -- * Low level info header access-  , SEXPInfo(..)-  , peekInfo-  , pokeInfo-  , mark-  , named-  -- * Internal types and functions-  ---  -- | Should not be used in user code. These exports are only needed for-  -- binding generation tools.-  , SEXPREC-  , SEXP0-  , sexp-  , unsexp-  , release-  , unsafeRelease-  , withProtected-  -- * Deprecated-  , indexVector-  ) where--import Control.Memory.Region-import {-# SOURCE #-} Language.R.HExp (HExp)-import Foreign.R.Internal hiding (SEXP0)-import Foreign.R.Type-import Foreign.R.Type as R--import Control.Applicative-import Control.DeepSeq (NFData(..))-import Control.Exception (bracket)-import Control.Monad.Primitive ( unsafeInlineIO )-import Data.Bits -- For c2hs < 0.26.-import Data.Complex-import Data.Int (Int32)-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 <R_ext/Memory.h>-#include "missing_r.h"----- | '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 #}---- 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                                                 --------------------------------------------------------------------------------------- | read CAR object value-{#fun CAR as car { unsexp `SEXP s a' } -> `SomeSEXP s' somesexp #}---- | read CDR object-{#fun CDR as cdr { unsexp `SEXP s a' } -> `SomeSEXP s' somesexp #}---- | read object`s Tag-{# fun TAG as tag { unsexp `SEXP s a' } -> `SomeSEXP s' somesexp #}  --- XXX: add better constraint------------------------------------------------------------------------------------- Environment functions                                                      --------------------------------------------------------------------------------------- | Environment frame.-{# fun FRAME as envFrame { unsexp `SEXP s R.Env' } -> `SEXP s R.PairList' sexp #}---- | Enclosing environment.-{# fun ENCLOS as envEnclosing { unsexp `SEXP s R.Env' } -> `SEXP s R.Env' sexp #}---- | Hash table associated with the environment, used for faster name lookups.-{# fun HASHTAB as envHashtab { unsexp `SEXP s R.Env' } -> `SEXP s R.Vector' sexp #}------------------------------------------------------------------------------------- Closure functions                                                          --------------------------------------------------------------------------------------- | Closure formals (aka the actual arguments).-{# fun FORMALS as closureFormals { unsexp `SEXP s R.Closure' } -> `SEXP s R.PairList' sexp #}---- | The code of the closure.-{# fun BODY as closureBody { unsexp `SEXP s R.Closure' } -> `SomeSEXP s' somesexp #}---- | The environment of the closure.-{# fun CLOENV as closureEnv { unsexp `SEXP s R.Closure' } -> `SEXP s R.Env' sexp #}------------------------------------------------------------------------------------- Promise functions                                                          --------------------------------------------------------------------------------------- | The code of a promise.-{# fun PRCODE as promiseCode { unsexp `SEXP s R.Promise'} -> `SomeSEXP s' somesexp #}---- | The environment in which to evaluate the promise.-{# fun PRENV as promiseEnv { unsexp `SEXP s R.Promise'} -> `SEXP s R.Env' sexp #}---- | The value of the promise, if it has already been forced.-{# fun PRVALUE as promiseValue { unsexp `SEXP s R.Promise'} -> `SomeSEXP s' somesexp #}------------------------------------------------------------------------------------- Vector accessor functions                                                  --------------------------------------------------------------------------------------- | Read True Length vector field.-{#fun TRUELENGTH as trueLength `R.IsVector a' => { unsexp `SEXP s a' } -> `CInt' id #}---- | Read character vector data-{#fun R_CHAR as char { unsexp `SEXP s R.Char' } -> `CString' id #}--- XXX: check if we really need Word8 here, maybe some better handling of--- encoding---- | Read real vector data.-{#fun REAL as real { unsexp `SEXP s R.Real' } -> `Ptr Double' castPtr #}---- | Read integer vector data.-{#fun unsafe INTEGER as integer { unsexp `SEXP s R.Int' } -> `Ptr Int32' castPtr #}---- | Read raw data.-{#fun RAW as raw { unsexp `SEXP s R.Raw' } -> `Ptr CChar' castPtr #}---- XXX Workaround c2hs syntax limitations.-type RLogical = 'R.Logical---- | Read logical vector data.-{#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' }-      -> `Ptr (Complex Double)' castPtr #}---- | Read string vector data.-{#fun STRING_PTR as string { unsexp `SEXP s R.String'}-      -> `Ptr (SEXP s R.Char)' castPtr #}--{# fun VECTOR_ELT as readVector `R.IsGenericVector a'-     => { unsexp `SEXP s a', `Int' }-     -> `SomeSEXP s' somesexp #}--indexVector :: IsGenericVector a => SEXP s a -> Int -> IO (SomeSEXP s)-{-# DEPRECATED indexVector "Use readVector instead." #-}-indexVector = readVector--{# fun SET_VECTOR_ELT as writeVector `R.IsGenericVector a'-     => { unsexp `SEXP s a', `Int', unsexp `SEXP s b' }-     -> `SEXP s a' sexp #}------------------------------------------------------------------------------------- Symbol accessor functions                                                  --------------------------------------------------------------------------------------- | Read a name from symbol.-{#fun PRINTNAME as symbolPrintName { unsexp `SEXP s R.Symbol' } -> `SEXP s R.Char' sexp #}---- | Read value from symbol.-{#fun SYMVALUE as symbolValue { unsexp `SEXP s R.Symbol' } -> `SEXP s a' sexp #}---- | Read internal value from symbol.-{#fun INTERNAL as symbolInternal { unsexp `SEXP s R.Symbol' } -> `SEXP s a' sexp #}------------------------------------------------------------------------------------- Value conversion                                                           ------------------------------------------------------------------------------------------------------------------------------------------------------------------------ Value contruction                                                          --------------------------------------------------------------------------------------- | Initialize a new string vector.-{#fun Rf_mkString as mkString { id `CString' } -> `SEXP V R.String' sexp #}---- | Initialize a new character vector (aka a string).-{#fun Rf_mkChar as mkChar { id `CString' } -> `SEXP V R.Char' sexp #}---- | Create Character value with specified encoding-{#fun Rf_mkCharCE as mkCharCE_ { id `CString', cIntFromEnum `CEType' } -> `SEXP V R.Char' sexp #}--mkCharCE :: CEType -> CString -> IO (SEXP V R.Char)-mkCharCE = flip mkCharCE_---- | Intern a string @name@ into the symbol table.------ If @name@ is not found, it is added to the symbol table. The symbol--- corresponding to the string @name@ is returned.-{#fun Rf_install as install { id `CString' } -> `SEXP V R.Symbol' sexp #}---- | Allocate a 'SEXP'.-{#fun Rf_allocSExp as allocSEXP { cUIntFromSingEnum `SSEXPTYPE a' }-      -> `SEXP V a' sexp #}---- | Allocate a pairlist of 'SEXP's, chained together.-{#fun Rf_allocList as allocList { `Int' } -> `SEXP V R.List' sexp #}---- | Allocate Vector.-{#fun Rf_allocVector as allocVector `R.IsVector a'-      => { cUIntFromSingEnum `SSEXPTYPE a',`Int' }-      -> `SEXP V a' sexp #}--allocVectorProtected :: (R.IsVector a) => SSEXPTYPE a -> Int -> IO (SEXP s a)-allocVectorProtected ty n = fmap release (protect =<< allocVector ty n)---- | Allocate a so-called cons cell, in essence a pair of 'SEXP' pointers.-{#fun Rf_cons as cons { unsexp `SEXP s a', unsexp `SEXP s b' } -> `SEXP V R.List' sexp #}---- | Allocate a so-called cons cell of language objects, in essence a pair of--- 'SEXP' pointers.-{#fun Rf_lcons as lcons { unsexp `SEXP s a', unsexp `SEXP s b' } -> `SEXP V R.Lang' sexp #}---- | Print a string representation of a 'SEXP' on the console.-{#fun Rf_PrintValue as printValue { unsexp `SEXP s a'} -> `()' #}------------------------------------------------------------------------------------- Garbage collection                                                         --------------------------------------------------------------------------------------- | Protect a 'SEXP' from being garbage collected by R. It is in particular--- necessary to do so for objects that are not yet pointed by any other object,--- e.g. when constructing a tree bottom-up rather than top-down.------ To avoid unbalancing calls to 'protect' and 'unprotect', do not use these--- functions directly but use 'Language.R.withProtected' instead.-{#fun Rf_protect as protect { unsexp `SEXP s a'} -> `SEXP G a' sexp #}---- | @unprotect n@ unprotects the last @n@ objects that were protected.-{#fun Rf_unprotect as unprotect { `Int' } -> `()' #}---- | Unprotect a specific object, referred to by pointer.-{#fun Rf_unprotect_ptr as unprotectPtr { unsexp `SEXP G a' } -> `()' #}---- | Invoke an R garbage collector sweep.-{#fun R_gc as gc { } -> `()' #}---- | Preserve an object accross GCs.-{#fun R_PreserveObject as preserveObject { unsexp `SEXP s a' } -> `()' #}---- | Allow GC to remove an preserved object.-{#fun R_ReleaseObject as releaseObject { unsexp `SEXP s a' } -> `()' #}------------------------------------------------------------------------------------- Evaluation                                                                 --------------------------------------------------------------------------------------- | Evaluate any 'SEXP' to its value.-{#fun Rf_eval as eval { unsexp `SEXP s a', unsexp `SEXP s R.Env' }-      -> `SomeSEXP V' somesexp #}---- | Try to evaluate expression.-{#fun R_tryEval as tryEval { unsexp `SEXP s a', unsexp `SEXP s R.Env', id `Ptr CInt'}-      -> `SomeSEXP V' somesexp #}---- | Try to evaluate without printing error/warning messages to stdout.-{#fun R_tryEvalSilent as tryEvalSilent-    { unsexp `SEXP s a', unsexp `SEXP s R.Env', id `Ptr CInt'}-      -> `SomeSEXP V' somesexp #}---- | Construct a nullary function call.-{#fun Rf_lang1 as lang1 { unsexp `SEXP s a'} -> `SEXP V R.Lang' sexp #}---- | Construct unary function call.-{#fun Rf_lang2 as lang2 { unsexp `SEXP s a', unsexp `SEXP s b'} -> `SEXP V R.Lang' sexp #}---- | Construct a binary function call.-{#fun Rf_lang3 as lang3 { unsexp `SEXP s a', unsexp `SEXP s b', unsexp `SEXP s c'}-      -> `SEXP V R.Lang' sexp #}---- | Find a function by name.-{#fun Rf_findFun as findFun { unsexp `SEXP s a', unsexp `SEXP s R.Env'}-      -> `SomeSEXP s' somesexp #}---- | Find a variable by name.-{#fun Rf_findVar as findVar { unsexp `SEXP s a', unsexp `SEXP s R.Env'}-      -> `SEXP s R.Symbol' sexp #}--{#fun R_MakeWeakRef as mkWeakRef { unsexp `SEXP s a', unsexp `SEXP s b', unsexp `SEXP s c', cIntFromEnum `Bool' }-      -> `SEXP V R.WeakRef' sexp #}------------------------------------------------------------------------------------ Encoding                                                                  -------------------------------------------------------------------------------------- | Content encoding.-{#enum cetype_t as CEType {} deriving (Eq, Show) #}---- | Perform an action with resource while protecting it from the garbage--- collection. This function is a safer alternative to 'R.protect' and--- 'R.unprotect', guaranteeing that a protected resource gets unprotected--- irrespective of the control flow, much like 'Control.Exception.bracket_'.-withProtected :: IO (SEXP V a)      -- Action to acquire resource-              -> (SEXP s a -> IO b) -- Action-              -> IO b-withProtected create f =-    bracket-      (do { x <- create; _ <- protect x; return x })-      (const $ unprotect 1)-      (f . unsafeRelease)

@@ -0,0 +1,499 @@+-- |+-- Copyright: (C) 2013 Amgen, Inc.+--+-- Low-level bindings to core R datatypes and functions. Nearly all structures+-- allocated internally in R are instances of a 'SEXPREC'. A pointer to+-- a 'SEXPREC' is called a 'SEXP'.+--+-- To allow for precise typing of bindings to primitive R functions, we index+-- 'SEXP's by 'SEXPTYPE', which classifies the /form/ of a 'SEXP' (see+-- "Foreign.R.Type"). A function accepting 'SEXP' arguments of any type should+-- leave the type index uninstantiated. A function returning a 'SEXP' result of+-- unknown type should use 'SomeSEXP'. (More precisely, unknown types in+-- /negative/ position should be /universally/ quantified and unknown types in+-- /positive/ position should be /existentially/ quantified).+--+-- This module is intended to be imported qualified.++{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE DeriveDataTypeable #-}+#endif+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++-- Warns about some sanity checks like IsVector, that has no methods and are+-- not used.+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++module Foreign.R+  ( module Foreign.R.Type+    -- * Internal R structures+  , SEXP(..)+  , SomeSEXP(..)+  , unSomeSEXP+    -- * Casts and coercions+    -- $cast-coerce+  , cast+  , asTypeOf+  , unsafeCoerce+    -- * Node creation+  , allocSEXP+  , allocList+  , allocVector+  , allocVectorProtected+  , install+  , mkString+  , mkChar+  , CEType(..)+  , mkCharCE+  , mkWeakRef+    -- * Node attributes+  , typeOf+  , isS4+  , setAttributes+  , getAttribute+  , getAttributes+    -- * Node accessor functions+    -- ** Lists+  , cons+  , lcons+  , car+  , cdr+  , tag+  , setCar+  , setCdr+  , setTag+    -- ** Environments+  , envFrame+  , envEnclosing+  , envHashtab+    -- ** Closures+  , closureFormals+  , closureBody+  , closureEnv+    -- ** Promises+  , promiseCode+  , promiseEnv+  , promiseValue+    -- ** Symbols+  , symbolPrintName+  , symbolValue+  , symbolInternal+    -- ** Vectors+  , length+  , trueLength+  , char+  , real+  , integer+  , logical+  , complex+  , raw+  , string+  , unsafeSEXPToVectorPtr+  , unsafeVectorPtrToSEXP+  , readVector+  , writeVector+    -- * Evaluation+  , eval+  , tryEval+  , tryEvalSilent+  , lang1+  , lang2+  , lang3+  , findFun+  , findVar+    -- * GC functions+  , protect+  , unprotect+  , unprotectPtr+  , preserveObject+  , releaseObject+  , gc+    -- * Globals+  , isRInteractive+  , nilValue+  , unboundValue+  , missingArg+  , baseEnv+  , emptyEnv+  , globalEnv+  , signalHandlers+  , interruptsPending+    -- * Communication with runtime+  , printValue+    -- * Low level info header access+  , SEXPInfo(..)+  , peekInfo+  , pokeInfo+  , mark+  , named+  -- * Internal types and functions+  --+  -- | Should not be used in user code. These exports are only needed for+  -- binding generation tools.+  , SEXPREC+  , SEXP0+  , sexp+  , unsexp+  , release+  , unsafeRelease+  , withProtected+  -- * Deprecated+  , indexVector+  ) where++import Control.Memory.Region+import Data.Monoid ((<>))+import Foreign.R.Internal+import Foreign.R.Type+import Foreign.R.Type as R++import Control.Applicative+import Control.Exception (bracket)+import Data.Complex+import Data.Int (Int32)+#if __GLASGOW_HASKELL__ < 710+import Data.Typeable (Typeable)+#endif+import Foreign (Ptr, castPtr)+import Foreign.C+import Foreign.R.Context (rCtx, SEXP0, SEXPREC)+import qualified Language.C.Inline as C+import Prelude hiding (asTypeOf, length)++#define USE_RINTERNALS+#include <Rinternals.h>++C.context (C.baseCtx <> rCtx)+C.include "<Rinternals.h>"+C.include "<stdlib.h>"+C.include "<stdint.h>"++--------------------------------------------------------------------------------+-- Generic accessor functions                                                 --+--------------------------------------------------------------------------------++-- | read CAR object value+car :: SEXP s a -> IO (SomeSEXP s)+car (unsexp -> s) = somesexp <$> [C.exp| SEXP { CAR( $(SEXP s) ) } |]++-- | read CDR object+cdr :: SEXP s a -> IO (SomeSEXP s)+cdr (unsexp -> s) = somesexp <$> [C.exp| SEXP { CAR( $(SEXP s) ) } |]++-- | read object`s Tag+tag :: SEXP s a -> IO (SomeSEXP s)+tag (unsexp -> s) = somesexp <$> [C.exp| SEXP { TAG( $(SEXP s) ) } |]++--------------------------------------------------------------------------------+-- Environment functions                                                      --+--------------------------------------------------------------------------------++envFrame :: (SEXP s 'R.Env) -> IO (SEXP s R.PairList)+envFrame (unsexp -> s) = sexp <$> [C.exp| SEXP { FRAME( $(SEXP s) ) } |]++-- | Enclosing environment.+envEnclosing :: SEXP s 'R.Env -> IO (SEXP s 'R.Env)+envEnclosing (unsexp -> s) = sexp <$> [C.exp| SEXP { ENCLOS( $(SEXP s) ) } |]++-- | Hash table associated with the environment, used for faster name lookups.+envHashtab :: SEXP s 'R.Env -> IO (SEXP s 'R.Vector)+envHashtab (unsexp -> s) = sexp <$> [C.exp| SEXP { HASHTAB( $(SEXP s) ) } |]++--------------------------------------------------------------------------------+-- Closure functions                                                          --+--------------------------------------------------------------------------------++-- | Closure formals (aka the actual arguments).+closureFormals :: SEXP s 'R.Closure -> IO (SEXP s R.PairList)+closureFormals (unsexp -> s) = sexp <$> [C.exp| SEXP { FORMALS( $(SEXP s) ) }|]++-- | The code of the closure.+closureBody :: SEXP s 'R.Closure -> IO (SomeSEXP s)+closureBody (unsexp -> s) = somesexp <$> [C.exp| SEXP { BODY( $(SEXP s) ) } |]++-- | The environment of the closure.+closureEnv :: SEXP s 'R.Closure -> IO (SEXP s 'R.Env)+closureEnv (unsexp -> s) = sexp <$> [C.exp| SEXP { CLOENV( $(SEXP s) ) }|]++--------------------------------------------------------------------------------+-- Promise functions                                                          --+--------------------------------------------------------------------------------++-- | The code of a promise.+promiseCode :: SEXP s 'R.Promise -> IO (SomeSEXP s)+promiseCode (unsexp -> s) = somesexp <$> [C.exp| SEXP { PRCODE( $(SEXP s) )}|]++-- | The environment in which to evaluate the promise.+promiseEnv :: SEXP s 'R.Promise -> IO (SomeSEXP s)+promiseEnv (unsexp -> s) = somesexp <$> [C.exp| SEXP { PRENV( $(SEXP s) )}|]++-- | The value of the promise, if it has already been forced.+promiseValue :: SEXP s 'R.Promise -> IO (SomeSEXP s)+promiseValue (unsexp -> s) = somesexp <$> [C.exp| SEXP { PRVALUE( $(SEXP s) )}|]++--------------------------------------------------------------------------------+-- Vector accessor functions                                                  --+--------------------------------------------------------------------------------++-- | Read True Length vector field.+trueLength :: R.IsVector a => SEXP s a -> IO CInt+trueLength (unsexp -> s) = [C.exp| int { TRUELENGTH( $(SEXP s) ) }|]++-- | Read character vector data+char :: SEXP s 'R.Char -> IO CString+char (unsexp -> s) = castPtr <$> [C.exp| const char* { CHAR($(SEXP s))}|]+-- XXX: check if we really need Word8 here, maybe some better handling of+-- encoding++-- | Read real vector data.+real :: SEXP s 'R.Real -> IO (Ptr Double)+real (unsexp -> s) = castPtr <$> [C.exp| double* { REAL( $(SEXP s)) }|]++-- | Read integer vector data.+integer :: SEXP s 'R.Int -> IO (Ptr Int32)+integer (unsexp -> s) = [C.exp| int32_t* { INTEGER( $(SEXP s) )}|]++-- | Read raw data.+raw :: SEXP s 'R.Raw -> IO (Ptr CChar)+raw (unsexp -> s) = [C.exp| char* { RAW($(SEXP s)) } |]++-- | Read logical vector data.+logical :: SEXP s 'R.Logical -> IO (Ptr R.Logical)+logical (unsexp -> s) = castPtr <$>+  [C.exp| int* { LOGICAL($(SEXP s)) } |]++-- | Read complex vector data.+complex :: SEXP s 'R.Complex -> IO (Ptr (Complex Double))+complex (unsexp -> s) = [C.exp| Rcomplex* { COMPLEX($(SEXP s)) }|]++-- | Read string vector data.+string :: SEXP s 'R.String -> IO (Ptr (SEXP s 'R.Char))+string (unsexp -> s) = castPtr <$>+  [C.exp| SEXP* { STRING_PTR($(SEXP s)) }|]++readVector :: R.IsGenericVector a => SEXP s a -> Int -> IO (SomeSEXP s)+readVector (unsexp -> s) (fromIntegral -> n) = somesexp <$>+  [C.exp| SEXP { VECTOR_ELT( $(SEXP s), $(int n) ) } |]++indexVector :: IsGenericVector a => SEXP s a -> Int -> IO (SomeSEXP s)+{-# DEPRECATED indexVector "Use readVector instead." #-}+indexVector = readVector++writeVector :: R.IsGenericVector a => SEXP s a -> Int -> SEXP s b -> IO (SEXP s a)+writeVector (unsexp -> a) (fromIntegral -> n) (unsexp -> b) = sexp <$>+  [C.exp| SEXP { SET_VECTOR_ELT($(SEXP a),$(int n), $(SEXP b)) } |]++--------------------------------------------------------------------------------+-- Symbol accessor functions                                                  --+--------------------------------------------------------------------------------++-- | Read a name from symbol.+symbolPrintName :: SEXP s 'R.Symbol -> IO (SEXP s a)+symbolPrintName (unsexp -> s) = sexp <$> [C.exp| SEXP { PRINTNAME( $(SEXP s)) } |]++-- | Read value from symbol.+symbolValue :: SEXP s 'R.Symbol -> IO (SEXP s a)+symbolValue (unsexp -> s) = sexp <$> [C.exp| SEXP { SYMVALUE( $(SEXP s)) } |]++-- | Read internal value from symbol.+symbolInternal :: SEXP s 'R.Symbol -> IO (SEXP s a)+symbolInternal (unsexp -> s) = sexp <$> [C.exp| SEXP { INTERNAL( $(SEXP s)) }|]++--------------------------------------------------------------------------------+-- Value contruction                                                          --+--------------------------------------------------------------------------------++-- | Initialize a new string vector.+mkString :: CString -> IO (SEXP V 'R.String)+mkString value = sexp <$>  [C.exp| SEXP { Rf_mkString($(char * value)) } |]++-- | Initialize a new character vector (aka a string).+mkChar :: CString -> IO (SEXP V 'R.Char)+mkChar value = sexp <$> [C.exp| SEXP { Rf_mkChar($(char * value)) } |]++-- | Create Character value with specified encoding+mkCharCE :: CEType -> CString -> IO (SEXP V 'R.Char)+mkCharCE (cIntFromEnum -> ce) value = sexp <$> +  [C.exp| SEXP  { Rf_mkCharCE($(char * value), $(int ce)) } |]++-- | Intern a string @name@ into the symbol table.+--+-- If @name@ is not found, it is added to the symbol table. The symbol+-- corresponding to the string @name@ is returned.+install :: CString -> IO (SEXP V 'R.Symbol)+install name = sexp <$>+  [C.exp| SEXP { Rf_install($(char * name)) }|]++-- | Allocate a 'SEXP'.+allocSEXP :: SSEXPTYPE a -> IO (SEXP V a)+allocSEXP (cUIntFromSingEnum -> s) = sexp <$>+  [C.exp| SEXP { Rf_allocSExp( $(unsigned int s) ) }|]++-- | Allocate a pairlist of 'SEXP's, chained together.+allocList :: Int -> IO (SEXP V 'R.List)+allocList (fromIntegral -> n) = sexp <$> [C.exp| SEXP {Rf_allocList($(int n))} |]++-- | Allocate Vector.+allocVector :: R.IsVector a => SSEXPTYPE a -> Int -> IO (SEXP V a)+allocVector (cUIntFromSingEnum -> p) (fromIntegral -> n) = sexp <$>+  [C.exp| SEXP {Rf_allocVector( $(unsigned int p), $(int n)) } |]++allocVectorProtected :: (R.IsVector a) => SSEXPTYPE a -> Int -> IO (SEXP s a)+allocVectorProtected ty n = fmap release (protect =<< allocVector ty n)++-- | Allocate a so-called cons cell, in essence a pair of 'SEXP' pointers.+cons :: SEXP s a -> SEXP s b -> IO (SEXP V 'R.List)+cons (unsexp -> a) (unsexp -> b) = sexp <$>+  [C.exp| SEXP { Rf_cons($(SEXP a), $(SEXP b)) }|]++-- | Allocate a so-called cons cell of language objects, in essence a pair of+-- 'SEXP' pointers.+lcons :: SEXP s a -> SEXP s b -> IO (SEXP V 'R.Lang)+lcons (unsexp -> a) (unsexp -> b) = sexp <$>+  [C.exp| SEXP { Rf_lcons($(SEXP a), $(SEXP b)) } |]+++printValue :: SEXP s a -> IO ()+printValue (unsexp -> s) =+  [C.exp| void { Rf_PrintValue($(SEXP s)) }|]++--------------------------------------------------------------------------------+-- Garbage collection                                                         --+--------------------------------------------------------------------------------++-- | Protect a 'SEXP' from being garbage collected by R. It is in particular+-- necessary to do so for objects that are not yet pointed by any other object,+-- e.g. when constructing a tree bottom-up rather than top-down.+--+-- To avoid unbalancing calls to 'protect' and 'unprotect', do not use these+-- functions directly but use 'Language.R.withProtected' instead.+protect :: SEXP s a -> IO (SEXP G a)+protect (unsexp -> s) = sexp <$> +  [C.exp| SEXP { Rf_protect($(SEXP s)) }|]++-- | @unprotect n@ unprotects the last @n@ objects that were protected.+unprotect :: Int -> IO ()+unprotect (fromIntegral -> i) =+  [C.exp| void { Rf_unprotect($(int i)) } |]++-- | Unprotect a specific object, referred to by pointer.+unprotectPtr :: SEXP G a -> IO ()+unprotectPtr (unsexp -> s) =+  [C.exp| void { Rf_unprotect_ptr($(SEXP s)) }|]++-- | Invoke an R garbage collector sweep.+gc :: IO ()+gc = [C.exp| void { R_gc() }|]++-- | Preserve an object accross GCs.+preserveObject :: SEXP s a -> IO ()+preserveObject (unsexp -> s) =+  [C.exp| void { R_PreserveObject( $(SEXP s) )} |]++-- | Allow GC to remove an preserved object.+releaseObject :: SEXP s a -> IO ()+releaseObject (unsexp -> s) =+  [C.exp| void { R_ReleaseObject( $(SEXP s) )} |]++--------------------------------------------------------------------------------+-- Evaluation                                                                 --+--------------------------------------------------------------------------------++-- | Evaluate any 'SEXP' to its value.+eval :: SEXP s a -> SEXP s 'R.Env -> IO (SomeSEXP V)+eval (unsexp -> expr) (unsexp -> env) = somesexp <$>+  [C.exp| SEXP { Rf_eval($(SEXP expr), $(SEXP env)) }|]++-- | Try to evaluate expression.+tryEval :: SEXP s a -> SEXP s 'R.Env -> Ptr CInt -> IO (SomeSEXP V)+tryEval (unsexp -> expr) (unsexp -> env) retCode = somesexp <$>+  [C.exp| SEXP { R_tryEval($(SEXP expr), $(SEXP env), $(int* retCode)) }|]++-- | Try to evaluate without printing error/warning messages to stdout.+tryEvalSilent :: SEXP  s a -> SEXP s 'R.Env -> Ptr CInt -> IO (SomeSEXP V)+tryEvalSilent (unsexp -> expr) (unsexp -> env) retCode = somesexp <$>+  [C.exp| SEXP { R_tryEvalSilent($(SEXP expr), $(SEXP env), $(int* retCode)) }|]++-- | Construct a nullary function call.+lang1 :: SEXP s a -> IO (SEXP V 'R.Lang)+lang1 (unsexp -> s) = sexp <$>+  [C.exp| SEXP {Rf_lang1($(SEXP s)) }|]++-- | Construct unary function call.+lang2 :: SEXP s a -> SEXP s b ->  IO (SEXP V 'R.Lang)+lang2 (unsexp -> f) (unsexp -> x) = sexp <$>+  [C.exp| SEXP {Rf_lang2($(SEXP f), $(SEXP x)) }|]++-- | Construct a binary function call.+lang3 :: SEXP s a -> SEXP s b ->  SEXP s c -> IO (SEXP V 'R.Lang)+lang3 (unsexp -> f) (unsexp -> x) (unsexp -> y) = sexp <$>+  [C.exp| SEXP {Rf_lang3($(SEXP f), $(SEXP x), $(SEXP y)) }|]++-- | Find a function by name.+findFun :: SEXP s a -> SEXP s 'R.Env -> IO (SomeSEXP s)+findFun (unsexp -> a) (unsexp -> env) = somesexp <$>+  [C.exp| SEXP { Rf_findFun($(SEXP a), $(SEXP env)) }|]++-- | Find a variable by name.+findVar :: SEXP s a -> SEXP s 'R.Env -> IO (SEXP s 'R.Symbol)+findVar (unsexp -> a) (unsexp -> env) = sexp <$>+  [C.exp| SEXP {Rf_findVar($(SEXP a), $(SEXP env))}|]++mkWeakRef :: SEXP s a -> SEXP s b -> SEXP s c -> Bool -> IO (SEXP V 'R.WeakRef)+mkWeakRef (unsexp -> a) (unsexp -> b) (unsexp -> c) (cIntFromEnum -> t) = sexp <$>+  [C.exp| SEXP {R_MakeWeakRef($(SEXP a), $(SEXP b), $(SEXP c), $(int t))}|]++-------------------------------------------------------------------------------+-- Encoding                                                                  --+-------------------------------------------------------------------------------++-- | Content encoding.+data CEType+  = CE_Native+  | CE_UTF8+  | CE_Latin1+  | CE_Bytes+  | CE_Symbol+  | CE_Any+  deriving (Eq, Show)++instance Enum CEType where+  fromEnum CE_Native = #const CE_NATIVE+  fromEnum CE_UTF8   = #const CE_UTF8+  fromEnum CE_Latin1 = #const CE_LATIN1+  fromEnum CE_Bytes  = #const CE_BYTES+  fromEnum CE_Symbol = #const CE_SYMBOL+  fromEnum CE_Any    = #const CE_ANY+  toEnum i = case i of+    (#const CE_NATIVE) -> CE_Native+    (#const CE_UTF8)   -> CE_UTF8+    (#const CE_LATIN1) -> CE_Latin1+    (#const CE_BYTES)  -> CE_Bytes+    (#const CE_SYMBOL) -> CE_Symbol+    (#const CE_ANY)    -> CE_Any+    _ -> error "CEType.fromEnum: unknown tag"++-- | Perform an action with resource while protecting it from the garbage+-- collection. This function is a safer alternative to 'R.protect' and+-- 'R.unprotect', guaranteeing that a protected resource gets unprotected+-- irrespective of the control flow, much like 'Control.Exception.bracket_'.+withProtected :: IO (SEXP V a)      -- Action to acquire resource+              -> (SEXP s a -> IO b) -- Action+              -> IO b+withProtected create f =+    bracket+      (do { x <- create; _ <- protect x; return x })+      (const $ unprotect 1)+      (f . unsafeRelease)

@@ -23,6 +23,5 @@   a :∈ (a ': as) = ()   a :∈ (b ': as) = a :∈ as --- | Class alias used for c2hs @fun@ hooks, since it currently does not like--- Unicode operators.+-- | Non unicode wrapper for the ':∈' type family. type In a b = a :∈ b

@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE CApiFFI           #-}+-- |+-- Copyright: 2018 (C) Tweag I/O Limited.+--+-- inline-c context.+module Foreign.R.Context+  ( rCtx+  , SEXPREC+  , SEXP0+  , Logical(..)+  ) where++import Data.Complex+import qualified Data.Map as Map+import Foreign.C+import Foreign.Ptr+import Foreign.Storable+import Language.C.Types (TypeSpecifier(TypeName))+import Language.C.Inline.Context (Context(..))+import Internal.Error++#include <Rinternals.h>++data {-# CTYPE  "SEXPREC" #-} SEXPREC++type SEXP0 = Ptr SEXPREC++-- | R uses three-valued logic.+data {-# CTYPE "Logical" #-} Logical = FALSE+             | TRUE+             | NA+-- XXX no Enum instance because NA = INT_MIN, not representable as an Int on+-- 32-bit systems.+               deriving (Eq, Ord, Show)++instance Storable Logical where+  sizeOf _       = sizeOf (undefined :: CInt)+  alignment _    = alignment (undefined :: CInt)+  poke ptr FALSE = poke (castPtr ptr) (0 :: CInt)+  poke ptr TRUE  = poke (castPtr ptr) (1 :: CInt)+  -- Currently NA_LOGICAL = INT_MIN.+  poke ptr NA    = poke (castPtr ptr) (#{const INT_MIN} :: CInt)+  peek ptr = do+      x <- peek (castPtr ptr)+      case x :: CInt of+          0 -> return FALSE+          1 -> return TRUE+          #{const INT_MIN} -> return NA+          _ -> failure "Storable Logical peek" "Not a Logical."++rCtx :: Context+rCtx = mempty { ctxTypesTable = Map.fromList tytabs }+  where+    tytabs =+      [ (TypeName "SEXP", [t| Ptr SEXPREC |])+      , (TypeName "Rcomplex", [t| Complex Double |])+      ]

@@ -1,26 +0,0 @@--- |--- Copyright: (C) 2013 Amgen, Inc.------ Bindings for @<R/Rembedded.h>@, containing entry points for running an--- instance of R embedded within another program.--{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}--{-# OPTIONS_GHC -fno-warn-unused-matches #-}-module Foreign.R.Embedded-  ( initEmbeddedR-  , endEmbeddedR-  ) where--import Foreign-import Foreign.C--#include <Rembedded.h>-#include "missing_r.h"---- | Initialize R.-{# fun Rf_initEmbeddedR as initEmbeddedR { `Int', castPtr `Ptr CString' } -> `()' #}---- | Finalize R.-{# fun Rf_endEmbeddedR as endEmbeddedR { `Int' } -> `()' #}

@@ -0,0 +1,34 @@+-- |+-- Copyright: (C) 2013 Amgen, Inc.+--+-- Bindings for @<R/Rembedded.h>@, containing entry points for running an+-- instance of R embedded within another program.++{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-unused-matches #-}+module Foreign.R.Embedded+  ( initEmbeddedR+  , endEmbeddedR+  ) where++import Foreign+import Foreign.C++#include <Rembedded.h>+#include "missing_r.h"++-- | Initialize R.+initEmbeddedR :: Int -> Ptr CString -> IO ()+initEmbeddedR (fromIntegral -> argc) argv = c_initEmbeddedR argc argv++foreign import ccall safe "Rembedded.h Rf_initEmbeddedR" c_initEmbeddedR+  :: CInt -> Ptr CString -> IO ()++endEmbeddedR :: Int -> IO ()+endEmbeddedR (fromIntegral -> retCode) = c_endEmbeddedR retCode++foreign import ccall safe "Rembedded.h Rf_endEmbeddedR" c_endEmbeddedR+  :: CInt -> IO ()

@@ -1,21 +0,0 @@--- |--- Copyright: (C) 2013 Amgen, Inc.------ Exception type wrapping errors thrown by the R runtime.--{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-module Foreign.R.Error-  ( RError(..)-  ) where--import Control.Exception-import Data.Typeable--data RError = RError String-      deriving ( Typeable )--instance Show RError where-  show (RError s)      = "R Runtime Error: " ++ s--instance Exception RError

@@ -0,0 +1,21 @@+-- |+-- Copyright: (C) 2013 Amgen, Inc.+--+-- Exception type wrapping errors thrown by the R runtime.++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Foreign.R.Error+  ( RError(..)+  ) where++import Control.Exception+import Data.Typeable++data RError = RError String+      deriving ( Typeable )++instance Show RError where+  show (RError s)      = "R Runtime Error: " ++ s++instance Exception RError

@@ -2,9 +2,7 @@ -- 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---+-- computing offsets of C struct field. We use hsc2hs for this purpose.  {-# LANGUAGE CApiFFI #-} {-# LANGUAGE CPP #-}@@ -31,6 +29,7 @@ import {-# SOURCE #-} Language.R.HExp (HExp) import Foreign.R.Type import Foreign.R.Type as R+import Foreign.R.Context (SEXP0)  import Control.Applicative import Control.DeepSeq (NFData(..))@@ -53,8 +52,6 @@ -- 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) }@@ -71,8 +68,6 @@  instance NFData (SEXP s a) where   rnf = (`seq` ())--type SEXP0 = Ptr SEXPREC  -- | Add a type index to the pointer. sexp :: SEXP0 -> SEXP s a

@@ -1,45 +0,0 @@--- |--- Copyright: (C) 2013 Amgen, Inc.------ Bindings for @<R/R_ext/Parse.h>@.--{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ForeignFunctionInterface #-}-#if __GLASGOW_HASKELL__ >= 710-{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}-#endif--#include <Rinternals.h>-#include <R_ext/Parse.h>-module Foreign.R.Parse-  ( parseVector-  , ParseStatus(..)-  ) where--import Foreign.R.Constraints-import qualified Foreign.R as R--- XXX Duplicate import to make c2hs happy. The problem is that c2hs doesn't--- like the "as R" of the above import.-{#import Foreign.R #}--import Foreign-import Foreign.C---- | The return code of a call to 'parseVector', indicating whether the parser--- failed or succeeded.-{#enum ParseStatus {} deriving (Eq, Show) #}---- | @parseVector text num status source@ parses the input string into an AST.--- @source@, if provided, names the origin of @text@ (e.g. a filename). @num@--- limits the number of expressions to parse, or @-1@ if no limit.---- TODO: use ParseStatus or write a wrapper for parseVector.-{#fun R_ParseVector as parseVector-  `(In a [R.Nil, R.String])'-  => { unsexp `SEXP s (R.String)'-     , `Int'-     , id `Ptr CInt'-     , unsexp `SEXP s a' }-  -> `SEXP s (R.Expr)' sexp #}

@@ -0,0 +1,69 @@+-- |+-- Copyright: (C) 2013 Amgen, Inc.+--+-- Bindings for @<R/R_ext/Parse.h>@.++{-# LANGUAGE CPP #-}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ForeignFunctionInterface #-}+#if __GLASGOW_HASKELL__ >= 710+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}+#endif++#include <Rinternals.h>+#include <R_ext/Parse.h>+module Foreign.R.Parse+  ( parseVector+  , ParseStatus(..)+  ) where++import Foreign.R.Constraints+import qualified Foreign.R as R++import Foreign+import Foreign.C++-- | The return code of a call to 'parseVector', indicating whether the parser+-- failed or succeeded.+data ParseStatus+  = PARSE_NULL+  | PARSE_OK+  | PARSE_INCOMPLETE+  | PARSE_ERROR+  | PARSE_EOF+  deriving (Eq, Show)++instance Enum ParseStatus where+  fromEnum PARSE_NULL       = #const PARSE_NULL+  fromEnum PARSE_OK         = #const PARSE_OK+  fromEnum PARSE_INCOMPLETE = #const PARSE_INCOMPLETE+  fromEnum PARSE_ERROR      = #const PARSE_ERROR+  fromEnum PARSE_EOF        = #const PARSE_EOF+  toEnum i = case i of+    (#const PARSE_NULL)       -> PARSE_NULL+    (#const PARSE_OK)         -> PARSE_OK+    (#const PARSE_INCOMPLETE) -> PARSE_INCOMPLETE+    (#const PARSE_ERROR)      -> PARSE_ERROR+    (#const PARSE_EOF)        -> PARSE_EOF+    _ -> error "ParseStatus.fromEnum: can't mach value"++-- | @parseVector text num status source@ parses the input string into an AST.+-- @source@, if provided, names the origin of @text@ (e.g. a filename). @num@+-- limits the number of expressions to parse, or @-1@ if no limit.++-- TODO: use ParseStatus or write a wrapper for parseVector.+parseVector+  :: (In a [R.Nil, R.String])+  => R.SEXP s R.String+  -> Int+  -> Ptr CInt+  -> R.SEXP s a+  -> IO (R.SEXP s R.Expr)+parseVector (R.unsexp -> s) (fromIntegral -> cnt) reti (R.unsexp -> input) =+  R.sexp <$> c_parseVector s cnt reti input+ +foreign import ccall "R_ext/Parse.h R_ParseVector" c_parseVector+  :: R.SEXP0 -> CInt -> Ptr CInt -> R.SEXP0 -> IO R.SEXP0

@@ -55,9 +55,7 @@ import Data.Singletons.TH  import Control.DeepSeq (NFData(..))-import Foreign (castPtr)-import Foreign.C (CInt)-import Foreign.Storable(Storable(..))+import Foreign.R.Context  -- | R \"type\". Note that what R calls a \"type\" is not what is usually meant -- by the term: there is really only a single type, called 'SEXP', and an@@ -168,29 +166,6 @@  instance Hs.Lift SEXPTYPE where   lift a = [| $(Hs.conE (Hs.mkName $ "Foreign.R.Type." ++ show a)) |]---- | R uses three-valued logic.-data Logical = FALSE-             | TRUE-             | NA--- XXX no Enum instance because NA = INT_MIN, not representable as an Int on--- 32-bit systems.-               deriving (Eq, Ord, Show)--instance Storable Logical where-  sizeOf _       = sizeOf (undefined :: CInt)-  alignment _    = alignment (undefined :: CInt)-  poke ptr FALSE = poke (castPtr ptr) (0 :: CInt)-  poke ptr TRUE  = poke (castPtr ptr) (1 :: CInt)-  -- Currently NA_LOGICAL = INT_MIN.-  poke ptr NA    = poke (castPtr ptr) (#{const INT_MIN} :: CInt)-  peek ptr = do-      x <- peek (castPtr ptr)-      case x :: CInt of-          0 -> return FALSE-          1 -> return TRUE-          #{const INT_MIN} -> return NA-          _ -> failure "Storable Logical peek" "Not a Logical."  -- | Used where the R documentation speaks of "pairlists", which are really just -- regular lists.

@@ -1,14 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-}-#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations #-}-#endif module Language.R.HExp where  import Foreign.R.Type (SEXPTYPE) -#if __GLASGOW_HASKELL__ >= 708 type role HExp phantom nominal-#endif data HExp :: * -> SEXPTYPE -> *

@@ -40,14 +40,6 @@ {-# 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(..)   , (===)@@ -59,7 +51,6 @@ 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@@ -76,7 +67,7 @@ import Data.Type.Equality (TestEquality(..), (:~:)(Refl)) import GHC.Ptr (Ptr(..)) import Foreign.Storable-import Foreign.C -- For c2hs < 0.26+import Foreign.C -- for hsc2hs import Foreign (castPtr) import Unsafe.Coerce (unsafeCoerce) -- Fixes redundant import warning >= 7.10 without CPP@@ -86,7 +77,6 @@ #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@@ -100,101 +90,101 @@ -- -- 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+  Nil       :: HExp s 'R.Nil   -- Fields: pname (is Nil for R_UnboundValue), value, internal.-  Symbol    :: (a :∈ [R.Char, R.Nil])+  Symbol    :: (a :∈ ['R.Char, 'R.Nil])             => SEXP s a             -> SEXP s b             -> SEXP s c-            -> HExp s R.Symbol+            -> HExp s 'R.Symbol   -- Fields: carval, cdrval, tagval.-  List      :: (R.IsPairList b, c :∈ [R.Symbol, R.Nil])+  List      :: (R.IsPairList b, c :∈ ['R.Symbol, 'R.Nil])             => SEXP s a             -> SEXP s b             -> SEXP s c-            -> HExp s R.List+            -> HExp s 'R.List   -- Fields: frame, enclos, hashtab.-  Env       :: (R.IsPairList a, b :∈ [R.Env, R.Nil], c :∈ [R.Vector, R.Nil])+  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+            -> 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+            -> 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])+  Promise   :: (R.IsExpression b, c :∈ ['R.Env, 'R.Nil])             => SEXP s a             -> SEXP s b             -> SEXP s c-            -> HExp s R.Promise+            -> 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+            -> HExp s 'R.Lang   -- Fields: offset.   Special   :: {-# UNPACK #-} !Int32-            -> HExp s R.Special+            -> 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+            -> 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+  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+            -> HExp s 'R.List   -- Fields: truelength, content.   Vector    :: {-# UNPACK #-} !Int32-            -> {-# UNPACK #-} !(Vector.Vector s R.Vector (SomeSEXP s))-            -> HExp s R.Vector+            -> {-# 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+            -> {-# 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+            -> 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] )+  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+            -> 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+            -> HExp s 'R.S4 +-- 'Im a hack+ instance Eq (HExp s a) where   (==) = (===) @@ -295,21 +285,6 @@       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}@@ -329,7 +304,7 @@         -- 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 :: SEXP s a -> SEXP s 'R.Any -- '         coerceAny = R.unsafeCoerce          sptr = R.unsexp s

@@ -16,6 +16,8 @@ {-# LANGUAGE UndecidableInstances #-} {-# Language ViewPatterns #-} +-- required to not warn about IsVector usage.+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Language.R.Literal   ( -- * Literals conversion     Literal(..)@@ -82,13 +84,13 @@  -- | Like 'fromSEXP', but with no static type satefy. Performs a dynamic -- (i.e. at runtime) check instead.-fromSomeSEXP :: forall s a form. (Literal a form,SingI form) => R.SomeSEXP s -> a+fromSomeSEXP :: forall s a form. (Literal a form) => R.SomeSEXP s -> a fromSomeSEXP = fromSEXP . R.cast (sing :: Sing form)  -- | Like 'fromSomeSEXP', but behaves like the @as.*@ family of functions -- in R, by performing a best effort conversion to the target form (e.g. rounds -- reals to integers, etc) for atomic types.-dynSEXP :: forall a s ty. (Literal a ty, SingI ty) => SomeSEXP s -> a+dynSEXP :: forall a s ty. (Literal a ty) => SomeSEXP s -> a dynSEXP (SomeSEXP sx) =     fromSomeSEXP $ unsafePerformIO $ case fromSing (sing :: SSEXPTYPE ty) of       R.Char -> r1 "as.character" sx

@@ -142,7 +142,7 @@ -- Result is always fully evaluated, since otherwise it wouldn't be possible to -- guarantee that thunks in the return value will not escape the memory region. matchOnly-  :: (MonadR m, Region m ~ s, NFData a)+  :: (MonadR m, NFData a)   => Matcher s a   -> SomeSEXP s   -> m (Either (MatcherError s) a)

@@ -133,7 +133,7 @@ -- @ expQQ :: String -> Q TH.Exp expQQ input = do-    expr <- runIO $ parse input+    expr <- runIO $ R.protect =<< parse input     let antis = [x | (hexp -> Char (Vector.toString -> x))                        <- Set.toList (collectAntis expr)]         args = map (TH.dyn . chop) antis@@ -142,7 +142,7 @@     vars <- mapM (\_ -> TH.newName "x") antis     -- Abstract over antis using fresh vars, to avoid captures with names bound     -- internally (such as 'f' below).-    (\body -> foldl TH.appE body args) $ TH.lamE (map TH.varP vars)+    x <- (\body -> foldl TH.appE body args) $ TH.lamE (map TH.varP vars)       [| 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@@ -158,3 +158,5 @@                                          car <- mkSEXPIO $(TH.varE x)                                          R.lcons car cdr |]) z vars)        |]+    runIO $ R.unprotectPtr expr+    pure x

@@ -0,0 +1,63 @@+{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE TemplateHaskell #-}+module Test.Matcher+  ( tests )+  where++import Control.Applicative+import Data.Int+import H.Prelude+import qualified Foreign.R as R+import Language.R.Matcher as P++import Test.Tasty hiding (defaultMain)+import Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "matcher"+  [ testCase "null" $ ((True @=?) =<<) $ do+       runRegion $ do+         s <- [r| NULL |]+         Right t <- matchOnly (P.null *> pure True <|> pure False) s+         return t+  , testCase "s3: pass non s3" $ ((True @=?) =<<) $ do+     runRegion  $ do+       s <- [r| c(1:10) |]+       Right t <- matchOnly (P.s3 ["matrix"] *> pure False <|> pure True) s+       return t+  , testCase "s3: matches matrix" $ ((True @=?) =<<) $ do+     runRegion  $ do+       s <- [r| x <- matrix(c(1:10)); class(x) <- "shmatrix"; x |]+       Right t <- matchOnly (P.s3 ["shmatrix"] *> pure True <|> pure False) s+       return t+  , testCase "typeOf: reads type" $ ((R.Int @=?) =<<) $ do+     runRegion $ do+       s <- [r| matrix(c(1:10)) |]+       Right t <- matchOnly P.typeOf s+       return t+  , testCase "guardType: proceeds" $ ((True @=?) =<<) $ do+     runRegion $ do+       s <- [r| matrix(c(1:10)) |]+       Right t <- matchOnly (P.guardType R.Int *> pure True <|> pure False) s+       return t+  , testCase "guardType: fails" $ ((True @=?) =<<) $ do+     runRegion $ do+       s <- [r| 1.0 |]+       Right t <- matchOnly (P.guardType R.Int *> pure False <|> pure True ) s+       return t+  , testCase "someAttribute" $ (([2,3::Int32] @=?) =<<) $ do+     runRegion $ do+       s <- [r| matrix(c(1:6), 2,3) |]+       Right t <- matchOnly (P.someAttribute "dim") s+       return (fromSEXP (R.cast SInt t))+  , testCase "someAttribute" $ (([2,3::Int32] @=?) =<<) $ do+     runRegion $ do+       s <- [r| matrix(c(1:6), 2,3) |]+       Right t <- matchOnly (P.attribute SInt "dim") s+       return (fromSEXP t)+  , testCase "getS3Class" $ ((["shmatrix"] @=?) =<<) $ do+     runRegion $ do+       s <- [r| x <- matrix(c(1:10),2,3); class(x) <- "shmatrix"; x |]+       Right t <- matchOnly P.getS3Class s+       return t+  ]

@@ -1,63 +0,0 @@-{-# LANGUAGE QuasiQuotes     #-}-{-# LANGUAGE TemplateHaskell #-}-module Test.Parser-  ( tests )-  where--import Control.Applicative-import Data.Int-import H.Prelude-import qualified Foreign.R as R-import Language.R.Matcher as P--import Test.Tasty hiding (defaultMain)-import Test.Tasty.HUnit--tests :: TestTree-tests = testGroup "matcher"-  [ testCase "null" $ ((True @=?) =<<) $ do-       runRegion $ do-         s <- [r| NULL |]-         Right t <- matchOnly (P.null *> pure True <|> pure False) s-         return t-  , testCase "s3: pass non s3" $ ((True @=?) =<<) $ do-     runRegion  $ do-       s <- [r| c(1:10) |]-       Right t <- matchOnly (P.s3 ["matrix"] *> pure False <|> pure True) s-       return t-  , testCase "s3: matches matrix" $ ((True @=?) =<<) $ do-     runRegion  $ do-       s <- [r| x <- matrix(c(1:10)); class(x) <- "shmatrix"; x |]-       Right t <- matchOnly (P.s3 ["shmatrix"] *> pure True <|> pure False) s-       return t-  , testCase "typeOf: reads type" $ ((R.Int @=?) =<<) $ do-     runRegion $ do-       s <- [r| matrix(c(1:10)) |]-       Right t <- matchOnly P.typeOf s-       return t-  , testCase "guardType: proceeds" $ ((True @=?) =<<) $ do-     runRegion $ do-       s <- [r| matrix(c(1:10)) |]-       Right t <- matchOnly (P.guardType R.Int *> pure True <|> pure False) s-       return t-  , testCase "guardType: fails" $ ((True @=?) =<<) $ do-     runRegion $ do-       s <- [r| 1.0 |]-       Right t <- matchOnly (P.guardType R.Int *> pure False <|> pure True ) s-       return t-  , testCase "someAttribute" $ (([2,3::Int32] @=?) =<<) $ do-     runRegion $ do-       s <- [r| matrix(c(1:6), 2,3) |]-       Right t <- matchOnly (P.someAttribute "dim") s-       return (fromSEXP (R.cast SInt t))-  , testCase "someAttribute" $ (([2,3::Int32] @=?) =<<) $ do-     runRegion $ do-       s <- [r| matrix(c(1:6), 2,3) |]-       Right t <- matchOnly (P.attribute SInt "dim") s-       return (fromSEXP t)-  , testCase "getS3Class" $ ((["shmatrix"] @=?) =<<) $ do-     runRegion $ do-       s <- [r| x <- matrix(c(1:10),2,3); class(x) <- "shmatrix"; x |]-       Right t <- matchOnly P.getS3Class s-       return t-  ]

@@ -19,7 +19,7 @@ import qualified Test.GC import qualified Test.Regions import qualified Test.Vector-import qualified Test.Parser+import qualified Test.Matcher  import H.Prelude import qualified Foreign.R as R@@ -102,7 +102,7 @@   , (if torture then id else ignoreTest) Test.Regions.tests   , Test.Vector.tests   , Test.Event.tests-  , Test.Parser.tests+  , Test.Matcher.tests     -- This test helps compiling quasiquoters concurrently from     -- multiple modules. This in turns helps testing for race     -- conditions when initializing R from multiple threads.