% -----------------------------------------------------------------------------
-% $Id: PrelBase.lhs,v 1.32 2000/06/30 13:39:35 simonmar Exp $
+% $Id: PrelBase.lhs,v 1.45 2001/04/14 22:28:22 qrczak Exp $
%
% (c) The University of Glasgow, 1992-2000
%
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
+#include "MachDeps.h"
+
module PrelBase
(
module PrelBase,
- module PrelGHC -- Re-export PrelGHC, to avoid lots of people
- -- having to import it explicitly
+ module PrelGHC, -- Re-export PrelGHC and PrelErr, to avoid lots
+ module PrelErr -- of people having to import it explicitly
)
where
-import {-# SOURCE #-} PrelErr ( error )
-import {-# SOURCE #-} PrelNum ( addr2Integer )
- -- Otherwise the system import of addr2Integer looks for PrelNum.hi
-
import PrelGHC
+import {-# SOURCE #-} PrelErr
infixr 9 .
infixr 5 ++, :
%*********************************************************
\begin{code}
-{-
+{-
data Bool = False | True
data Ordering = LT | EQ | GT
data Char = C# Char#
type String = [Char]
data Int = I# Int#
data () = ()
--- data [] a = MkNil
+data [] a = MkNil
not True = False
(&&) True True = True
build = error "urk"
foldr = error "urk"
-unpackCString# :: Addr# -> [Char]
-unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
+unpackCString# :: Addr# -> [Char]
+unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
unpackAppendCString# :: Addr# -> [Char] -> [Char]
-unpackNBytes# :: Addr# -> Int# -> [Char]
-unpackNBytes# a b = error "urk"
+unpackCStringUtf8# :: Addr# -> [Char]
unpackCString# a = error "urk"
unpackFoldrCString# a = error "urk"
unpackAppendCString# a = error "urk"
+unpackCStringUtf8# a = error "urk"
-}
\end{code}
\begin{code}
class Eq a where
- (==), (/=) :: a -> a -> Bool
+ (==), (/=) :: a -> a -> Bool
--- x /= y = not (x == y)
--- x == y = not (x /= y)
--- x /= y = True
- (/=) x y = not ((==) x y)
- x == y = True
+ x /= y = not (x == y)
+ x == y = not (x /= y)
class (Eq a) => Ord a where
- compare :: a -> a -> Ordering
- (<), (<=), (>=), (>):: a -> a -> Bool
- max, min :: a -> a -> a
+ compare :: a -> a -> Ordering
+ (<), (<=), (>), (>=) :: a -> a -> Bool
+ max, min :: a -> a -> a
+
+ -- An instance of Ord should define either 'compare' or '<='.
+ -- Using 'compare' can be more efficient for complex types.
--- An instance of Ord should define either compare or <=
--- Using compare can be more efficient for complex types.
compare x y
- | x == y = EQ
- | x <= y = LT -- NB: must be '<=' not '<' to validate the
- -- above claim about the minimal things that can
- -- be defined for an instance of Ord
- | otherwise = GT
-
- x <= y = case compare x y of { GT -> False; _other -> True }
- x < y = case compare x y of { LT -> True; _other -> False }
- x >= y = case compare x y of { LT -> False; _other -> True }
- x > y = case compare x y of { GT -> True; _other -> False }
-
- -- These two default methods use '>' rather than compare
+ | x == y = EQ
+ | x <= y = LT -- NB: must be '<=' not '<' to validate the
+ -- above claim about the minimal things that
+ -- can be defined for an instance of Ord
+ | otherwise = GT
+
+ x < y = case compare x y of { LT -> True; _other -> False }
+ x <= y = case compare x y of { GT -> False; _other -> True }
+ x > y = case compare x y of { GT -> True; _other -> False }
+ x >= y = case compare x y of { LT -> False; _other -> True }
+
+ -- These two default methods use '<=' rather than 'compare'
-- because the latter is often more expensive
- max x y = if x > y then x else y
- min x y = if x > y then y else x
+ max x y = if x <= y then y else x
+ min x y = if x <= y then x else y
\end{code}
%*********************************************************
\begin{code}
class Functor f where
- fmap :: (a -> b) -> f a -> f b
+ fmap :: (a -> b) -> f a -> f b
class Monad m where
(>>=) :: m a -> (a -> m b) -> m b
m >> k = m >>= \_ -> k
fail s = error s
-
\end{code}
instance (Eq a) => Eq [a] where
-{-
{-# SPECIALISE instance Eq [Char] #-}
--}
- [] == [] = True
+ [] == [] = True
(x:xs) == (y:ys) = x == y && xs == ys
- _xs == _ys = False
-
- xs /= ys = if (xs == ys) then False else True
+ _xs == _ys = False
instance (Ord a) => Ord [a] where
-{-
{-# SPECIALISE instance Ord [Char] #-}
--}
- a < b = case compare a b of { LT -> True; EQ -> False; GT -> False }
- a <= b = case compare a b of { LT -> True; EQ -> True; GT -> False }
- a >= b = case compare a b of { LT -> False; EQ -> True; GT -> True }
- a > b = case compare a b of { LT -> False; EQ -> False; GT -> True }
compare [] [] = EQ
- compare (_:_) [] = GT
compare [] (_:_) = LT
+ compare (_:_) [] = GT
compare (x:xs) (y:ys) = case compare x y of
- LT -> LT
- GT -> GT
- EQ -> compare xs ys
+ EQ -> compare xs ys
+ other -> other
instance Functor [] where
fmap = map
foldr k z xs = go xs
where
go [] = z
- go (x:xs) = x `k` go xs
+ go (y:ys) = y `k` go ys
build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
{-# INLINE 2 build #-}
map = mapList
-- Note eta expanded
+mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst
mapFB c f x ys = c (f x) ys
mapList :: (a -> b) -> [a] -> [b]
%*********************************************************
\begin{code}
-type String = [Char]
+type String = [Char]
data Char = C# Char#
(C# c1) < (C# c2) = c1 `ltChar#` c2
chr :: Int -> Char
-chr (I# i) | i >=# 0# && i <=# 255# = C# (chr# i)
- | otherwise = error ("Prelude.chr: bad argument")
+chr (I# i) | i >=# 0# && i <=# 0x10FFFF# = C# (chr# i)
+ | otherwise = error "Prelude.chr: bad argument"
unsafeChr :: Int -> Char
unsafeChr (I# i) = C# (chr# i)
ord (C# c) = I# (ord# c)
\end{code}
+String equality is used when desugaring pattern-matches against strings.
+
+\begin{code}
+eqString :: String -> String -> Bool
+eqString = (==)
+\end{code}
%*********************************************************
%* *
zeroInt = I# 0#
oneInt = I# 1#
twoInt = I# 2#
-minInt = I# (-2147483648#) -- GHC <= 2.09 had this at -2147483647
-maxInt = I# 2147483647#
+#if WORD_SIZE_IN_BYTES == 4
+minInt = I# (-0x80000000#)
+maxInt = I# 0x7FFFFFFF#
+#else
+minInt = I# (-0x8000000000000000#)
+maxInt = I# 0x7FFFFFFFFFFFFFFF#
+#endif
instance Eq Int where
- (==) x y = x `eqInt` y
- (/=) x y = x `neInt` y
+ (==) = eqInt
+ (/=) = neInt
instance Ord Int where
- compare x y = compareInt x y
+ compare = compareInt
- (<) x y = ltInt x y
- (<=) x y = leInt x y
- (>=) x y = geInt x y
- (>) x y = gtInt x y
+ (<) = ltInt
+ (<=) = leInt
+ (>=) = geInt
+ (>) = gtInt
compareInt :: Int -> Int -> Ordering
-(I# x) `compareInt` (I# y) | x <# y = LT
- | x ==# y = EQ
- | otherwise = GT
+(I# x) `compareInt` (I# y) = compareInt# x y
+
+compareInt# :: Int# -> Int# -> Ordering
+compareInt# x# y#
+ | x# <# y# = LT
+ | x# ==# y# = EQ
+ | otherwise = GT
\end{code}
-- right-associating infix application operator (useful in continuation-
-- passing style)
+{-# INLINE ($) #-}
($) :: (a -> b) -> a -> b
f $ x = f x
%*********************************************************
%* *
+\subsection{Generics}
+%* *
+%*********************************************************
+
+\begin{code}
+data Unit = Unit
+data a :+: b = Inl a | Inr b
+data a :*: b = a :*: b
+\end{code}
+
+
+%*********************************************************
+%* *
\subsection{Numeric primops}
%* *
%*********************************************************
+\begin{code}
+divInt#, modInt# :: Int# -> Int# -> Int#
+x# `divInt#` y#
+ | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y#
+ | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y#
+ | otherwise = x# `quotInt#` y#
+x# `modInt#` y#
+ | (x# ># 0#) && (y# <# 0#) ||
+ (x# <# 0#) && (y# ># 0#) = if r# /=# 0# then r# +# y# else 0#
+ | otherwise = r#
+ where
+ r# = x# `remInt#` y#
+\end{code}
+
Definitions of the boxed PrimOps; these will be
used in the case of partial applications, etc.
{-# INLINE remInt #-}
{-# INLINE negateInt #-}
-plusInt, minusInt, timesInt, quotInt, remInt, gcdInt :: Int -> Int -> Int
-plusInt (I# x) (I# y) = I# (x +# y)
-minusInt(I# x) (I# y) = I# (x -# y)
-timesInt(I# x) (I# y) = I# (x *# y)
-quotInt (I# x) (I# y) = I# (quotInt# x y)
-remInt (I# x) (I# y) = I# (remInt# x y)
+plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt, gcdInt :: Int -> Int -> Int
+(I# x) `plusInt` (I# y) = I# (x +# y)
+(I# x) `minusInt` (I# y) = I# (x -# y)
+(I# x) `timesInt` (I# y) = I# (x *# y)
+(I# x) `quotInt` (I# y) = I# (x `quotInt#` y)
+(I# x) `remInt` (I# y) = I# (x `remInt#` y)
+(I# x) `divInt` (I# y) = I# (x `divInt#` y)
+(I# x) `modInt` (I# y) = I# (x `modInt#` y)
gcdInt (I# a) (I# b) = g a b
where g 0# 0# = error "PrelBase.gcdInt: gcd 0 0 is undefined"
negateInt :: Int -> Int
negateInt (I# x) = I# (negateInt# x)
-divInt, modInt :: Int -> Int -> Int
-x `divInt` y
- | x > zeroInt && y < zeroInt = quotInt ((x `minusInt` y) `minusInt` oneInt) y
- | x < zeroInt && y > zeroInt = quotInt ((x `minusInt` y) `plusInt` oneInt) y
- | otherwise = quotInt x y
-
-x `modInt` y
- | x > zeroInt && y < zeroInt ||
- x < zeroInt && y > zeroInt = if r/=zeroInt then r `plusInt` y else zeroInt
- | otherwise = r
- where
- r = remInt x y
-
gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool
-gtInt (I# x) (I# y) = x ># y
-geInt (I# x) (I# y) = x >=# y
-eqInt (I# x) (I# y) = x ==# y
-neInt (I# x) (I# y) = x /=# y
-ltInt (I# x) (I# y) = x <# y
-leInt (I# x) (I# y) = x <=# y
+(I# x) `gtInt` (I# y) = x ># y
+(I# x) `geInt` (I# y) = x >=# y
+(I# x) `eqInt` (I# y) = x ==# y
+(I# x) `neInt` (I# y) = x /=# y
+(I# x) `ltInt` (I# y) = x <# y
+(I# x) `leInt` (I# y) = x <=# y
+
+#if WORD_SIZE_IN_BYTES == 4
+{-# RULES
+"intToInt32#" forall x#. intToInt32# x# = x#
+"wordToWord32#" forall x#. wordToWord32# x# = x#
+ #-}
+#endif
+
+{-# RULES
+"int2Word2Int" forall x#. int2Word# (word2Int# x#) = x#
+"word2Int2Word" forall x#. word2Int# (int2Word# x#) = x#
+ #-}
\end{code}
unpacking the strings of error messages.
\begin{code}
-unpackCString# :: Addr# -> [Char]
+unpackCString# :: Addr# -> [Char]
unpackCString# a = unpackCStringList# a
-unpackCStringList# :: Addr# -> [Char]
+unpackCStringList# :: Addr# -> [Char]
unpackCStringList# addr
= unpack 0#
where
where
ch = indexCharOffAddr# addr nh
-unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
+unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
unpackFoldrCString# addr f z
= unpack 0#
where
where
ch = indexCharOffAddr# addr nh
-unpackNBytes# :: Addr# -> Int# -> [Char]
- -- This one is called by the compiler to unpack literal
- -- strings with NULs in them; rare. It's strict!
- -- We don't try to do list deforestation for this one
+unpackCStringUtf8# :: Addr# -> [Char]
+unpackCStringUtf8# addr
+ = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = []
+ | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#)
+ | ch `leChar#` '\xDF'# =
+ C# (chr# ((ord# ch -# 0xC0#) `iShiftL#` 6# +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) :
+ unpack (nh +# 2#)
+ | ch `leChar#` '\xEF'# =
+ C# (chr# ((ord# ch -# 0xE0#) `iShiftL#` 12# +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `iShiftL#` 6# +#
+ (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) :
+ unpack (nh +# 3#)
+ | otherwise =
+ C# (chr# ((ord# ch -# 0xF0#) `iShiftL#` 18# +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `iShiftL#` 12# +#
+ (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `iShiftL#` 6# +#
+ (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) :
+ unpack (nh +# 4#)
+ where
+ ch = indexCharOffAddr# addr nh
+unpackNBytes# :: Addr# -> Int# -> [Char]
unpackNBytes# _addr 0# = []
unpackNBytes# addr len# = unpack [] (len# -# 1#)
where
-- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n
#-}
-
\end{code}
projects / ghc-hetmet.git / blobdiff