ghc/lib/prelude/GHCps.hs

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