1 {-# OPTIONS -#include "PackedString.h" #-}
2 -----------------------------------------------------------------------------
4 -- Module : Data.PackedString
5 -- Copyright : (c) The University of Glasgow 2001
6 -- License : BSD-style (see the file libraries/core/LICENSE)
8 -- Maintainer : libraries@haskell.org
9 -- Stability : experimental
10 -- Portability : non-portable
12 -- $Id: PackedString.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
14 -- The PackedString type, and associated operations.
15 -- GHC implementation by Bryan O'Sullivan.
17 -----------------------------------------------------------------------------
19 module Data.PackedString (
20 PackedString, -- abstract, instances: Eq, Ord, Show, Typeable
22 -- Creating the beasts
23 packString, -- :: [Char] -> PackedString
24 packStringST, -- :: [Char] -> ST s PackedString
25 packCBytesST, -- :: Int -> Ptr a -> ST s PackedString
27 byteArrayToPS, -- :: ByteArray Int -> PackedString
28 cByteArrayToPS, -- :: ByteArray Int -> PackedString
29 unsafeByteArrayToPS, -- :: ByteArray a -> Int -> PackedString
31 psToByteArray, -- :: PackedString -> ByteArray Int
32 psToCString, -- :: PackedString -> Ptr a
33 isCString, -- :: PackedString -> Bool
35 unpackPS, -- :: PackedString -> [Char]
36 unpackNBytesPS, -- :: PackedString -> Int -> [Char]
37 unpackPSIO, -- :: PackedString -> IO [Char]
39 hPutPS, -- :: Handle -> PackedString -> IO ()
40 hGetPS, -- :: Handle -> Int -> IO PackedString
42 nilPS, -- :: PackedString
43 consPS, -- :: Char -> PackedString -> PackedString
44 headPS, -- :: PackedString -> Char
45 tailPS, -- :: PackedString -> PackedString
46 nullPS, -- :: PackedString -> Bool
47 appendPS, -- :: PackedString -> PackedString -> PackedString
48 lengthPS, -- :: PackedString -> Int
49 {- 0-origin indexing into the string -}
50 indexPS, -- :: PackedString -> Int -> Char
51 mapPS, -- :: (Char -> Char) -> PackedString -> PackedString
52 filterPS, -- :: (Char -> Bool) -> PackedString -> PackedString
53 foldlPS, -- :: (a -> Char -> a) -> a -> PackedString -> a
54 foldrPS, -- :: (Char -> a -> a) -> a -> PackedString -> a
55 takePS, -- :: Int -> PackedString -> PackedString
56 dropPS, -- :: Int -> PackedString -> PackedString
57 splitAtPS, -- :: Int -> PackedString -> (PackedString, PackedString)
58 takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
59 dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
60 spanPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
61 breakPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
62 linesPS, -- :: PackedString -> [PackedString]
64 wordsPS, -- :: PackedString -> [PackedString]
65 reversePS, -- :: PackedString -> PackedString
66 splitPS, -- :: Char -> PackedString -> [PackedString]
67 splitWithPS, -- :: (Char -> Bool) -> PackedString -> [PackedString]
68 joinPS, -- :: PackedString -> [PackedString] -> PackedString
69 concatPS, -- :: [PackedString] -> PackedString
70 elemPS, -- :: Char -> PackedString -> Bool
73 Pluck out a piece of a PS start and end
74 chars you want; both 0-origin-specified
76 substrPS, -- :: PackedString -> Int -> Int -> PackedString
78 comparePS -- :: PackedString -> PackedString -> Ordering
92 import GHC.Show ( showList__ ) -- ToDo: better
93 import GHC.Pack ( new_ps_array, freeze_ps_array, write_ps_array )
95 import Control.Monad.ST
98 import System.IO.Unsafe ( unsafePerformIO )
99 import GHC.IO ( hPutBufBA, hGetBufBA )
102 import Data.Char ( isSpace )
105 -- -----------------------------------------------------------------------------
106 -- PackedString type declaration
109 = PS ByteArray# -- the bytes
110 Int# -- length (*not* including NUL at the end)
111 Bool -- True <=> contains a NUL
112 | CPS Addr# -- pointer to the (null-terminated) bytes in C land
113 Int# -- length, as per strlen
114 -- definitely doesn't contain a NUL
116 instance Eq PackedString where
117 x == y = compare x y == EQ
118 x /= y = compare x y /= EQ
120 instance Ord PackedString where
122 x <= y = compare x y /= GT
123 x < y = compare x y == LT
124 x >= y = compare x y /= LT
125 x > y = compare x y == GT
126 max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x }
127 min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y }
129 --instance Read PackedString: ToDo
131 instance Show PackedString where
132 showsPrec p ps r = showsPrec p (unpackPS ps) r
133 showList = showList__ (showsPrec 0)
136 INSTANCE_TYPEABLE0(PackedString,packedStringTc,"PackedString")
138 -- -----------------------------------------------------------------------------
139 -- PackedString instances
141 -- We try hard to make this go fast:
143 comparePS :: PackedString -> PackedString -> Ordering
145 comparePS (PS bs1 len1 has_null1) (PS bs2 len2 has_null2)
146 | not has_null1 && not has_null2
148 _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
151 else if res ==# 0# then EQ
155 ba1 = ByteArray 0 (I# (len1 -# 1#)) bs1
156 ba2 = ByteArray 0 (I# (len2 -# 1#)) bs2
158 comparePS (PS bs1 len1 has_null1) (CPS bs2 _)
161 _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
164 else if res ==# 0# then EQ
168 ba1 = ByteArray 0 (I# (len1 -# 1#)) bs1
171 comparePS (CPS bs1 len1) (CPS bs2 _)
173 _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
176 else if res ==# 0# then EQ
183 comparePS a@(CPS _ _) b@(PS _ _ has_null2)
185 = -- try them the other way 'round
186 case (comparePS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
188 comparePS ps1 ps2 -- slow catch-all case (esp for "has_null" True)
191 end1 = lengthPS# ps1 -# 1#
192 end2 = lengthPS# ps2 -# 1#
195 = if char# ># end1 then
196 if char# ># end2 then -- both strings ran out at once
198 else -- ps1 ran out before ps2
200 else if char# ># end2 then
201 GT -- ps2 ran out before ps1
204 ch1 = indexPS# ps1 char#
205 ch2 = indexPS# ps2 char#
207 if ch1 `eqChar#` ch2 then
208 looking_at (char# +# 1#)
209 else if ch1 `ltChar#` ch2 then LT
213 -- -----------------------------------------------------------------------------
214 -- Constructor functions
216 -- Easy ones first. @packString@ requires getting some heap-bytes and
217 -- scribbling stuff into them.
219 nilPS :: PackedString
222 consPS :: Char -> PackedString -> PackedString
223 consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better
225 packString :: [Char] -> PackedString
226 packString str = runST (packStringST str)
228 packStringST :: [Char] -> ST s PackedString
230 let len = length str in
233 packNCharsST :: Int -> [Char] -> ST s PackedString
234 packNCharsST (I# length#) str =
236 allocate an array that will hold the string
237 (not forgetting the NUL byte at the end)
239 new_ps_array (length# +# 1#) >>= \ ch_array ->
240 -- fill in packed string from "str"
241 fill_in ch_array 0# str >>
243 freeze_ps_array ch_array length# >>= \ (ByteArray _ _ frozen#) ->
244 let has_null = byteArrayHasNUL# frozen# length# in
245 return (PS frozen# length# has_null)
247 fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
248 fill_in arr_in# idx [] =
249 write_ps_array arr_in# idx (chr# 0#) >>
252 fill_in arr_in# idx (C# c : cs) =
253 write_ps_array arr_in# idx c >>
254 fill_in arr_in# (idx +# 1#) cs
256 byteArrayToPS :: ByteArray Int -> PackedString
257 byteArrayToPS (ByteArray l u frozen#) =
264 else ((index ixs u) + 1)
267 PS frozen# n# (byteArrayHasNUL# frozen# n#)
269 -- byteArray is zero-terminated, make everything upto it
271 cByteArrayToPS :: ByteArray Int -> PackedString
272 cByteArrayToPS (ByteArray l u frozen#) =
279 else ((index ixs u) + 1)
285 | ch# `eqChar#` '\0'# = i# -- everything upto the sentinel
286 | otherwise = findNull (i# +# 1#)
288 ch# = indexCharArray# frozen# i#
290 PS frozen# len# False
292 unsafeByteArrayToPS :: ByteArray a -> Int -> PackedString
293 unsafeByteArrayToPS (ByteArray _ _ frozen#) (I# n#)
294 = PS frozen# n# (byteArrayHasNUL# frozen# n#)
296 psToByteArray :: PackedString -> ByteArray Int
297 psToByteArray (PS bytes n _) = ByteArray 0 (I# (n -# 1#)) bytes
299 psToByteArray (CPS addr len#)
302 byte_array_form = packCBytes len (Ptr addr)
304 case byte_array_form of { PS bytes _ _ ->
305 ByteArray 0 (len - 1) bytes }
307 -- isCString is useful when passing PackedStrings to the
308 -- outside world, and need to figure out whether you can
309 -- pass it as an Addr or ByteArray.
311 isCString :: PackedString -> Bool
312 isCString (CPS _ _ ) = True
315 -- psToCString doesn't add a zero terminator!
316 -- this doesn't appear to be very useful --SDM
317 psToCString :: PackedString -> Ptr a
318 psToCString (CPS addr _) = (Ptr addr)
319 psToCString (PS bytes l# _) =
321 stuff <- mallocBytes (I# (l# +# 1#))
324 | n# ==# 0# = return ()
326 let ch# = indexCharArray# bytes i#
327 pokeByteOff stuff (I# i#) (castCharToCChar (C# ch#))
328 fill_in (n# -# 1#) (i# +# 1#)
330 pokeByteOff stuff (I# l#) (C# '\0'#)
333 -- -----------------------------------------------------------------------------
334 -- Destructor functions (taking PackedStrings apart)
336 -- OK, but this code gets *hammered*:
338 -- = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ]
340 unpackPS :: PackedString -> [Char]
341 unpackPS (PS bytes len _) = unpack 0#
345 | otherwise = C# ch : unpack (nh +# 1#)
347 ch = indexCharArray# bytes nh
349 unpackPS (CPS addr _) = unpack 0#
352 | ch `eqChar#` '\0'# = []
353 | otherwise = C# ch : unpack (nh +# 1#)
355 ch = indexCharOffAddr# addr nh
357 unpackNBytesPS :: PackedString -> Int -> [Char]
358 unpackNBytesPS ps len@(I# l#)
359 | len < 0 = error ("PackedString.unpackNBytesPS: negative length "++ show len)
363 PS bytes len# has_null -> unpackPS (PS bytes (min# len# l#) has_null)
364 CPS a len# -> unpackPS (CPS a (min# len# l#))
370 unpackPSIO :: PackedString -> IO String
371 unpackPSIO ps@(PS bytes _ _) = return (unpackPS ps)
372 unpackPSIO (CPS addr _) = unpack 0#
375 ch <- peekByteOff (Ptr addr) (I# nh)
376 let c = castCCharToChar ch
380 ls <- unpack (nh +# 1#)
383 -- Output a packed string via a handle:
385 hPutPS :: Handle -> PackedString -> IO ()
386 hPutPS handle (CPS a# len#) = hPutBuf handle (Ptr a#) (I# len#)
387 hPutPS handle (PS ba# len# _) = do
388 let mba = MutableByteArray (bottom::Int) bottom (unsafeCoerce# ba#)
389 hPutBufBA handle mba (I# len#)
391 bottom = error "hPutPS"
393 -- The dual to @_putPS@, note that the size of the chunk specified
394 -- is the upper bound of the size of the chunk returned.
396 hGetPS :: Handle -> Int -> IO PackedString
397 hGetPS hdl len@(I# len#)
398 | len# <=# 0# = return nilPS -- I'm being kind here.
400 -- Allocate an array for system call to store its bytes into.
401 stToIO (new_ps_array len# ) >>= \ ch_arr ->
402 stToIO (freeze_ps_array ch_arr len#) >>= \ (ByteArray _ _ frozen#) ->
403 hGetBufBA hdl ch_arr len >>= \ (I# read#) ->
404 if read# ==# 0# then -- EOF or other error
405 ioError (userError "hGetPS: EOF reached or other error")
408 The system call may not return the number of
409 bytes requested. Instead of failing with an error
410 if the number of bytes read is less than requested,
411 a packed string containing the bytes we did manage
412 to snarf is returned.
415 has_null = byteArrayHasNUL# frozen# read#
417 return (PS frozen# read# has_null)
419 -- -----------------------------------------------------------------------------
420 -- List-mimicking functions for PackedStrings
422 -- First, the basic functions that do look into the representation;
423 -- @indexPS@ is the most important one.
425 lengthPS :: PackedString -> Int
426 lengthPS ps = I# (lengthPS# ps)
428 {-# INLINE lengthPS# #-}
430 lengthPS# :: PackedString -> Int#
431 lengthPS# (PS _ i _) = i
432 lengthPS# (CPS _ i) = i
434 {-# INLINE strlen# #-}
436 strlen# :: Addr# -> Int
439 _ccall_ strlen (Ptr a) >>= \ len@(I# _) ->
443 byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool
444 byteArrayHasNUL# bs len
446 _ccall_ byteArrayHasNUL__ ba (I# len) >>= \ (I# res) ->
448 if res ==# 0# then False else True
451 ba = ByteArray 0 (I# (len -# 1#)) bs
453 -----------------------
455 indexPS :: PackedString -> Int -> Char
456 indexPS ps (I# n) = C# (indexPS# ps n)
458 {-# INLINE indexPS# #-}
460 indexPS# :: PackedString -> Int# -> Char#
461 indexPS# (PS bs i _) n
462 = --ASSERT (n >=# 0# && n <# i) -- error checking: my eye! (WDP 94/10)
466 = indexCharOffAddr# a n
468 -- Now, the rest of the functions can be defined without digging
469 -- around in the representation.
471 headPS :: PackedString -> Char
473 | nullPS ps = error "headPS: head []"
474 | otherwise = C# (indexPS# ps 0#)
476 tailPS :: PackedString -> PackedString
478 | len <=# 0# = error "tailPS: tail []"
480 | otherwise = substrPS# ps 1# (len -# 1#)
484 nullPS :: PackedString -> Bool
485 nullPS (PS _ i _) = i ==# 0#
486 nullPS (CPS _ i) = i ==# 0#
488 appendPS :: PackedString -> PackedString -> PackedString
492 | otherwise = concatPS [xs,ys]
494 mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-}
500 new_ps_array (length +# 1#) >>= \ ps_arr ->
501 whizz ps_arr length 0# >>
502 freeze_ps_array ps_arr length >>= \ (ByteArray _ _ frozen#) ->
503 let has_null = byteArrayHasNUL# frozen# length in
504 return (PS frozen# length has_null))
506 length = lengthPS# xs
508 whizz :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
511 = write_ps_array arr# i (chr# 0#) >>
517 write_ps_array arr# i (case f (C# ch) of { (C# x) -> x}) >>
518 whizz arr# (n -# 1#) (i +# 1#)
520 filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
526 Filtering proceeds as follows:
528 * traverse the list, applying the pred. to each element,
529 remembering the positions where it was satisfied.
531 Encode these positions using a run-length encoding of the gaps
532 between the matching positions.
534 * Allocate a MutableByteArray in the heap big enough to hold
535 all the matched entries, and copy the elements that matched over.
537 A better solution that merges the scan© passes into one,
538 would be to copy the filtered elements over into a growable
539 buffer. No such operation currently supported over
540 MutableByteArrays (could of course use malloc&realloc)
541 But, this solution may in the case of repeated realloc's
542 be worse than the current solution.
546 (rle,len_filtered) = filter_ps (len# -# 1#) 0# 0# []
547 len_filtered# = case len_filtered of { I# x# -> x#}
549 if len# ==# len_filtered# then
550 {- not much filtering as everything passed through. -}
552 else if len_filtered# ==# 0# then
555 new_ps_array (len_filtered# +# 1#) >>= \ ps_arr ->
556 copy_arr ps_arr rle 0# 0# >>
557 freeze_ps_array ps_arr len_filtered# >>= \ (ByteArray _ _ frozen#) ->
558 let has_null = byteArrayHasNUL# frozen# len_filtered# in
559 return (PS frozen# len_filtered# has_null))
563 matchOffset :: Int# -> [Char] -> (Int,[Char])
564 matchOffset off [] = (I# off,[])
565 matchOffset off (C# c:cs) =
570 if x==# 0# then -- escape code, add 255#
575 copy_arr :: MutableByteArray s Int -> [Char] -> Int# -> Int# -> ST s ()
576 copy_arr _ [_] _ _ = return ()
577 copy_arr arr# ls n i =
579 (x,ls') = matchOffset 0# ls
580 n' = n +# (case x of { (I# x#) -> x#}) -# 1#
583 write_ps_array arr# i ch >>
584 copy_arr arr# ls' (n' +# 1#) (i +# 1#)
586 esc :: Int# -> Int# -> [Char] -> [Char]
587 esc v 0# ls = (C# (chr# v)):ls
588 esc v n ls = esc v (n -# 1#) (C# (chr# 0#):ls)
590 filter_ps :: Int# -> Int# -> Int# -> [Char] -> ([Char],Int)
591 filter_ps n hits run acc
594 escs = run `quotInt#` 255#
595 v = run `remInt#` 255#
597 (esc (v +# 1#) escs acc, I# hits)
605 escs = run `quotInt#` 255#
606 v = run `remInt#` 255#
607 acc' = esc (v +# 1#) escs acc
609 filter_ps n' (hits +# 1#) 0# acc'
611 filter_ps n' hits (run +# 1#) acc
614 foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
623 --whizzLR :: a -> Int# -> a
626 | otherwise = whizzLR (f b (C# (indexPS# ps idx))) (idx +# 1#)
629 foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
632 | otherwise = whizzRL v len
636 --whizzRL :: a -> Int# -> a
639 | otherwise = whizzRL (f (C# (indexPS# ps idx)) b) (idx -# 1#)
641 takePS :: Int -> PackedString -> PackedString
644 | otherwise = substrPS# ps 0# (n -# 1#)
646 dropPS :: Int -> PackedString -> PackedString
649 | otherwise = substrPS# ps n (lengthPS# ps -# 1#)
653 splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
654 splitAtPS n ps = (takePS n ps, dropPS n ps)
656 takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
659 break_pt = char_pos_that_dissatisfies
665 if break_pt ==# 0# then
668 substrPS# ps 0# (break_pt -# 1#)
670 dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
674 break_pt = char_pos_that_dissatisfies
680 if len ==# break_pt then
683 substrPS# ps break_pt (len -# 1#)
685 elemPS :: Char -> PackedString -> Bool
689 break_pt = first_char_pos_that_satisfies
697 char_pos_that_dissatisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
699 char_pos_that_dissatisfies p ps len pos
700 | pos >=# len = pos -- end
701 | p (indexPS# ps pos) = -- predicate satisfied; keep going
702 char_pos_that_dissatisfies p ps len (pos +# 1#)
703 | otherwise = pos -- predicate not satisfied
705 first_char_pos_that_satisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
706 first_char_pos_that_satisfies p ps len pos
707 | pos >=# len = pos -- end
708 | p (indexPS# ps pos) = pos -- got it!
709 | otherwise = first_char_pos_that_satisfies p ps len (pos +# 1#)
711 -- ToDo: could certainly go quicker
712 spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
713 spanPS p ps = (takeWhilePS p ps, dropWhilePS p ps)
715 breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
716 breakPS p ps = spanPS (not . p) ps
718 linesPS :: PackedString -> [PackedString]
719 linesPS ps = splitPS '\n' ps
721 wordsPS :: PackedString -> [PackedString]
722 wordsPS ps = splitWithPS isSpace ps
724 reversePS :: PackedString -> PackedString
726 if nullPS ps then -- don't create stuff unnecessarily.
730 new_ps_array (length +# 1#) >>= \ arr# -> -- incl NUL byte!
731 fill_in arr# (length -# 1#) 0# >>
732 freeze_ps_array arr# length >>= \ (ByteArray _ _ frozen#) ->
733 let has_null = byteArrayHasNUL# frozen# length in
734 return (PS frozen# length has_null))
736 length = lengthPS# ps
738 fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
739 fill_in arr_in# n i =
743 write_ps_array arr_in# i ch >>
745 write_ps_array arr_in# (i +# 1#) (chr# 0#) >>
748 fill_in arr_in# (n -# 1#) (i +# 1#)
750 concatPS :: [PackedString] -> PackedString
754 tot_len# = case (foldr ((+) . lengthPS) 0 pss) of { I# x -> x }
757 new_ps_array (tot_len# +# 1#) >>= \ arr# -> -- incl NUL byte!
758 packum arr# pss 0# >>
759 freeze_ps_array arr# tot_len# >>= \ (ByteArray _ _ frozen#) ->
761 let has_null = byteArrayHasNUL# frozen# tot_len# in
763 return (PS frozen# tot_len# has_null)
766 packum :: MutableByteArray s Int -> [PackedString] -> Int# -> ST s ()
769 = write_ps_array arr pos (chr# 0#) >>
771 packum arr (ps : pss) pos
772 = fill arr pos ps 0# (lengthPS# ps) >>= \ (I# next_pos) ->
773 packum arr pss next_pos
775 fill :: MutableByteArray s Int -> Int# -> PackedString -> Int# -> Int# -> ST s Int
777 fill arr arr_i ps ps_i ps_len
779 = return (I# (arr_i +# ps_len))
781 = write_ps_array arr (arr_i +# ps_i) (indexPS# ps ps_i) >>
782 fill arr arr_i ps (ps_i +# 1#) ps_len
784 ------------------------------------------------------------
785 joinPS :: PackedString -> [PackedString] -> PackedString
786 joinPS filler pss = concatPS (splice pss)
790 splice (x:y:xs) = x:filler:splice (y:xs)
792 -- ToDo: the obvious generalisation
794 Some properties that hold:
797 where False = any (map (x `elemPS`) ls')
798 False = any (map (nullPS) ls')
800 * all x's have been chopped out.
801 * no empty PackedStrings in returned list. A conseq.
806 * joinPS (packString [x]) (_splitPS x ls) = ls
810 splitPS :: Char -> PackedString -> [PackedString]
811 splitPS (C# ch) = splitWithPS (\ (C# c) -> c `eqChar#` ch)
813 splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]
814 splitWithPS pred ps =
824 first_char_pos_that_satisfies
830 if break_pt ==# n then -- immediate match, no substring to cut out.
831 splitify (break_pt +# 1#)
833 substrPS# ps n (break_pt -# 1#): -- leave out the matching character
834 splitify (break_pt +# 1#)
836 -- -----------------------------------------------------------------------------
837 -- Local utility functions
839 -- The definition of @_substrPS@ is essentially:
840 -- @take (end - begin + 1) (drop begin str)@.
842 substrPS :: PackedString -> Int -> Int -> PackedString
843 substrPS ps (I# begin) (I# end) = substrPS# ps begin end
845 substrPS# :: PackedString -> Int# -> Int# -> PackedString
847 | s <# 0# || s >=# len || result_len# <=# 0#
852 new_ps_array (result_len# +# 1#) >>= \ ch_arr -> -- incl NUL byte!
854 freeze_ps_array ch_arr result_len# >>= \ (ByteArray _ _ frozen#) ->
856 let has_null = byteArrayHasNUL# frozen# result_len# in
858 return (PS frozen# result_len# has_null)
863 result_len# = (if e <# len then (e +# 1#) else len) -# s
865 -----------------------
866 fill_in :: MutableByteArray s Int -> Int# -> ST s ()
869 | idx ==# result_len#
870 = write_ps_array arr_in# idx (chr# 0#) >>
874 ch = indexPS# ps (s +# idx)
876 write_ps_array arr_in# idx ch >>
877 fill_in arr_in# (idx +# 1#)
879 -- -----------------------------------------------------------------------------
880 -- Packing and unpacking C strings
882 cStringToPS :: Ptr a -> PackedString
883 cStringToPS (Ptr a#) = -- the easy one; we just believe the caller
886 len = case (strlen# a#) of { I# x -> x }
888 packCBytes :: Int -> Ptr a -> PackedString
889 packCBytes len addr = runST (packCBytesST len addr)
891 packCBytesST :: Int -> Ptr a -> ST s PackedString
892 packCBytesST (I# length#) (Ptr addr) =
894 allocate an array that will hold the string
895 (not forgetting the NUL byte at the end)
897 new_ps_array (length# +# 1#) >>= \ ch_array ->
898 -- fill in packed string from "addr"
899 fill_in ch_array 0# >>
901 freeze_ps_array ch_array length# >>= \ (ByteArray _ _ frozen#) ->
902 let has_null = byteArrayHasNUL# frozen# length# in
903 return (PS frozen# length# has_null)
905 fill_in :: MutableByteArray s Int -> Int# -> ST s ()
909 = write_ps_array arr_in# idx (chr# 0#) >>
912 = case (indexCharOffAddr# addr idx) of { ch ->
913 write_ps_array arr_in# idx ch >>
914 fill_in arr_in# (idx +# 1#) }