ghc/lib/misc/PackedString.lhs

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