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