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