diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Change Log +## 0.9.2 - 2018-06-29 +* GHC 8.4 compatibility +* Add Literal instance for 'Text' + ## 0.9.1 - 2018-01-26 * Droped c2hs usage. Fixes installation on macOS. * Fix QQ generation. Fixed possible resource free during QQ generation. diff --git a/inline-r.cabal b/inline-r.cabal --- a/inline-r.cabal +++ b/inline-r.cabal @@ -1,12 +1,11 @@ name: inline-r -version: 0.9.1 +version: 0.9.2 license: BSD3 license-file: LICENSE copyright: Copyright (c) 2013-2015 Amgen, Inc. - Copyright (c) 2015-2017 Tweag I/O Limited. + Copyright (c) 2015-2018 Tweag I/O Limited. author: Mathieu Boespflug, Facundo Dominguez, Alexander Vershilov maintainer: Mathieu Boespflug -cabal-version: >=1.10 build-type: Simple Category: FFI Synopsis: Seamlessly call R from Haskell and vice versa. No FFI required. @@ -35,6 +34,7 @@ tests/shootout/fannkuchredux.R tests/R/fib.R tests/R/fib-benchmark.R +extra-tmp-files: inline-r.buildinfo source-repository head type: git @@ -98,8 +98,6 @@ 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 diff --git a/src/Data/Vector/SEXP.hs b/src/Data/Vector/SEXP.hs --- a/src/Data/Vector/SEXP.hs +++ b/src/Data/Vector/SEXP.hs @@ -252,8 +252,10 @@ -- ** SEXP specific helpers. , toString , toByteString + , unsafeWithByteString ) where +import Control.Exception (evaluate) import Control.Monad.R.Class import Control.Monad.R.Internal import Control.Memory.Region @@ -265,7 +267,6 @@ import qualified Foreign.R as R import Foreign.R.Type ( SEXPTYPE(Char) ) -import Control.Monad.Primitive ( PrimMonad ) import Control.Monad.ST (ST, runST) import Data.Int import Data.Proxy (Proxy(..)) @@ -274,6 +275,7 @@ import Data.Vector.Generic.New (run) import Data.ByteString ( ByteString ) import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B import Control.Applicative hiding (empty) #if MIN_VERSION_vector(0,11,0) @@ -288,7 +290,8 @@ import qualified Data.Vector.Fusion.Stream.Monadic as MStream #endif -import Control.Monad.Primitive ( unsafeInlineIO, unsafePrimToPrim ) +import Control.Monad.Primitive ( PrimMonad, unsafeInlineIO, unsafePrimToPrim ) +import qualified Control.DeepSeq as DeepSeq import Data.Word ( Word8 ) import Foreign ( Storable, Ptr, castPtr, peekElemOff ) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) @@ -454,6 +457,17 @@ toByteString v = unsafeInlineIO $ B.packCStringLen ( castPtr $ unsafeToPtr v , fromIntegral $ vectorLength v) + +-- | This function is unsafe and ByteString should not be used +-- outside of the function. Any change to bytestring will be +-- reflected in the source vector, thus breaking referencial +-- transparancy. +unsafeWithByteString :: DeepSeq.NFData a => Vector s 'Char Word8 -> (ByteString -> IO a) -> a +unsafeWithByteString v f = unsafeInlineIO $ do + x <- B.unsafePackCStringLen (castPtr $ unsafeToPtr v + ,fromIntegral $ vectorLength v) + w <- DeepSeq.force <$> f x + evaluate w ------------------------------------------------------------------------ -- Vector API diff --git a/src/Foreign/R.c b/src/Foreign/R.c deleted file mode 100644 --- a/src/Foreign/R.c +++ /dev/null @@ -1,254 +0,0 @@ - -#include - -#include - -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)); -} - diff --git a/src/Foreign/R.hsc b/src/Foreign/R.hsc --- a/src/Foreign/R.hsc +++ b/src/Foreign/R.hsc @@ -57,6 +57,7 @@ , mkChar , CEType(..) , mkCharCE + , mkCharLenCE , mkWeakRef -- * Node attributes , typeOf @@ -327,6 +328,10 @@ mkCharCE :: CEType -> CString -> IO (SEXP V 'R.Char) mkCharCE (cIntFromEnum -> ce) value = sexp <$> [C.exp| SEXP { Rf_mkCharCE($(char * value), $(int ce)) } |] + +mkCharLenCE :: CEType -> CString -> Int -> IO (SEXP V 'R.Char) +mkCharLenCE (cIntFromEnum -> ce) value (fromIntegral -> len) = sexp <$> + [C.exp| SEXP { Rf_mkCharLenCE($(char * value), $(int len), $(int ce)) } |] -- | Intern a string @name@ into the symbol table. -- diff --git a/src/Language/R/Instance.hs b/src/Language/R/Instance.hs --- a/src/Language/R/Instance.hs +++ b/src/Language/R/Instance.hs @@ -40,6 +40,7 @@ import Control.Monad.Primitive (PrimMonad(..)) import Control.Monad.R.Class import Control.Monad.ST.Unsafe (unsafeSTToIO) +import qualified Data.Semigroup as Sem import Data.Monoid import Data.Default.Class (Default(..)) import qualified Foreign.R as R @@ -160,13 +161,16 @@ instance Default Config where def = defaultConfig -instance Monoid Config where - mempty = defaultConfig - mappend cfg1 cfg2 = Config +instance Sem.Semigroup Config where + (<>) cfg1 cfg2 = Config { configProgName = configProgName cfg1 <> configProgName cfg2 , configArgs = configArgs cfg1 <> configArgs cfg2 , configSignalHandlers = configSignalHandlers cfg1 <> configSignalHandlers cfg2 } + +instance Monoid Config where + mempty = defaultConfig + mappend = (<>) -- | Default argument to pass to 'initialize'. defaultConfig :: Config diff --git a/src/Language/R/Literal.hs b/src/Language/R/Literal.hs --- a/src/Language/R/Literal.hs +++ b/src/Language/R/Literal.hs @@ -56,7 +56,10 @@ import Control.DeepSeq ( NFData ) import Control.Monad ( void, zipWithM_ ) import Data.Int (Int32) +import qualified Data.ByteString.Unsafe as B import Data.Complex (Complex) +import Data.Text (Text) +import qualified Data.Text.Encoding as T import Foreign ( FunPtr, castPtr ) import Foreign.C.String ( withCString ) import Foreign.Storable ( Storable, pokeElemOff ) @@ -170,6 +173,19 @@ map (\(hexp -> Char xs) -> SVector.toString xs) (SVector.toList v) fromSEXP _ = failure "fromSEXP" "String expected where some other expression appeared." + +instance Literal Text 'R.String where + mkSEXPIO s = + mkSEXPVectorIO sing + [ B.unsafeUseAsCStringLen (T.encodeUtf8 s) $ + uncurry (R.mkCharLenCE R.CE_UTF8) ] + fromSEXP (hexp -> String v) = + case SVector.toList v of + [hexp -> Char x] -> SVector.unsafeWithByteString x $ \p -> do + pure $ T.decodeUtf8 p + _ -> failure "fromSEXP" "Not a singleton vector" + fromSEXP _ = + failure "fromSEXP" "String expected where some other expression appeared." -- | Create a pairlist from an association list. Result is either a pairlist or -- @nilValue@ if the input is the null list. These are two distinct forms. Hence diff --git a/src/Language/R/Matcher.hs b/src/Language/R/Matcher.hs --- a/src/Language/R/Matcher.hs +++ b/src/Language/R/Matcher.hs @@ -67,6 +67,7 @@ import Data.Foldable (asum) import Data.Functor (void) import Data.Maybe (mapMaybe) +import Data.Semigroup as Sem import Data.Singletons import Data.Traversable import Data.Typeable (Typeable) @@ -120,10 +121,13 @@ f <|> g = Matcher $ \s ok err -> runMatcher f s ok (\e' -> runMatcher g s ok (err . (mappend e'))) +instance Sem.Semigroup (MatcherError s) where + a <> MatcherError "empty" = a + _ <> a = a + instance Monoid (MatcherError s) where mempty = MatcherError "empty" - a `mappend` MatcherError "empty" = a - _ `mappend` a = a + mappend = (<>) -- | Exception during matching. data MatcherError s @@ -182,7 +186,7 @@ -- $guards -- -- Guards provides a handy way to check if we are expecting object of the type --- we are interesting in. +-- we are interested in. -- | Succeeds if current @SomeSEXP@ is 'R.Null'. null :: Matcher s () @@ -203,7 +207,7 @@ -- it's better to use 'getS3Class' because it will run same check, but also will -- return the class(es) of the current expression. -- --- This test is not expressible in terms of the 'guardType', becausee guardType +-- This test is not expressible in terms of the 'guardType', because guardType -- does not see additional information about S3 types. And any raw object can be -- a class instance. s3 :: [String] -> Matcher s () @@ -224,7 +228,7 @@ -- vector, or factors are presented as an interger vector with 'rownames' -- attribute attached. --- | Returns any attribute by it's name if it exists. Fails with +-- | Returns any attribute by its name if it exists. Fails with -- @NoSuchAttribute@ otherwise. someAttribute :: String -> Matcher s (SomeSEXP s) someAttribute n = Matcher $ \(SomeSEXP s) ok err -> @@ -267,7 +271,7 @@ lookupAttribute s = (Just <$> someAttribute s) <|> pure Nothing -- | 'Language.R.Hexp.hexp' lifted to Matcher, applies hexp to the current value --- and allow to run internal matcher on it. Is useful when you need to inspect +-- and allows you to run internal matcher on it. Is useful when you need to inspect -- data using high level functions from @Language.R@. hexp :: SSEXPTYPE ty -> (HExp s ty -> Matcher s a) -> Matcher s a hexp ty f = f . H.hexp =<< sexp ty diff --git a/tests/test-qq.hs b/tests/test-qq.hs --- a/tests/test-qq.hs +++ b/tests/test-qq.hs @@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} module Main where @@ -17,6 +18,7 @@ import qualified Data.Vector.SEXP as SVector import qualified Data.Vector.SEXP.Mutable as SMVector import Control.Memory.Region +import Data.Text (Text) import Control.Applicative import Control.Monad.Trans (liftIO) @@ -108,9 +110,11 @@ ("c(7, 2, 3)" @=?) =<< [r| v = v2_hs; v[1] <- 7; v |] io . assertEqual "" "fromList [1,2,3]" . Prelude.show =<< SVector.unsafeFreeze v1 - let utf8string = "abcd çéõßø" + let utf8string = "abcd çéõßø" :: String io . assertEqual "" utf8string =<< fromSEXP <$> R.cast (sing :: R.SSEXPTYPE 'R.String) <$> [r| utf8string_hs |] + let utf8string1 = "abcd çéõßø" :: Text + io . assertEqual "" utf8string1 =<< fromSEXP <$> R.cast (sing :: R.SSEXPTYPE 'R.String) <$> [r| utf8string1_hs |] -- Disable gctorture, otherwise test takes too long to execute. _ <- [r| gctorture2(0) |]