% -----------------------------------------------------------------------------
-% $Id: PrelBase.lhs,v 1.34 2000/08/02 14:13:27 rrt Exp $
+% $Id: PrelBase.lhs,v 1.39 2000/10/03 08:43:05 simonpj Exp $
%
% (c) The University of Glasgow, 1992-2000
%
(
module PrelBase,
module PrelGHC, -- Re-export PrelGHC, PrelErr & PrelNum, to avoid lots
- module PrelErr, -- of people having to import it explicitly
- module PrelNum
+ module PrelErr -- of people having to import it explicitly
)
where
import PrelGHC
import {-# SOURCE #-} PrelErr
-import {-# SOURCE #-} PrelNum
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}
class Eq a where
(==), (/=) :: 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
\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}
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]
(C# c1) < (C# c2) = c1 `ltChar#` c2
chr :: Int -> Char
-chr (I# i) | i >=# 0# && i <=# 255# = C# (chr# i)
+chr (I# i) | i >=# 0#
+#if INT_SIZE_IN_BYTES > 4
+ && i <=# 0x7FFFFFFF#
+#endif
+ = C# (chr# i)
| otherwise = error ("Prelude.chr: bad argument")
unsafeChr :: Int -> Char
ord (C# c) = I# (ord# c)
\end{code}
+String equality is used when desugaring pattern-matches against strings.
+It's worth making it fast, and providing a rule to use the fast version
+where possible.
+
+\begin{code}
+eqString :: String -> String -> Bool
+eqString [] [] = True
+eqString (C# c1 : cs1) (C# c2 : cs2) = c1 `eqChar#` c2 && cs1 `eqString` cs2
+eqString _ _ = False
+
+{-# RULES
+"eqString" (==) = eqString
+ #-}
+\end{code}
%*********************************************************
%* *
%*********************************************************
%* *
+\subsection{Generics}
+%* *
+%*********************************************************
+
+\begin{code}
+data Unit = Unit
+data a :+: b = Inl a | Inr b
+data a :*: b = a :*: b
+\end{code}
+
+
+%*********************************************************
+%* *
\subsection{Numeric primops}
%* *
%*********************************************************
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 `iShiftL#` 6#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#))) -# 0x3080#))
+ : unpack (nh +# 2#)
+ | ch `leChar#` '\xEF'# = C# (chr# ((ord# ch `iShiftL#` 12#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) `iShiftL#` 6#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 2#))) -# 0xE2080#))
+ : unpack (nh +# 3#)
+ | ch `leChar#` '\xF7'# = C# (chr# ((ord# ch `iShiftL#` 18#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) `iShiftL#` 12#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 2#)) `iShiftL#` 6#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 3#))) -# 0x3C82080#))
+ : unpack (nh +# 4#)
+ | ch `leChar#` '\xFB'# = C# (chr# ((ord# ch -# 0xF8# `iShiftL#` 24#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) `iShiftL#` 18#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 2#)) `iShiftL#` 12#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 3#)) `iShiftL#` 6#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 4#))) -# 0x2082080#))
+ : unpack (nh +# 5#)
+ | otherwise = C# (chr# (((ord# ch -# 0xFC#) `iShiftL#` 30#) +#
+ ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#)
+ `iShiftL#` 24#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 2#)) `iShiftL#` 18#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 3#)) `iShiftL#` 12#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 4#)) `iShiftL#` 6#) +#
+ (ord# (indexCharOffAddr# addr (nh +# 5#))) -# 0x2082080#))
+ : unpack (nh +# 6#)
+ 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}