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