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