%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section{Packed strings}
unsafeByteArrayToPS, -- :: ByteArray a -> Int -> PackedString
psToByteArray, -- :: PackedString -> ByteArray Int
- psToByteArrayST, -- :: PackedString -> ST s (ByteArray Int)
psToCString, -- :: PackedString -> Addr
isCString, -- :: PackedString -> Bool
unpackNBytesPS, -- :: PackedString -> Int -> [Char]
unpackPSIO, -- :: PackedString -> IO [Char]
-{-LATER:
hPutPS, -- :: Handle -> PackedString -> IO ()
- putPS, -- :: FILE -> PackedString -> PrimIO () -- ToDo: more sensible type
- getPS, -- :: FILE -> Int -> PrimIO PackedString
--}
+ hGetPS, -- :: Handle -> Int -> IO PackedString
+
nilPS, -- :: PackedString
consPS, -- :: Char -> PackedString -> PackedString
headPS, -- :: PackedString -> Char
-}
substrPS, -- :: PackedString -> Int -> Int -> PackedString
- comparePS,
-
- -- Converting to C strings
- packCString#,
- unpackCString#,
- unpackCString2#,
- unpackAppendCString#,
- unpackFoldrCString#,
- unpackCString,
- unpackCStringIO,
- unpackCStringLenIO
+ comparePS -- :: PackedString -> PackedString -> Ordering
) where
import GlaExts
import PrelBase ( showList__ ) -- ToDo: better
+import PrelPack
+ ( new_ps_array
+ , freeze_ps_array
+ , write_ps_array
+ )
import Addr
import PrelArr ( StateAndMutableByteArray#(..) , StateAndByteArray#(..) )
import PrelST
import ST
import IOExts ( unsafePerformIO )
+import IO
+import PrelHandle ( hFillBufBA )
import Ix
import Char (isSpace)
-- fill in packed string from "str"
fill_in ch_array 0# str >>
-- freeze the puppy:
- freeze_ps_array ch_array >>= \ (ByteArray _ frozen#) ->
+ freeze_ps_array ch_array length# >>= \ (ByteArray _ frozen#) ->
let has_null = byteArrayHasNUL# frozen# length# in
return (PS frozen# length# has_null)
where
unpackNBytesPS :: PackedString -> Int -> [Char]
unpackNBytesPS ps len@(I# l#)
| len < 0 = error ("PackedString.unpackNBytesPS: negative length "++ show len)
+ | len == 0 = []
| otherwise =
case ps of
PS bytes len# has_null -> unpackPS (PS bytes (min# len# l#) has_null)
Output a packed string via a handle:
\begin{code}
-{- LATER:
hPutPS :: Handle -> PackedString -> IO ()
-hPutPS handle ps =
- let
- len =
- case ps of
- PS _ len _ -> len
- CPS _ len -> len
- in
- if len ==# 0# then
- return ()
- else
- _readHandle handle >>= \ htype ->
- case htype of
- _ErrorHandle ioError ->
- _writeHandle handle htype >>
- failWith ioError
- _ClosedHandle ->
- _writeHandle handle htype >>
- failWith (IllegalOperation "handle is closed")
- _SemiClosedHandle _ _ ->
- _writeHandle handle htype >>
- failWith (IllegalOperation "handle is closed")
- _ReadHandle _ _ _ ->
- _writeHandle handle htype >>
- failWith (IllegalOperation "handle is not open for writing")
- other ->
- _getBufferMode other >>= \ other ->
- (case _bufferMode other of
- Just LineBuffering ->
- writeLines (_filePtr other)
- Just (BlockBuffering (Just size)) ->
- writeBlocks (_filePtr other) size
- Just (BlockBuffering Nothing) ->
- writeBlocks (_filePtr other) ``BUFSIZ''
- _ -> -- Nothing is treated pessimistically as NoBuffering
- writeChars (_filePtr other) 0#
- ) >>= \ success ->
- _writeHandle handle (_markHandle other) >>
- if success then
- return ()
- else
- _constructError "hPutStr" >>= \ ioError ->
- failWith ioError
-
+hPutPS handle (CPS a# len#) = hPutBuf handle (A# a#) (I# len#)
+hPutPS handle (PS ba# len# _) = hPutBufBA handle (ByteArray bottom ba#) (I# len#)
where
- pslen = lengthPS# ps
-
- writeLines :: Addr -> IO Bool
- writeLines = writeChunks ``BUFSIZ'' True
-
- writeBlocks :: Addr -> Int -> IO Bool
- writeBlocks fp size = writeChunks size False fp
-
- {-
- The breaking up of output into lines along \n boundaries
- works fine as long as there are newlines to split by.
- Avoid the splitting up into lines altogether (doesn't work
- for overly long lines like the stuff that showsPrec instances
- normally return). Instead, we split them up into fixed size
- chunks before blasting them off to the Real World.
-
- Hacked to avoid multiple passes over the strings - unsightly, but
- a whole lot quicker. -- SOF 3/96
- -}
-
- writeChunks :: Int -> Bool -> Addr -> IO Bool
- writeChunks (I# bufLen) chopOnNewLine fp =
- newCharArray (0,I# bufLen) >>= \ arr@(MutableByteArray _ arr#) ->
- let
- shoveString :: Int# -> Int# -> IO Bool
- shoveString n i
- | i ==# pslen = -- end of string
- if n ==# 0# then
- return True
- else
- _ccall_ writeFile arr fp (I# n) >>= \rc ->
- return (rc==0)
- | otherwise =
- (\ (S# s#) ->
- case writeCharArray# arr# n (indexPS# ps i) s# of
- s1# ->
- {- Flushing lines - should we bother? -}
- (if n ==# bufLen then
- _ccall_ writeFile arr fp (I# (n +# 1#)) >>= \rc ->
- if rc == 0 then
- shoveString 0# (i +# 1#)
- else
- return False
- else
- shoveString (n +# 1#) (i +# 1#)) (S# s1#))
- in
- shoveString 0# 0#
-
- writeChars :: Addr -> Int# -> IO Bool
- writeChars fp i
- | i ==# pslen = return True
- | otherwise =
- _ccall_ filePutc fp (ord (C# (indexPS# ps i))) >>= \ rc ->
- if rc == 0 then
- writeChars fp (i +# 1#)
- else
- return False
-
----------------------------------------------
-
-putPS :: _FILE -> PackedString -> IO ()
-putPS file ps@(PS bytes len has_null)
- | len ==# 0#
- = return ()
- | otherwise
- = let
- byte_array = ByteArray (0, I# (len -# 1#)) bytes
- in
- _ccall_ fwrite byte_array (1::Int){-size-} (I# len) file
- >>= \ (I# written) ->
- if written ==# len then
- return ()
- else
- error "putPS: fwrite failed!\n"
-
-putPS file (CPS addr len)
- | len ==# 0#
- = return ()
- | otherwise
- = _ccall_ fputs (A# addr) file >>= \ (I# _){-force type-} ->
- return ()
+ bottom = error "hPutPS"
\end{code}
The dual to @_putPS@, note that the size of the chunk specified
is the upper bound of the size of the chunk returned.
\begin{code}
-getPS :: _FILE -> Int -> IO PackedString
-getPS file len@(I# len#)
+hGetPS :: Handle -> Int -> IO PackedString
+hGetPS hdl len@(I# len#)
| len# <=# 0# = return nilPS -- I'm being kind here.
| otherwise =
-- Allocate an array for system call to store its bytes into.
- new_ps_array len# >>= \ ch_arr ->
- freeze_ps_array ch_arr >>= \ (ByteArray _ frozen#) ->
+ stToIO (new_ps_array len# ) >>= \ ch_arr ->
+ stToIO (freeze_ps_array ch_arr len#) >>= \ (ByteArray _ frozen#) ->
let
byte_array = ByteArray (0, I# len#) frozen#
in
- _ccall_ fread byte_array (1::Int) len file >>= \ (I# read#) ->
+ hFillBufBA hdl byte_array len >>= \ (I# read#) ->
if read# ==# 0# then -- EOF or other error
- error "getPS: EOF reached or other error"
+ fail (userError "hGetPS: EOF reached or other error")
else
{-
The system call may not return the number of
has_null = byteArrayHasNUL# frozen# read#
in
return (PS frozen# read# has_null)
-END LATER -}
+
\end{code}
%************************************************************************
nullPS (PS _ i _) = i ==# 0#
nullPS (CPS _ i) = i ==# 0#
-{- (ToDo: some non-lousy implementations...)
-
- Old : _appendPS xs ys = packString (unpackPS xs ++ unpackPS ys)
-
--}
appendPS :: PackedString -> PackedString -> PackedString
appendPS xs ys
| nullPS xs = ys
| nullPS ys = xs
| otherwise = concatPS [xs,ys]
-{- OLD: mapPS f xs = packString (map f (unpackPS xs)) -}
-
mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-}
mapPS f xs =
if nullPS xs then
runST (
new_ps_array (length +# 1#) >>= \ ps_arr ->
whizz ps_arr length 0# >>
- freeze_ps_array ps_arr >>= \ (ByteArray _ frozen#) ->
+ freeze_ps_array ps_arr length >>= \ (ByteArray _ frozen#) ->
let has_null = byteArrayHasNUL# frozen# length in
return (PS frozen# length has_null))
where
else if len_filtered# ==# 0# then
return nilPS
else
- new_ps_array (len_filtered# +# 1#) >>= \ ps_arr ->
- copy_arr ps_arr rle 0# 0# >>
- freeze_ps_array ps_arr >>= \ (ByteArray _ frozen#) ->
+ new_ps_array (len_filtered# +# 1#) >>= \ ps_arr ->
+ copy_arr ps_arr rle 0# 0# >>
+ freeze_ps_array ps_arr len_filtered# >>= \ (ByteArray _ frozen#) ->
let has_null = byteArrayHasNUL# frozen# len_filtered# in
return (PS frozen# len_filtered# has_null))
where
runST (
new_ps_array (length +# 1#) >>= \ arr# -> -- incl NUL byte!
fill_in arr# (length -# 1#) 0# >>
- freeze_ps_array arr# >>= \ (ByteArray _ frozen#) ->
+ freeze_ps_array arr# length >>= \ (ByteArray _ frozen#) ->
let has_null = byteArrayHasNUL# frozen# length in
return (PS frozen# length has_null))
where
runST (
new_ps_array (tot_len# +# 1#) >>= \ arr# -> -- incl NUL byte!
packum arr# pss 0# >>
- freeze_ps_array arr# >>= \ (ByteArray _ frozen#) ->
+ freeze_ps_array arr# tot_len# >>= \ (ByteArray _ frozen#) ->
let has_null = byteArrayHasNUL# frozen# tot_len# in
| otherwise
= runST (
- new_ps_array (result_len# +# 1#) >>= \ ch_arr -> -- incl NUL byte!
- fill_in ch_arr 0# >>
- freeze_ps_array ch_arr >>= \ (ByteArray _ frozen#) ->
+ new_ps_array (result_len# +# 1#) >>= \ ch_arr -> -- incl NUL byte!
+ fill_in ch_arr 0# >>
+ freeze_ps_array ch_arr result_len# >>= \ (ByteArray _ frozen#) ->
let has_null = byteArrayHasNUL# frozen# result_len# in
fill_in arr_in# (idx +# 1#)
\end{code}
-(Very :-) ``Specialised'' versions of some CharArray things...
-
-\begin{code}
-new_ps_array :: Int# -> ST s (MutableByteArray s Int)
-write_ps_array :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
-freeze_ps_array :: MutableByteArray s Int -> ST s (ByteArray Int)
-
-new_ps_array size = ST $ \ s# ->
- case newCharArray# size s# of { StateAndMutableByteArray# s2# barr# ->
- STret s2# (MutableByteArray bot barr#)}
- where
- bot = error "new_ps_array"
-
-write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
- case writeCharArray# barr# n ch s# of { s2# ->
- STret s2# ()}
-
--- same as unsafeFreezeByteArray
-freeze_ps_array (MutableByteArray ixs arr#) = ST $ \ s# ->
- case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
- STret s2# (ByteArray ixs frozen#) }
-\end{code}
-
-
%*********************************************************
%* *
\subsection{Packing and unpacking C strings}
%*********************************************************
\begin{code}
-unpackCString :: Addr -> [Char]
-
--- Calls to the next four are injected by the compiler itself,
--- to deal with literal strings
-packCString# :: [Char] -> ByteArray#
-unpackCString# :: Addr# -> [Char]
-unpackCString2# :: Addr# -> Int# -> [Char]
-unpackAppendCString# :: Addr# -> [Char] -> [Char]
-unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
-
-packCString# str = case (packString str) of { PS bytes _ _ -> bytes }
-
-unpackCString a@(A# addr) =
- if a == ``NULL'' then
- []
- else
- unpackCString# addr
-
-unpackCString# addr
- = unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = []
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
-
-unpackCStringIO :: Addr -> IO String
-unpackCStringIO addr = unpack 0#
- where
- unpack nh = do
- ch <- readCharOffAddr addr (I# nh)
- if ch == '\0'
- then return []
- else do
- ls <- unpack (nh +# 1#)
- return (ch : ls)
-
--- unpack 'len' chars
-unpackCStringLenIO :: Addr -> Int -> IO String
-unpackCStringLenIO addr l@(I# len#)
- | len# <# 0# = fail (userError ("PackedString.unpackCStringLenIO: negative length (" ++ show l ++ ")"))
- | otherwise = unpack len#
- where
- unpack 0# = return []
- unpack nh = do
- ch <- readCharOffAddr addr (I# nh)
- ls <- unpack (nh -# 1#)
- return (ch : ls)
-
-
-unpackCString2# addr len
- -- This one is called by the compiler to unpack literal strings with NULs in them; rare.
- = unpackPS (packCBytes (I# len) (A# addr))
-
-unpackAppendCString# addr rest
- = unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = rest
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
-
-unpackFoldrCString# addr f z
- = unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = z
- | otherwise = C# ch `f` unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
-
-
cStringToPS :: Addr -> PackedString
cStringToPS (A# a#) = -- the easy one; we just believe the caller
CPS a# len
where
len = case (strlen# a#) of { I# x -> x }
-packBytesForC :: [Char] -> ByteArray Int
-packBytesForC str = psToByteArray (packString 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)
-
-packNBytesForCST :: Int -> [Char] -> ST s (ByteArray Int)
-packNBytesForCST len str =
- packNCharsST len str >>= \ (PS bytes n has_null) ->
- return (ByteArray (0, I# (n -# 1#)) bytes)
-
packCBytes :: Int -> Addr -> PackedString
packCBytes len addr = runST (packCBytesST len addr)
-- fill in packed string from "addr"
fill_in ch_array 0# >>
-- freeze the puppy:
- freeze_ps_array ch_array >>= \ (ByteArray _ frozen#) ->
+ freeze_ps_array ch_array length# >>= \ (ByteArray _ frozen#) ->
let has_null = byteArrayHasNUL# frozen# length# in
return (PS frozen# length# has_null)
where
projects / ghc-hetmet.git / blobdiff