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