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