[project @ 2002-02-12 11:44:54 by simonmar]
[ghc-hetmet.git] / ghc / lib / std / PrelBase.lhs
1 % -----------------------------------------------------------------------------
2 % $Id: PrelBase.lhs,v 1.61 2002/02/12 03:52:09 chak Exp $
3 %
4 % (c) The University of Glasgow, 1992-2000
5 %
6 \section[PrelBase]{Module @PrelBase@}
7
8
9 The overall structure of the GHC Prelude is a bit tricky.
10
11   a) We want to avoid "orphan modules", i.e. ones with instance
12         decls that don't belong either to a tycon or a class
13         defined in the same module
14
15   b) We want to avoid giant modules
16
17 So the rough structure is as follows, in (linearised) dependency order
18
19
20 PrelGHC         Has no implementation.  It defines built-in things, and
21                 by importing it you bring them into scope.
22                 The source file is PrelGHC.hi-boot, which is just
23                 copied to make PrelGHC.hi
24
25                 Classes: CCallable, CReturnable
26
27 PrelBase        Classes: Eq, Ord, Functor, Monad
28                 Types:   list, (), Int, Bool, Ordering, Char, String
29
30 PrelTup         Types: tuples, plus instances for PrelBase classes
31
32 PrelShow        Class: Show, plus instances for PrelBase/PrelTup types
33
34 PrelEnum        Class: Enum,  plus instances for PrelBase/PrelTup types
35
36 PrelMaybe       Type: Maybe, plus instances for PrelBase classes
37
38 PrelNum         Class: Num, plus instances for Int
39                 Type:  Integer, plus instances for all classes so far (Eq, Ord, Num, Show)
40
41                 Integer is needed here because it is mentioned in the signature
42                 of 'fromInteger' in class Num
43
44 PrelReal        Classes: Real, Integral, Fractional, RealFrac
45                          plus instances for Int, Integer
46                 Types:  Ratio, Rational
47                         plus intances for classes so far
48
49                 Rational is needed here because it is mentioned in the signature
50                 of 'toRational' in class Real
51
52 Ix              Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples
53
54 PrelArr         Types: Array, MutableArray, MutableVar
55
56                 Does *not* contain any ByteArray stuff (see PrelByteArr)
57                 Arrays are used by a function in PrelFloat
58
59 PrelFloat       Classes: Floating, RealFloat
60                 Types:   Float, Double, plus instances of all classes so far
61
62                 This module contains everything to do with floating point.
63                 It is a big module (900 lines)
64                 With a bit of luck, many modules can be compiled without ever reading PrelFloat.hi
65
66 PrelByteArr     Types: ByteArray, MutableByteArray
67                 
68                 We want this one to be after PrelFloat, because it defines arrays
69                 of unboxed floats.
70
71
72 Other Prelude modules are much easier with fewer complex dependencies.
73
74
75 \begin{code}
76 {-# OPTIONS -fno-implicit-prelude #-}
77
78 #include "MachDeps.h"
79
80 module PrelBase
81         (
82         module PrelBase,
83         module PrelGHC,         -- Re-export PrelGHC and PrelErr, to avoid lots
84         module PrelErr          -- of people having to import it explicitly
85   ) 
86         where
87
88 import PrelGHC
89 import {-# SOURCE #-} PrelErr
90
91 infixr 9  .
92 infixr 5  ++, :
93 infix  4  ==, /=, <, <=, >=, >
94 infixr 3  &&
95 infixr 2  ||
96 infixl 1  >>, >>=
97 infixr 0  $
98
99 default ()              -- Double isn't available yet
100 \end{code}
101
102
103 %*********************************************************
104 %*                                                      *
105 \subsection{DEBUGGING STUFF}
106 %*  (for use when compiling PrelBase itself doesn't work)
107 %*                                                      *
108 %*********************************************************
109
110 \begin{code}
111 {-
112 data  Bool  =  False | True
113 data Ordering = LT | EQ | GT 
114 data Char = C# Char#
115 type  String = [Char]
116 data Int = I# Int#
117 data  ()  =  ()
118 data [] a = MkNil
119
120 not True = False
121 (&&) True True = True
122 otherwise = True
123
124 build = error "urk"
125 foldr = error "urk"
126
127 unpackCString# :: Addr# -> [Char]
128 unpackFoldrCString# :: Addr# -> (Char  -> a -> a) -> a -> a 
129 unpackAppendCString# :: Addr# -> [Char] -> [Char]
130 unpackCStringUtf8# :: Addr# -> [Char]
131 unpackCString# a = error "urk"
132 unpackFoldrCString# a = error "urk"
133 unpackAppendCString# a = error "urk"
134 unpackCStringUtf8# a = error "urk"
135 -}
136 \end{code}
137
138
139 %*********************************************************
140 %*                                                      *
141 \subsection{Standard classes @Eq@, @Ord@}
142 %*                                                      *
143 %*********************************************************
144
145 \begin{code}
146 class  Eq a  where
147     (==), (/=)           :: a -> a -> Bool
148
149     x /= y               = not (x == y)
150     x == y               = not (x /= y)
151
152 class  (Eq a) => Ord a  where
153     compare              :: a -> a -> Ordering
154     (<), (<=), (>), (>=) :: a -> a -> Bool
155     max, min             :: a -> a -> a
156
157     -- An instance of Ord should define either 'compare' or '<='.
158     -- Using 'compare' can be more efficient for complex types.
159
160     compare x y
161         | x == y    = EQ
162         | x <= y    = LT        -- NB: must be '<=' not '<' to validate the
163                                 -- above claim about the minimal things that
164                                 -- can be defined for an instance of Ord
165         | otherwise = GT
166
167     x <  y = case compare x y of { LT -> True;  _other -> False }
168     x <= y = case compare x y of { GT -> False; _other -> True }
169     x >  y = case compare x y of { GT -> True;  _other -> False }
170     x >= y = case compare x y of { LT -> False; _other -> True }
171
172         -- These two default methods use '<=' rather than 'compare'
173         -- because the latter is often more expensive
174     max x y = if x <= y then y else x
175     min x y = if x <= y then x else y
176 \end{code}
177
178 %*********************************************************
179 %*                                                      *
180 \subsection{Monadic classes @Functor@, @Monad@ }
181 %*                                                      *
182 %*********************************************************
183
184 \begin{code}
185 class  Functor f  where
186     fmap        :: (a -> b) -> f a -> f b
187
188 class  Monad m  where
189     (>>=)       :: m a -> (a -> m b) -> m b
190     (>>)        :: m a -> m b -> m b
191     return      :: a -> m a
192     fail        :: String -> m a
193
194     m >> k      = m >>= \_ -> k
195     fail s      = error s
196 \end{code}
197
198
199 %*********************************************************
200 %*                                                      *
201 \subsection{The list type}
202 %*                                                      *
203 %*********************************************************
204
205 \begin{code}
206 data [] a = [] | a : [a]  -- do explicitly: deriving (Eq, Ord)
207                           -- to avoid weird names like con2tag_[]#
208
209
210 instance (Eq a) => Eq [a] where
211     {-# SPECIALISE instance Eq [Char] #-}
212     []     == []     = True
213     (x:xs) == (y:ys) = x == y && xs == ys
214     _xs    == _ys    = False
215
216 instance (Ord a) => Ord [a] where
217     {-# SPECIALISE instance Ord [Char] #-}
218     compare []     []     = EQ
219     compare []     (_:_)  = LT
220     compare (_:_)  []     = GT
221     compare (x:xs) (y:ys) = case compare x y of
222                                 EQ    -> compare xs ys
223                                 other -> other
224
225 instance Functor [] where
226     fmap = map
227
228 instance  Monad []  where
229     m >>= k             = foldr ((++) . k) [] m
230     m >> k              = foldr ((++) . (\ _ -> k)) [] m
231     return x            = [x]
232     fail _              = []
233 \end{code}
234
235 A few list functions that appear here because they are used here.
236 The rest of the prelude list functions are in PrelList.
237
238 ----------------------------------------------
239 --      foldr/build/augment
240 ----------------------------------------------
241   
242 \begin{code}
243 foldr            :: (a -> b -> b) -> b -> [a] -> b
244 -- foldr _ z []     =  z
245 -- foldr f z (x:xs) =  f x (foldr f z xs)
246 {-# INLINE [0] foldr #-}
247 -- Inline only in the final stage, after the foldr/cons rule has had a chance
248 foldr k z xs = go xs
249              where
250                go []     = z
251                go (y:ys) = y `k` go ys
252
253 build   :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
254 {-# INLINE [1] build #-}
255         -- The INLINE is important, even though build is tiny,
256         -- because it prevents [] getting inlined in the version that
257         -- appears in the interface file.  If [] *is* inlined, it
258         -- won't match with [] appearing in rules in an importing module.
259         --
260         -- The "1" says to inline in phase 1
261
262 build g = g (:) []
263
264 augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]
265 {-# INLINE [1] augment #-}
266 augment g xs = g (:) xs
267
268 {-# RULES
269 "fold/build"    forall k z (g::forall b. (a->b->b) -> b -> b) . 
270                 foldr k z (build g) = g k z
271
272 "foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) . 
273                 foldr k z (augment g xs) = g k (foldr k z xs)
274
275 "foldr/id"                        foldr (:) [] = \x->x
276 "foldr/app"     [1] forall xs ys. foldr (:) ys xs = xs ++ ys
277         -- Only activate this from phase 1, because that's
278         -- when we disable the rule that expands (++) into foldr
279
280 -- The foldr/cons rule looks nice, but it can give disastrously
281 -- bloated code when commpiling
282 --      array (a,b) [(1,2), (2,2), (3,2), ...very long list... ]
283 -- i.e. when there are very very long literal lists
284 -- So I've disabled it for now. We could have special cases
285 -- for short lists, I suppose.
286 -- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)
287
288 "foldr/single"  forall k z x. foldr k z [x] = k x z
289 "foldr/nil"     forall k z.   foldr k z []  = z 
290
291 "augment/build" forall (g::forall b. (a->b->b) -> b -> b)
292                        (h::forall b. (a->b->b) -> b -> b) .
293                        augment g (build h) = build (\c n -> g c (h c n))
294 "augment/nil"   forall (g::forall b. (a->b->b) -> b -> b) .
295                         augment g [] = build g
296  #-}
297
298 -- This rule is true, but not (I think) useful:
299 --      augment g (augment h t) = augment (\cn -> g c (h c n)) t
300 \end{code}
301
302
303 ----------------------------------------------
304 --              map     
305 ----------------------------------------------
306
307 \begin{code}
308 map :: (a -> b) -> [a] -> [b]
309 map _ []     = []
310 map f (x:xs) = f x : map f xs
311
312 -- Note eta expanded
313 mapFB ::  (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst
314 {-# INLINE [0] mapFB #-}
315 mapFB c f x ys = c (f x) ys
316
317 -- The rules for map work like this.
318 -- 
319 -- Up to (but not including) phase 1, we use the "map" rule to
320 -- rewrite all saturated applications of map with its build/fold 
321 -- form, hoping for fusion to happen.
322 -- In phase 1 and 0, we switch off that rule, inline build, and
323 -- switch on the "mapList" rule, which rewrites the foldr/mapFB
324 -- thing back into plain map.  
325 --
326 -- It's important that these two rules aren't both active at once 
327 -- (along with build's unfolding) else we'd get an infinite loop 
328 -- in the rules.  Hence the activation control below.
329 --
330 -- The "mapFB" rule optimises compositions of map.
331 --
332 -- This same pattern is followed by many other functions: 
333 -- e.g. append, filter, iterate, repeat, etc.
334
335 {-# RULES
336 "map"       [~1] forall f xs.   map f xs                = build (\c n -> foldr (mapFB c f) n xs)
337 "mapList"   [1]  forall f.      foldr (mapFB (:) f) []  = map f
338 "mapFB"     forall c f g.       mapFB (mapFB c f) g     = mapFB c (f.g) 
339   #-}
340 \end{code}
341
342
343 ----------------------------------------------
344 --              append  
345 ----------------------------------------------
346 \begin{code}
347 (++) :: [a] -> [a] -> [a]
348 (++) []     ys = ys
349 (++) (x:xs) ys = x : xs ++ ys
350
351 {-# RULES
352 "++"    [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys
353   #-}
354
355 \end{code}
356
357
358 %*********************************************************
359 %*                                                      *
360 \subsection{Type @Bool@}
361 %*                                                      *
362 %*********************************************************
363
364 \begin{code}
365 data  Bool  =  False | True  deriving (Eq, Ord)
366         -- Read in PrelRead, Show in PrelShow
367
368 -- Boolean functions
369
370 (&&), (||)              :: Bool -> Bool -> Bool
371 True  && x              =  x
372 False && _              =  False
373 True  || _              =  True
374 False || x              =  x
375
376 not                     :: Bool -> Bool
377 not True                =  False
378 not False               =  True
379
380 otherwise               :: Bool
381 otherwise               =  True
382 \end{code}
383
384
385 %*********************************************************
386 %*                                                      *
387 \subsection{The @()@ type}
388 %*                                                      *
389 %*********************************************************
390
391 The Unit type is here because virtually any program needs it (whereas
392 some programs may get away without consulting PrelTup).  Furthermore,
393 the renamer currently *always* asks for () to be in scope, so that
394 ccalls can use () as their default type; so when compiling PrelBase we
395 need ().  (We could arrange suck in () only if -fglasgow-exts, but putting
396 it here seems more direct.)
397
398 \begin{code}
399 data () = ()
400
401 instance Eq () where
402     () == () = True
403     () /= () = False
404
405 instance Ord () where
406     () <= () = True
407     () <  () = False
408     () >= () = True
409     () >  () = False
410     max () () = ()
411     min () () = ()
412     compare () () = EQ
413 \end{code}
414
415
416 %*********************************************************
417 %*                                                      *
418 \subsection{Type @Ordering@}
419 %*                                                      *
420 %*********************************************************
421
422 \begin{code}
423 data Ordering = LT | EQ | GT deriving (Eq, Ord)
424         -- Read in PrelRead, Show in PrelShow
425 \end{code}
426
427
428 %*********************************************************
429 %*                                                      *
430 \subsection{Type @Char@ and @String@}
431 %*                                                      *
432 %*********************************************************
433
434 \begin{code}
435 type String = [Char]
436
437 data Char = C# Char#
438
439 -- We don't use deriving for Eq and Ord, because for Ord the derived
440 -- instance defines only compare, which takes two primops.  Then
441 -- '>' uses compare, and therefore takes two primops instead of one.
442
443 instance Eq Char where
444     (C# c1) == (C# c2) = c1 `eqChar#` c2
445     (C# c1) /= (C# c2) = c1 `neChar#` c2
446
447 instance Ord Char where
448     (C# c1) >  (C# c2) = c1 `gtChar#` c2
449     (C# c1) >= (C# c2) = c1 `geChar#` c2
450     (C# c1) <= (C# c2) = c1 `leChar#` c2
451     (C# c1) <  (C# c2) = c1 `ltChar#` c2
452
453 {-# RULES
454 "x# `eqChar#` x#" forall x#. x# `eqChar#` x# = True
455 "x# `neChar#` x#" forall x#. x# `neChar#` x# = False
456 "x# `gtChar#` x#" forall x#. x# `gtChar#` x# = False
457 "x# `geChar#` x#" forall x#. x# `geChar#` x# = True
458 "x# `leChar#` x#" forall x#. x# `leChar#` x# = True
459 "x# `ltChar#` x#" forall x#. x# `ltChar#` x# = False
460   #-}
461
462 chr :: Int -> Char
463 chr (I# i#) | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#)
464             | otherwise                                  = error "Prelude.chr: bad argument"
465
466 unsafeChr :: Int -> Char
467 unsafeChr (I# i#) = C# (chr# i#)
468
469 ord :: Char -> Int
470 ord (C# c#) = I# (ord# c#)
471 \end{code}
472
473 String equality is used when desugaring pattern-matches against strings.
474
475 \begin{code}
476 eqString :: String -> String -> Bool
477 eqString []       []       = True
478 eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2
479 eqString cs1      cs2      = False
480
481 {-# RULES "eqString" (==) = eqString #-}
482 \end{code}
483
484
485 %*********************************************************
486 %*                                                      *
487 \subsection{Type @Int@}
488 %*                                                      *
489 %*********************************************************
490
491 \begin{code}
492 data Int = I# Int#
493
494 zeroInt, oneInt, twoInt, maxInt, minInt :: Int
495 zeroInt = I# 0#
496 oneInt  = I# 1#
497 twoInt  = I# 2#
498
499 {- Seems clumsy. Should perhaps put minInt and MaxInt directly into MachDeps.h -}
500 #if WORD_SIZE_IN_BITS == 31
501 minInt  = I# (-0x40000000#)
502 maxInt  = I# 0x3FFFFFFF#
503 #elif WORD_SIZE_IN_BITS == 32
504 minInt  = I# (-0x80000000#)
505 maxInt  = I# 0x7FFFFFFF#
506 #else 
507 minInt  = I# (-0x8000000000000000#)
508 maxInt  = I# 0x7FFFFFFFFFFFFFFF#
509 #endif
510
511 instance Eq Int where
512     (==) = eqInt
513     (/=) = neInt
514
515 instance Ord Int where
516     compare = compareInt
517     (<)     = ltInt
518     (<=)    = leInt
519     (>=)    = geInt
520     (>)     = gtInt
521
522 compareInt :: Int -> Int -> Ordering
523 (I# x#) `compareInt` (I# y#) = compareInt# x# y#
524
525 compareInt# :: Int# -> Int# -> Ordering
526 compareInt# x# y#
527     | x# <#  y# = LT
528     | x# ==# y# = EQ
529     | otherwise = GT
530 \end{code}
531
532
533 %*********************************************************
534 %*                                                      *
535 \subsection{The function type}
536 %*                                                      *
537 %*********************************************************
538
539 \begin{code}
540 -- identity function
541 id                      :: a -> a
542 id x                    =  x
543
544 -- constant function
545 const                   :: a -> b -> a
546 const x _               =  x
547
548 -- function composition
549 {-# INLINE (.) #-}
550 (.)       :: (b -> c) -> (a -> b) -> a -> c
551 (.) f g x = f (g x)
552
553 -- flip f  takes its (first) two arguments in the reverse order of f.
554 flip                    :: (a -> b -> c) -> b -> a -> c
555 flip f x y              =  f y x
556
557 -- right-associating infix application operator (useful in continuation-
558 -- passing style)
559 {-# INLINE ($) #-}
560 ($)                     :: (a -> b) -> a -> b
561 f $ x                   =  f x
562
563 -- until p f  yields the result of applying f until p holds.
564 until                   :: (a -> Bool) -> (a -> a) -> a -> a
565 until p f x | p x       =  x
566             | otherwise =  until p f (f x)
567
568 -- asTypeOf is a type-restricted version of const.  It is usually used
569 -- as an infix operator, and its typing forces its first argument
570 -- (which is usually overloaded) to have the same type as the second.
571 asTypeOf                :: a -> a -> a
572 asTypeOf                =  const
573 \end{code}
574
575 %*********************************************************
576 %*                                                      *
577 \subsection{CCallable instances}
578 %*                                                      *
579 %*********************************************************
580
581 Defined here to avoid orphans
582
583 \begin{code}
584 instance CCallable Char
585 instance CReturnable Char
586
587 instance CCallable   Int
588 instance CReturnable Int
589
590 instance CReturnable () -- Why, exactly?
591 \end{code}
592
593
594 %*********************************************************
595 %*                                                      *
596 \subsection{Generics}
597 %*                                                      *
598 %*********************************************************
599
600 \begin{code}
601 data Unit = Unit
602 data (:+:) a b = Inl a | Inr b
603 data (:*:) a b = a :*: b
604 \end{code}
605
606
607 %*********************************************************
608 %*                                                      *
609 \subsection{Numeric primops}
610 %*                                                      *
611 %*********************************************************
612
613 \begin{code}
614 divInt#, modInt# :: Int# -> Int# -> Int#
615 x# `divInt#` y#
616     | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y#
617     | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y#
618     | otherwise                = x# `quotInt#` y#
619 x# `modInt#` y#
620     | (x# ># 0#) && (y# <# 0#) ||
621       (x# <# 0#) && (y# ># 0#)    = if r# /=# 0# then r# +# y# else 0#
622     | otherwise                   = r#
623     where
624     r# = x# `remInt#` y#
625 \end{code}
626
627 Definitions of the boxed PrimOps; these will be
628 used in the case of partial applications, etc.
629
630 \begin{code}
631 {-# INLINE eqInt #-}
632 {-# INLINE neInt #-}
633 {-# INLINE gtInt #-}
634 {-# INLINE geInt #-}
635 {-# INLINE ltInt #-}
636 {-# INLINE leInt #-}
637 {-# INLINE plusInt #-}
638 {-# INLINE minusInt #-}
639 {-# INLINE timesInt #-}
640 {-# INLINE quotInt #-}
641 {-# INLINE remInt #-}
642 {-# INLINE negateInt #-}
643
644 plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt, gcdInt :: Int -> Int -> Int
645 (I# x) `plusInt`  (I# y) = I# (x +# y)
646 (I# x) `minusInt` (I# y) = I# (x -# y)
647 (I# x) `timesInt` (I# y) = I# (x *# y)
648 (I# x) `quotInt`  (I# y) = I# (x `quotInt#` y)
649 (I# x) `remInt`   (I# y) = I# (x `remInt#`  y)
650 (I# x) `divInt`   (I# y) = I# (x `divInt#`  y)
651 (I# x) `modInt`   (I# y) = I# (x `modInt#`  y)
652
653 {-# RULES
654 "x# +# 0#" forall x#. x# +# 0# = x#
655 "0# +# x#" forall x#. 0# +# x# = x#
656 "x# -# 0#" forall x#. x# -# 0# = x#
657 "x# -# x#" forall x#. x# -# x# = 0#
658 "x# *# 0#" forall x#. x# *# 0# = 0#
659 "0# *# x#" forall x#. 0# *# x# = 0#
660 "x# *# 1#" forall x#. x# *# 1# = x#
661 "1# *# x#" forall x#. 1# *# x# = x#
662   #-}
663
664 gcdInt (I# a) (I# b) = g a b
665    where g 0# 0# = error "PrelBase.gcdInt: gcd 0 0 is undefined"
666          g 0# _  = I# absB
667          g _  0# = I# absA
668          g _  _  = I# (gcdInt# absA absB)
669
670          absInt x = if x <# 0# then negateInt# x else x
671
672          absA     = absInt a
673          absB     = absInt b
674
675 negateInt :: Int -> Int
676 negateInt (I# x) = I# (negateInt# x)
677
678 gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool
679 (I# x) `gtInt` (I# y) = x >#  y
680 (I# x) `geInt` (I# y) = x >=# y
681 (I# x) `eqInt` (I# y) = x ==# y
682 (I# x) `neInt` (I# y) = x /=# y
683 (I# x) `ltInt` (I# y) = x <#  y
684 (I# x) `leInt` (I# y) = x <=# y
685
686 {-# RULES
687 "x# ># x#"  forall x#. x# >#  x# = False
688 "x# >=# x#" forall x#. x# >=# x# = True
689 "x# ==# x#" forall x#. x# ==# x# = True
690 "x# /=# x#" forall x#. x# /=# x# = False
691 "x# <# x#"  forall x#. x# <#  x# = False
692 "x# <=# x#" forall x#. x# <=# x# = True
693   #-}
694
695 -- Wrappers for the shift operations.  The uncheckedShift# family are
696 -- undefined when the amount being shifted by is greater than the size
697 -- in bits of Int#, so these wrappers perform a check and return
698 -- either zero or -1 appropriately.
699 --
700 -- Note that these wrappers still produce undefined results when the
701 -- second argument (the shift amount) is negative.
702
703 shiftL#, shiftRL# :: Word# -> Int# -> Word#
704
705 a `shiftL#` b   | b >=# WORD_SIZE_IN_BITS# = int2Word# 0#
706                 | otherwise                = a `uncheckedShiftL#` b
707
708 a `shiftRL#` b  | b >=# WORD_SIZE_IN_BITS# = int2Word# 0#
709                 | otherwise                = a `uncheckedShiftRL#` b
710
711 iShiftL#, iShiftRA#, iShiftRL# :: Int# -> Int# -> Int#
712
713 a `iShiftL#` b  | b >=# WORD_SIZE_IN_BITS# = 0#
714                 | otherwise                = a `uncheckedIShiftL#` b
715
716 a `iShiftRA#` b | b >=# WORD_SIZE_IN_BITS# = if a <# 0# then (-1#) else 0#
717                 | otherwise                = a `uncheckedIShiftRA#` b
718
719 a `iShiftRL#` b | b >=# WORD_SIZE_IN_BITS# = 0#
720                 | otherwise                = a `uncheckedIShiftRL#` b
721
722 #if WORD_SIZE_IN_BITS == 32
723 {-# RULES
724 "narrow32Int#"  forall x#. narrow32Int#   x# = x#
725 "narrow32Word#" forall x#. narrow32Word#   x# = x#
726    #-}
727 #endif
728
729 {-# RULES
730 "int2Word2Int"  forall x#. int2Word# (word2Int# x#) = x#
731 "word2Int2Word" forall x#. word2Int# (int2Word# x#) = x#
732   #-}
733 \end{code}
734
735
736 %********************************************************
737 %*                                                      *
738 \subsection{Unpacking C strings}
739 %*                                                      *
740 %********************************************************
741
742 This code is needed for virtually all programs, since it's used for
743 unpacking the strings of error messages.
744
745 \begin{code}
746 unpackCString# :: Addr# -> [Char]
747 {-# NOINLINE [1] unpackCString# #-}
748 unpackCString# a = unpackCStringList# a
749
750 unpackCStringList# :: Addr# -> [Char]
751 unpackCStringList# addr 
752   = unpack 0#
753   where
754     unpack nh
755       | ch `eqChar#` '\0'# = []
756       | otherwise          = C# ch : unpack (nh +# 1#)
757       where
758         ch = indexCharOffAddr# addr nh
759
760 unpackAppendCString# :: Addr# -> [Char] -> [Char]
761 unpackAppendCString# addr rest
762   = unpack 0#
763   where
764     unpack nh
765       | ch `eqChar#` '\0'# = rest
766       | otherwise          = C# ch : unpack (nh +# 1#)
767       where
768         ch = indexCharOffAddr# addr nh
769
770 unpackFoldrCString# :: Addr# -> (Char  -> a -> a) -> a -> a 
771 {-# NOINLINE [0] unpackFoldrCString# #-}
772 -- Don't inline till right at the end;
773 -- usually the unpack-list rule turns it into unpackCStringList
774 unpackFoldrCString# addr f z 
775   = unpack 0#
776   where
777     unpack nh
778       | ch `eqChar#` '\0'# = z
779       | otherwise          = C# ch `f` unpack (nh +# 1#)
780       where
781         ch = indexCharOffAddr# addr nh
782
783 unpackCStringUtf8# :: Addr# -> [Char]
784 unpackCStringUtf8# addr 
785   = unpack 0#
786   where
787     unpack nh
788       | ch `eqChar#` '\0'#   = []
789       | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#)
790       | ch `leChar#` '\xDF'# =
791           C# (chr# ((ord# ch                                  -# 0xC0#) `uncheckedIShiftL#`  6# +#
792                     (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) :
793           unpack (nh +# 2#)
794       | ch `leChar#` '\xEF'# =
795           C# (chr# ((ord# ch                                  -# 0xE0#) `uncheckedIShiftL#` 12# +#
796                     (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#`  6# +#
797                     (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) :
798           unpack (nh +# 3#)
799       | otherwise            =
800           C# (chr# ((ord# ch                                  -# 0xF0#) `uncheckedIShiftL#` 18# +#
801                     (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12# +#
802                     (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#`  6# +#
803                     (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) :
804           unpack (nh +# 4#)
805       where
806         ch = indexCharOffAddr# addr nh
807
808 unpackNBytes# :: Addr# -> Int# -> [Char]
809 unpackNBytes# _addr 0#   = []
810 unpackNBytes#  addr len# = unpack [] (len# -# 1#)
811     where
812      unpack acc i#
813       | i# <# 0#  = acc
814       | otherwise = 
815          case indexCharOffAddr# addr i# of
816             ch -> unpack (C# ch : acc) (i# -# 1#)
817
818 {-# RULES
819 "unpack"       [~1] forall a   . unpackCString# a                  = build (unpackFoldrCString# a)
820 "unpack-list"  [1]  forall a   . unpackFoldrCString# a (:) [] = unpackCStringList# a
821 "unpack-append"     forall a n . unpackFoldrCString# a (:) n  = unpackAppendCString# a n
822
823 -- There's a built-in rule (in PrelRules.lhs) for
824 --      unpackFoldr "foo" c (unpackFoldr "baz" c n)  =  unpackFoldr "foobaz" c n
825
826   #-}
827 \end{code}