ghc/lib/prelude/PS.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
   3 %
   4 \section[PrelPS]{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 PreludePS{-yes, a Prelude module!-} (
  12         _packString,
  13         _packStringST,
  14         _packCString,
  15         _packCBytes,
  16         _packCBytesST,
  17         _packStringForC,
  18         _packBytesForC,
  19         _packBytesForCST,
  20         _nilPS,
  21         _consPS,
  22 --OLD:  packString#,
  23 --OLD:  packToCString,
  24         _byteArrayToPS,
  25         _unsafeByteArrayToPS,
  26         _psToByteArray,
  27
  28         _unpackPS,
  29 --      toCString,
  30         _putPS,
  31         _getPS,
  32
  33         _headPS,
  34         _tailPS,
  35         _nullPS,
  36         _appendPS,
  37         _lengthPS,
  38         _indexPS,
  39         _mapPS,
  40         _filterPS,
  41         _foldlPS,
  42         _foldrPS,
  43         _takePS,
  44         _dropPS,
  45         _splitAtPS,
  46         _takeWhilePS,
  47         _dropWhilePS,
  48         _spanPS,
  49         _breakPS,
  50         _linesPS,
  51         _wordsPS,
  52         _reversePS,
  53         _concatPS,
  54
  55         _substrPS,
  56 --???   _hashPS,
  57
  58         -- to make interface self-sufficient
  59         _PackedString, -- abstract!
  60         _FILE
  61     ) where
  62
  63 import PreludeGlaST
  64 import Stdio            ( _FILE )
  65 import TyArray          ( _ByteArray(..) )
  66
  67 import Cls
  68 import Core
  69 import IChar
  70 import IList
  71 import IInt
  72 import Prel             ( otherwise, (&&), (||), chr, ($), not, (.), isSpace, flip )
  73 import List             ( length, (++), map, filter, foldl, foldr,
  74                           lines, words, reverse, null, foldr1,
  75                           dropWhile, break
  76                         )
  77 import TyArray          ( Array(..) )
  78 import TyComplex
  79 import Text
  80 \end{code}
  81
  82 %************************************************************************
  83 %*                                                                      *
  84 \subsection{@_PackedString@ type declaration and interface (signatures)}
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 The things we want:
  89 \begin{code}
  90 data _PackedString
  91   = _PS         ByteArray#  -- the bytes
  92                 Int#        -- length (*not* including NUL at the end)
  93                 Bool        -- True <=> contains a NUL
  94   | _CPS        Addr#       -- pointer to the (null-terminated) bytes in C land
  95                 Int#        -- length, as per strlen
  96                 -- definitely doesn't contain a NUL
  97
  98 _packString      :: [Char] -> _PackedString
  99 _packStringST    :: [Char] -> _ST s _PackedString
 100 _packCString     :: _Addr  -> _PackedString
 101 _packCBytes      :: Int -> _Addr -> _PackedString
 102 _packCBytesST    :: Int -> _Addr -> _ST s _PackedString
 103 _packStringForC  :: [Char] -> ByteArray#        -- calls injected by compiler
 104 _packBytesForC   :: [Char] -> _ByteArray Int
 105 _packBytesForCST :: [Char] -> _ST s (_ByteArray Int)
 106 _nilPS           :: _PackedString
 107 _consPS          :: Char -> _PackedString -> _PackedString
 108 _byteArrayToPS   :: _ByteArray Int -> _PackedString
 109 _psToByteArray   :: _PackedString -> _ByteArray Int
 110
 111 --OLD: packString#      :: [Char] -> ByteArray#
 112 --OLD: packToCString    :: [Char] -> _ByteArray Int -- hmmm... weird name
 113
 114 _unpackPS       :: _PackedString -> [Char]
 115 --???toCString  :: _PackedString -> ByteArray#
 116 _putPS          :: _FILE -> _PackedString -> PrimIO () -- ToDo: more sensible type
 117 \end{code}
 118
 119 \begin{code}
 120 _headPS     :: _PackedString -> Char
 121 _tailPS     :: _PackedString -> _PackedString
 122 _nullPS     :: _PackedString -> Bool
 123 _appendPS   :: _PackedString -> _PackedString -> _PackedString
 124 _lengthPS   :: _PackedString -> Int
 125 _indexPS    :: _PackedString -> Int -> Char
 126             -- 0-origin indexing into the string
 127 _mapPS      :: (Char -> Char) -> _PackedString -> _PackedString {-or String?-}
 128 _filterPS   :: (Char -> Bool) -> _PackedString -> _PackedString {-or String?-}
 129 _foldlPS    :: (a -> Char -> a) -> a -> _PackedString -> a
 130 _foldrPS    :: (Char -> a -> a) -> a -> _PackedString -> a
 131 _takePS     :: Int -> _PackedString -> _PackedString
 132 _dropPS     :: Int -> _PackedString -> _PackedString
 133 _splitAtPS  :: Int -> _PackedString -> (_PackedString, _PackedString)
 134 _takeWhilePS:: (Char -> Bool) -> _PackedString -> _PackedString
 135 _dropWhilePS:: (Char -> Bool) -> _PackedString -> _PackedString
 136 _spanPS     :: (Char -> Bool) -> _PackedString -> (_PackedString, _PackedString)
 137 _breakPS    :: (Char -> Bool) -> _PackedString -> (_PackedString, _PackedString)
 138 _linesPS    :: _PackedString -> [_PackedString]
 139 _wordsPS    :: _PackedString -> [_PackedString]
 140 _reversePS  :: _PackedString -> _PackedString
 141 _concatPS   :: [_PackedString] -> _PackedString
 142
 143 _substrPS   :: _PackedString -> Int -> Int -> _PackedString
 144             -- pluck out a piece of a _PS
 145             -- start and end chars you want; both 0-origin-specified
 146 --??? _hashPS       :: _PackedString -> Int -> Int
 147             -- use the _PS to produce a hash value between 0 & m (inclusive)
 148 \end{code}
 149
 150 %************************************************************************
 151 %*                                                                      *
 152 \subsection{Constructor functions}
 153 %*                                                                      *
 154 %************************************************************************
 155
 156 Easy ones first.  @_packString@ requires getting some heap-bytes and
 157 scribbling stuff into them.
 158
 159 \begin{code}
 160 _packCString (A# a#)    -- the easy one; we just believe the caller
 161   = _CPS a# len
 162   where
 163     len = case (strlen# a#) of { I# x -> x }
 164
 165 _nilPS = _CPS ""# 0#
 166 _consPS c cs = _packString (c : (_unpackPS cs)) -- ToDo:better
 167
 168 _packStringForC str
 169   = case (_packString str) of
 170       _PS bytes _ _ -> bytes
 171
 172 _packBytesForC str
 173   = _psToByteArray (_packString str)
 174
 175 _packBytesForCST str
 176   = _packStringST str   `thenStrictlyST` \ (_PS bytes n has_null) ->
 177     --later? ASSERT(not has_null)
 178     returnStrictlyST (_ByteArray (0, I# (n -# 1#)) bytes)
 179
 180 _packString str = _runST (_packStringST str)
 181
 182 _packStringST str
 183   = let  len = length str  in
 184     pack_me len str
 185   where
 186     pack_me :: Int -> [Char] -> _ST s _PackedString
 187
 188     pack_me len@(I# length#) str
 189       =     -- allocate an array that will hold the string
 190             -- (not forgetting the NUL byte at the end)
 191           new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array ->
 192
 193             -- fill in packed string from "str"
 194           fill_in ch_array 0# str   `seqStrictlyST`
 195
 196             -- freeze the puppy:
 197           freeze_ps_array ch_array `thenStrictlyST` \ (_ByteArray _ frozen#) ->
 198
 199           let has_null = byteArrayHasNUL# frozen# length# in
 200
 201           returnStrictlyST (_PS frozen# length# has_null)
 202       where
 203         fill_in :: _MutableByteArray s Int -> Int# -> [Char] -> _ST s ()
 204
 205         fill_in arr_in# idx []
 206           = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
 207             returnStrictlyST ()
 208
 209         fill_in arr_in# idx (C# c : cs)
 210           = write_ps_array arr_in# idx c         `seqStrictlyST`
 211             fill_in arr_in# (idx +# 1#) cs
 212
 213 _packCBytes len addr = _runST (_packCBytesST len addr)
 214
 215 _packCBytesST len@(I# length#) (A# addr)
 216   =   -- allocate an array that will hold the string
 217       -- (not forgetting the NUL byte at the end)
 218     new_ps_array (length# +# 1#)  `thenStrictlyST` \ ch_array ->
 219
 220       -- fill in packed string from "addr"
 221     fill_in ch_array 0#   `seqStrictlyST`
 222
 223       -- freeze the puppy:
 224     freeze_ps_array ch_array `thenStrictlyST` \ (_ByteArray _ frozen#) ->
 225
 226     let has_null = byteArrayHasNUL# frozen# length# in
 227
 228     returnStrictlyST (_PS frozen# length# has_null)
 229   where
 230     fill_in :: _MutableByteArray s Int -> Int# -> _ST s ()
 231
 232     fill_in arr_in# idx
 233       | idx ==# length#
 234       = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
 235         returnStrictlyST ()
 236       | otherwise
 237       = case (indexCharOffAddr# addr idx) of { ch ->
 238         write_ps_array arr_in# idx ch `seqStrictlyST`
 239         fill_in arr_in# (idx +# 1#) }
 240
 241 _byteArrayToPS (_ByteArray ixs@(_, ix_end) frozen#)
 242   = let
 243         n# = case (
 244                 if null (range ixs)
 245                   then 0
 246                   else ((index ixs ix_end) + 1)
 247              ) of { I# x -> x }
 248     in
 249     _PS frozen# n# (byteArrayHasNUL# frozen# n#)
 250
 251 _unsafeByteArrayToPS (_ByteArray _ frozen#) (I# n#)
 252   = _PS frozen# n# (byteArrayHasNUL# frozen# n#)
 253
 254 _psToByteArray (_PS bytes n has_null)
 255   = _ByteArray (0, I# (n -# 1#)) bytes
 256
 257 _psToByteArray (_CPS addr len#)
 258   = let
 259         len             = I# len#
 260         byte_array_form = _packCBytes len (A# addr)
 261     in
 262     case byte_array_form of { _PS bytes _ _ ->
 263     _ByteArray (0, len - 1) bytes }
 264 \end{code}
 265
 266 %************************************************************************
 267 %*                                                                      *
 268 \subsection{Destructor functions (taking @_PackedStrings@ apart)}
 269 %*                                                                      *
 270 %************************************************************************
 271
 272 \begin{code}
 273 {- OLD: but good? WDP 96/01
 274 unpackPS# addr -- calls injected by compiler
 275   = _unpackPS (_CPS addr len)
 276   where
 277     len = case (strlen# addr) of { I# x -> x }
 278 -}
 279
 280 -- OK, but this code gets *hammered*:
 281 -- _unpackPS ps
 282 --   = [ _indexPS ps n | n <- [ 0::Int .. _lengthPS ps - 1 ] ]
 283
 284 _unpackPS (_PS bytes len has_null)
 285   = unpack 0#
 286   where
 287     unpack nh
 288       | nh >=# len  = []
 289       | otherwise   = C# ch : unpack (nh +# 1#)
 290       where
 291         ch = indexCharArray# bytes nh
 292
 293 _unpackPS (_CPS addr len)
 294   = unpack 0#
 295   where
 296     unpack nh
 297       | ch `eqChar#` '\0'# = []
 298       | otherwise          = C# ch : unpack (nh +# 1#)
 299       where
 300         ch = indexCharOffAddr# addr nh
 301 \end{code}
 302
 303 \begin{code}
 304 _putPS file ps@(_PS bytes len has_null)
 305   | len ==# 0#
 306   = returnPrimIO ()
 307   | otherwise
 308   = let
 309         byte_array = _ByteArray (0, I# (len -# 1#)) bytes
 310     in
 311     _ccall_ fwrite byte_array (1::Int){-size-} (I# len) file
 312                                         `thenPrimIO` \ (I# written) ->
 313     if written ==# len then
 314         returnPrimIO ()
 315     else
 316         error "_putPS: fwrite failed!\n"
 317
 318 _putPS file (_CPS addr len)
 319   | len ==# 0#
 320   = returnPrimIO ()
 321   | otherwise
 322   = _ccall_ fputs (A# addr) file `thenPrimIO` \ (I# _){-force type-} ->
 323     returnPrimIO ()
 324 \end{code}
 325
 326 The dual to @_putPS@, note that the size of the chunk specified
 327 is the upper bound of the size of the chunk returned.
 328
 329 \begin{code}
 330 _getPS :: _FILE -> Int -> PrimIO _PackedString
 331 _getPS file len@(I# len#)
 332  | len# <=# 0# = returnPrimIO _nilPS -- I'm being kind here.
 333  | otherwise   =
 334     -- Allocate an array for system call to store its bytes into.
 335    new_ps_array len#      `thenPrimIO` \ ch_arr ->
 336    freeze_ps_array ch_arr `thenPrimIO` \ (_ByteArray _ frozen#) ->
 337    let
 338     byte_array = _ByteArray (0, I# len#) frozen#
 339    in
 340    _ccall_ fread byte_array (1::Int) len file `thenPrimIO` \  (I# read#) ->
 341    if read# ==# 0# then -- EOF or other error
 342       error "_getPS: EOF reached or other error"
 343    else
 344      {-
 345        The system call may not return the number of
 346        bytes requested. Instead of failing with an error
 347        if the number of bytes read is less than requested,
 348        a packed string containing the bytes we did manage
 349        to snarf is returned.
 350      -}
 351      let
 352       has_null = byteArrayHasNUL# frozen# read#
 353      in
 354      returnPrimIO (_PS frozen# read# has_null)
 355
 356 \end{code}
 357
 358 %************************************************************************
 359 %*                                                                      *
 360 \subsection{List-mimicking functions for @_PackedStrings@}
 361 %*                                                                      *
 362 %************************************************************************
 363
 364 First, the basic functions that do look into the representation;
 365 @indexPS@ is the most important one.
 366 \begin{code}
 367 _lengthPS ps = I# (lengthPS# ps)
 368
 369 {-# INLINE lengthPS# #-}
 370
 371 lengthPS# (_PS  _ i _) = i
 372 lengthPS# (_CPS _ i)   = i
 373
 374 {-# INLINE strlen# #-}
 375
 376 strlen# :: Addr# -> Int
 377 strlen# a
 378   = unsafePerformPrimIO (
 379     _ccall_ strlen (A# a)  `thenPrimIO` \ len@(I# _) ->
 380     returnPrimIO len
 381     )
 382
 383 byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool
 384
 385 byteArrayHasNUL# bs len
 386   = unsafePerformPrimIO (
 387     _ccall_ byteArrayHasNUL__ ba (I# len)  `thenPrimIO` \ (I# res) ->
 388     returnPrimIO (
 389     if res ==# 0# then False else True
 390     ))
 391   where
 392     ba = _ByteArray (0, I# (len -# 1#)) bs
 393
 394 -----------------------
 395 _indexPS ps (I# n) = C# (indexPS# ps n)
 396
 397 {-# INLINE indexPS# #-}
 398
 399 indexPS# (_PS bs i _) n
 400   = --ASSERT (n >=# 0# && n <# i)       -- error checking: my eye!  (WDP 94/10)
 401     indexCharArray# bs n
 402
 403 indexPS# (_CPS a _) n
 404   = indexCharOffAddr# a n
 405 \end{code}
 406
 407 Now, the rest of the functions can be defined without digging
 408 around in the representation.
 409 \begin{code}
 410 _headPS ps
 411   | _nullPS ps = error "_headPS: head []"
 412   | otherwise  = C# (indexPS# ps 0#)
 413
 414 _tailPS ps
 415   | len <=# 0# = error "_tailPS: tail []"
 416   | len ==# 1# = _nilPS
 417   | otherwise  = substrPS# ps 1# (len -# 1#)
 418   where
 419     len = lengthPS# ps
 420
 421 _nullPS (_PS  _ i _) = i ==# 0#
 422 _nullPS (_CPS _ i)   = i ==# 0#
 423
 424 -- ToDo: some non-lousy implementations...
 425
 426 _appendPS xs ys
 427   | _nullPS xs = ys
 428   | _nullPS ys = xs
 429   | otherwise  = _packString (_unpackPS xs ++ _unpackPS ys)
 430
 431 _mapPS f xs = _packString (map f (_unpackPS xs))
 432
 433 _filterPS p  ps = _packString (filter p (_unpackPS ps))
 434 _foldlPS f b ps = foldl f b (_unpackPS ps)
 435 _foldrPS f b ps = foldr f b (_unpackPS ps)
 436
 437 _takePS (I# n) ps = substrPS# ps 0# (n -# 1#)
 438 _dropPS (I# n) ps = substrPS# ps n  (lengthPS# ps -# 1#)
 439 _splitAtPS  n ps  = (_takePS n ps, _dropPS n ps)
 440
 441 _takeWhilePS pred ps
 442   = let
 443         break_pt = char_pos_that_dissatisfies
 444                         (\ c -> pred (C# c))
 445                         ps
 446                         (lengthPS# ps)
 447                         0#
 448     in
 449     substrPS# ps 0# (break_pt -# 1#)
 450
 451 _dropWhilePS pred ps
 452   = let
 453         len      = lengthPS# ps
 454         break_pt = char_pos_that_dissatisfies
 455                         (\ c -> pred (C# c))
 456                         ps
 457                         len
 458                         0#
 459     in
 460     substrPS# ps break_pt (len -# 1#)
 461
 462 char_pos_that_dissatisfies :: (Char# -> Bool) -> _PackedString -> Int# -> Int# -> Int#
 463
 464 char_pos_that_dissatisfies p ps len pos
 465   | pos >=# len         = pos -- end
 466   | p (indexPS# ps pos) = -- predicate satisfied; keep going
 467                           char_pos_that_dissatisfies p ps len (pos +# 1#)
 468   | otherwise           = pos -- predicate not satisfied
 469
 470 char_pos_that_dissatisfies p ps len pos -- dead code: HACK to avoid badly-typed error msg
 471   = 0#
 472
 473 -- ToDo: could certainly go quicker
 474 _spanPS  p ps = (_takeWhilePS p ps, _dropWhilePS p ps)
 475 _breakPS p ps = _spanPS (not . p) ps
 476
 477 _linesPS ps = map _packString (lines (_unpackPS ps))
 478 _wordsPS ps = map _packString (words (_unpackPS ps))
 479
 480 _reversePS ps = _packString (reverse (_unpackPS ps))
 481
 482 _concatPS [] = _nilPS
 483 _concatPS pss
 484   = let
 485         tot_len# = case (foldr ((+) . _lengthPS) 0 pss) of { I# x -> x }
 486         tot_len  = I# tot_len#
 487     in
 488     _runST (
 489     new_ps_array (tot_len# +# 1#)   `thenStrictlyST` \ arr# -> -- incl NUL byte!
 490     packum arr# pss 0#              `seqStrictlyST`
 491     freeze_ps_array arr#            `thenStrictlyST` \ (_ByteArray _ frozen#) ->
 492
 493     let has_null = byteArrayHasNUL# frozen# tot_len# in
 494
 495     returnStrictlyST (_PS frozen# tot_len# has_null)
 496     )
 497   where
 498     packum :: _MutableByteArray s Int -> [_PackedString] -> Int# -> _ST s ()
 499
 500     packum arr [] pos
 501       = write_ps_array arr pos (chr# 0#) `seqStrictlyST`
 502         returnStrictlyST ()
 503     packum arr (ps : pss) pos
 504       = fill arr pos ps 0# (lengthPS# ps)  `thenStrictlyST` \ (I# next_pos) ->
 505         packum arr pss next_pos
 506
 507     fill :: _MutableByteArray s Int -> Int# -> _PackedString -> Int# -> Int# -> _ST s Int
 508
 509     fill arr arr_i ps ps_i ps_len
 510      | ps_i ==# ps_len
 511        = returnStrictlyST (I# (arr_i +# ps_len))
 512      | otherwise
 513        = write_ps_array arr (arr_i +# ps_i) (indexPS# ps ps_i) `seqStrictlyST`
 514          fill arr arr_i ps (ps_i +# 1#) ps_len
 515 \end{code}
 516
 517 %************************************************************************
 518 %*                                                                      *
 519 \subsection{Instances for @_PackedStrings@: @Eq@, @Ord@, @Text@}
 520 %*                                                                      *
 521 %************************************************************************
 522
 523 Instances:
 524 \begin{code}
 525 instance Eq _PackedString where
 526     a == b = case _tagCmpPS a b of { _LT -> False; _EQ -> True;  _GT -> False }
 527     a /= b = case _tagCmpPS a b of { _LT -> True;  _EQ -> False; _GT -> True  }
 528
 529 instance Ord _PackedString where
 530     a <= b = case _tagCmpPS a b of { _LT -> True;  _EQ -> True;  _GT -> False }
 531     a <  b = case _tagCmpPS a b of { _LT -> True;  _EQ -> False; _GT -> False }
 532     a >= b = case _tagCmpPS a b of { _LT -> False; _EQ -> True;  _GT -> True  }
 533     a >  b = case _tagCmpPS a b of { _LT -> False; _EQ -> False; _GT -> True  }
 534     max x y | x >= y    =  x
 535             | otherwise =  y
 536     min x y | x <= y    =  x
 537             | otherwise =  y
 538     _tagCmp a b = _tagCmpPS a b
 539 \end{code}
 540
 541 We try hard to make this go fast:
 542 \begin{code}
 543 _tagCmpPS :: _PackedString -> _PackedString -> _CMP_TAG
 544
 545 _tagCmpPS (_PS  bs1 len1 has_null1) (_PS  bs2 len2 has_null2)
 546   | not has_null1 && not has_null2
 547   = unsafePerformPrimIO (
 548     _ccall_ strcmp ba1 ba2  `thenPrimIO` \ (I# res) ->
 549     returnPrimIO (
 550     if      res <#  0# then _LT
 551     else if res ==# 0# then _EQ
 552     else                    _GT
 553     ))
 554   where
 555     ba1 = _ByteArray (0, I# (len1 -# 1#)) bs1
 556     ba2 = _ByteArray (0, I# (len2 -# 1#)) bs2
 557
 558 _tagCmpPS (_PS  bs1 len1 has_null1) (_CPS bs2 len2)
 559   | not has_null1
 560   = unsafePerformPrimIO (
 561     _ccall_ strcmp ba1 ba2  `thenPrimIO` \ (I# res) ->
 562     returnPrimIO (
 563     if      res <#  0# then _LT
 564     else if res ==# 0# then _EQ
 565     else                    _GT
 566     ))
 567   where
 568     ba1 = _ByteArray (0, I# (len1 -# 1#)) bs1
 569     ba2 = A# bs2
 570
 571 _tagCmpPS (_CPS bs1 len1) (_CPS bs2 len2)
 572   = unsafePerformPrimIO (
 573     _ccall_ strcmp ba1 ba2  `thenPrimIO` \ (I# res) ->
 574     returnPrimIO (
 575     if      res <#  0# then _LT
 576     else if res ==# 0# then _EQ
 577     else                    _GT
 578     ))
 579   where
 580     ba1 = A# bs1
 581     ba2 = A# bs2
 582
 583 _tagCmpPS a@(_CPS _ _) b@(_PS _ _ has_null2)
 584   | not has_null2
 585   = -- try them the other way 'round
 586     case (_tagCmpPS b a) of { _LT -> _GT; _EQ -> _EQ; _GT -> _LT }
 587
 588 _tagCmpPS ps1 ps2 -- slow catch-all case (esp for "has_null" True)
 589   = looking_at 0#
 590   where
 591     end1 = lengthPS# ps1 -# 1#
 592     end2 = lengthPS# ps2 -# 1#
 593
 594     looking_at char#
 595       = if char# ># end1 then
 596            if char# ># end2 then -- both strings ran out at once
 597               _EQ
 598            else -- ps1 ran out before ps2
 599               _LT
 600         else if char# ># end2 then
 601            _GT  -- ps2 ran out before ps1
 602         else
 603            let
 604               ch1 = indexPS# ps1 char#
 605               ch2 = indexPS# ps2 char#
 606            in
 607            if ch1 `eqChar#` ch2 then
 608               looking_at (char# +# 1#)
 609            else if ch1 `ltChar#` ch2 then _LT
 610                                      else _GT
 611
 612 instance Text _PackedString where
 613     readsPrec p = error "readsPrec: _PackedString: ToDo"
 614     showsPrec p ps r = showsPrec p (_unpackPS ps) r
 615     readList = _readList (readsPrec 0)
 616     showList = _showList (showsPrec 0)
 617 \end{code}
 618
 619 %************************************************************************
 620 %*                                                                      *
 621 \subsection{Uniquely PackedString functions}
 622 %*                                                                      *
 623 %************************************************************************
 624
 625 For @_substrPS@, see the next section.
 626
 627 @_hashPS@ is just what we happen to need in GHC...
 628 \begin{code}
 629 {- LATER?
 630 _hashPS ps (I# hASH_TBL_SIZE#)
 631   = I# (h `remInt#` hASH_TBL_SIZE#)
 632   where
 633     len = lengthPS# ps
 634
 635     h | len <=# 0# = 0# -- probably should just be an "error"
 636       | len ==# 1# = ord# c1
 637       | len ==# 2# = ord# c2
 638       | len ==# 3# = ord# c2 +# ord# c3
 639       | len ==# 4# = ord# c2 +# ord# c3 +# ord# c4
 640       | len ==# 5# = ord# c2 +# ord# c3 +# ord# c4 +# ord# c5
 641       | len >=# 6# = ord# c2 +# ord# c3 +# ord# c4 +# ord# c5 +# ord# c6
 642       | otherwise  = 999# -- will never happen
 643
 644     c1 = indexPS# ps 0#
 645     c2 = indexPS# ps 1#
 646     c3 = indexPS# ps 2#
 647     c4 = indexPS# ps 3#
 648     c5 = indexPS# ps 4#
 649     c6 = indexPS# ps 5#
 650 -}
 651 \end{code}
 652
 653 %************************************************************************
 654 %*                                                                      *
 655 \subsection{Local utility functions}
 656 %*                                                                      *
 657 %************************************************************************
 658
 659 The definition of @_substrPS@ is essentially:
 660 @take (end - begin + 1) (drop begin str)@.
 661 \begin{code}
 662 _substrPS ps (I# begin) (I# end) = substrPS# ps begin end
 663
 664 substrPS# ps s e
 665   | s <# 0# || e <# s
 666   = error "_substrPS: bounds out of range"
 667
 668   | s >=# len || result_len# <=# 0#
 669   = _nilPS
 670
 671   | otherwise
 672   = _runST (
 673         new_ps_array (result_len# +# 1#) `thenStrictlyST` \ ch_arr -> -- incl NUL byte!
 674         fill_in ch_arr 0#                `seqStrictlyST`
 675         freeze_ps_array ch_arr           `thenStrictlyST` \ (_ByteArray _ frozen#) ->
 676
 677         let has_null = byteArrayHasNUL# frozen# result_len# in
 678
 679         returnStrictlyST (_PS frozen# result_len# has_null)
 680     )
 681   where
 682     len = lengthPS# ps
 683
 684     result_len# = (if e <# len then (e +# 1#) else len) -# s
 685     result_len  = I# result_len#
 686
 687     -----------------------
 688     fill_in :: _MutableByteArray s Int -> Int# -> _ST s ()
 689
 690     fill_in arr_in# idx
 691       | idx ==# result_len#
 692       = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
 693         returnStrictlyST ()
 694       | otherwise
 695       = let
 696             ch = indexPS# ps (s +# idx)
 697         in
 698         write_ps_array arr_in# idx ch        `seqStrictlyST`
 699         fill_in arr_in# (idx +# 1#)
 700 \end{code}
 701
 702 (Very :-) ``Specialised'' versions of some CharArray things...
 703 \begin{code}
 704 new_ps_array    :: Int# -> _ST s (_MutableByteArray s Int)
 705 write_ps_array  :: _MutableByteArray s Int -> Int# -> Char# -> _ST s ()
 706 freeze_ps_array :: _MutableByteArray s Int -> _ST s (_ByteArray Int)
 707
 708 new_ps_array size (S# s)
 709   = case (newCharArray# size s)   of { StateAndMutableByteArray# s2# barr# ->
 710     (_MutableByteArray bot barr#, S# s2#)}
 711   where
 712     bot = error "new_ps_array"
 713
 714 write_ps_array (_MutableByteArray _ barr#) n ch (S# s#)
 715   = case writeCharArray# barr# n ch s#  of { s2#   ->
 716     ((), S# s2#)}
 717
 718 -- same as unsafeFreezeByteArray
 719 freeze_ps_array (_MutableByteArray ixs arr#) (S# s#)
 720   = case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
 721     (_ByteArray ixs frozen#, S# s2#) }
 722 \end{code}