ghc/lib/misc/PackedString.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section{Packed strings}
   5
   6 This sits on top of the sequencing/arrays world, notably @ByteArray#@s.
   7
   8 Glorious hacking (all the hard work) by Bryan O'Sullivan.
   9
  10 \begin{code}
  11 {-# OPTIONS -#include "cbits/PackedString.h" #-}
  12
  13 module PackedString (
  14         PackedString,      -- abstract
  15
  16          -- Creating the beasts
  17         packString,          -- :: [Char] -> PackedString
  18         packStringST,        -- :: [Char] -> ST s PackedString
  19         packCBytesST,        -- :: Int -> Addr -> ST s PackedString
  20
  21         byteArrayToPS,       -- :: ByteArray Int -> PackedString
  22         cByteArrayToPS,      -- :: ByteArray Int -> PackedString
  23         unsafeByteArrayToPS, -- :: ByteArray a   -> Int -> PackedString
  24
  25         psToByteArray,       -- :: PackedString  -> ByteArray Int
  26         psToCString,         -- :: PackedString  -> Addr
  27         isCString,           -- :: PackedString  -> Bool
  28
  29         unpackPS,        -- :: PackedString -> [Char]
  30         unpackNBytesPS,  -- :: PackedString -> Int -> [Char]
  31         unpackPSIO,      -- :: PackedString -> IO [Char]
  32
  33         hPutPS,      -- :: Handle -> PackedString -> IO ()
  34         hGetPS,      -- :: Handle -> Int -> IO PackedString
  35
  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]
  57
  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
  65
  66          {-
  67            Pluck out a piece of a PS start and end
  68            chars you want; both 0-origin-specified
  69          -}
  70         substrPS,    -- :: PackedString -> Int -> Int -> PackedString
  71
  72         comparePS    -- :: PackedString -> PackedString -> Ordering
  73
  74     ) where
  75
  76 import GlaExts
  77 import PrelBase ( showList__  ) -- ToDo: better
  78 import PrelPack
  79           (  new_ps_array
  80           ,  freeze_ps_array
  81           ,  write_ps_array
  82           )
  83 import Addr
  84
  85 import PrelST
  86 import ST
  87 import IOExts   ( unsafePerformIO )
  88 import IO
  89 import PrelHandle ( hFillBufBA )
  90
  91 import Ix
  92 import Char (isSpace)
  93
  94 \end{code}
  95
  96 %************************************************************************
  97 %*                                                                      *
  98 \subsection{@PackedString@ type declaration}
  99 %*                                                                      *
 100 %************************************************************************
 101
 102 \begin{code}
 103 data PackedString
 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
 110
 111 instance Eq PackedString where
 112     x == y  = compare x y == EQ
 113     x /= y  = compare x y /= EQ
 114
 115 instance Ord PackedString where
 116     compare = comparePS
 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 }
 123
 124 --instance Read PackedString: ToDo
 125
 126 instance Show PackedString where
 127     showsPrec p ps r = showsPrec p (unpackPS ps) r
 128     showList = showList__ (showsPrec 0)
 129 \end{code}
 130
 131
 132 %************************************************************************
 133 %*                                                                      *
 134 \subsection{@PackedString@ instances}
 135 %*                                                                      *
 136 %************************************************************************
 137
 138 We try hard to make this go fast:
 139 \begin{code}
 140 comparePS :: PackedString -> PackedString -> Ordering
 141
 142 comparePS (PS  bs1 len1 has_null1) (PS  bs2 len2 has_null2)
 143   | not has_null1 && not has_null2
 144   = unsafePerformIO (
 145     _ccall_ strcmp ba1 ba2  >>= \ (I# res) ->
 146     return (
 147     if      res <#  0# then LT
 148     else if res ==# 0# then EQ
 149     else                    GT
 150     ))
 151   where
 152     ba1 = ByteArray (0, I# (len1 -# 1#)) bs1
 153     ba2 = ByteArray (0, I# (len2 -# 1#)) bs2
 154
 155 comparePS (PS  bs1 len1 has_null1) (CPS bs2 _)
 156   | not has_null1
 157   = unsafePerformIO (
 158     _ccall_ strcmp ba1 ba2  >>= \ (I# res) ->
 159     return (
 160     if      res <#  0# then LT
 161     else if res ==# 0# then EQ
 162     else                    GT
 163     ))
 164   where
 165     ba1 = ByteArray (0, I# (len1 -# 1#)) bs1
 166     ba2 = A# bs2
 167
 168 comparePS (CPS bs1 len1) (CPS bs2 _)
 169   = unsafePerformIO (
 170     _ccall_ strcmp ba1 ba2  >>= \ (I# res) ->
 171     return (
 172     if      res <#  0# then LT
 173     else if res ==# 0# then EQ
 174     else                    GT
 175     ))
 176   where
 177     ba1 = A# bs1
 178     ba2 = A# bs2
 179
 180 comparePS a@(CPS _ _) b@(PS _ _ has_null2)
 181   | not has_null2
 182   = -- try them the other way 'round
 183     case (comparePS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
 184
 185 comparePS ps1 ps2 -- slow catch-all case (esp for "has_null" True)
 186   = looking_at 0#
 187   where
 188     end1 = lengthPS# ps1 -# 1#
 189     end2 = lengthPS# ps2 -# 1#
 190
 191     looking_at char#
 192       = if char# ># end1 then
 193            if char# ># end2 then -- both strings ran out at once
 194               EQ
 195            else -- ps1 ran out before ps2
 196               LT
 197         else if char# ># end2 then
 198            GT   -- ps2 ran out before ps1
 199         else
 200            let
 201               ch1 = indexPS# ps1 char#
 202               ch2 = indexPS# ps2 char#
 203            in
 204            if ch1 `eqChar#` ch2 then
 205               looking_at (char# +# 1#)
 206            else if ch1 `ltChar#` ch2 then LT
 207                                      else GT
 208 \end{code}
 209
 210
 211 %************************************************************************
 212 %*                                                                      *
 213 \subsection{Constructor functions}
 214 %*                                                                      *
 215 %************************************************************************
 216
 217 Easy ones first.  @packString@ requires getting some heap-bytes and
 218 scribbling stuff into them.
 219
 220 \begin{code}
 221 nilPS :: PackedString
 222 nilPS = CPS ""# 0#
 223
 224 consPS :: Char -> PackedString -> PackedString
 225 consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better
 226
 227 packString :: [Char] -> PackedString
 228 packString str = runST (packStringST str)
 229
 230 packStringST :: [Char] -> ST s PackedString
 231 packStringST str =
 232   let len = length str  in
 233   packNCharsST len str
 234
 235 packNCharsST :: Int -> [Char] -> ST s PackedString
 236 packNCharsST (I# length#) str =
 237   {-
 238    allocate an array that will hold the string
 239    (not forgetting the NUL byte at the end)
 240   -}
 241  new_ps_array (length# +# 1#) >>= \ ch_array ->
 242    -- fill in packed string from "str"
 243  fill_in ch_array 0# str   >>
 244    -- freeze the puppy:
 245  freeze_ps_array ch_array length# >>= \ (ByteArray _ frozen#) ->
 246  let has_null = byteArrayHasNUL# frozen# length# in
 247  return (PS frozen# length# has_null)
 248  where
 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#) >>
 252    return ()
 253
 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
 257
 258 byteArrayToPS :: ByteArray Int -> PackedString
 259 byteArrayToPS (ByteArray ixs@(_, ix_end) frozen#) =
 260  let
 261   n# =
 262    case (
 263          if null (range ixs)
 264           then 0
 265           else ((index ixs ix_end) + 1)
 266         ) of { I# x -> x }
 267  in
 268  PS frozen# n# (byteArrayHasNUL# frozen# n#)
 269
 270 -- byteArray is zero-terminated, make everything upto it
 271 -- a packed string.
 272 cByteArrayToPS :: ByteArray Int -> PackedString
 273 cByteArrayToPS (ByteArray ixs@(_, ix_end) frozen#) =
 274  let
 275   n# =
 276    case (
 277          if null (range ixs)
 278           then 0
 279           else ((index ixs ix_end) + 1)
 280         ) of { I# x -> x }
 281   len# = findNull 0#
 282
 283   findNull i#
 284      | i# ==# n#           = n#
 285      | ch# `eqChar#` '\0'# = i# -- everything upto the sentinel
 286      | otherwise           = findNull (i# +# 1#)
 287     where
 288      ch#  = indexCharArray# frozen# i#
 289  in
 290  PS frozen# len# False
 291
 292 unsafeByteArrayToPS :: ByteArray a -> Int -> PackedString
 293 unsafeByteArrayToPS (ByteArray _ frozen#) (I# n#)
 294   = PS frozen# n# (byteArrayHasNUL# frozen# n#)
 295
 296 psToByteArray    :: PackedString -> ByteArray Int
 297 psToByteArray (PS bytes n _) = ByteArray (0, I# (n -# 1#)) bytes
 298
 299 psToByteArray (CPS addr len#)
 300   = let
 301         len             = I# len#
 302         byte_array_form = packCBytes len (A# addr)
 303     in
 304     case byte_array_form of { PS bytes _ _ ->
 305     ByteArray (0, len - 1) bytes }
 306
 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.
 310 --
 311 isCString :: PackedString -> Bool
 312 isCString (CPS _ _ ) = True
 313 isCString _          = False
 314
 315 psToCString :: PackedString -> Addr
 316 psToCString (CPS addr _)    = (A# addr)
 317 psToCString (PS bytes l# _) =
 318   unsafePerformIO $ do
 319     stuff <- _ccall_ malloc ((I# l#) * (``sizeof(char)''))
 320     let
 321      fill_in n# i#
 322       | n# ==# 0# = return ()
 323       | otherwise = do
 324          let ch#  = indexCharArray# bytes i#
 325          writeCharOffAddr stuff (I# i#) (C# ch#)
 326          fill_in (n# -# 1#) (i# +# 1#)
 327     fill_in l# 0#
 328     return stuff
 329
 330 \end{code}
 331
 332 %************************************************************************
 333 %*                                                                      *
 334 \subsection{Destructor functions (taking @PackedStrings@ apart)}
 335 %*                                                                      *
 336 %************************************************************************
 337
 338 \begin{code}
 339 -- OK, but this code gets *hammered*:
 340 -- unpackPS ps
 341 --   = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ]
 342
 343 unpackPS :: PackedString -> [Char]
 344 unpackPS (PS bytes len _) = unpack 0#
 345  where
 346     unpack nh
 347       | nh >=# len  = []
 348       | otherwise   = C# ch : unpack (nh +# 1#)
 349       where
 350         ch = indexCharArray# bytes nh
 351
 352 unpackPS (CPS addr _) = unpack 0#
 353   where
 354     unpack nh
 355       | ch `eqChar#` '\0'# = []
 356       | otherwise          = C# ch : unpack (nh +# 1#)
 357       where
 358         ch = indexCharOffAddr# addr nh
 359
 360 unpackNBytesPS :: PackedString -> Int -> [Char]
 361 unpackNBytesPS ps len@(I# l#)
 362  | len < 0      = error ("PackedString.unpackNBytesPS: negative length "++ show len)
 363  | len == 0     = []
 364  | otherwise    =
 365     case ps of
 366       PS bytes len# has_null -> unpackPS (PS bytes (min# len# l#) has_null)
 367       CPS a len# -> unpackPS (CPS a (min# len# l#))
 368  where
 369   min# x# y#
 370     | x# <# y#  = x#
 371     | otherwise = y#
 372
 373 unpackPSIO :: PackedString -> IO String
 374 unpackPSIO ps@(PS bytes _ _) = return (unpackPS ps)
 375 unpackPSIO (CPS addr _)      = unpack 0#
 376   where
 377     unpack nh = do
 378        ch <- readCharOffAddr (A# addr) (I# nh)
 379        if ch == '\0'
 380         then return []
 381         else do
 382            ls <- unpack (nh +# 1#)
 383            return (ch : ls)
 384
 385 \end{code}
 386
 387 Output a packed string via a handle:
 388
 389 \begin{code}
 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#)
 393   where
 394     bottom = error "hPutPS"
 395 \end{code}
 396
 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.
 399
 400 \begin{code}
 401 hGetPS :: Handle -> Int -> IO PackedString
 402 hGetPS hdl len@(I# len#)
 403  | len# <=# 0# = return nilPS -- I'm being kind here.
 404  | otherwise   =
 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#) ->
 408    let
 409     byte_array = ByteArray (0, I# len#) frozen#
 410    in
 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")
 414    else
 415      {-
 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.
 421      -}
 422      let
 423       has_null = byteArrayHasNUL# frozen# read#
 424      in
 425      return (PS frozen# read# has_null)
 426
 427 \end{code}
 428
 429 %************************************************************************
 430 %*                                                                      *
 431 \subsection{List-mimicking functions for @PackedStrings@}
 432 %*                                                                      *
 433 %************************************************************************
 434
 435 First, the basic functions that do look into the representation;
 436 @indexPS@ is the most important one.
 437
 438 \begin{code}
 439 lengthPS   :: PackedString -> Int
 440 lengthPS ps = I# (lengthPS# ps)
 441
 442 {-# INLINE lengthPS# #-}
 443
 444 lengthPS# :: PackedString -> Int#
 445 lengthPS# (PS  _ i _) = i
 446 lengthPS# (CPS _ i)   = i
 447
 448 {-# INLINE strlen# #-}
 449
 450 strlen# :: Addr# -> Int
 451 strlen# a
 452   = unsafePerformIO (
 453     _ccall_ strlen (A# a)  >>= \ len@(I# _) ->
 454     return len
 455     )
 456
 457 byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool
 458 byteArrayHasNUL# bs len
 459   = unsafePerformIO (
 460     _ccall_ byteArrayHasNUL__ ba (I# len)  >>= \ (I# res) ->
 461     return (
 462     if res ==# 0# then False else True
 463     ))
 464   where
 465     ba = ByteArray (0, I# (len -# 1#)) bs
 466
 467 -----------------------
 468
 469 indexPS :: PackedString -> Int -> Char
 470 indexPS ps (I# n) = C# (indexPS# ps n)
 471
 472 {-# INLINE indexPS# #-}
 473
 474 indexPS# :: PackedString -> Int# -> Char#
 475 indexPS# (PS bs i _) n
 476   = --ASSERT (n >=# 0# && n <# i)       -- error checking: my eye!  (WDP 94/10)
 477     indexCharArray# bs n
 478
 479 indexPS# (CPS a _) n
 480   = indexCharOffAddr# a n
 481 \end{code}
 482
 483 Now, the rest of the functions can be defined without digging
 484 around in the representation.
 485
 486 \begin{code}
 487 headPS :: PackedString -> Char
 488 headPS ps
 489   | nullPS ps = error "headPS: head []"
 490   | otherwise  = C# (indexPS# ps 0#)
 491
 492 tailPS :: PackedString -> PackedString
 493 tailPS ps
 494   | len <=# 0# = error "tailPS: tail []"
 495   | len ==# 1# = nilPS
 496   | otherwise  = substrPS# ps 1# (len -# 1#)
 497   where
 498     len = lengthPS# ps
 499
 500 nullPS :: PackedString -> Bool
 501 nullPS (PS  _ i _) = i ==# 0#
 502 nullPS (CPS _ i)   = i ==# 0#
 503
 504 appendPS :: PackedString -> PackedString -> PackedString
 505 appendPS xs ys
 506   | nullPS xs = ys
 507   | nullPS ys = xs
 508   | otherwise  = concatPS [xs,ys]
 509
 510 mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-}
 511 mapPS f xs =
 512   if nullPS xs then
 513      xs
 514   else
 515      runST (
 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))
 521   where
 522    length = lengthPS# xs
 523
 524    whizz :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
 525    whizz arr# n i
 526     | n ==# 0#
 527       = write_ps_array arr# i (chr# 0#) >>
 528         return ()
 529     | otherwise
 530       = let
 531          ch = indexPS# xs i
 532         in
 533         write_ps_array arr# i (case f (C# ch) of { (C# x) -> x})     >>
 534         whizz arr# (n -# 1#) (i +# 1#)
 535
 536 filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
 537 filterPS pred ps =
 538   if nullPS ps then
 539      ps
 540   else
 541      {-
 542       Filtering proceeds as follows:
 543
 544        * traverse the list, applying the pred. to each element,
 545          remembering the positions where it was satisfied.
 546
 547          Encode these positions using a run-length encoding of the gaps
 548          between the matching positions.
 549
 550        * Allocate a MutableByteArray in the heap big enough to hold
 551          all the matched entries, and copy the elements that matched over.
 552
 553       A better solution that merges the scan&copy 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.
 559      -}
 560      runST (
 561        let
 562         (rle,len_filtered) = filter_ps (len# -# 1#) 0# 0# []
 563         len_filtered#      = case len_filtered of { I# x# -> x#}
 564        in
 565        if len# ==# len_filtered# then
 566          {- not much filtering as everything passed through. -}
 567          return ps
 568        else if len_filtered# ==# 0# then
 569          return nilPS
 570        else
 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))
 576   where
 577    len# = lengthPS# ps
 578
 579    matchOffset :: Int# -> [Char] -> (Int,[Char])
 580    matchOffset off [] = (I# off,[])
 581    matchOffset off (C# c:cs) =
 582     let
 583      x    = ord# c
 584      off' = off +# x
 585     in
 586     if x==# 0# then -- escape code, add 255#
 587        matchOffset off' cs
 588     else
 589        (I# off', cs)
 590
 591    copy_arr :: MutableByteArray s Int -> [Char] -> Int# -> Int# -> ST s ()
 592    copy_arr _    [_] _ _ = return ()
 593    copy_arr arr# ls  n i =
 594      let
 595       (x,ls') = matchOffset 0# ls
 596       n'      = n +# (case x of { (I# x#) -> x#}) -# 1#
 597       ch      = indexPS# ps n'
 598      in
 599      write_ps_array arr# i ch                >>
 600      copy_arr arr# ls' (n' +# 1#) (i +# 1#)
 601
 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)
 605
 606    filter_ps :: Int# -> Int# -> Int# -> [Char] -> ([Char],Int)
 607    filter_ps n hits run acc
 608     | n <# 0# =
 609         let
 610          escs = run `quotInt#` 255#
 611          v    = run `remInt#`  255#
 612         in
 613        (esc (v +# 1#) escs acc, I# hits)
 614     | otherwise
 615        = let
 616           ch = indexPS# ps n
 617           n' = n -# 1#
 618          in
 619          if pred (C# ch) then
 620             let
 621              escs = run `quotInt#` 255#
 622              v    = run `remInt#`  255#
 623              acc' = esc (v +# 1#) escs acc
 624             in
 625             filter_ps n' (hits +# 1#) 0# acc'
 626          else
 627             filter_ps n' hits (run +# 1#) acc
 628
 629
 630 foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
 631 foldlPS f b ps
 632  = if nullPS ps then
 633       b
 634    else
 635       whizzLR b 0#
 636    where
 637     len = lengthPS# ps
 638
 639     --whizzLR :: a -> Int# -> a
 640     whizzLR b idx
 641      | idx ==# len = b
 642      | otherwise   = whizzLR (f b (C# (indexPS# ps idx))) (idx +# 1#)
 643
 644
 645 foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
 646 foldrPS f v ps
 647   | nullPS ps = v
 648   | otherwise = whizzRL v len
 649    where
 650     len = lengthPS# ps
 651
 652     --whizzRL :: a -> Int# -> a
 653     whizzRL b idx
 654      | idx <# 0# = b
 655      | otherwise = whizzRL (f (C# (indexPS# ps idx)) b) (idx -# 1#)
 656
 657 takePS :: Int -> PackedString -> PackedString
 658 takePS (I# n) ps
 659   | n ==# 0#   = nilPS
 660   | otherwise  = substrPS# ps 0# (n -# 1#)
 661
 662 dropPS  :: Int -> PackedString -> PackedString
 663 dropPS (I# n) ps
 664   | n ==# len = nilPS
 665   | otherwise = substrPS# ps n  (lengthPS# ps -# 1#)
 666   where
 667     len = lengthPS# ps
 668
 669 splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
 670 splitAtPS  n ps  = (takePS n ps, dropPS n ps)
 671
 672 takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
 673 takeWhilePS pred ps
 674   = let
 675         break_pt = char_pos_that_dissatisfies
 676                         (\ c -> pred (C# c))
 677                         ps
 678                         (lengthPS# ps)
 679                         0#
 680     in
 681     if break_pt ==# 0# then
 682        nilPS
 683     else
 684        substrPS# ps 0# (break_pt -# 1#)
 685
 686 dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
 687 dropWhilePS pred ps
 688   = let
 689         len      = lengthPS# ps
 690         break_pt = char_pos_that_dissatisfies
 691                         (\ c -> pred (C# c))
 692                         ps
 693                         len
 694                         0#
 695     in
 696     if len ==# break_pt then
 697        nilPS
 698     else
 699        substrPS# ps break_pt (len -# 1#)
 700
 701 elemPS :: Char -> PackedString -> Bool
 702 elemPS (C# ch) ps
 703   = let
 704         len      = lengthPS# ps
 705         break_pt = first_char_pos_that_satisfies
 706                         (`eqChar#` ch)
 707                         ps
 708                         len
 709                         0#
 710     in
 711     break_pt <# len
 712
 713 char_pos_that_dissatisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
 714
 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
 720
 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#)
 726
 727 -- ToDo: could certainly go quicker
 728 spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
 729 spanPS  p ps = (takeWhilePS p ps, dropWhilePS p ps)
 730
 731 breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
 732 breakPS p ps = spanPS (not . p) ps
 733
 734 linesPS :: PackedString -> [PackedString]
 735 linesPS ps = splitPS '\n' ps
 736
 737 wordsPS :: PackedString -> [PackedString]
 738 wordsPS ps = splitWithPS isSpace ps
 739
 740 reversePS :: PackedString -> PackedString
 741 reversePS ps =
 742   if nullPS ps then -- don't create stuff unnecessarily.
 743      ps
 744   else
 745     runST (
 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))
 751  where
 752   length = lengthPS# ps
 753
 754   fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
 755   fill_in arr_in# n i =
 756    let
 757     ch = indexPS# ps n
 758    in
 759    write_ps_array arr_in# i ch                   >>
 760    if n ==# 0# then
 761       write_ps_array arr_in# (i +# 1#) (chr# 0#) >>
 762       return ()
 763    else
 764       fill_in arr_in# (n -# 1#) (i +# 1#)
 765
 766 concatPS :: [PackedString] -> PackedString
 767 concatPS [] = nilPS
 768 concatPS pss
 769   = let
 770         tot_len# = case (foldr ((+) . lengthPS) 0 pss) of { I# x -> x }
 771     in
 772     runST (
 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#) ->
 776
 777     let has_null = byteArrayHasNUL# frozen# tot_len# in
 778
 779     return (PS frozen# tot_len# has_null)
 780     )
 781   where
 782     packum :: MutableByteArray s Int -> [PackedString] -> Int# -> ST s ()
 783
 784     packum arr [] pos
 785       = write_ps_array arr pos (chr# 0#) >>
 786         return ()
 787     packum arr (ps : pss) pos
 788       = fill arr pos ps 0# (lengthPS# ps)  >>= \ (I# next_pos) ->
 789         packum arr pss next_pos
 790
 791     fill :: MutableByteArray s Int -> Int# -> PackedString -> Int# -> Int# -> ST s Int
 792
 793     fill arr arr_i ps ps_i ps_len
 794      | ps_i ==# ps_len
 795        = return (I# (arr_i +# ps_len))
 796      | otherwise
 797        = write_ps_array arr (arr_i +# ps_i) (indexPS# ps ps_i) >>
 798          fill arr arr_i ps (ps_i +# 1#) ps_len
 799
 800 ------------------------------------------------------------
 801 joinPS :: PackedString -> [PackedString] -> PackedString
 802 joinPS filler pss = concatPS (splice pss)
 803  where
 804   splice []  = []
 805   splice [x] = [x]
 806   splice (x:y:xs) = x:filler:splice (y:xs)
 807
 808 -- ToDo: the obvious generalisation
 809 {-
 810   Some properties that hold:
 811
 812   * splitPS x ls = ls'
 813       where False = any (map (x `elemPS`) ls')
 814             False = any (map (nullPS) ls')
 815
 816     * all x's have been chopped out.
 817     * no empty PackedStrings in returned list. A conseq.
 818       of this is:
 819            splitPS x nilPS = []
 820
 821
 822   * joinPS (packString [x]) (_splitPS x ls) = ls
 823
 824 -}
 825
 826 splitPS :: Char -> PackedString -> [PackedString]
 827 splitPS (C# ch) = splitWithPS (\ (C# c) -> c `eqChar#` ch)
 828
 829 splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]
 830 splitWithPS pred ps =
 831  splitify 0#
 832  where
 833   len = lengthPS# ps
 834
 835   splitify n
 836    | n >=# len = []
 837    | otherwise =
 838       let
 839        break_pt =
 840          first_char_pos_that_satisfies
 841             (\ c -> pred (C# c))
 842             ps
 843             len
 844             n
 845       in
 846       if break_pt ==# n then -- immediate match, no substring to cut out.
 847          splitify (break_pt +# 1#)
 848       else
 849          substrPS# ps n (break_pt -# 1#): -- leave out the matching character
 850          splitify (break_pt +# 1#)
 851 \end{code}
 852
 853 %************************************************************************
 854 %*                                                                      *
 855 \subsection{Local utility functions}
 856 %*                                                                      *
 857 %************************************************************************
 858
 859 The definition of @_substrPS@ is essentially:
 860 @take (end - begin + 1) (drop begin str)@.
 861
 862 \begin{code}
 863 substrPS :: PackedString -> Int -> Int -> PackedString
 864 substrPS ps (I# begin) (I# end) = substrPS# ps begin end
 865
 866 substrPS# :: PackedString -> Int# -> Int# -> PackedString
 867 substrPS# ps s e
 868   | s <# 0# || e <# s
 869   = error "substrPS: bounds out of range"
 870
 871   | s >=# len || result_len# <=# 0#
 872   = nilPS
 873
 874   | otherwise
 875   = runST (
 876         new_ps_array (result_len# +# 1#)   >>= \ ch_arr -> -- incl NUL byte!
 877         fill_in ch_arr 0#                  >>
 878         freeze_ps_array ch_arr result_len# >>= \ (ByteArray _ frozen#) ->
 879
 880         let has_null = byteArrayHasNUL# frozen# result_len# in
 881
 882         return (PS frozen# result_len# has_null)
 883     )
 884   where
 885     len = lengthPS# ps
 886
 887     result_len# = (if e <# len then (e +# 1#) else len) -# s
 888
 889     -----------------------
 890     fill_in :: MutableByteArray s Int -> Int# -> ST s ()
 891
 892     fill_in arr_in# idx
 893       | idx ==# result_len#
 894       = write_ps_array arr_in# idx (chr# 0#) >>
 895         return ()
 896       | otherwise
 897       = let
 898             ch = indexPS# ps (s +# idx)
 899         in
 900         write_ps_array arr_in# idx ch        >>
 901         fill_in arr_in# (idx +# 1#)
 902 \end{code}
 903
 904 %*********************************************************
 905 %*                                                      *
 906 \subsection{Packing and unpacking C strings}
 907 %*                                                      *
 908 %*********************************************************
 909
 910 \begin{code}
 911 cStringToPS      :: Addr  -> PackedString
 912 cStringToPS (A# a#) =   -- the easy one; we just believe the caller
 913  CPS a# len
 914  where
 915   len = case (strlen# a#) of { I# x -> x }
 916
 917 packCBytes :: Int -> Addr -> PackedString
 918 packCBytes len addr = runST (packCBytesST len addr)
 919
 920 packCBytesST :: Int -> Addr -> ST s PackedString
 921 packCBytesST (I# length#) (A# addr) =
 922   {-
 923     allocate an array that will hold the string
 924     (not forgetting the NUL byte at the end)
 925   -}
 926   new_ps_array (length# +# 1#)  >>= \ ch_array ->
 927    -- fill in packed string from "addr"
 928   fill_in ch_array 0#   >>
 929    -- freeze the puppy:
 930   freeze_ps_array ch_array length# >>= \ (ByteArray _ frozen#) ->
 931   let has_null = byteArrayHasNUL# frozen# length# in
 932   return (PS frozen# length# has_null)
 933   where
 934     fill_in :: MutableByteArray s Int -> Int# -> ST s ()
 935
 936     fill_in arr_in# idx
 937       | idx ==# length#
 938       = write_ps_array arr_in# idx (chr# 0#) >>
 939         return ()
 940       | otherwise
 941       = case (indexCharOffAddr# addr idx) of { ch ->
 942         write_ps_array arr_in# idx ch >>
 943         fill_in arr_in# (idx +# 1#) }
 944
 945 \end{code}