Add fromPtr0

Fixes haskell#302.
sjshuck · Apr 15, 2022 · c5f8182 · c5f8182
1 parent 0941fed
commit c5f8182
Show file tree

Hide file tree

Showing 3 changed files with 16 additions and 2 deletions.
diff --git a/src/Data/Text/Foreign.hs b/src/Data/Text/Foreign.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, MagicHash #-}
 -- |
 -- Module      : Data.Text.Foreign
 -- Copyright   : (c) 2009, 2010 Bryan O'Sullivan
@@ -17,6 +17,7 @@ module Data.Text.Foreign
       I8
     -- * Safe conversion functions
     , fromPtr
+    , fromPtr0
     , useAsPtr
     , asForeignPtr
     -- ** Encoding as UTF-8
@@ -36,12 +37,14 @@ import Data.ByteString.Unsafe (unsafePackCStringLen, unsafeUseAsCStringLen)
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import Data.Text.Internal (Text(..), empty)
 import Data.Text.Internal.Unsafe (unsafeWithForeignPtr)
+import Data.Text.Show (addrLen)
 import Data.Text.Unsafe (lengthWord8)
 import Data.Word (Word8)
 import Foreign.C.String (CStringLen)
 import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrArray)
 import Foreign.Marshal.Alloc (allocaBytes)
 import Foreign.Ptr (Ptr, castPtr)
+import GHC.Exts (Ptr(..))
 import qualified Data.Text.Array as A
 
 -- $interop
@@ -72,6 +75,12 @@ fromPtr ptr (I8 len) = unsafeSTToIO $ do
   arr <- A.unsafeFreeze dst
   return $! Text arr 0 len
 
+-- | /O(n)/ Create a new 'Text' from a 'Ptr' 'Word8' by copying the
+-- contents of the NUL-terminated array.
+fromPtr0 :: Ptr Word8           -- ^ source array
+         -> IO Text
+fromPtr0 ptr@(Ptr addr#) = fromPtr ptr (fromIntegral (addrLen addr#))
+
 -- $lowlevel
 --
 -- Foreign functions that use UTF-8 internally may return indices in

diff --git a/src/Data/Text/Show.hs b/src/Data/Text/Show.hs
@@ -16,7 +16,8 @@
 
 module Data.Text.Show
     (
-      singleton
+      addrLen
+    , singleton
     , unpack
     , unpackCString#
     , unpackCStringAscii#

diff --git a/tests/Tests/Properties/LowLevel.hs b/tests/Tests/Properties/LowLevel.hs
@@ -66,6 +66,9 @@ t_dropWord8 m t = dropWord8 m t `T.isSuffixOf` t
 t_takeWord8 m t = takeWord8 m t `T.isPrefixOf` t
 t_take_drop_8 (Small n) t = T.append (takeWord8 n t) (dropWord8 n t) === t
 t_use_from t = ioProperty $ (==t) <$> useAsPtr t fromPtr
+t_use_from0 t = ioProperty $ do
+  let t' = t `T.snoc` '\0'
+  (== T.takeWhile (/= '\0') t') <$> useAsPtr t' (const . fromPtr0)
 
 t_copy t = T.copy t === t
 
@@ -118,6 +121,7 @@ testLowLevel =
       testProperty "t_takeWord8" t_takeWord8,
       testProperty "t_take_drop_8" t_take_drop_8,
       testProperty "t_use_from" t_use_from,
+      testProperty "t_use_from0" t_use_from0,
       testProperty "t_copy" t_copy,
       testCase "t_literal_length1" t_literal_length1,
       testCase "t_literal_length2" t_literal_length2,