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