diff --git a/inline-r/src/Language/R/Literal.hs b/inline-r/src/Language/R/Literal.hs index 12d255d5..3ef6bb43 100644 --- a/inline-r/src/Language/R/Literal.hs +++ b/inline-r/src/Language/R/Literal.hs @@ -57,6 +57,8 @@ import Control.DeepSeq ( NFData ) import Control.Monad ( void, zipWithM_ ) import Data.Int (Int32) import Data.Complex (Complex) +import Data.Text (Text) +import qualified Data.Text as T import Foreign ( FunPtr, castPtr ) import Foreign.C.String ( withCString ) import Foreign.Storable ( Storable, pokeElemOff ) @@ -171,6 +173,17 @@ 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 + [GHC.withCString utf8 (T.unpack s) (R.mkCharCE R.CE_UTF8)] + fromSEXP (hexp -> String v) = + case map (\(hexp -> Char xs) -> SVector.toString xs) (SVector.toList v) of + [x] -> T.pack x + _ -> 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. diff --git a/inline-r/tests/test-qq.hs b/inline-r/tests/test-qq.hs index 7b396c43..cdc588be 100644 --- a/inline-r/tests/test-qq.hs +++ b/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) |]