Support Text literals.

Author: qnikst

inline-r/src/Data/Vector/SEXP.hs

@@ -252,8 +252,10 @@ module Data.Vector.SEXP
  -- ** 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 Foreign.R ( SEXP(..) )
 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 qualified Data.Vector.Generic as G
 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 as Stream
 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)
@@ -455,6 +458,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
 --

inline-r/src/Foreign/R.hsc

@@ -57,6 +57,7 @@ module Foreign.R
  , mkChar
  , CEType(..)
  , mkCharCE
+ , mkCharLenCE
  , mkWeakRef
  -- * Node attributes
  , typeOf
@@ -328,6 +329,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.
 --
 -- If @name@ is not found, it is added to the symbol table. The symbol

inline-r/src/Language/R/Literal.hs

@@ -56,9 +56,10 @@ import Data.Singletons ( Sing, SingI, fromSing, sing )
 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 as T
+import qualified Data.Text.Encoding as T
 import Foreign ( FunPtr, castPtr )
 import Foreign.C.String ( withCString )
 import Foreign.Storable ( Storable, pokeElemOff )
@@ -176,10 +177,12 @@ instance Literal [String] 'R.String where
 instance Literal Text 'R.String where
  mkSEXPIO s =
  mkSEXPVectorIO sing
- [GHC.withCString utf8 (T.unpack s) (R.mkCharCE R.CE_UTF8)]
+ [ B.unsafeUseAsCStringLen (T.encodeUtf8 s) $
+ uncurry (R.mkCharLenCE R.CE_UTF8) ]
  fromSEXP (hexp -> String v) =
- case map (\(hexp -> Char xs) -> SVector.toString xs) (SVector.toList v) of
- [x] -> T.pack x
+ 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."