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