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 len2)
 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 len2)
 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 len@(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 has_null)
 298   = ByteArray (0, I# (n -# 1#)) bytes
 299
 300 psToByteArray (CPS addr len#)
 301   = let
 302         len             = I# len#
 303         byte_array_form = packCBytes len (A# addr)
 304     in
 305     case byte_array_form of { PS bytes _ _ ->
 306     ByteArray (0, len - 1) bytes }
 307
 308 -- isCString is useful when passing PackedStrings to the
 309 -- outside world, and need to figure out whether you can
 310 -- pass it as an Addr or ByteArray.
 311 --
 312 isCString :: PackedString -> Bool
 313 isCString (CPS _ _ ) = True
 314 isCString _          = False
 315
 316 psToCString :: PackedString -> Addr
 317 psToCString (CPS addr _) = (A# addr)
 318 psToCString (PS bytes n# has_null) =
 319   unsafePerformIO $ do
 320     stuff <- _ccall_ malloc ((I# n#) * (``sizeof(char)''))
 321     let
 322      fill_in n# i#
 323       | n# ==# 0# = return ()
 324       | otherwise = do
 325          let ch#  = indexCharArray# bytes i#
 326          writeCharOffAddr stuff (I# i#) (C# ch#)
 327          fill_in (n# -# 1#) (i# +# 1#)
 328     fill_in n# 0#
 329     return stuff
 330
 331 \end{code}
 332
 333 %************************************************************************
 334 %*                                                                      *
 335 \subsection{Destructor functions (taking @PackedStrings@ apart)}
 336 %*                                                                      *
 337 %************************************************************************
 338
 339 \begin{code}
 340 -- OK, but this code gets *hammered*:
 341 -- unpackPS ps
 342 --   = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ]
 343
 344 unpackPS :: PackedString -> [Char]
 345 unpackPS (PS bytes len has_null)
 346  = unpack 0#
 347  where
 348     unpack nh
 349       | nh >=# len  = []
 350       | otherwise   = C# ch : unpack (nh +# 1#)
 351       where
 352         ch = indexCharArray# bytes nh
 353
 354 unpackPS (CPS addr len)
 355   = unpack 0#
 356   where
 357     unpack nh
 358       | ch `eqChar#` '\0'# = []
 359       | otherwise          = C# ch : unpack (nh +# 1#)
 360       where
 361         ch = indexCharOffAddr# addr nh
 362
 363 unpackNBytesPS :: PackedString -> Int -> [Char]
 364 unpackNBytesPS ps len@(I# l#)
 365  | len < 0      = error ("PackedString.unpackNBytesPS: negative length "++ show len)
 366  | len == 0     = []
 367  | otherwise    =
 368     case ps of
 369       PS bytes len# has_null -> unpackPS (PS bytes (min# len# l#) has_null)
 370       CPS a len# -> unpackPS (CPS a (min# len# l#))
 371  where
 372   min# x# y#
 373     | x# <# y#  = x#
 374     | otherwise = y#
 375
 376 unpackPSIO :: PackedString -> IO String
 377 unpackPSIO ps@(PS bytes len has_null) = return (unpackPS ps)
 378 unpackPSIO (CPS addr len)
 379   = unpack 0#
 380   where
 381     unpack nh = do
 382        ch <- readCharOffAddr (A# addr) (I# nh)
 383        if ch == '\0'
 384         then return []
 385         else do
 386            ls <- unpack (nh +# 1#)
 387            return (ch : ls)
 388
 389 \end{code}
 390
 391 Output a packed string via a handle:
 392
 393 \begin{code}
 394 hPutPS :: Handle -> PackedString -> IO ()
 395 hPutPS handle (CPS a# len#)    = hPutBuf    handle (A# a#) (I# len#)
 396 hPutPS handle (PS  ba# len# _) = hPutBufBA  handle (ByteArray bottom ba#) (I# len#)
 397   where
 398     bottom = error "hPutPS"
 399 \end{code}
 400
 401 The dual to @_putPS@, note that the size of the chunk specified
 402 is the upper bound of the size of the chunk returned.
 403
 404 \begin{code}
 405 hGetPS :: Handle -> Int -> IO PackedString
 406 hGetPS hdl len@(I# len#)
 407  | len# <=# 0# = return nilPS -- I'm being kind here.
 408  | otherwise   =
 409     -- Allocate an array for system call to store its bytes into.
 410    stToIO (new_ps_array len# )           >>= \ ch_arr ->
 411    stToIO (freeze_ps_array ch_arr len#)  >>= \ (ByteArray _ frozen#) ->
 412    let
 413     byte_array = ByteArray (0, I# len#) frozen#
 414    in
 415    hFillBufBA hdl byte_array len >>= \  (I# read#) ->
 416    if read# ==# 0# then -- EOF or other error
 417       fail (userError "hGetPS: EOF reached or other error")
 418    else
 419      {-
 420        The system call may not return the number of
 421        bytes requested. Instead of failing with an error
 422        if the number of bytes read is less than requested,
 423        a packed string containing the bytes we did manage
 424        to snarf is returned.
 425      -}
 426      let
 427       has_null = byteArrayHasNUL# frozen# read#
 428      in
 429      return (PS frozen# read# has_null)
 430
 431 \end{code}
 432
 433 %************************************************************************
 434 %*                                                                      *
 435 \subsection{List-mimicking functions for @PackedStrings@}
 436 %*                                                                      *
 437 %************************************************************************
 438
 439 First, the basic functions that do look into the representation;
 440 @indexPS@ is the most important one.
 441
 442 \begin{code}
 443 lengthPS   :: PackedString -> Int
 444 lengthPS ps = I# (lengthPS# ps)
 445
 446 {-# INLINE lengthPS# #-}
 447
 448 lengthPS# (PS  _ i _) = i
 449 lengthPS# (CPS _ i)   = i
 450
 451 {-# INLINE strlen# #-}
 452
 453 strlen# :: Addr# -> Int
 454 strlen# a
 455   = unsafePerformIO (
 456     _ccall_ strlen (A# a)  >>= \ len@(I# _) ->
 457     return len
 458     )
 459
 460 byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool
 461 byteArrayHasNUL# bs len
 462   = unsafePerformIO (
 463     _ccall_ byteArrayHasNUL__ ba (I# len)  >>= \ (I# res) ->
 464     return (
 465     if res ==# 0# then False else True
 466     ))
 467   where
 468     ba = ByteArray (0, I# (len -# 1#)) bs
 469
 470 -----------------------
 471
 472 indexPS :: PackedString -> Int -> Char
 473 indexPS ps (I# n) = C# (indexPS# ps n)
 474
 475 {-# INLINE indexPS# #-}
 476
 477 indexPS# (PS bs i _) n
 478   = --ASSERT (n >=# 0# && n <# i)       -- error checking: my eye!  (WDP 94/10)
 479     indexCharArray# bs n
 480
 481 indexPS# (CPS a _) n
 482   = indexCharOffAddr# a n
 483 \end{code}
 484
 485 Now, the rest of the functions can be defined without digging
 486 around in the representation.
 487
 488 \begin{code}
 489 headPS :: PackedString -> Char
 490 headPS ps
 491   | nullPS ps = error "headPS: head []"
 492   | otherwise  = C# (indexPS# ps 0#)
 493
 494 tailPS :: PackedString -> PackedString
 495 tailPS ps
 496   | len <=# 0# = error "tailPS: tail []"
 497   | len ==# 1# = nilPS
 498   | otherwise  = substrPS# ps 1# (len -# 1#)
 499   where
 500     len = lengthPS# ps
 501
 502 nullPS :: PackedString -> Bool
 503 nullPS (PS  _ i _) = i ==# 0#
 504 nullPS (CPS _ i)   = i ==# 0#
 505
 506 appendPS :: PackedString -> PackedString -> PackedString
 507 appendPS xs ys
 508   | nullPS xs = ys
 509   | nullPS ys = xs
 510   | otherwise  = concatPS [xs,ys]
 511
 512 mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-}
 513 mapPS f xs =
 514   if nullPS xs then
 515      xs
 516   else
 517      runST (
 518        new_ps_array (length +# 1#)         >>= \ ps_arr ->
 519        whizz ps_arr length 0#              >>
 520        freeze_ps_array ps_arr length       >>= \ (ByteArray _ frozen#) ->
 521        let has_null = byteArrayHasNUL# frozen# length in
 522        return (PS frozen# length has_null))
 523   where
 524    length = lengthPS# xs
 525
 526    whizz :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
 527    whizz arr# n i
 528     | n ==# 0#
 529       = write_ps_array arr# i (chr# 0#) >>
 530         return ()
 531     | otherwise
 532       = let
 533          ch = indexPS# xs i
 534         in
 535         write_ps_array arr# i (case f (C# ch) of { (C# x) -> x})     >>
 536         whizz arr# (n -# 1#) (i +# 1#)
 537
 538 filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
 539 filterPS pred ps =
 540   if nullPS ps then
 541      ps
 542   else
 543      {-
 544       Filtering proceeds as follows:
 545
 546        * traverse the list, applying the pred. to each element,
 547          remembering the positions where it was satisfied.
 548
 549          Encode these positions using a run-length encoding of the gaps
 550          between the matching positions.
 551
 552        * Allocate a MutableByteArray in the heap big enough to hold
 553          all the matched entries, and copy the elements that matched over.
 554
 555       A better solution that merges the scan&copy passes into one,
 556       would be to copy the filtered elements over into a growable
 557       buffer. No such operation currently supported over
 558       MutableByteArrays (could of course use malloc&realloc)
 559       But, this solution may in the case of repeated realloc's
 560       be worse than the current solution.
 561      -}
 562      runST (
 563        let
 564         (rle,len_filtered) = filter_ps (len# -# 1#) 0# 0# []
 565         len_filtered#      = case len_filtered of { I# x# -> x#}
 566        in
 567        if len# ==# len_filtered# then
 568          {- not much filtering as everything passed through. -}
 569          return ps
 570        else if len_filtered# ==# 0# then
 571          return nilPS
 572        else
 573          new_ps_array (len_filtered# +# 1#)   >>= \ ps_arr ->
 574          copy_arr ps_arr rle 0# 0#            >>
 575          freeze_ps_array ps_arr len_filtered# >>= \ (ByteArray _ frozen#) ->
 576          let has_null = byteArrayHasNUL# frozen# len_filtered# in
 577          return (PS frozen# len_filtered# has_null))
 578   where
 579    len# = lengthPS# ps
 580
 581    matchOffset :: Int# -> [Char] -> (Int,[Char])
 582    matchOffset off [] = (I# off,[])
 583    matchOffset off (C# c:cs) =
 584     let
 585      x    = ord# c
 586      off' = off +# x
 587     in
 588     if x==# 0# then -- escape code, add 255#
 589        matchOffset off' cs
 590     else
 591        (I# off', cs)
 592
 593    copy_arr :: MutableByteArray s Int -> [Char] -> Int# -> Int# -> ST s ()
 594    copy_arr arr# [_] _ _ = return ()
 595    copy_arr arr# ls  n i =
 596      let
 597       (x,ls') = matchOffset 0# ls
 598       n'      = n +# (case x of { (I# x#) -> x#}) -# 1#
 599       ch      = indexPS# ps n'
 600      in
 601      write_ps_array arr# i ch                >>
 602      copy_arr arr# ls' (n' +# 1#) (i +# 1#)
 603
 604    esc :: Int# -> Int# -> [Char] -> [Char]
 605    esc v 0# ls = (C# (chr# v)):ls
 606    esc v n  ls = esc v (n -# 1#) (C# (chr# 0#):ls)
 607
 608    filter_ps :: Int# -> Int# -> Int# -> [Char] -> ([Char],Int)
 609    filter_ps n hits run acc
 610     | n <# 0# =
 611         let
 612          escs = run `quotInt#` 255#
 613          v    = run `remInt#`  255#
 614         in
 615        (esc (v +# 1#) escs acc, I# hits)
 616     | otherwise
 617        = let
 618           ch = indexPS# ps n
 619           n' = n -# 1#
 620          in
 621          if pred (C# ch) then
 622             let
 623              escs = run `quotInt#` 255#
 624              v    = run `remInt#`  255#
 625              acc' = esc (v +# 1#) escs acc
 626             in
 627             filter_ps n' (hits +# 1#) 0# acc'
 628          else
 629             filter_ps n' hits (run +# 1#) acc
 630
 631
 632 foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
 633 foldlPS f b ps
 634  = if nullPS ps then
 635       b
 636    else
 637       whizzLR b 0#
 638    where
 639     len = lengthPS# ps
 640
 641     --whizzLR :: a -> Int# -> a
 642     whizzLR b idx
 643      | idx ==# len = b
 644      | otherwise   = whizzLR (f b (C# (indexPS# ps idx))) (idx +# 1#)
 645
 646
 647 foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
 648 foldrPS f b ps
 649  = if nullPS ps then
 650       b
 651    else
 652       whizzRL b len
 653    where
 654     len = lengthPS# ps
 655
 656     --whizzRL :: a -> Int# -> a
 657     whizzRL b idx
 658      | idx <# 0# = b
 659      | otherwise = whizzRL (f (C# (indexPS# ps idx)) b) (idx -# 1#)
 660
 661 takePS :: Int -> PackedString -> PackedString
 662 takePS (I# n) ps
 663   | n ==# 0#   = nilPS
 664   | otherwise  = substrPS# ps 0# (n -# 1#)
 665
 666 dropPS  :: Int -> PackedString -> PackedString
 667 dropPS (I# n) ps
 668   | n ==# len = nilPS
 669   | otherwise = substrPS# ps n  (lengthPS# ps -# 1#)
 670   where
 671     len = lengthPS# ps
 672
 673 splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
 674 splitAtPS  n ps  = (takePS n ps, dropPS n ps)
 675
 676 takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
 677 takeWhilePS pred ps
 678   = let
 679         break_pt = char_pos_that_dissatisfies
 680                         (\ c -> pred (C# c))
 681                         ps
 682                         (lengthPS# ps)
 683                         0#
 684     in
 685     if break_pt ==# 0# then
 686        nilPS
 687     else
 688        substrPS# ps 0# (break_pt -# 1#)
 689
 690 dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
 691 dropWhilePS pred ps
 692   = let
 693         len      = lengthPS# ps
 694         break_pt = char_pos_that_dissatisfies
 695                         (\ c -> pred (C# c))
 696                         ps
 697                         len
 698                         0#
 699     in
 700     if len ==# break_pt then
 701        nilPS
 702     else
 703        substrPS# ps break_pt (len -# 1#)
 704
 705 elemPS :: Char -> PackedString -> Bool
 706 elemPS (C# ch) ps
 707   = let
 708         len      = lengthPS# ps
 709         break_pt = first_char_pos_that_satisfies
 710                         (`eqChar#` ch)
 711                         ps
 712                         len
 713                         0#
 714     in
 715     break_pt <# len
 716
 717 char_pos_that_dissatisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
 718
 719 char_pos_that_dissatisfies p ps len pos
 720   | pos >=# len         = pos -- end
 721   | p (indexPS# ps pos) = -- predicate satisfied; keep going
 722                           char_pos_that_dissatisfies p ps len (pos +# 1#)
 723   | otherwise           = pos -- predicate not satisfied
 724
 725 first_char_pos_that_satisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
 726 first_char_pos_that_satisfies p ps len pos
 727   | pos >=# len         = pos -- end
 728   | p (indexPS# ps pos) = pos -- got it!
 729   | otherwise           = first_char_pos_that_satisfies p ps len (pos +# 1#)
 730
 731 -- ToDo: could certainly go quicker
 732 spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
 733 spanPS  p ps = (takeWhilePS p ps, dropWhilePS p ps)
 734
 735 breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
 736 breakPS p ps = spanPS (not . p) ps
 737
 738 linesPS :: PackedString -> [PackedString]
 739 linesPS ps = splitPS '\n' ps
 740
 741 wordsPS :: PackedString -> [PackedString]
 742 wordsPS ps = splitWithPS isSpace ps
 743
 744 reversePS :: PackedString -> PackedString
 745 reversePS ps =
 746   if nullPS ps then -- don't create stuff unnecessarily.
 747      ps
 748   else
 749     runST (
 750       new_ps_array (length +# 1#)    >>= \ arr# -> -- incl NUL byte!
 751       fill_in arr# (length -# 1#) 0# >>
 752       freeze_ps_array arr# length    >>= \ (ByteArray _ frozen#) ->
 753       let has_null = byteArrayHasNUL# frozen# length in
 754       return (PS frozen# length has_null))
 755  where
 756   length = lengthPS# ps
 757
 758   fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
 759   fill_in arr_in# n i =
 760    let
 761     ch = indexPS# ps n
 762    in
 763    write_ps_array arr_in# i ch                   >>
 764    if n ==# 0# then
 765       write_ps_array arr_in# (i +# 1#) (chr# 0#) >>
 766       return ()
 767    else
 768       fill_in arr_in# (n -# 1#) (i +# 1#)
 769
 770 concatPS :: [PackedString] -> PackedString
 771 concatPS [] = nilPS
 772 concatPS pss
 773   = let
 774         tot_len# = case (foldr ((+) . lengthPS) 0 pss) of { I# x -> x }
 775         tot_len  = I# tot_len#
 776     in
 777     runST (
 778     new_ps_array (tot_len# +# 1#)   >>= \ arr# -> -- incl NUL byte!
 779     packum arr# pss 0#              >>
 780     freeze_ps_array arr# tot_len#   >>= \ (ByteArray _ frozen#) ->
 781
 782     let has_null = byteArrayHasNUL# frozen# tot_len# in
 783
 784     return (PS frozen# tot_len# has_null)
 785     )
 786   where
 787     packum :: MutableByteArray s Int -> [PackedString] -> Int# -> ST s ()
 788
 789     packum arr [] pos
 790       = write_ps_array arr pos (chr# 0#) >>
 791         return ()
 792     packum arr (ps : pss) pos
 793       = fill arr pos ps 0# (lengthPS# ps)  >>= \ (I# next_pos) ->
 794         packum arr pss next_pos
 795
 796     fill :: MutableByteArray s Int -> Int# -> PackedString -> Int# -> Int# -> ST s Int
 797
 798     fill arr arr_i ps ps_i ps_len
 799      | ps_i ==# ps_len
 800        = return (I# (arr_i +# ps_len))
 801      | otherwise
 802        = write_ps_array arr (arr_i +# ps_i) (indexPS# ps ps_i) >>
 803          fill arr arr_i ps (ps_i +# 1#) ps_len
 804
 805 ------------------------------------------------------------
 806 joinPS :: PackedString -> [PackedString] -> PackedString
 807 joinPS filler pss = concatPS (splice pss)
 808  where
 809   splice []  = []
 810   splice [x] = [x]
 811   splice (x:y:xs) = x:filler:splice (y:xs)
 812
 813 -- ToDo: the obvious generalisation
 814 {-
 815   Some properties that hold:
 816
 817   * splitPS x ls = ls'
 818       where False = any (map (x `elemPS`) ls')
 819             False = any (map (nullPS) ls')
 820
 821     * all x's have been chopped out.
 822     * no empty PackedStrings in returned list. A conseq.
 823       of this is:
 824            splitPS x nilPS = []
 825
 826
 827   * joinPS (packString [x]) (_splitPS x ls) = ls
 828
 829 -}
 830
 831 splitPS :: Char -> PackedString -> [PackedString]
 832 splitPS (C# ch) = splitWithPS (\ (C# c) -> c `eqChar#` ch)
 833
 834 splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]
 835 splitWithPS pred ps =
 836  splitify 0#
 837  where
 838   len = lengthPS# ps
 839
 840   splitify n
 841    | n >=# len = []
 842    | otherwise =
 843       let
 844        break_pt =
 845          first_char_pos_that_satisfies
 846             (\ c -> pred (C# c))
 847             ps
 848             len
 849             n
 850       in
 851       if break_pt ==# n then -- immediate match, no substring to cut out.
 852          splitify (break_pt +# 1#)
 853       else
 854          substrPS# ps n (break_pt -# 1#): -- leave out the matching character
 855          splitify (break_pt +# 1#)
 856 \end{code}
 857
 858 %************************************************************************
 859 %*                                                                      *
 860 \subsection{Local utility functions}
 861 %*                                                                      *
 862 %************************************************************************
 863
 864 The definition of @_substrPS@ is essentially:
 865 @take (end - begin + 1) (drop begin str)@.
 866
 867 \begin{code}
 868 substrPS :: PackedString -> Int -> Int -> PackedString
 869 substrPS ps (I# begin) (I# end) = substrPS# ps begin end
 870
 871 substrPS# ps s e
 872   | s <# 0# || e <# s
 873   = error "substrPS: bounds out of range"
 874
 875   | s >=# len || result_len# <=# 0#
 876   = nilPS
 877
 878   | otherwise
 879   = runST (
 880         new_ps_array (result_len# +# 1#)   >>= \ ch_arr -> -- incl NUL byte!
 881         fill_in ch_arr 0#                  >>
 882         freeze_ps_array ch_arr result_len# >>= \ (ByteArray _ frozen#) ->
 883
 884         let has_null = byteArrayHasNUL# frozen# result_len# in
 885
 886         return (PS frozen# result_len# has_null)
 887     )
 888   where
 889     len = lengthPS# ps
 890
 891     result_len# = (if e <# len then (e +# 1#) else len) -# s
 892     result_len  = I# result_len#
 893
 894     -----------------------
 895     fill_in :: MutableByteArray s Int -> Int# -> ST s ()
 896
 897     fill_in arr_in# idx
 898       | idx ==# result_len#
 899       = write_ps_array arr_in# idx (chr# 0#) >>
 900         return ()
 901       | otherwise
 902       = let
 903             ch = indexPS# ps (s +# idx)
 904         in
 905         write_ps_array arr_in# idx ch        >>
 906         fill_in arr_in# (idx +# 1#)
 907 \end{code}
 908
 909 %*********************************************************
 910 %*                                                      *
 911 \subsection{Packing and unpacking C strings}
 912 %*                                                      *
 913 %*********************************************************
 914
 915 \begin{code}
 916 cStringToPS      :: Addr  -> PackedString
 917 cStringToPS (A# a#) =   -- the easy one; we just believe the caller
 918  CPS a# len
 919  where
 920   len = case (strlen# a#) of { I# x -> x }
 921
 922 packCBytes :: Int -> Addr -> PackedString
 923 packCBytes len addr = runST (packCBytesST len addr)
 924
 925 packCBytesST :: Int -> Addr -> ST s PackedString
 926 packCBytesST len@(I# length#) (A# addr) =
 927   {-
 928     allocate an array that will hold the string
 929     (not forgetting the NUL byte at the end)
 930   -}
 931   new_ps_array (length# +# 1#)  >>= \ ch_array ->
 932    -- fill in packed string from "addr"
 933   fill_in ch_array 0#   >>
 934    -- freeze the puppy:
 935   freeze_ps_array ch_array length# >>= \ (ByteArray _ frozen#) ->
 936   let has_null = byteArrayHasNUL# frozen# length# in
 937   return (PS frozen# length# has_null)
 938   where
 939     fill_in :: MutableByteArray s Int -> Int# -> ST s ()
 940
 941     fill_in arr_in# idx
 942       | idx ==# length#
 943       = write_ps_array arr_in# idx (chr# 0#) >>
 944         return ()
 945       | otherwise
 946       = case (indexCharOffAddr# addr idx) of { ch ->
 947         write_ps_array arr_in# idx ch >>
 948         fill_in arr_in# (idx +# 1#) }
 949
 950 \end{code}