Merge pull request #325 from tweag/gh-272

Support Text literal instances.

Author: mboes

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,7 +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.Encoding as T
 import Foreign ( FunPtr, castPtr )
 import Foreign.C.String ( withCString )
 import Foreign.Storable ( Storable, pokeElemOff )
@@ -171,6 +174,19 @@ instance Literal [String] 'R.String where
  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
 -- why the type of this function is not more precise.

inline-r/tests/test-qq.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Main where
 
@@ -17,6 +18,7 @@ import H.Prelude as H
 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 @@ main = H.withEmbeddedR H.defaultConfig $ H.runRegion $ do
  ("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) |]