From a9f54d46509228f98c2989dc26919b6e0216da8d Mon Sep 17 00:00:00 2001
From: Alexander Vershilov <alexander.vershilov@gmail.com>
Date: Sat, 9 Jun 2018 17:57:50 +0300
Subject: [PATCH] Support Text literals.

---
 inline-r/src/Data/Vector/SEXP.hs   | 18 ++++++++++++++++--
 inline-r/src/Foreign/R.hsc         |  5 +++++
 inline-r/src/Language/R/Literal.hs | 11 +++++++----
 3 files changed, 28 insertions(+), 6 deletions(-)

diff --git a/inline-r/src/Data/Vector/SEXP.hs b/inline-r/src/Data/Vector/SEXP.hs
index 00336e96..2f6ec056 100644
--- a/inline-r/src/Data/Vector/SEXP.hs
+++ b/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
 --
diff --git a/inline-r/src/Foreign/R.hsc b/inline-r/src/Foreign/R.hsc
index ce44af6f..0120d427 100644
--- a/inline-r/src/Foreign/R.hsc
+++ b/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
diff --git a/inline-r/src/Language/R/Literal.hs b/inline-r/src/Language/R/Literal.hs
index 3ef6bb43..8c0b974b 100644
--- a/inline-r/src/Language/R/Literal.hs
+++ b/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."