Data/PackedString.hs

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