+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
-\section{Packed strings}
-
-This sits on top of the sequencing/arrays world, notably @ByteArray#@s.
-
-Glorious hacking (all the hard work) by Bryan O'Sullivan.
-
-\begin{code}
-{-# OPTIONS -#include "cbits/PackedString.h" #-}
-
-module PackedString (
- PackedString, -- abstract
-
- -- Creating the beasts
- packString, -- :: [Char] -> PackedString
- packStringST, -- :: [Char] -> ST s PackedString
- packCBytesST, -- :: Int -> Addr -> ST s PackedString
-
- byteArrayToPS, -- :: ByteArray Int -> PackedString
- cByteArrayToPS, -- :: ByteArray Int -> PackedString
- unsafeByteArrayToPS, -- :: ByteArray a -> Int -> PackedString
-
- psToByteArray, -- :: PackedString -> ByteArray Int
- psToCString, -- :: PackedString -> Addr
- isCString, -- :: PackedString -> Bool
-
- unpackPS, -- :: PackedString -> [Char]
- unpackNBytesPS, -- :: PackedString -> Int -> [Char]
- unpackPSIO, -- :: PackedString -> IO [Char]
-
- hPutPS, -- :: Handle -> PackedString -> IO ()
- hGetPS, -- :: Handle -> Int -> IO PackedString
-
- nilPS, -- :: PackedString
- consPS, -- :: Char -> PackedString -> PackedString
- headPS, -- :: PackedString -> Char
- tailPS, -- :: PackedString -> PackedString
- nullPS, -- :: PackedString -> Bool
- appendPS, -- :: PackedString -> PackedString -> PackedString
- lengthPS, -- :: PackedString -> Int
- {- 0-origin indexing into the string -}
- indexPS, -- :: PackedString -> Int -> Char
- mapPS, -- :: (Char -> Char) -> PackedString -> PackedString
- filterPS, -- :: (Char -> Bool) -> PackedString -> PackedString
- foldlPS, -- :: (a -> Char -> a) -> a -> PackedString -> a
- foldrPS, -- :: (Char -> a -> a) -> a -> PackedString -> a
- takePS, -- :: Int -> PackedString -> PackedString
- dropPS, -- :: Int -> PackedString -> PackedString
- splitAtPS, -- :: Int -> PackedString -> (PackedString, PackedString)
- takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
- dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
- spanPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
- breakPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
- linesPS, -- :: PackedString -> [PackedString]
-
- wordsPS, -- :: PackedString -> [PackedString]
- reversePS, -- :: PackedString -> PackedString
- splitPS, -- :: Char -> PackedString -> [PackedString]
- splitWithPS, -- :: (Char -> Bool) -> PackedString -> [PackedString]
- joinPS, -- :: PackedString -> [PackedString] -> PackedString
- concatPS, -- :: [PackedString] -> PackedString
- elemPS, -- :: Char -> PackedString -> Bool
-
- {-
- Pluck out a piece of a PS start and end
- chars you want; both 0-origin-specified
- -}
- substrPS, -- :: PackedString -> Int -> Int -> PackedString
-
- comparePS -- :: PackedString -> PackedString -> Ordering
-
- ) where
-
-import GlaExts
-import PrelShow ( showList__ ) -- ToDo: better
-import PrelPack
- ( new_ps_array
- , freeze_ps_array
- , write_ps_array
- )
-import Addr
-
-import PrelST
-import ST
-import IOExts ( unsafePerformIO )
-import IO
-import PrelHandle ( hFillBufBA )
-
-import Ix
-import Char (isSpace)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{@PackedString@ type declaration}
-%* *
-%************************************************************************
-
-\begin{code}
-data PackedString
- = PS ByteArray# -- the bytes
- Int# -- length (*not* including NUL at the end)
- Bool -- True <=> contains a NUL
- | CPS Addr# -- pointer to the (null-terminated) bytes in C land
- Int# -- length, as per strlen
- -- definitely doesn't contain a NUL
-
-instance Eq PackedString where
- x == y = compare x y == EQ
- x /= y = compare x y /= EQ
-
-instance Ord PackedString where
- compare = comparePS
- x <= y = compare x y /= GT
- x < y = compare x y == LT
- x >= y = compare x y /= LT
- x > y = compare x y == GT
- max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x }
- min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y }
-
---instance Read PackedString: ToDo
-
-instance Show PackedString where
- showsPrec p ps r = showsPrec p (unpackPS ps) r
- showList = showList__ (showsPrec 0)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{@PackedString@ instances}
-%* *
-%************************************************************************
-
-We try hard to make this go fast:
-\begin{code}
-comparePS :: PackedString -> PackedString -> Ordering
-
-comparePS (PS bs1 len1 has_null1) (PS bs2 len2 has_null2)
- | not has_null1 && not has_null2
- = unsafePerformIO (
- _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
- return (
- if res <# 0# then LT
- else if res ==# 0# then EQ
- else GT
- ))
- where
- ba1 = ByteArray 0 (I# (len1 -# 1#)) bs1
- ba2 = ByteArray 0 (I# (len2 -# 1#)) bs2
-
-comparePS (PS bs1 len1 has_null1) (CPS bs2 _)
- | not has_null1
- = unsafePerformIO (
- _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
- return (
- if res <# 0# then LT
- else if res ==# 0# then EQ
- else GT
- ))
- where
- ba1 = ByteArray 0 (I# (len1 -# 1#)) bs1
- ba2 = A# bs2
-
-comparePS (CPS bs1 len1) (CPS bs2 _)
- = unsafePerformIO (
- _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
- return (
- if res <# 0# then LT
- else if res ==# 0# then EQ
- else GT
- ))
- where
- ba1 = A# bs1
- ba2 = A# bs2
-
-comparePS a@(CPS _ _) b@(PS _ _ has_null2)
- | not has_null2
- = -- try them the other way 'round
- case (comparePS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
-
-comparePS ps1 ps2 -- slow catch-all case (esp for "has_null" True)
- = looking_at 0#
- where
- end1 = lengthPS# ps1 -# 1#
- end2 = lengthPS# ps2 -# 1#
-
- looking_at char#
- = if char# ># end1 then
- if char# ># end2 then -- both strings ran out at once
- EQ
- else -- ps1 ran out before ps2
- LT
- else if char# ># end2 then
- GT -- ps2 ran out before ps1
- else
- let
- ch1 = indexPS# ps1 char#
- ch2 = indexPS# ps2 char#
- in
- if ch1 `eqChar#` ch2 then
- looking_at (char# +# 1#)
- else if ch1 `ltChar#` ch2 then LT
- else GT
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Constructor functions}
-%* *
-%************************************************************************
-
-Easy ones first. @packString@ requires getting some heap-bytes and
-scribbling stuff into them.
-
-\begin{code}
-nilPS :: PackedString
-nilPS = CPS ""# 0#
-
-consPS :: Char -> PackedString -> PackedString
-consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better
-
-packString :: [Char] -> PackedString
-packString str = runST (packStringST str)
-
-packStringST :: [Char] -> ST s PackedString
-packStringST str =
- let len = length str in
- packNCharsST len str
-
-packNCharsST :: Int -> [Char] -> ST s PackedString
-packNCharsST (I# length#) str =
- {-
- allocate an array that will hold the string
- (not forgetting the NUL byte at the end)
- -}
- new_ps_array (length# +# 1#) >>= \ ch_array ->
- -- fill in packed string from "str"
- fill_in ch_array 0# str >>
- -- freeze the puppy:
- freeze_ps_array ch_array length# >>= \ (ByteArray _ _ frozen#) ->
- let has_null = byteArrayHasNUL# frozen# length# in
- return (PS frozen# length# has_null)
- where
- fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
- fill_in arr_in# idx [] =
- write_ps_array arr_in# idx (chr# 0#) >>
- return ()
-
- fill_in arr_in# idx (C# c : cs) =
- write_ps_array arr_in# idx c >>
- fill_in arr_in# (idx +# 1#) cs
-
-byteArrayToPS :: ByteArray Int -> PackedString
-byteArrayToPS (ByteArray l u frozen#) =
- let
- ixs = (l,u)
- n# =
- case (
- if null (range ixs)
- then 0
- else ((index ixs u) + 1)
- ) of { I# x -> x }
- in
- PS frozen# n# (byteArrayHasNUL# frozen# n#)
-
--- byteArray is zero-terminated, make everything upto it
--- a packed string.
-cByteArrayToPS :: ByteArray Int -> PackedString
-cByteArrayToPS (ByteArray l u frozen#) =
- let
- ixs = (l,u)
- n# =
- case (
- if null (range ixs)
- then 0
- else ((index ixs u) + 1)
- ) of { I# x -> x }
- len# = findNull 0#
-
- findNull i#
- | i# ==# n# = n#
- | ch# `eqChar#` '\0'# = i# -- everything upto the sentinel
- | otherwise = findNull (i# +# 1#)
- where
- ch# = indexCharArray# frozen# i#
- in
- PS frozen# len# False
-
-unsafeByteArrayToPS :: ByteArray a -> Int -> PackedString
-unsafeByteArrayToPS (ByteArray _ _ frozen#) (I# n#)
- = PS frozen# n# (byteArrayHasNUL# frozen# n#)
-
-psToByteArray :: PackedString -> ByteArray Int
-psToByteArray (PS bytes n _) = ByteArray 0 (I# (n -# 1#)) bytes
-
-psToByteArray (CPS addr len#)
- = let
- len = I# len#
- byte_array_form = packCBytes len (A# addr)
- in
- case byte_array_form of { PS bytes _ _ ->
- ByteArray 0 (len - 1) bytes }
-
--- isCString is useful when passing PackedStrings to the
--- outside world, and need to figure out whether you can
--- pass it as an Addr or ByteArray.
---
-isCString :: PackedString -> Bool
-isCString (CPS _ _ ) = True
-isCString _ = False
-
-psToCString :: PackedString -> Addr
-psToCString (CPS addr _) = (A# addr)
-psToCString (PS bytes l# _) =
- unsafePerformIO $ do
- stuff <- _ccall_ malloc ((I# l#) * (``sizeof(char)''))
- let
- fill_in n# i#
- | n# ==# 0# = return ()
- | otherwise = do
- let ch# = indexCharArray# bytes i#
- writeCharOffAddr stuff (I# i#) (C# ch#)
- fill_in (n# -# 1#) (i# +# 1#)
- fill_in l# 0#
- return stuff
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Destructor functions (taking @PackedStrings@ apart)}
-%* *
-%************************************************************************
-
-\begin{code}
--- OK, but this code gets *hammered*:
--- unpackPS ps
--- = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ]
-
-unpackPS :: PackedString -> [Char]
-unpackPS (PS bytes len _) = unpack 0#
- where
- unpack nh
- | nh >=# len = []
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharArray# bytes nh
-
-unpackPS (CPS addr _) = unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = []
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
-
-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)
- CPS a len# -> unpackPS (CPS a (min# len# l#))
- where
- min# x# y#
- | x# <# y# = x#
- | otherwise = y#
-
-unpackPSIO :: PackedString -> IO String
-unpackPSIO ps@(PS bytes _ _) = return (unpackPS ps)
-unpackPSIO (CPS addr _) = unpack 0#
- where
- unpack nh = do
- ch <- readCharOffAddr (A# addr) (I# nh)
- if ch == '\0'
- then return []
- else do
- ls <- unpack (nh +# 1#)
- return (ch : ls)
-
-\end{code}
-
-Output a packed string via a handle:
-
-\begin{code}
-hPutPS :: Handle -> PackedString -> IO ()
-hPutPS handle (CPS a# len#) = hPutBuf handle (A# a#) (I# len#)
-hPutPS handle (PS ba# len# _) = hPutBufBA handle (ByteArray bottom bottom ba#) (I# len#)
- where
- 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}
-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.
- 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
- hFillBufBA hdl byte_array len >>= \ (I# read#) ->
- if read# ==# 0# then -- EOF or other error
- ioError (userError "hGetPS: EOF reached or other error")
- else
- {-
- The system call may not return the number of
- bytes requested. Instead of failing with an error
- if the number of bytes read is less than requested,
- a packed string containing the bytes we did manage
- to snarf is returned.
- -}
- let
- has_null = byteArrayHasNUL# frozen# read#
- in
- return (PS frozen# read# has_null)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{List-mimicking functions for @PackedStrings@}
-%* *
-%************************************************************************
-
-First, the basic functions that do look into the representation;
-@indexPS@ is the most important one.
-
-\begin{code}
-lengthPS :: PackedString -> Int
-lengthPS ps = I# (lengthPS# ps)
-
-{-# INLINE lengthPS# #-}
-
-lengthPS# :: PackedString -> Int#
-lengthPS# (PS _ i _) = i
-lengthPS# (CPS _ i) = i
-
-{-# INLINE strlen# #-}
-
-strlen# :: Addr# -> Int
-strlen# a
- = unsafePerformIO (
- _ccall_ strlen (A# a) >>= \ len@(I# _) ->
- return len
- )
-
-byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool
-byteArrayHasNUL# bs len
- = unsafePerformIO (
- _ccall_ byteArrayHasNUL__ ba (I# len) >>= \ (I# res) ->
- return (
- if res ==# 0# then False else True
- ))
- where
- ba = ByteArray 0 (I# (len -# 1#)) bs
-
------------------------
-
-indexPS :: PackedString -> Int -> Char
-indexPS ps (I# n) = C# (indexPS# ps n)
-
-{-# INLINE indexPS# #-}
-
-indexPS# :: PackedString -> Int# -> Char#
-indexPS# (PS bs i _) n
- = --ASSERT (n >=# 0# && n <# i) -- error checking: my eye! (WDP 94/10)
- indexCharArray# bs n
-
-indexPS# (CPS a _) n
- = indexCharOffAddr# a n
-\end{code}
-
-Now, the rest of the functions can be defined without digging
-around in the representation.
-
-\begin{code}
-headPS :: PackedString -> Char
-headPS ps
- | nullPS ps = error "headPS: head []"
- | otherwise = C# (indexPS# ps 0#)
-
-tailPS :: PackedString -> PackedString
-tailPS ps
- | len <=# 0# = error "tailPS: tail []"
- | len ==# 1# = nilPS
- | otherwise = substrPS# ps 1# (len -# 1#)
- where
- len = lengthPS# ps
-
-nullPS :: PackedString -> Bool
-nullPS (PS _ i _) = i ==# 0#
-nullPS (CPS _ i) = i ==# 0#
-
-appendPS :: PackedString -> PackedString -> PackedString
-appendPS xs ys
- | nullPS xs = ys
- | nullPS ys = xs
- | otherwise = concatPS [xs,ys]
-
-mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-}
-mapPS f xs =
- if nullPS xs then
- xs
- else
- runST (
- new_ps_array (length +# 1#) >>= \ ps_arr ->
- whizz ps_arr length 0# >>
- freeze_ps_array ps_arr length >>= \ (ByteArray _ _ frozen#) ->
- let has_null = byteArrayHasNUL# frozen# length in
- return (PS frozen# length has_null))
- where
- length = lengthPS# xs
-
- whizz :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
- whizz arr# n i
- | n ==# 0#
- = write_ps_array arr# i (chr# 0#) >>
- return ()
- | otherwise
- = let
- ch = indexPS# xs i
- in
- write_ps_array arr# i (case f (C# ch) of { (C# x) -> x}) >>
- whizz arr# (n -# 1#) (i +# 1#)
-
-filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
-filterPS pred ps =
- if nullPS ps then
- ps
- else
- {-
- Filtering proceeds as follows:
-
- * traverse the list, applying the pred. to each element,
- remembering the positions where it was satisfied.
-
- Encode these positions using a run-length encoding of the gaps
- between the matching positions.
-
- * Allocate a MutableByteArray in the heap big enough to hold
- all the matched entries, and copy the elements that matched over.
-
- A better solution that merges the scan© passes into one,
- would be to copy the filtered elements over into a growable
- buffer. No such operation currently supported over
- MutableByteArrays (could of course use malloc&realloc)
- But, this solution may in the case of repeated realloc's
- be worse than the current solution.
- -}
- runST (
- let
- (rle,len_filtered) = filter_ps (len# -# 1#) 0# 0# []
- len_filtered# = case len_filtered of { I# x# -> x#}
- in
- if len# ==# len_filtered# then
- {- not much filtering as everything passed through. -}
- return ps
- 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 len_filtered# >>= \ (ByteArray _ _ frozen#) ->
- let has_null = byteArrayHasNUL# frozen# len_filtered# in
- return (PS frozen# len_filtered# has_null))
- where
- len# = lengthPS# ps
-
- matchOffset :: Int# -> [Char] -> (Int,[Char])
- matchOffset off [] = (I# off,[])
- matchOffset off (C# c:cs) =
- let
- x = ord# c
- off' = off +# x
- in
- if x==# 0# then -- escape code, add 255#
- matchOffset off' cs
- else
- (I# off', cs)
-
- copy_arr :: MutableByteArray s Int -> [Char] -> Int# -> Int# -> ST s ()
- copy_arr _ [_] _ _ = return ()
- copy_arr arr# ls n i =
- let
- (x,ls') = matchOffset 0# ls
- n' = n +# (case x of { (I# x#) -> x#}) -# 1#
- ch = indexPS# ps n'
- in
- write_ps_array arr# i ch >>
- copy_arr arr# ls' (n' +# 1#) (i +# 1#)
-
- esc :: Int# -> Int# -> [Char] -> [Char]
- esc v 0# ls = (C# (chr# v)):ls
- esc v n ls = esc v (n -# 1#) (C# (chr# 0#):ls)
-
- filter_ps :: Int# -> Int# -> Int# -> [Char] -> ([Char],Int)
- filter_ps n hits run acc
- | n <# 0# =
- let
- escs = run `quotInt#` 255#
- v = run `remInt#` 255#
- in
- (esc (v +# 1#) escs acc, I# hits)
- | otherwise
- = let
- ch = indexPS# ps n
- n' = n -# 1#
- in
- if pred (C# ch) then
- let
- escs = run `quotInt#` 255#
- v = run `remInt#` 255#
- acc' = esc (v +# 1#) escs acc
- in
- filter_ps n' (hits +# 1#) 0# acc'
- else
- filter_ps n' hits (run +# 1#) acc
-
-
-foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
-foldlPS f b ps
- = if nullPS ps then
- b
- else
- whizzLR b 0#
- where
- len = lengthPS# ps
-
- --whizzLR :: a -> Int# -> a
- whizzLR b idx
- | idx ==# len = b
- | otherwise = whizzLR (f b (C# (indexPS# ps idx))) (idx +# 1#)
-
-
-foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
-foldrPS f v ps
- | nullPS ps = v
- | otherwise = whizzRL v len
- where
- len = lengthPS# ps
-
- --whizzRL :: a -> Int# -> a
- whizzRL b idx
- | idx <# 0# = b
- | otherwise = whizzRL (f (C# (indexPS# ps idx)) b) (idx -# 1#)
-
-takePS :: Int -> PackedString -> PackedString
-takePS (I# n) ps
- | n ==# 0# = nilPS
- | otherwise = substrPS# ps 0# (n -# 1#)
-
-dropPS :: Int -> PackedString -> PackedString
-dropPS (I# n) ps
- | n ==# len = nilPS
- | otherwise = substrPS# ps n (lengthPS# ps -# 1#)
- where
- len = lengthPS# ps
-
-splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
-splitAtPS n ps = (takePS n ps, dropPS n ps)
-
-takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
-takeWhilePS pred ps
- = let
- break_pt = char_pos_that_dissatisfies
- (\ c -> pred (C# c))
- ps
- (lengthPS# ps)
- 0#
- in
- if break_pt ==# 0# then
- nilPS
- else
- substrPS# ps 0# (break_pt -# 1#)
-
-dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
-dropWhilePS pred ps
- = let
- len = lengthPS# ps
- break_pt = char_pos_that_dissatisfies
- (\ c -> pred (C# c))
- ps
- len
- 0#
- in
- if len ==# break_pt then
- nilPS
- else
- substrPS# ps break_pt (len -# 1#)
-
-elemPS :: Char -> PackedString -> Bool
-elemPS (C# ch) ps
- = let
- len = lengthPS# ps
- break_pt = first_char_pos_that_satisfies
- (`eqChar#` ch)
- ps
- len
- 0#
- in
- break_pt <# len
-
-char_pos_that_dissatisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
-
-char_pos_that_dissatisfies p ps len pos
- | pos >=# len = pos -- end
- | p (indexPS# ps pos) = -- predicate satisfied; keep going
- char_pos_that_dissatisfies p ps len (pos +# 1#)
- | otherwise = pos -- predicate not satisfied
-
-first_char_pos_that_satisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
-first_char_pos_that_satisfies p ps len pos
- | pos >=# len = pos -- end
- | p (indexPS# ps pos) = pos -- got it!
- | otherwise = first_char_pos_that_satisfies p ps len (pos +# 1#)
-
--- ToDo: could certainly go quicker
-spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
-spanPS p ps = (takeWhilePS p ps, dropWhilePS p ps)
-
-breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
-breakPS p ps = spanPS (not . p) ps
-
-linesPS :: PackedString -> [PackedString]
-linesPS ps = splitPS '\n' ps
-
-wordsPS :: PackedString -> [PackedString]
-wordsPS ps = splitWithPS isSpace ps
-
-reversePS :: PackedString -> PackedString
-reversePS ps =
- if nullPS ps then -- don't create stuff unnecessarily.
- ps
- else
- runST (
- new_ps_array (length +# 1#) >>= \ arr# -> -- incl NUL byte!
- fill_in arr# (length -# 1#) 0# >>
- freeze_ps_array arr# length >>= \ (ByteArray _ _ frozen#) ->
- let has_null = byteArrayHasNUL# frozen# length in
- return (PS frozen# length has_null))
- where
- length = lengthPS# ps
-
- fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
- fill_in arr_in# n i =
- let
- ch = indexPS# ps n
- in
- write_ps_array arr_in# i ch >>
- if n ==# 0# then
- write_ps_array arr_in# (i +# 1#) (chr# 0#) >>
- return ()
- else
- fill_in arr_in# (n -# 1#) (i +# 1#)
-
-concatPS :: [PackedString] -> PackedString
-concatPS [] = nilPS
-concatPS pss
- = let
- tot_len# = case (foldr ((+) . lengthPS) 0 pss) of { I# x -> x }
- in
- runST (
- new_ps_array (tot_len# +# 1#) >>= \ arr# -> -- incl NUL byte!
- packum arr# pss 0# >>
- freeze_ps_array arr# tot_len# >>= \ (ByteArray _ _ frozen#) ->
-
- let has_null = byteArrayHasNUL# frozen# tot_len# in
-
- return (PS frozen# tot_len# has_null)
- )
- where
- packum :: MutableByteArray s Int -> [PackedString] -> Int# -> ST s ()
-
- packum arr [] pos
- = write_ps_array arr pos (chr# 0#) >>
- return ()
- packum arr (ps : pss) pos
- = fill arr pos ps 0# (lengthPS# ps) >>= \ (I# next_pos) ->
- packum arr pss next_pos
-
- fill :: MutableByteArray s Int -> Int# -> PackedString -> Int# -> Int# -> ST s Int
-
- fill arr arr_i ps ps_i ps_len
- | ps_i ==# ps_len
- = return (I# (arr_i +# ps_len))
- | otherwise
- = write_ps_array arr (arr_i +# ps_i) (indexPS# ps ps_i) >>
- fill arr arr_i ps (ps_i +# 1#) ps_len
-
-------------------------------------------------------------
-joinPS :: PackedString -> [PackedString] -> PackedString
-joinPS filler pss = concatPS (splice pss)
- where
- splice [] = []
- splice [x] = [x]
- splice (x:y:xs) = x:filler:splice (y:xs)
-
--- ToDo: the obvious generalisation
-{-
- Some properties that hold:
-
- * splitPS x ls = ls'
- where False = any (map (x `elemPS`) ls')
- False = any (map (nullPS) ls')
-
- * all x's have been chopped out.
- * no empty PackedStrings in returned list. A conseq.
- of this is:
- splitPS x nilPS = []
-
-
- * joinPS (packString [x]) (_splitPS x ls) = ls
-
--}
-
-splitPS :: Char -> PackedString -> [PackedString]
-splitPS (C# ch) = splitWithPS (\ (C# c) -> c `eqChar#` ch)
-
-splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]
-splitWithPS pred ps =
- splitify 0#
- where
- len = lengthPS# ps
-
- splitify n
- | n >=# len = []
- | otherwise =
- let
- break_pt =
- first_char_pos_that_satisfies
- (\ c -> pred (C# c))
- ps
- len
- n
- in
- if break_pt ==# n then -- immediate match, no substring to cut out.
- splitify (break_pt +# 1#)
- else
- substrPS# ps n (break_pt -# 1#): -- leave out the matching character
- splitify (break_pt +# 1#)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Local utility functions}
-%* *
-%************************************************************************
-
-The definition of @_substrPS@ is essentially:
-@take (end - begin + 1) (drop begin str)@.
-
-\begin{code}
-substrPS :: PackedString -> Int -> Int -> PackedString
-substrPS ps (I# begin) (I# end) = substrPS# ps begin end
-
-substrPS# :: PackedString -> Int# -> Int# -> PackedString
-substrPS# ps s e
- | s <# 0# || e <# s
- = error "substrPS: bounds out of range"
-
- | s >=# len || result_len# <=# 0#
- = nilPS
-
- | otherwise
- = runST (
- 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
-
- return (PS frozen# result_len# has_null)
- )
- where
- len = lengthPS# ps
-
- result_len# = (if e <# len then (e +# 1#) else len) -# s
-
- -----------------------
- fill_in :: MutableByteArray s Int -> Int# -> ST s ()
-
- fill_in arr_in# idx
- | idx ==# result_len#
- = write_ps_array arr_in# idx (chr# 0#) >>
- return ()
- | otherwise
- = let
- ch = indexPS# ps (s +# idx)
- in
- write_ps_array arr_in# idx ch >>
- fill_in arr_in# (idx +# 1#)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Packing and unpacking C strings}
-%* *
-%*********************************************************
-
-\begin{code}
-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 }
-
-packCBytes :: Int -> Addr -> PackedString
-packCBytes len addr = runST (packCBytesST len addr)
-
-packCBytesST :: Int -> Addr -> ST s PackedString
-packCBytesST (I# length#) (A# addr) =
- {-
- allocate an array that will hold the string
- (not forgetting the NUL byte at the end)
- -}
- new_ps_array (length# +# 1#) >>= \ ch_array ->
- -- fill in packed string from "addr"
- fill_in ch_array 0# >>
- -- freeze the puppy:
- freeze_ps_array ch_array length# >>= \ (ByteArray _ _ frozen#) ->
- let has_null = byteArrayHasNUL# frozen# length# in
- return (PS frozen# length# has_null)
- where
- fill_in :: MutableByteArray s Int -> Int# -> ST s ()
-
- fill_in arr_in# idx
- | idx ==# length#
- = write_ps_array arr_in# idx (chr# 0#) >>
- return ()
- | otherwise
- = case (indexCharOffAddr# addr idx) of { ch ->
- write_ps_array arr_in# idx ch >>
- fill_in arr_in# (idx +# 1#) }
-
-\end{code}
projects / ghc-hetmet.git / blobdiff