Glorious hacking (all the hard work) by Bryan O'Sullivan.
\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS -fno-implicit-prelude '-#include "cbits/stgio.h"' #-}
module PackedString (
+ PackedString, -- abstract
- packString, -- :: [Char] -> PackedString
- packStringST, -- :: [Char] -> ST s PackedString
- nilPS, -- :: PackedString
- consPS, -- :: Char -> PackedString -> PackedString
+ -- Creating the beasts
+ packString, -- :: [Char] -> PackedString
+ packStringST, -- :: [Char] -> ST s PackedString
+ packCBytesST, -- :: Int -> Addr -> ST s PackedString
byteArrayToPS, -- :: ByteArray Int -> PackedString
unsafeByteArrayToPS, -- :: ByteArray a -> Int -> PackedString
+
psToByteArray, -- :: PackedString -> ByteArray Int
+ psToByteArrayST, -- :: PackedString -> ST s (ByteArray Int)
unpackPS, -- :: PackedString -> [Char]
{-LATER:
putPS, -- :: FILE -> PackedString -> PrimIO () -- ToDo: more sensible type
getPS, -- :: FILE -> Int -> PrimIO PackedString
-}
+ nilPS, -- :: PackedString
+ consPS, -- :: Char -> PackedString -> PackedString
headPS, -- :: PackedString -> Char
tailPS, -- :: PackedString -> PackedString
nullPS, -- :: PackedString -> Bool
comparePS,
- -- Converting to C strings
+ -- Converting to C strings
packCString#,
unpackCString#, unpackCString2#, unpackAppendCString#, unpackFoldrCString#,
- packCBytesST, unpackCString
+ unpackCString
) where
import {-# SOURCE #-} IOBase ( error )
import STBase
import ArrBase
import PrelBase
+import Foreign ( Addr(..) )
import GHC
+
\end{code}
%************************************************************************
char_pos_that_dissatisfies p ps len (pos +# 1#)
| otherwise = pos -- predicate not satisfied
-char_pos_that_dissatisfies p ps len pos -- dead code: HACK to avoid badly-typed error msg
- = 0#
-
first_char_pos_that_satisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
first_char_pos_that_satisfies p ps len pos
| pos >=# len = pos -- end
-- to deal with literal strings
packCString# :: [Char] -> ByteArray#
unpackCString# :: Addr# -> [Char]
-unpackCString2# :: Addr# -> Int -> [Char]
+unpackCString2# :: Addr# -> Int# -> [Char]
unpackAppendCString# :: Addr# -> [Char] -> [Char]
unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
where
unpack nh
| ch `eqChar#` '\0'# = []
- | True = C# ch : unpack (nh +# 1#)
+ | otherwise = C# ch : unpack (nh +# 1#)
where
ch = indexCharOffAddr# addr nh
unpackCString2# addr len
-- This one is called by the compiler to unpack literal strings with NULs in them; rare.
- = unpackPS (packCBytes len (A# addr))
+ = unpackPS (packCBytes (I# len) (A# addr))
unpackAppendCString# addr rest
= unpack 0#
where
unpack nh
| ch `eqChar#` '\0'# = rest
- | True = C# ch : unpack (nh +# 1#)
+ | otherwise = C# ch : unpack (nh +# 1#)
where
ch = indexCharOffAddr# addr nh
where
unpack nh
| ch `eqChar#` '\0'# = z
- | True = C# ch `f` unpack (nh +# 1#)
+ | otherwise = C# ch `f` unpack (nh +# 1#)
where
ch = indexCharOffAddr# addr nh
packBytesForC :: [Char] -> ByteArray Int
packBytesForC str = psToByteArray (packString str)
-packBytesForCST :: [Char] -> ST s (ByteArray Int)
-packBytesForCST str =
+psToByteArrayST :: [Char] -> ST s (ByteArray Int)
+psToByteArrayST str =
packStringST str >>= \ (PS bytes n has_null) ->
--later? ASSERT(not has_null)
return (ByteArray (0, I# (n -# 1#)) bytes)
= case (indexCharOffAddr# addr idx) of { ch ->
write_ps_array arr_in# idx ch >>
fill_in arr_in# (idx +# 1#) }
-\end{code}
-
+\end{code}