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 _)
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 _)
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 (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 _) = ByteArray (0, I# (n -# 1#)) bytes
299 psToByteArray (CPS addr len#)
302 byte_array_form = packCBytes len (A# 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 :: PackedString -> Addr
316 psToCString (CPS addr _) = (A# addr)
317 psToCString (PS bytes l# _) =
319 stuff <- _ccall_ malloc ((I# l#) * (``sizeof(char)''))
322 | n# ==# 0# = return ()
324 let ch# = indexCharArray# bytes i#
325 writeCharOffAddr stuff (I# i#) (C# ch#)
326 fill_in (n# -# 1#) (i# +# 1#)
332 %************************************************************************
334 \subsection{Destructor functions (taking @PackedStrings@ apart)}
336 %************************************************************************
339 -- OK, but this code gets *hammered*:
341 -- = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ]
343 unpackPS :: PackedString -> [Char]
344 unpackPS (PS bytes len _) = unpack 0#
348 | otherwise = C# ch : unpack (nh +# 1#)
350 ch = indexCharArray# bytes nh
352 unpackPS (CPS addr _) = unpack 0#
355 | ch `eqChar#` '\0'# = []
356 | otherwise = C# ch : unpack (nh +# 1#)
358 ch = indexCharOffAddr# addr nh
360 unpackNBytesPS :: PackedString -> Int -> [Char]
361 unpackNBytesPS ps len@(I# l#)
362 | len < 0 = error ("PackedString.unpackNBytesPS: negative length "++ show len)
366 PS bytes len# has_null -> unpackPS (PS bytes (min# len# l#) has_null)
367 CPS a len# -> unpackPS (CPS a (min# len# l#))
373 unpackPSIO :: PackedString -> IO String
374 unpackPSIO ps@(PS bytes _ _) = return (unpackPS ps)
375 unpackPSIO (CPS addr _) = unpack 0#
378 ch <- readCharOffAddr (A# addr) (I# nh)
382 ls <- unpack (nh +# 1#)
387 Output a packed string via a handle:
390 hPutPS :: Handle -> PackedString -> IO ()
391 hPutPS handle (CPS a# len#) = hPutBuf handle (A# a#) (I# len#)
392 hPutPS handle (PS ba# len# _) = hPutBufBA handle (ByteArray bottom ba#) (I# len#)
394 bottom = error "hPutPS"
397 The dual to @_putPS@, note that the size of the chunk specified
398 is the upper bound of the size of the chunk returned.
401 hGetPS :: Handle -> Int -> IO PackedString
402 hGetPS hdl len@(I# len#)
403 | len# <=# 0# = return nilPS -- I'm being kind here.
405 -- Allocate an array for system call to store its bytes into.
406 stToIO (new_ps_array len# ) >>= \ ch_arr ->
407 stToIO (freeze_ps_array ch_arr len#) >>= \ (ByteArray _ frozen#) ->
409 byte_array = ByteArray (0, I# len#) frozen#
411 hFillBufBA hdl byte_array len >>= \ (I# read#) ->
412 if read# ==# 0# then -- EOF or other error
413 ioError (userError "hGetPS: EOF reached or other error")
416 The system call may not return the number of
417 bytes requested. Instead of failing with an error
418 if the number of bytes read is less than requested,
419 a packed string containing the bytes we did manage
420 to snarf is returned.
423 has_null = byteArrayHasNUL# frozen# read#
425 return (PS frozen# read# has_null)
429 %************************************************************************
431 \subsection{List-mimicking functions for @PackedStrings@}
433 %************************************************************************
435 First, the basic functions that do look into the representation;
436 @indexPS@ is the most important one.
439 lengthPS :: PackedString -> Int
440 lengthPS ps = I# (lengthPS# ps)
442 {-# INLINE lengthPS# #-}
444 lengthPS# :: PackedString -> Int#
445 lengthPS# (PS _ i _) = i
446 lengthPS# (CPS _ i) = i
448 {-# INLINE strlen# #-}
450 strlen# :: Addr# -> Int
453 _ccall_ strlen (A# a) >>= \ len@(I# _) ->
457 byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool
458 byteArrayHasNUL# bs len
460 _ccall_ byteArrayHasNUL__ ba (I# len) >>= \ (I# res) ->
462 if res ==# 0# then False else True
465 ba = ByteArray (0, I# (len -# 1#)) bs
467 -----------------------
469 indexPS :: PackedString -> Int -> Char
470 indexPS ps (I# n) = C# (indexPS# ps n)
472 {-# INLINE indexPS# #-}
474 indexPS# :: PackedString -> Int# -> Char#
475 indexPS# (PS bs i _) n
476 = --ASSERT (n >=# 0# && n <# i) -- error checking: my eye! (WDP 94/10)
480 = indexCharOffAddr# a n
483 Now, the rest of the functions can be defined without digging
484 around in the representation.
487 headPS :: PackedString -> Char
489 | nullPS ps = error "headPS: head []"
490 | otherwise = C# (indexPS# ps 0#)
492 tailPS :: PackedString -> PackedString
494 | len <=# 0# = error "tailPS: tail []"
496 | otherwise = substrPS# ps 1# (len -# 1#)
500 nullPS :: PackedString -> Bool
501 nullPS (PS _ i _) = i ==# 0#
502 nullPS (CPS _ i) = i ==# 0#
504 appendPS :: PackedString -> PackedString -> PackedString
508 | otherwise = concatPS [xs,ys]
510 mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-}
516 new_ps_array (length +# 1#) >>= \ ps_arr ->
517 whizz ps_arr length 0# >>
518 freeze_ps_array ps_arr length >>= \ (ByteArray _ frozen#) ->
519 let has_null = byteArrayHasNUL# frozen# length in
520 return (PS frozen# length has_null))
522 length = lengthPS# xs
524 whizz :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
527 = write_ps_array arr# i (chr# 0#) >>
533 write_ps_array arr# i (case f (C# ch) of { (C# x) -> x}) >>
534 whizz arr# (n -# 1#) (i +# 1#)
536 filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
542 Filtering proceeds as follows:
544 * traverse the list, applying the pred. to each element,
545 remembering the positions where it was satisfied.
547 Encode these positions using a run-length encoding of the gaps
548 between the matching positions.
550 * Allocate a MutableByteArray in the heap big enough to hold
551 all the matched entries, and copy the elements that matched over.
553 A better solution that merges the scan© passes into one,
554 would be to copy the filtered elements over into a growable
555 buffer. No such operation currently supported over
556 MutableByteArrays (could of course use malloc&realloc)
557 But, this solution may in the case of repeated realloc's
558 be worse than the current solution.
562 (rle,len_filtered) = filter_ps (len# -# 1#) 0# 0# []
563 len_filtered# = case len_filtered of { I# x# -> x#}
565 if len# ==# len_filtered# then
566 {- not much filtering as everything passed through. -}
568 else if len_filtered# ==# 0# then
571 new_ps_array (len_filtered# +# 1#) >>= \ ps_arr ->
572 copy_arr ps_arr rle 0# 0# >>
573 freeze_ps_array ps_arr len_filtered# >>= \ (ByteArray _ frozen#) ->
574 let has_null = byteArrayHasNUL# frozen# len_filtered# in
575 return (PS frozen# len_filtered# has_null))
579 matchOffset :: Int# -> [Char] -> (Int,[Char])
580 matchOffset off [] = (I# off,[])
581 matchOffset off (C# c:cs) =
586 if x==# 0# then -- escape code, add 255#
591 copy_arr :: MutableByteArray s Int -> [Char] -> Int# -> Int# -> ST s ()
592 copy_arr _ [_] _ _ = return ()
593 copy_arr arr# ls n i =
595 (x,ls') = matchOffset 0# ls
596 n' = n +# (case x of { (I# x#) -> x#}) -# 1#
599 write_ps_array arr# i ch >>
600 copy_arr arr# ls' (n' +# 1#) (i +# 1#)
602 esc :: Int# -> Int# -> [Char] -> [Char]
603 esc v 0# ls = (C# (chr# v)):ls
604 esc v n ls = esc v (n -# 1#) (C# (chr# 0#):ls)
606 filter_ps :: Int# -> Int# -> Int# -> [Char] -> ([Char],Int)
607 filter_ps n hits run acc
610 escs = run `quotInt#` 255#
611 v = run `remInt#` 255#
613 (esc (v +# 1#) escs acc, I# hits)
621 escs = run `quotInt#` 255#
622 v = run `remInt#` 255#
623 acc' = esc (v +# 1#) escs acc
625 filter_ps n' (hits +# 1#) 0# acc'
627 filter_ps n' hits (run +# 1#) acc
630 foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
639 --whizzLR :: a -> Int# -> a
642 | otherwise = whizzLR (f b (C# (indexPS# ps idx))) (idx +# 1#)
645 foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
648 | otherwise = whizzRL v len
652 --whizzRL :: a -> Int# -> a
655 | otherwise = whizzRL (f (C# (indexPS# ps idx)) b) (idx -# 1#)
657 takePS :: Int -> PackedString -> PackedString
660 | otherwise = substrPS# ps 0# (n -# 1#)
662 dropPS :: Int -> PackedString -> PackedString
665 | otherwise = substrPS# ps n (lengthPS# ps -# 1#)
669 splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
670 splitAtPS n ps = (takePS n ps, dropPS n ps)
672 takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
675 break_pt = char_pos_that_dissatisfies
681 if break_pt ==# 0# then
684 substrPS# ps 0# (break_pt -# 1#)
686 dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
690 break_pt = char_pos_that_dissatisfies
696 if len ==# break_pt then
699 substrPS# ps break_pt (len -# 1#)
701 elemPS :: Char -> PackedString -> Bool
705 break_pt = first_char_pos_that_satisfies
713 char_pos_that_dissatisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
715 char_pos_that_dissatisfies p ps len pos
716 | pos >=# len = pos -- end
717 | p (indexPS# ps pos) = -- predicate satisfied; keep going
718 char_pos_that_dissatisfies p ps len (pos +# 1#)
719 | otherwise = pos -- predicate not satisfied
721 first_char_pos_that_satisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
722 first_char_pos_that_satisfies p ps len pos
723 | pos >=# len = pos -- end
724 | p (indexPS# ps pos) = pos -- got it!
725 | otherwise = first_char_pos_that_satisfies p ps len (pos +# 1#)
727 -- ToDo: could certainly go quicker
728 spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
729 spanPS p ps = (takeWhilePS p ps, dropWhilePS p ps)
731 breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
732 breakPS p ps = spanPS (not . p) ps
734 linesPS :: PackedString -> [PackedString]
735 linesPS ps = splitPS '\n' ps
737 wordsPS :: PackedString -> [PackedString]
738 wordsPS ps = splitWithPS isSpace ps
740 reversePS :: PackedString -> PackedString
742 if nullPS ps then -- don't create stuff unnecessarily.
746 new_ps_array (length +# 1#) >>= \ arr# -> -- incl NUL byte!
747 fill_in arr# (length -# 1#) 0# >>
748 freeze_ps_array arr# length >>= \ (ByteArray _ frozen#) ->
749 let has_null = byteArrayHasNUL# frozen# length in
750 return (PS frozen# length has_null))
752 length = lengthPS# ps
754 fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
755 fill_in arr_in# n i =
759 write_ps_array arr_in# i ch >>
761 write_ps_array arr_in# (i +# 1#) (chr# 0#) >>
764 fill_in arr_in# (n -# 1#) (i +# 1#)
766 concatPS :: [PackedString] -> PackedString
770 tot_len# = case (foldr ((+) . lengthPS) 0 pss) of { I# x -> x }
773 new_ps_array (tot_len# +# 1#) >>= \ arr# -> -- incl NUL byte!
774 packum arr# pss 0# >>
775 freeze_ps_array arr# tot_len# >>= \ (ByteArray _ frozen#) ->
777 let has_null = byteArrayHasNUL# frozen# tot_len# in
779 return (PS frozen# tot_len# has_null)
782 packum :: MutableByteArray s Int -> [PackedString] -> Int# -> ST s ()
785 = write_ps_array arr pos (chr# 0#) >>
787 packum arr (ps : pss) pos
788 = fill arr pos ps 0# (lengthPS# ps) >>= \ (I# next_pos) ->
789 packum arr pss next_pos
791 fill :: MutableByteArray s Int -> Int# -> PackedString -> Int# -> Int# -> ST s Int
793 fill arr arr_i ps ps_i ps_len
795 = return (I# (arr_i +# ps_len))
797 = write_ps_array arr (arr_i +# ps_i) (indexPS# ps ps_i) >>
798 fill arr arr_i ps (ps_i +# 1#) ps_len
800 ------------------------------------------------------------
801 joinPS :: PackedString -> [PackedString] -> PackedString
802 joinPS filler pss = concatPS (splice pss)
806 splice (x:y:xs) = x:filler:splice (y:xs)
808 -- ToDo: the obvious generalisation
810 Some properties that hold:
813 where False = any (map (x `elemPS`) ls')
814 False = any (map (nullPS) ls')
816 * all x's have been chopped out.
817 * no empty PackedStrings in returned list. A conseq.
822 * joinPS (packString [x]) (_splitPS x ls) = ls
826 splitPS :: Char -> PackedString -> [PackedString]
827 splitPS (C# ch) = splitWithPS (\ (C# c) -> c `eqChar#` ch)
829 splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]
830 splitWithPS pred ps =
840 first_char_pos_that_satisfies
846 if break_pt ==# n then -- immediate match, no substring to cut out.
847 splitify (break_pt +# 1#)
849 substrPS# ps n (break_pt -# 1#): -- leave out the matching character
850 splitify (break_pt +# 1#)
853 %************************************************************************
855 \subsection{Local utility functions}
857 %************************************************************************
859 The definition of @_substrPS@ is essentially:
860 @take (end - begin + 1) (drop begin str)@.
863 substrPS :: PackedString -> Int -> Int -> PackedString
864 substrPS ps (I# begin) (I# end) = substrPS# ps begin end
866 substrPS# :: PackedString -> Int# -> Int# -> PackedString
869 = error "substrPS: bounds out of range"
871 | s >=# len || result_len# <=# 0#
876 new_ps_array (result_len# +# 1#) >>= \ ch_arr -> -- incl NUL byte!
878 freeze_ps_array ch_arr result_len# >>= \ (ByteArray _ frozen#) ->
880 let has_null = byteArrayHasNUL# frozen# result_len# in
882 return (PS frozen# result_len# has_null)
887 result_len# = (if e <# len then (e +# 1#) else len) -# s
889 -----------------------
890 fill_in :: MutableByteArray s Int -> Int# -> ST s ()
893 | idx ==# result_len#
894 = write_ps_array arr_in# idx (chr# 0#) >>
898 ch = indexPS# ps (s +# idx)
900 write_ps_array arr_in# idx ch >>
901 fill_in arr_in# (idx +# 1#)
904 %*********************************************************
906 \subsection{Packing and unpacking C strings}
908 %*********************************************************
911 cStringToPS :: Addr -> PackedString
912 cStringToPS (A# a#) = -- the easy one; we just believe the caller
915 len = case (strlen# a#) of { I# x -> x }
917 packCBytes :: Int -> Addr -> PackedString
918 packCBytes len addr = runST (packCBytesST len addr)
920 packCBytesST :: Int -> Addr -> ST s PackedString
921 packCBytesST (I# length#) (A# addr) =
923 allocate an array that will hold the string
924 (not forgetting the NUL byte at the end)
926 new_ps_array (length# +# 1#) >>= \ ch_array ->
927 -- fill in packed string from "addr"
928 fill_in ch_array 0# >>
930 freeze_ps_array ch_array length# >>= \ (ByteArray _ frozen#) ->
931 let has_null = byteArrayHasNUL# frozen# length# in
932 return (PS frozen# length# has_null)
934 fill_in :: MutableByteArray s Int -> Int# -> ST s ()
938 = write_ps_array arr_in# idx (chr# 0#) >>
941 = case (indexCharOffAddr# addr idx) of { ch ->
942 write_ps_array arr_in# idx ch >>
943 fill_in arr_in# (idx +# 1#) }