ghc/lib/misc/PackedString.lhs

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