2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section{Packed strings}
6 This sits on top of the sequencing/arrays world, notably @ByteArray#@s.
8 Glorious hacking (all the hard work) by Bryan O'Sullivan.
11 {-# OPTIONS -#include "cbits/PackedString.h" #-}
14 PackedString, -- abstract
16 -- Creating the beasts
17 packString, -- :: [Char] -> PackedString
18 packStringST, -- :: [Char] -> ST s PackedString
19 packCBytesST, -- :: Int -> Addr -> ST s PackedString
21 byteArrayToPS, -- :: ByteArray Int -> PackedString
22 cByteArrayToPS, -- :: ByteArray Int -> PackedString
23 unsafeByteArrayToPS, -- :: ByteArray a -> Int -> PackedString
25 psToByteArray, -- :: PackedString -> ByteArray Int
26 psToCString, -- :: PackedString -> Addr
27 isCString, -- :: PackedString -> Bool
29 unpackPS, -- :: PackedString -> [Char]
30 unpackNBytesPS, -- :: PackedString -> Int -> [Char]
31 unpackPSIO, -- :: PackedString -> IO [Char]
33 hPutPS, -- :: Handle -> PackedString -> IO ()
34 hGetPS, -- :: Handle -> Int -> IO PackedString
36 nilPS, -- :: PackedString
37 consPS, -- :: Char -> PackedString -> PackedString
38 headPS, -- :: PackedString -> Char
39 tailPS, -- :: PackedString -> PackedString
40 nullPS, -- :: PackedString -> Bool
41 appendPS, -- :: PackedString -> PackedString -> PackedString
42 lengthPS, -- :: PackedString -> Int
43 {- 0-origin indexing into the string -}
44 indexPS, -- :: PackedString -> Int -> Char
45 mapPS, -- :: (Char -> Char) -> PackedString -> PackedString
46 filterPS, -- :: (Char -> Bool) -> PackedString -> PackedString
47 foldlPS, -- :: (a -> Char -> a) -> a -> PackedString -> a
48 foldrPS, -- :: (Char -> a -> a) -> a -> PackedString -> a
49 takePS, -- :: Int -> PackedString -> PackedString
50 dropPS, -- :: Int -> PackedString -> PackedString
51 splitAtPS, -- :: Int -> PackedString -> (PackedString, PackedString)
52 takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
53 dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
54 spanPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
55 breakPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
56 linesPS, -- :: PackedString -> [PackedString]
58 wordsPS, -- :: PackedString -> [PackedString]
59 reversePS, -- :: PackedString -> PackedString
60 splitPS, -- :: Char -> PackedString -> [PackedString]
61 splitWithPS, -- :: (Char -> Bool) -> PackedString -> [PackedString]
62 joinPS, -- :: PackedString -> [PackedString] -> PackedString
63 concatPS, -- :: [PackedString] -> PackedString
64 elemPS, -- :: Char -> PackedString -> Bool
67 Pluck out a piece of a PS start and end
68 chars you want; both 0-origin-specified
70 substrPS, -- :: PackedString -> Int -> Int -> PackedString
72 comparePS -- :: PackedString -> PackedString -> Ordering
77 import PrelBase ( showList__ ) -- ToDo: better
87 import IOExts ( unsafePerformIO )
89 import PrelHandle ( hFillBufBA )
96 %************************************************************************
98 \subsection{@PackedString@ type declaration}
100 %************************************************************************
104 = PS ByteArray# -- the bytes
105 Int# -- length (*not* including NUL at the end)
106 Bool -- True <=> contains a NUL
107 | CPS Addr# -- pointer to the (null-terminated) bytes in C land
108 Int# -- length, as per strlen
109 -- definitely doesn't contain a NUL
111 instance Eq PackedString where
112 x == y = compare x y == EQ
113 x /= y = compare x y /= EQ
115 instance Ord PackedString where
117 x <= y = compare x y /= GT
118 x < y = compare x y == LT
119 x >= y = compare x y /= LT
120 x > y = compare x y == GT
121 max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x }
122 min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y }
124 --instance Read PackedString: ToDo
126 instance Show PackedString where
127 showsPrec p ps r = showsPrec p (unpackPS ps) r
128 showList = showList__ (showsPrec 0)
132 %************************************************************************
134 \subsection{@PackedString@ instances}
136 %************************************************************************
138 We try hard to make this go fast:
140 comparePS :: PackedString -> PackedString -> Ordering
142 comparePS (PS bs1 len1 has_null1) (PS bs2 len2 has_null2)
143 | not has_null1 && not has_null2
145 _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
148 else if res ==# 0# then EQ
152 ba1 = ByteArray (0, I# (len1 -# 1#)) bs1
153 ba2 = ByteArray (0, I# (len2 -# 1#)) bs2
155 comparePS (PS bs1 len1 has_null1) (CPS bs2 len2)
158 _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
161 else if res ==# 0# then EQ
165 ba1 = ByteArray (0, I# (len1 -# 1#)) bs1
168 comparePS (CPS bs1 len1) (CPS bs2 len2)
170 _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
173 else if res ==# 0# then EQ
180 comparePS a@(CPS _ _) b@(PS _ _ has_null2)
182 = -- try them the other way 'round
183 case (comparePS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
185 comparePS ps1 ps2 -- slow catch-all case (esp for "has_null" True)
188 end1 = lengthPS# ps1 -# 1#
189 end2 = lengthPS# ps2 -# 1#
192 = if char# ># end1 then
193 if char# ># end2 then -- both strings ran out at once
195 else -- ps1 ran out before ps2
197 else if char# ># end2 then
198 GT -- ps2 ran out before ps1
201 ch1 = indexPS# ps1 char#
202 ch2 = indexPS# ps2 char#
204 if ch1 `eqChar#` ch2 then
205 looking_at (char# +# 1#)
206 else if ch1 `ltChar#` ch2 then LT
211 %************************************************************************
213 \subsection{Constructor functions}
215 %************************************************************************
217 Easy ones first. @packString@ requires getting some heap-bytes and
218 scribbling stuff into them.
221 nilPS :: PackedString
224 consPS :: Char -> PackedString -> PackedString
225 consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better
227 packString :: [Char] -> PackedString
228 packString str = runST (packStringST str)
230 packStringST :: [Char] -> ST s PackedString
232 let len = length str in
235 packNCharsST :: Int -> [Char] -> ST s PackedString
236 packNCharsST len@(I# length#) str =
238 allocate an array that will hold the string
239 (not forgetting the NUL byte at the end)
241 new_ps_array (length# +# 1#) >>= \ ch_array ->
242 -- fill in packed string from "str"
243 fill_in ch_array 0# str >>
245 freeze_ps_array ch_array length# >>= \ (ByteArray _ frozen#) ->
246 let has_null = byteArrayHasNUL# frozen# length# in
247 return (PS frozen# length# has_null)
249 fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
250 fill_in arr_in# idx [] =
251 write_ps_array arr_in# idx (chr# 0#) >>
254 fill_in arr_in# idx (C# c : cs) =
255 write_ps_array arr_in# idx c >>
256 fill_in arr_in# (idx +# 1#) cs
258 byteArrayToPS :: ByteArray Int -> PackedString
259 byteArrayToPS (ByteArray ixs@(_, ix_end) frozen#) =
265 else ((index ixs ix_end) + 1)
268 PS frozen# n# (byteArrayHasNUL# frozen# n#)
270 -- byteArray is zero-terminated, make everything upto it
272 cByteArrayToPS :: ByteArray Int -> PackedString
273 cByteArrayToPS (ByteArray ixs@(_, ix_end) frozen#) =
279 else ((index ixs ix_end) + 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 has_null)
298 = ByteArray (0, I# (n -# 1#)) bytes
300 psToByteArray (CPS addr len#)
303 byte_array_form = packCBytes len (A# addr)
305 case byte_array_form of { PS bytes _ _ ->
306 ByteArray (0, len - 1) bytes }
308 -- isCString is useful when passing PackedStrings to the
309 -- outside world, and need to figure out whether you can
310 -- pass it as an Addr or ByteArray.
312 isCString :: PackedString -> Bool
313 isCString (CPS _ _ ) = True
316 psToCString :: PackedString -> Addr
317 psToCString (CPS addr _) = (A# addr)
318 psToCString (PS bytes n# has_null) =
320 stuff <- _ccall_ malloc ((I# n#) * (``sizeof(char)''))
323 | n# ==# 0# = return ()
325 let ch# = indexCharArray# bytes i#
326 writeCharOffAddr stuff (I# i#) (C# ch#)
327 fill_in (n# -# 1#) (i# +# 1#)
333 %************************************************************************
335 \subsection{Destructor functions (taking @PackedStrings@ apart)}
337 %************************************************************************
340 -- OK, but this code gets *hammered*:
342 -- = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ]
344 unpackPS :: PackedString -> [Char]
345 unpackPS (PS bytes len has_null)
350 | otherwise = C# ch : unpack (nh +# 1#)
352 ch = indexCharArray# bytes nh
354 unpackPS (CPS addr len)
358 | ch `eqChar#` '\0'# = []
359 | otherwise = C# ch : unpack (nh +# 1#)
361 ch = indexCharOffAddr# addr nh
363 unpackNBytesPS :: PackedString -> Int -> [Char]
364 unpackNBytesPS ps len@(I# l#)
365 | len < 0 = error ("PackedString.unpackNBytesPS: negative length "++ show len)
369 PS bytes len# has_null -> unpackPS (PS bytes (min# len# l#) has_null)
370 CPS a len# -> unpackPS (CPS a (min# len# l#))
376 unpackPSIO :: PackedString -> IO String
377 unpackPSIO ps@(PS bytes len has_null) = return (unpackPS ps)
378 unpackPSIO (CPS addr len)
382 ch <- readCharOffAddr (A# addr) (I# nh)
386 ls <- unpack (nh +# 1#)
391 Output a packed string via a handle:
394 hPutPS :: Handle -> PackedString -> IO ()
395 hPutPS handle (CPS a# len#) = hPutBuf handle (A# a#) (I# len#)
396 hPutPS handle (PS ba# len# _) = hPutBufBA handle (ByteArray bottom ba#) (I# len#)
398 bottom = error "hPutPS"
401 The dual to @_putPS@, note that the size of the chunk specified
402 is the upper bound of the size of the chunk returned.
405 hGetPS :: Handle -> Int -> IO PackedString
406 hGetPS hdl len@(I# len#)
407 | len# <=# 0# = return nilPS -- I'm being kind here.
409 -- Allocate an array for system call to store its bytes into.
410 stToIO (new_ps_array len# ) >>= \ ch_arr ->
411 stToIO (freeze_ps_array ch_arr len#) >>= \ (ByteArray _ frozen#) ->
413 byte_array = ByteArray (0, I# len#) frozen#
415 hFillBufBA hdl byte_array len >>= \ (I# read#) ->
416 if read# ==# 0# then -- EOF or other error
417 fail (userError "hGetPS: EOF reached or other error")
420 The system call may not return the number of
421 bytes requested. Instead of failing with an error
422 if the number of bytes read is less than requested,
423 a packed string containing the bytes we did manage
424 to snarf is returned.
427 has_null = byteArrayHasNUL# frozen# read#
429 return (PS frozen# read# has_null)
433 %************************************************************************
435 \subsection{List-mimicking functions for @PackedStrings@}
437 %************************************************************************
439 First, the basic functions that do look into the representation;
440 @indexPS@ is the most important one.
443 lengthPS :: PackedString -> Int
444 lengthPS ps = I# (lengthPS# ps)
446 {-# INLINE lengthPS# #-}
448 lengthPS# (PS _ i _) = i
449 lengthPS# (CPS _ i) = i
451 {-# INLINE strlen# #-}
453 strlen# :: Addr# -> Int
456 _ccall_ strlen (A# a) >>= \ len@(I# _) ->
460 byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool
461 byteArrayHasNUL# bs len
463 _ccall_ byteArrayHasNUL__ ba (I# len) >>= \ (I# res) ->
465 if res ==# 0# then False else True
468 ba = ByteArray (0, I# (len -# 1#)) bs
470 -----------------------
472 indexPS :: PackedString -> Int -> Char
473 indexPS ps (I# n) = C# (indexPS# ps n)
475 {-# INLINE indexPS# #-}
477 indexPS# (PS bs i _) n
478 = --ASSERT (n >=# 0# && n <# i) -- error checking: my eye! (WDP 94/10)
482 = indexCharOffAddr# a n
485 Now, the rest of the functions can be defined without digging
486 around in the representation.
489 headPS :: PackedString -> Char
491 | nullPS ps = error "headPS: head []"
492 | otherwise = C# (indexPS# ps 0#)
494 tailPS :: PackedString -> PackedString
496 | len <=# 0# = error "tailPS: tail []"
498 | otherwise = substrPS# ps 1# (len -# 1#)
502 nullPS :: PackedString -> Bool
503 nullPS (PS _ i _) = i ==# 0#
504 nullPS (CPS _ i) = i ==# 0#
506 appendPS :: PackedString -> PackedString -> PackedString
510 | otherwise = concatPS [xs,ys]
512 mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-}
518 new_ps_array (length +# 1#) >>= \ ps_arr ->
519 whizz ps_arr length 0# >>
520 freeze_ps_array ps_arr length >>= \ (ByteArray _ frozen#) ->
521 let has_null = byteArrayHasNUL# frozen# length in
522 return (PS frozen# length has_null))
524 length = lengthPS# xs
526 whizz :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
529 = write_ps_array arr# i (chr# 0#) >>
535 write_ps_array arr# i (case f (C# ch) of { (C# x) -> x}) >>
536 whizz arr# (n -# 1#) (i +# 1#)
538 filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
544 Filtering proceeds as follows:
546 * traverse the list, applying the pred. to each element,
547 remembering the positions where it was satisfied.
549 Encode these positions using a run-length encoding of the gaps
550 between the matching positions.
552 * Allocate a MutableByteArray in the heap big enough to hold
553 all the matched entries, and copy the elements that matched over.
555 A better solution that merges the scan© passes into one,
556 would be to copy the filtered elements over into a growable
557 buffer. No such operation currently supported over
558 MutableByteArrays (could of course use malloc&realloc)
559 But, this solution may in the case of repeated realloc's
560 be worse than the current solution.
564 (rle,len_filtered) = filter_ps (len# -# 1#) 0# 0# []
565 len_filtered# = case len_filtered of { I# x# -> x#}
567 if len# ==# len_filtered# then
568 {- not much filtering as everything passed through. -}
570 else if len_filtered# ==# 0# then
573 new_ps_array (len_filtered# +# 1#) >>= \ ps_arr ->
574 copy_arr ps_arr rle 0# 0# >>
575 freeze_ps_array ps_arr len_filtered# >>= \ (ByteArray _ frozen#) ->
576 let has_null = byteArrayHasNUL# frozen# len_filtered# in
577 return (PS frozen# len_filtered# has_null))
581 matchOffset :: Int# -> [Char] -> (Int,[Char])
582 matchOffset off [] = (I# off,[])
583 matchOffset off (C# c:cs) =
588 if x==# 0# then -- escape code, add 255#
593 copy_arr :: MutableByteArray s Int -> [Char] -> Int# -> Int# -> ST s ()
594 copy_arr arr# [_] _ _ = return ()
595 copy_arr arr# ls n i =
597 (x,ls') = matchOffset 0# ls
598 n' = n +# (case x of { (I# x#) -> x#}) -# 1#
601 write_ps_array arr# i ch >>
602 copy_arr arr# ls' (n' +# 1#) (i +# 1#)
604 esc :: Int# -> Int# -> [Char] -> [Char]
605 esc v 0# ls = (C# (chr# v)):ls
606 esc v n ls = esc v (n -# 1#) (C# (chr# 0#):ls)
608 filter_ps :: Int# -> Int# -> Int# -> [Char] -> ([Char],Int)
609 filter_ps n hits run acc
612 escs = run `quotInt#` 255#
613 v = run `remInt#` 255#
615 (esc (v +# 1#) escs acc, I# hits)
623 escs = run `quotInt#` 255#
624 v = run `remInt#` 255#
625 acc' = esc (v +# 1#) escs acc
627 filter_ps n' (hits +# 1#) 0# acc'
629 filter_ps n' hits (run +# 1#) acc
632 foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
641 --whizzLR :: a -> Int# -> a
644 | otherwise = whizzLR (f b (C# (indexPS# ps idx))) (idx +# 1#)
647 foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
656 --whizzRL :: a -> Int# -> a
659 | otherwise = whizzRL (f (C# (indexPS# ps idx)) b) (idx -# 1#)
661 takePS :: Int -> PackedString -> PackedString
664 | otherwise = substrPS# ps 0# (n -# 1#)
666 dropPS :: Int -> PackedString -> PackedString
669 | otherwise = substrPS# ps n (lengthPS# ps -# 1#)
673 splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
674 splitAtPS n ps = (takePS n ps, dropPS n ps)
676 takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
679 break_pt = char_pos_that_dissatisfies
685 if break_pt ==# 0# then
688 substrPS# ps 0# (break_pt -# 1#)
690 dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
694 break_pt = char_pos_that_dissatisfies
700 if len ==# break_pt then
703 substrPS# ps break_pt (len -# 1#)
705 elemPS :: Char -> PackedString -> Bool
709 break_pt = first_char_pos_that_satisfies
717 char_pos_that_dissatisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
719 char_pos_that_dissatisfies p ps len pos
720 | pos >=# len = pos -- end
721 | p (indexPS# ps pos) = -- predicate satisfied; keep going
722 char_pos_that_dissatisfies p ps len (pos +# 1#)
723 | otherwise = pos -- predicate not satisfied
725 first_char_pos_that_satisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
726 first_char_pos_that_satisfies p ps len pos
727 | pos >=# len = pos -- end
728 | p (indexPS# ps pos) = pos -- got it!
729 | otherwise = first_char_pos_that_satisfies p ps len (pos +# 1#)
731 -- ToDo: could certainly go quicker
732 spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
733 spanPS p ps = (takeWhilePS p ps, dropWhilePS p ps)
735 breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
736 breakPS p ps = spanPS (not . p) ps
738 linesPS :: PackedString -> [PackedString]
739 linesPS ps = splitPS '\n' ps
741 wordsPS :: PackedString -> [PackedString]
742 wordsPS ps = splitWithPS isSpace ps
744 reversePS :: PackedString -> PackedString
746 if nullPS ps then -- don't create stuff unnecessarily.
750 new_ps_array (length +# 1#) >>= \ arr# -> -- incl NUL byte!
751 fill_in arr# (length -# 1#) 0# >>
752 freeze_ps_array arr# length >>= \ (ByteArray _ frozen#) ->
753 let has_null = byteArrayHasNUL# frozen# length in
754 return (PS frozen# length has_null))
756 length = lengthPS# ps
758 fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
759 fill_in arr_in# n i =
763 write_ps_array arr_in# i ch >>
765 write_ps_array arr_in# (i +# 1#) (chr# 0#) >>
768 fill_in arr_in# (n -# 1#) (i +# 1#)
770 concatPS :: [PackedString] -> PackedString
774 tot_len# = case (foldr ((+) . lengthPS) 0 pss) of { I# x -> x }
775 tot_len = I# tot_len#
778 new_ps_array (tot_len# +# 1#) >>= \ arr# -> -- incl NUL byte!
779 packum arr# pss 0# >>
780 freeze_ps_array arr# tot_len# >>= \ (ByteArray _ frozen#) ->
782 let has_null = byteArrayHasNUL# frozen# tot_len# in
784 return (PS frozen# tot_len# has_null)
787 packum :: MutableByteArray s Int -> [PackedString] -> Int# -> ST s ()
790 = write_ps_array arr pos (chr# 0#) >>
792 packum arr (ps : pss) pos
793 = fill arr pos ps 0# (lengthPS# ps) >>= \ (I# next_pos) ->
794 packum arr pss next_pos
796 fill :: MutableByteArray s Int -> Int# -> PackedString -> Int# -> Int# -> ST s Int
798 fill arr arr_i ps ps_i ps_len
800 = return (I# (arr_i +# ps_len))
802 = write_ps_array arr (arr_i +# ps_i) (indexPS# ps ps_i) >>
803 fill arr arr_i ps (ps_i +# 1#) ps_len
805 ------------------------------------------------------------
806 joinPS :: PackedString -> [PackedString] -> PackedString
807 joinPS filler pss = concatPS (splice pss)
811 splice (x:y:xs) = x:filler:splice (y:xs)
813 -- ToDo: the obvious generalisation
815 Some properties that hold:
818 where False = any (map (x `elemPS`) ls')
819 False = any (map (nullPS) ls')
821 * all x's have been chopped out.
822 * no empty PackedStrings in returned list. A conseq.
827 * joinPS (packString [x]) (_splitPS x ls) = ls
831 splitPS :: Char -> PackedString -> [PackedString]
832 splitPS (C# ch) = splitWithPS (\ (C# c) -> c `eqChar#` ch)
834 splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]
835 splitWithPS pred ps =
845 first_char_pos_that_satisfies
851 if break_pt ==# n then -- immediate match, no substring to cut out.
852 splitify (break_pt +# 1#)
854 substrPS# ps n (break_pt -# 1#): -- leave out the matching character
855 splitify (break_pt +# 1#)
858 %************************************************************************
860 \subsection{Local utility functions}
862 %************************************************************************
864 The definition of @_substrPS@ is essentially:
865 @take (end - begin + 1) (drop begin str)@.
868 substrPS :: PackedString -> Int -> Int -> PackedString
869 substrPS ps (I# begin) (I# end) = substrPS# ps begin end
873 = error "substrPS: bounds out of range"
875 | s >=# len || result_len# <=# 0#
880 new_ps_array (result_len# +# 1#) >>= \ ch_arr -> -- incl NUL byte!
882 freeze_ps_array ch_arr result_len# >>= \ (ByteArray _ frozen#) ->
884 let has_null = byteArrayHasNUL# frozen# result_len# in
886 return (PS frozen# result_len# has_null)
891 result_len# = (if e <# len then (e +# 1#) else len) -# s
892 result_len = I# result_len#
894 -----------------------
895 fill_in :: MutableByteArray s Int -> Int# -> ST s ()
898 | idx ==# result_len#
899 = write_ps_array arr_in# idx (chr# 0#) >>
903 ch = indexPS# ps (s +# idx)
905 write_ps_array arr_in# idx ch >>
906 fill_in arr_in# (idx +# 1#)
909 %*********************************************************
911 \subsection{Packing and unpacking C strings}
913 %*********************************************************
916 cStringToPS :: Addr -> PackedString
917 cStringToPS (A# a#) = -- the easy one; we just believe the caller
920 len = case (strlen# a#) of { I# x -> x }
922 packCBytes :: Int -> Addr -> PackedString
923 packCBytes len addr = runST (packCBytesST len addr)
925 packCBytesST :: Int -> Addr -> ST s PackedString
926 packCBytesST len@(I# length#) (A# addr) =
928 allocate an array that will hold the string
929 (not forgetting the NUL byte at the end)
931 new_ps_array (length# +# 1#) >>= \ ch_array ->
932 -- fill in packed string from "addr"
933 fill_in ch_array 0# >>
935 freeze_ps_array ch_array length# >>= \ (ByteArray _ frozen#) ->
936 let has_null = byteArrayHasNUL# frozen# length# in
937 return (PS frozen# length# has_null)
939 fill_in :: MutableByteArray s Int -> Int# -> ST s ()
943 = write_ps_array arr_in# idx (chr# 0#) >>
946 = case (indexCharOffAddr# addr idx) of { ch ->
947 write_ps_array arr_in# idx ch >>
948 fill_in arr_in# (idx +# 1#) }