2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
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 -fno-implicit-prelude #-}
15 packString, -- :: [Char] -> PackedString
16 packStringST, -- :: [Char] -> ST s PackedString
17 nilPS, -- :: PackedString
18 consPS, -- :: Char -> PackedString -> PackedString
20 byteArrayToPS, -- :: ByteArray Int -> PackedString
21 unsafeByteArrayToPS, -- :: ByteArray a -> Int -> PackedString
22 psToByteArray, -- :: PackedString -> ByteArray Int
24 unpackPS, -- :: PackedString -> [Char]
26 hPutPS, -- :: Handle -> PackedString -> IO ()
27 putPS, -- :: FILE -> PackedString -> PrimIO () -- ToDo: more sensible type
28 getPS, -- :: FILE -> Int -> PrimIO PackedString
30 headPS, -- :: PackedString -> Char
31 tailPS, -- :: PackedString -> PackedString
32 nullPS, -- :: PackedString -> Bool
33 appendPS, -- :: PackedString -> PackedString -> PackedString
34 lengthPS, -- :: PackedString -> Int
35 {- 0-origin indexing into the string -}
36 indexPS, -- :: PackedString -> Int -> Char
37 mapPS, -- :: (Char -> Char) -> PackedString -> PackedString
38 filterPS, -- :: (Char -> Bool) -> PackedString -> PackedString
39 foldlPS, -- :: (a -> Char -> a) -> a -> PackedString -> a
40 foldrPS, -- :: (Char -> a -> a) -> a -> PackedString -> a
41 takePS, -- :: Int -> PackedString -> PackedString
42 dropPS, -- :: Int -> PackedString -> PackedString
43 splitAtPS, -- :: Int -> PackedString -> (PackedString, PackedString)
44 takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
45 dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
46 spanPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
47 breakPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
48 linesPS, -- :: PackedString -> [PackedString]
50 wordsPS, -- :: PackedString -> [PackedString]
51 reversePS, -- :: PackedString -> PackedString
52 splitPS, -- :: Char -> PackedString -> [PackedString]
53 splitWithPS, -- :: (Char -> Bool) -> PackedString -> [PackedString]
54 joinPS, -- :: PackedString -> [PackedString] -> PackedString
55 concatPS, -- :: [PackedString] -> PackedString
56 elemPS, -- :: Char -> PackedString -> Bool
59 Pluck out a piece of a PS start and end
60 chars you want; both 0-origin-specified
62 substrPS, -- :: PackedString -> Int -> Int -> PackedString
66 -- Converting to C strings
68 unpackCString#, unpackCString2#, unpackAppendCString#, unpackFoldrCString#,
69 packCBytesST, unpackCString
72 import {-# SOURCE #-} IOBase ( error )
81 %************************************************************************
83 \subsection{@PackedString@ type declaration}
85 %************************************************************************
89 = PS ByteArray# -- the bytes
90 Int# -- length (*not* including NUL at the end)
91 Bool -- True <=> contains a NUL
92 | CPS Addr# -- pointer to the (null-terminated) bytes in C land
93 Int# -- length, as per strlen
94 -- definitely doesn't contain a NUL
96 instance Eq PackedString where
97 x == y = compare x y == EQ
98 x /= y = compare x y /= EQ
100 instance Ord PackedString where
102 x <= y = compare x y /= GT
103 x < y = compare x y == LT
104 x >= y = compare x y /= LT
105 x > y = compare x y == GT
106 max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x }
107 min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y }
109 --instance Read PackedString: ToDo
111 instance Show PackedString where
112 showsPrec p ps r = showsPrec p (unpackPS ps) r
113 showList = showList__ (showsPrec 0)
117 %************************************************************************
119 \subsection{@PackedString@ instances}
121 %************************************************************************
123 We try hard to make this go fast:
125 comparePS :: PackedString -> PackedString -> Ordering
127 comparePS (PS bs1 len1 has_null1) (PS bs2 len2 has_null2)
128 | not has_null1 && not has_null2
129 = unsafePerformPrimIO (
130 _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
133 else if res ==# 0# then EQ
137 ba1 = ByteArray (0, I# (len1 -# 1#)) bs1
138 ba2 = ByteArray (0, I# (len2 -# 1#)) bs2
140 comparePS (PS bs1 len1 has_null1) (CPS bs2 len2)
142 = unsafePerformPrimIO (
143 _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
146 else if res ==# 0# then EQ
150 ba1 = ByteArray (0, I# (len1 -# 1#)) bs1
153 comparePS (CPS bs1 len1) (CPS bs2 len2)
154 = unsafePerformPrimIO (
155 _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
158 else if res ==# 0# then EQ
165 comparePS a@(CPS _ _) b@(PS _ _ has_null2)
167 = -- try them the other way 'round
168 case (comparePS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
170 comparePS ps1 ps2 -- slow catch-all case (esp for "has_null" True)
173 end1 = lengthPS# ps1 -# 1#
174 end2 = lengthPS# ps2 -# 1#
177 = if char# ># end1 then
178 if char# ># end2 then -- both strings ran out at once
180 else -- ps1 ran out before ps2
182 else if char# ># end2 then
183 GT -- ps2 ran out before ps1
186 ch1 = indexPS# ps1 char#
187 ch2 = indexPS# ps2 char#
189 if ch1 `eqChar#` ch2 then
190 looking_at (char# +# 1#)
191 else if ch1 `ltChar#` ch2 then LT
196 %************************************************************************
198 \subsection{Constructor functions}
200 %************************************************************************
202 Easy ones first. @packString@ requires getting some heap-bytes and
203 scribbling stuff into them.
206 nilPS :: PackedString
209 consPS :: Char -> PackedString -> PackedString
210 consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better
212 packString :: [Char] -> PackedString
213 packString str = runST (packStringST str)
215 packStringST :: [Char] -> ST s PackedString
217 let len = length str in
220 packNCharsST :: Int -> [Char] -> ST s PackedString
221 packNCharsST len@(I# length#) str =
223 allocate an array that will hold the string
224 (not forgetting the NUL byte at the end)
226 new_ps_array (length# +# 1#) >>= \ ch_array ->
227 -- fill in packed string from "str"
228 fill_in ch_array 0# str >>
230 freeze_ps_array ch_array >>= \ (ByteArray _ frozen#) ->
231 let has_null = byteArrayHasNUL# frozen# length# in
232 return (PS frozen# length# has_null)
234 fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
235 fill_in arr_in# idx [] =
236 write_ps_array arr_in# idx (chr# 0#) >>
239 fill_in arr_in# idx (C# c : cs) =
240 write_ps_array arr_in# idx c >>
241 fill_in arr_in# (idx +# 1#) cs
243 byteArrayToPS :: ByteArray Int -> PackedString
244 byteArrayToPS (ByteArray ixs@(_, ix_end) frozen#) =
250 else ((index ixs ix_end) + 1)
253 PS frozen# n# (byteArrayHasNUL# frozen# n#)
255 unsafeByteArrayToPS :: ByteArray a -> Int -> PackedString
256 unsafeByteArrayToPS (ByteArray _ frozen#) (I# n#)
257 = PS frozen# n# (byteArrayHasNUL# frozen# n#)
259 psToByteArray :: PackedString -> ByteArray Int
260 psToByteArray (PS bytes n has_null)
261 = ByteArray (0, I# (n -# 1#)) bytes
263 psToByteArray (CPS addr len#)
266 byte_array_form = packCBytes len (A# addr)
268 case byte_array_form of { PS bytes _ _ ->
269 ByteArray (0, len - 1) bytes }
272 %************************************************************************
274 \subsection{Destructor functions (taking @PackedStrings@ apart)}
276 %************************************************************************
279 -- OK, but this code gets *hammered*:
281 -- = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ]
283 unpackPS :: PackedString -> [Char]
284 unpackPS (PS bytes len has_null)
289 | otherwise = C# ch : unpack (nh +# 1#)
291 ch = indexCharArray# bytes nh
293 unpackPS (CPS addr len)
297 | ch `eqChar#` '\0'# = []
298 | otherwise = C# ch : unpack (nh +# 1#)
300 ch = indexCharOffAddr# addr nh
303 Output a packed string via a handle:
307 hPutPS :: Handle -> PackedString -> IO ()
318 _readHandle handle >>= \ htype ->
320 _ErrorHandle ioError ->
321 _writeHandle handle htype >>
324 _writeHandle handle htype >>
325 failWith (IllegalOperation "handle is closed")
326 _SemiClosedHandle _ _ ->
327 _writeHandle handle htype >>
328 failWith (IllegalOperation "handle is closed")
330 _writeHandle handle htype >>
331 failWith (IllegalOperation "handle is not open for writing")
333 _getBufferMode other >>= \ other ->
334 (case _bufferMode other of
335 Just LineBuffering ->
336 writeLines (_filePtr other)
337 Just (BlockBuffering (Just size)) ->
338 writeBlocks (_filePtr other) size
339 Just (BlockBuffering Nothing) ->
340 writeBlocks (_filePtr other) ``BUFSIZ''
341 _ -> -- Nothing is treated pessimistically as NoBuffering
342 writeChars (_filePtr other) 0#
344 _writeHandle handle (_markHandle other) >>
348 _constructError "hPutStr" >>= \ ioError ->
354 writeLines :: Addr -> PrimIO Bool
355 writeLines = writeChunks ``BUFSIZ'' True
357 writeBlocks :: Addr -> Int -> PrimIO Bool
358 writeBlocks fp size = writeChunks size False fp
361 The breaking up of output into lines along \n boundaries
362 works fine as long as there are newlines to split by.
363 Avoid the splitting up into lines altogether (doesn't work
364 for overly long lines like the stuff that showsPrec instances
365 normally return). Instead, we split them up into fixed size
366 chunks before blasting them off to the Real World.
368 Hacked to avoid multiple passes over the strings - unsightly, but
369 a whole lot quicker. -- SOF 3/96
372 writeChunks :: Int -> Bool -> Addr -> PrimIO Bool
373 writeChunks (I# bufLen) chopOnNewLine fp =
374 newCharArray (0,I# bufLen) >>= \ arr@(MutableByteArray _ arr#) ->
376 shoveString :: Int# -> Int# -> PrimIO Bool
378 | i ==# pslen = -- end of string
382 _ccall_ writeFile arr fp (I# n) >>= \rc ->
386 case writeCharArray# arr# n (indexPS# ps i) s# of
388 {- Flushing lines - should we bother? -}
389 (if n ==# bufLen then
390 _ccall_ writeFile arr fp (I# (n +# 1#)) >>= \rc ->
392 shoveString 0# (i +# 1#)
396 shoveString (n +# 1#) (i +# 1#)) (S# s1#))
400 writeChars :: Addr -> Int# -> PrimIO Bool
402 | i ==# pslen = return True
404 _ccall_ filePutc fp (ord (C# (indexPS# ps i))) >>= \ rc ->
406 writeChars fp (i +# 1#)
410 ---------------------------------------------
412 putPS :: _FILE -> PackedString -> PrimIO ()
413 putPS file ps@(PS bytes len has_null)
418 byte_array = ByteArray (0, I# (len -# 1#)) bytes
420 _ccall_ fwrite byte_array (1::Int){-size-} (I# len) file
421 >>= \ (I# written) ->
422 if written ==# len then
425 error "putPS: fwrite failed!\n"
427 putPS file (CPS addr len)
431 = _ccall_ fputs (A# addr) file >>= \ (I# _){-force type-} ->
435 The dual to @_putPS@, note that the size of the chunk specified
436 is the upper bound of the size of the chunk returned.
439 getPS :: _FILE -> Int -> PrimIO PackedString
440 getPS file len@(I# len#)
441 | len# <=# 0# = return nilPS -- I'm being kind here.
443 -- Allocate an array for system call to store its bytes into.
444 new_ps_array len# >>= \ ch_arr ->
445 freeze_ps_array ch_arr >>= \ (ByteArray _ frozen#) ->
447 byte_array = ByteArray (0, I# len#) frozen#
449 _ccall_ fread byte_array (1::Int) len file >>= \ (I# read#) ->
450 if read# ==# 0# then -- EOF or other error
451 error "getPS: EOF reached or other error"
454 The system call may not return the number of
455 bytes requested. Instead of failing with an error
456 if the number of bytes read is less than requested,
457 a packed string containing the bytes we did manage
458 to snarf is returned.
461 has_null = byteArrayHasNUL# frozen# read#
463 return (PS frozen# read# has_null)
467 %************************************************************************
469 \subsection{List-mimicking functions for @PackedStrings@}
471 %************************************************************************
473 First, the basic functions that do look into the representation;
474 @indexPS@ is the most important one.
477 lengthPS :: PackedString -> Int
478 lengthPS ps = I# (lengthPS# ps)
480 {-# INLINE lengthPS# #-}
482 lengthPS# (PS _ i _) = i
483 lengthPS# (CPS _ i) = i
485 {-# INLINE strlen# #-}
487 strlen# :: Addr# -> Int
489 = unsafePerformPrimIO (
490 _ccall_ strlen (A# a) >>= \ len@(I# _) ->
494 byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool
495 byteArrayHasNUL# bs len
496 = unsafePerformPrimIO (
497 _ccall_ byteArrayHasNUL__ ba (I# len) >>= \ (I# res) ->
499 if res ==# 0# then False else True
502 ba = ByteArray (0, I# (len -# 1#)) bs
504 -----------------------
506 indexPS :: PackedString -> Int -> Char
507 indexPS ps (I# n) = C# (indexPS# ps n)
509 {-# INLINE indexPS# #-}
511 indexPS# (PS bs i _) n
512 = --ASSERT (n >=# 0# && n <# i) -- error checking: my eye! (WDP 94/10)
516 = indexCharOffAddr# a n
519 Now, the rest of the functions can be defined without digging
520 around in the representation.
523 headPS :: PackedString -> Char
525 | nullPS ps = error "headPS: head []"
526 | otherwise = C# (indexPS# ps 0#)
528 tailPS :: PackedString -> PackedString
530 | len <=# 0# = error "tailPS: tail []"
532 | otherwise = substrPS# ps 1# (len -# 1#)
536 nullPS :: PackedString -> Bool
537 nullPS (PS _ i _) = i ==# 0#
538 nullPS (CPS _ i) = i ==# 0#
540 {- (ToDo: some non-lousy implementations...)
542 Old : _appendPS xs ys = packString (unpackPS xs ++ unpackPS ys)
545 appendPS :: PackedString -> PackedString -> PackedString
549 | otherwise = concatPS [xs,ys]
551 {- OLD: mapPS f xs = packString (map f (unpackPS xs)) -}
553 mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-}
559 new_ps_array (length +# 1#) >>= \ ps_arr ->
560 whizz ps_arr length 0# >>
561 freeze_ps_array ps_arr >>= \ (ByteArray _ frozen#) ->
562 let has_null = byteArrayHasNUL# frozen# length in
563 return (PS frozen# length has_null))
565 length = lengthPS# xs
567 whizz :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
570 = write_ps_array arr# i (chr# 0#) >>
576 write_ps_array arr# i (case f (C# ch) of { (C# x) -> x}) >>
577 whizz arr# (n -# 1#) (i +# 1#)
579 filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
585 Filtering proceeds as follows:
587 * traverse the list, applying the pred. to each element,
588 remembering the positions where it was satisfied.
590 Encode these positions using a run-length encoding of the gaps
591 between the matching positions.
593 * Allocate a MutableByteArray in the heap big enough to hold
594 all the matched entries, and copy the elements that matched over.
596 A better solution that merges the scan© passes into one,
597 would be to copy the filtered elements over into a growable
598 buffer. No such operation currently supported over
599 MutableByteArrays (could of course use malloc&realloc)
600 But, this solution may in the case of repeated realloc's
601 be worse than the current solution.
605 (rle,len_filtered) = filter_ps len# 0# 0# []
606 len_filtered# = case len_filtered of { I# x# -> x#}
608 if len# ==# len_filtered# then
609 {- not much filtering as everything passed through. -}
611 else if len_filtered# ==# 0# then
614 new_ps_array (len_filtered# +# 1#) >>= \ ps_arr ->
615 copy_arr ps_arr rle 0# 0# >>
616 freeze_ps_array ps_arr >>= \ (ByteArray _ frozen#) ->
617 let has_null = byteArrayHasNUL# frozen# len_filtered# in
618 return (PS frozen# len_filtered# has_null))
622 matchOffset :: Int# -> [Char] -> (Int,[Char])
623 matchOffset off [] = (I# off,[])
624 matchOffset off (C# c:cs) =
629 if x==# 0# then -- escape code, add 255#
634 copy_arr :: MutableByteArray s Int -> [Char] -> Int# -> Int# -> ST s ()
635 copy_arr arr# [_] _ _ = return ()
636 copy_arr arr# ls n i =
638 (x,ls') = matchOffset 0# ls
639 n' = n +# (case x of { (I# x#) -> x#}) -# 1#
642 write_ps_array arr# i ch >>
643 copy_arr arr# ls' (n' +# 1#) (i +# 1#)
645 esc :: Int# -> Int# -> [Char] -> [Char]
646 esc v 0# ls = (C# (chr# v)):ls
647 esc v n ls = esc v (n -# 1#) (C# (chr# 0#):ls)
649 filter_ps :: Int# -> Int# -> Int# -> [Char] -> ([Char],Int)
650 filter_ps n hits run acc
653 escs = run `quotInt#` 255#
654 v = run `remInt#` 255#
656 (esc (v +# 1#) escs acc, I# hits)
664 escs = run `quotInt#` 255#
665 v = run `remInt#` 255#
666 acc' = esc (v +# 1#) escs acc
668 filter_ps n' (hits +# 1#) 0# acc'
670 filter_ps n' hits (run +# 1#) acc
673 foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
682 --whizzLR :: a -> Int# -> a
685 | otherwise = whizzLR (f b (C# (indexPS# ps idx))) (idx +# 1#)
688 foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
697 --whizzRL :: a -> Int# -> a
700 | otherwise = whizzRL (f (C# (indexPS# ps idx)) b) (idx -# 1#)
702 takePS :: Int -> PackedString -> PackedString
705 | otherwise = substrPS# ps 0# (n -# 1#)
707 dropPS :: Int -> PackedString -> PackedString
710 | otherwise = substrPS# ps n (lengthPS# ps -# 1#)
714 splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
715 splitAtPS n ps = (takePS n ps, dropPS n ps)
717 takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
720 break_pt = char_pos_that_dissatisfies
726 if break_pt ==# 0# then
729 substrPS# ps 0# (break_pt -# 1#)
731 dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
735 break_pt = char_pos_that_dissatisfies
741 if len ==# break_pt then
744 substrPS# ps break_pt (len -# 1#)
746 elemPS :: Char -> PackedString -> Bool
750 break_pt = first_char_pos_that_satisfies
758 char_pos_that_dissatisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
760 char_pos_that_dissatisfies p ps len pos
761 | pos >=# len = pos -- end
762 | p (indexPS# ps pos) = -- predicate satisfied; keep going
763 char_pos_that_dissatisfies p ps len (pos +# 1#)
764 | otherwise = pos -- predicate not satisfied
766 char_pos_that_dissatisfies p ps len pos -- dead code: HACK to avoid badly-typed error msg
769 first_char_pos_that_satisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
770 first_char_pos_that_satisfies p ps len pos
771 | pos >=# len = pos -- end
772 | p (indexPS# ps pos) = pos -- got it!
773 | otherwise = first_char_pos_that_satisfies p ps len (pos +# 1#)
775 -- ToDo: could certainly go quicker
776 spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
777 spanPS p ps = (takeWhilePS p ps, dropWhilePS p ps)
779 breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
780 breakPS p ps = spanPS (not . p) ps
782 linesPS :: PackedString -> [PackedString]
783 linesPS ps = splitPS '\n' ps
785 wordsPS :: PackedString -> [PackedString]
786 wordsPS ps = splitWithPS isSpace ps
788 reversePS :: PackedString -> PackedString
790 if nullPS ps then -- don't create stuff unnecessarily.
794 new_ps_array (length +# 1#) >>= \ arr# -> -- incl NUL byte!
795 fill_in arr# (length -# 1#) 0# >>
796 freeze_ps_array arr# >>= \ (ByteArray _ frozen#) ->
797 let has_null = byteArrayHasNUL# frozen# length in
798 return (PS frozen# length has_null))
800 length = lengthPS# ps
802 fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
803 fill_in arr_in# n i =
807 write_ps_array arr_in# i ch >>
809 write_ps_array arr_in# (i +# 1#) (chr# 0#) >>
812 fill_in arr_in# (n -# 1#) (i +# 1#)
814 concatPS :: [PackedString] -> PackedString
818 tot_len# = case (foldr ((+) . lengthPS) 0 pss) of { I# x -> x }
819 tot_len = I# tot_len#
822 new_ps_array (tot_len# +# 1#) >>= \ arr# -> -- incl NUL byte!
823 packum arr# pss 0# >>
824 freeze_ps_array arr# >>= \ (ByteArray _ frozen#) ->
826 let has_null = byteArrayHasNUL# frozen# tot_len# in
828 return (PS frozen# tot_len# has_null)
831 packum :: MutableByteArray s Int -> [PackedString] -> Int# -> ST s ()
834 = write_ps_array arr pos (chr# 0#) >>
836 packum arr (ps : pss) pos
837 = fill arr pos ps 0# (lengthPS# ps) >>= \ (I# next_pos) ->
838 packum arr pss next_pos
840 fill :: MutableByteArray s Int -> Int# -> PackedString -> Int# -> Int# -> ST s Int
842 fill arr arr_i ps ps_i ps_len
844 = return (I# (arr_i +# ps_len))
846 = write_ps_array arr (arr_i +# ps_i) (indexPS# ps ps_i) >>
847 fill arr arr_i ps (ps_i +# 1#) ps_len
849 ------------------------------------------------------------
850 joinPS :: PackedString -> [PackedString] -> PackedString
851 joinPS filler pss = concatPS (splice pss)
855 splice (x:y:xs) = x:filler:splice (y:xs)
857 -- ToDo: the obvious generalisation
859 Some properties that hold:
862 where False = any (map (x `elemPS`) ls')
863 False = any (map (nullPS) ls')
865 * all x's have been chopped out.
866 * no empty PackedStrings in returned list. A conseq.
871 * joinPS (packString [x]) (_splitPS x ls) = ls
875 splitPS :: Char -> PackedString -> [PackedString]
876 splitPS (C# ch) = splitWithPS (\ (C# c) -> c `eqChar#` ch)
878 splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]
879 splitWithPS pred ps =
889 first_char_pos_that_satisfies
895 if break_pt ==# n then -- immediate match, no substring to cut out.
896 splitify (break_pt +# 1#)
898 substrPS# ps n (break_pt -# 1#): -- leave out the matching character
899 splitify (break_pt +# 1#)
902 %************************************************************************
904 \subsection{Local utility functions}
906 %************************************************************************
908 The definition of @_substrPS@ is essentially:
909 @take (end - begin + 1) (drop begin str)@.
912 substrPS :: PackedString -> Int -> Int -> PackedString
913 substrPS ps (I# begin) (I# end) = substrPS# ps begin end
917 = error "substrPS: bounds out of range"
919 | s >=# len || result_len# <=# 0#
924 new_ps_array (result_len# +# 1#) >>= \ ch_arr -> -- incl NUL byte!
926 freeze_ps_array ch_arr >>= \ (ByteArray _ frozen#) ->
928 let has_null = byteArrayHasNUL# frozen# result_len# in
930 return (PS frozen# result_len# has_null)
935 result_len# = (if e <# len then (e +# 1#) else len) -# s
936 result_len = I# result_len#
938 -----------------------
939 fill_in :: MutableByteArray s Int -> Int# -> ST s ()
942 | idx ==# result_len#
943 = write_ps_array arr_in# idx (chr# 0#) >>
947 ch = indexPS# ps (s +# idx)
949 write_ps_array arr_in# idx ch >>
950 fill_in arr_in# (idx +# 1#)
953 (Very :-) ``Specialised'' versions of some CharArray things...
956 new_ps_array :: Int# -> ST s (MutableByteArray s Int)
957 write_ps_array :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
958 freeze_ps_array :: MutableByteArray s Int -> ST s (ByteArray Int)
960 new_ps_array size = ST $ \ (S# s) ->
961 case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# ->
962 (MutableByteArray bot barr#, S# s2#)}
964 bot = error "new_ps_array"
966 write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ (S# s#) ->
967 case writeCharArray# barr# n ch s# of { s2# ->
970 -- same as unsafeFreezeByteArray
971 freeze_ps_array (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
972 case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
973 (ByteArray ixs frozen#, S# s2#) }
977 %*********************************************************
979 \subsection{Packing and unpacking C strings}
981 %*********************************************************
984 unpackCString :: Addr -> [Char]
986 -- Calls to the next four are injected by the compiler itself,
987 -- to deal with literal strings
988 packCString# :: [Char] -> ByteArray#
989 unpackCString# :: Addr# -> [Char]
990 unpackCString2# :: Addr# -> Int -> [Char]
991 unpackAppendCString# :: Addr# -> [Char] -> [Char]
992 unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
994 packCString# str = case (packString str) of { PS bytes _ _ -> bytes }
996 unpackCString (A# addr) = unpackCString# addr
1002 | ch `eqChar#` '\0'# = []
1003 | True = C# ch : unpack (nh +# 1#)
1005 ch = indexCharOffAddr# addr nh
1007 unpackCString2# addr len
1008 -- This one is called by the compiler to unpack literal strings with NULs in them; rare.
1009 = unpackPS (packCBytes len (A# addr))
1011 unpackAppendCString# addr rest
1015 | ch `eqChar#` '\0'# = rest
1016 | True = C# ch : unpack (nh +# 1#)
1018 ch = indexCharOffAddr# addr nh
1020 unpackFoldrCString# addr f z
1024 | ch `eqChar#` '\0'# = z
1025 | True = C# ch `f` unpack (nh +# 1#)
1027 ch = indexCharOffAddr# addr nh
1030 cStringToPS :: Addr -> PackedString
1031 cStringToPS (A# a#) = -- the easy one; we just believe the caller
1034 len = case (strlen# a#) of { I# x -> x }
1036 packBytesForC :: [Char] -> ByteArray Int
1037 packBytesForC str = psToByteArray (packString str)
1039 packBytesForCST :: [Char] -> ST s (ByteArray Int)
1040 packBytesForCST str =
1041 packStringST str >>= \ (PS bytes n has_null) ->
1042 --later? ASSERT(not has_null)
1043 return (ByteArray (0, I# (n -# 1#)) bytes)
1045 packNBytesForCST :: Int -> [Char] -> ST s (ByteArray Int)
1046 packNBytesForCST len str =
1047 packNCharsST len str >>= \ (PS bytes n has_null) ->
1048 return (ByteArray (0, I# (n -# 1#)) bytes)
1050 packCBytes :: Int -> Addr -> PackedString
1051 packCBytes len addr = runST (packCBytesST len addr)
1053 packCBytesST :: Int -> Addr -> ST s PackedString
1054 packCBytesST len@(I# length#) (A# addr) =
1056 allocate an array that will hold the string
1057 (not forgetting the NUL byte at the end)
1059 new_ps_array (length# +# 1#) >>= \ ch_array ->
1060 -- fill in packed string from "addr"
1061 fill_in ch_array 0# >>
1062 -- freeze the puppy:
1063 freeze_ps_array ch_array >>= \ (ByteArray _ frozen#) ->
1064 let has_null = byteArrayHasNUL# frozen# length# in
1065 return (PS frozen# length# has_null)
1067 fill_in :: MutableByteArray s Int -> Int# -> ST s ()
1071 = write_ps_array arr_in# idx (chr# 0#) >>
1074 = case (indexCharOffAddr# addr idx) of { ch ->
1075 write_ps_array arr_in# idx ch >>
1076 fill_in arr_in# (idx +# 1#) }