+% -----------------------------------------------------------------------------
+% $Id: PrelBase.lhs,v 1.61 2002/02/12 03:52:09 chak Exp $
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The University of Glasgow, 1992-2000
%
\section[PrelBase]{Module @PrelBase@}
-\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
-
-module PrelBase(
- module PrelBase,
- module PrelGHC -- Re-export PrelGHC, to avoid lots of people
- -- having to import it explicitly
- ) where
-
-import {-# SOURCE #-} PrelErr ( error )
-import PrelGHC
-
-infixr 9 .
-infixl 9 !!
-infixl 7 *
-infixl 6 +, -
-infixr 5 ++, :
-infix 4 ==, /=, <, <=, >=, >
-infixr 3 &&
-infixr 2 ||
-infixl 1 >>, >>=
-infixr 0 $
-\end{code}
-
-
-\begin{code}
-{-
-class Eval a
-data Bool = False | True
-data Int = I# Int#
-data Double = D# Double#
-data () = () --easier to do explicitly: deriving (Eq, Ord, Enum, Show, Bounded)
- -- (avoids weird-named functions, e.g., con2tag_()#
-
-data Maybe a = Nothing | Just a
-data Ordering = LT | EQ | GT deriving( Eq )
-
-type String = [Char]
+The overall structure of the GHC Prelude is a bit tricky.
-data Char = C# Char#
-data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord)
- -- to avoid weird names like con2tag_[]#
+ a) We want to avoid "orphan modules", i.e. ones with instance
+ decls that don't belong either to a tycon or a class
+ defined in the same module
+ b) We want to avoid giant modules
--------------- Stage 2 -----------------------
-not True = False
-not False = True
-True && x = x
-False && x = False
-otherwise = True
+So the rough structure is as follows, in (linearised) dependency order
-maybe :: b -> (a -> b) -> Maybe a -> b
-maybe n f Nothing = n
-maybe n f (Just x) = f x
--------------- Stage 3 -----------------------
-class Eq a where
- (==), (/=) :: a -> a -> Bool
+PrelGHC Has no implementation. It defines built-in things, and
+ by importing it you bring them into scope.
+ The source file is PrelGHC.hi-boot, which is just
+ copied to make PrelGHC.hi
- x /= y = not (x == y)
+ Classes: CCallable, CReturnable
--- f :: Eq a => a -> a -> Bool
-f x y = x == y
+PrelBase Classes: Eq, Ord, Functor, Monad
+ Types: list, (), Int, Bool, Ordering, Char, String
-g :: Eq a => a -> a -> Bool
-g x y = f x y
+PrelTup Types: tuples, plus instances for PrelBase classes
--------------- Stage 4 -----------------------
+PrelShow Class: Show, plus instances for PrelBase/PrelTup types
-class (Eq a) => Ord a where
- compare :: a -> a -> Ordering
- (<), (<=), (>=), (>):: a -> a -> Bool
- max, min :: a -> a -> a
+PrelEnum Class: Enum, plus instances for PrelBase/PrelTup 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
- | otherwise = GT
+PrelMaybe Type: Maybe, plus instances for PrelBase classes
- x <= y = compare x y /= GT
- x < y = compare x y == LT
- x >= y = compare x y /= LT
- x > y = compare x y == GT
- max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x }
- min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y }
+PrelNum Class: Num, plus instances for Int
+ Type: Integer, plus instances for all classes so far (Eq, Ord, Num, Show)
-eqInt (I# x) (I# y) = x ==# y
+ Integer is needed here because it is mentioned in the signature
+ of 'fromInteger' in class Num
-instance Eq Int where
- (==) x y = x `eqInt` y
+PrelReal Classes: Real, Integral, Fractional, RealFrac
+ plus instances for Int, Integer
+ Types: Ratio, Rational
+ plus intances for classes so far
-instance Ord Int where
- compare x y = error "help"
-
-class Bounded a where
- minBound, maxBound :: a
+ Rational is needed here because it is mentioned in the signature
+ of 'toRational' in class Real
+Ix Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples
-type ShowS = String -> String
+PrelArr Types: Array, MutableArray, MutableVar
-class Show a where
- showsPrec :: Bool -> a -> ShowS
- showList :: [a] -> ShowS
+ Does *not* contain any ByteArray stuff (see PrelByteArr)
+ Arrays are used by a function in PrelFloat
- showList ls = showList__ (showsPrec True) ls
+PrelFloat Classes: Floating, RealFloat
+ Types: Float, Double, plus instances of all classes so far
-showList__ :: (a -> ShowS) -> [a] -> ShowS
-showList__ showx [] = showString "[]"
+ This module contains everything to do with floating point.
+ It is a big module (900 lines)
+ With a bit of luck, many modules can be compiled without ever reading PrelFloat.hi
-showString :: String -> ShowS
-showString = (++)
+PrelByteArr Types: ByteArray, MutableByteArray
+
+ We want this one to be after PrelFloat, because it defines arrays
+ of unboxed floats.
-[] ++ [] = []
-shows :: (Show a) => a -> ShowS
-shows = showsPrec True
-
--- show :: (Show a) => a -> String
---show x = shows x ""
--}
-\end{code}
+Other Prelude modules are much easier with fewer complex dependencies.
-%*********************************************************
-%* *
-\subsection{Standard classes @Eq@, @Ord@, @Bounded@, @Eval@}
-%* *
-%*********************************************************
-
\begin{code}
-class Eq a where
- (==), (/=) :: a -> a -> Bool
-
- x /= y = not (x == y)
+{-# OPTIONS -fno-implicit-prelude #-}
-class (Eq a) => Ord a where
- compare :: a -> a -> Ordering
- (<), (<=), (>=), (>):: a -> a -> Bool
- max, min :: a -> a -> a
+#include "MachDeps.h"
--- 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
- | otherwise = GT
+module PrelBase
+ (
+ module PrelBase,
+ module PrelGHC, -- Re-export PrelGHC and PrelErr, to avoid lots
+ module PrelErr -- of people having to import it explicitly
+ )
+ where
- x <= y = compare x y /= GT
- x < y = compare x y == LT
- x >= y = compare x y /= LT
- x > y = compare x y == GT
- max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x }
- min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y }
+import PrelGHC
+import {-# SOURCE #-} PrelErr
-class Bounded a where
- minBound, maxBound :: a
+infixr 9 .
+infixr 5 ++, :
+infix 4 ==, /=, <, <=, >=, >
+infixr 3 &&
+infixr 2 ||
+infixl 1 >>, >>=
+infixr 0 $
-class Eval a
+default () -- Double isn't available yet
\end{code}
+
%*********************************************************
%* *
-\subsection{Monadic classes @Functor@, @Monad@, @MonadZero@, @MonadPlus@}
+\subsection{DEBUGGING STUFF}
+%* (for use when compiling PrelBase itself doesn't work)
%* *
%*********************************************************
\begin{code}
-class Functor f where
- map :: (a -> b) -> f a -> f b
-
-class Monad m where
- (>>=) :: m a -> (a -> m b) -> m b
- (>>) :: m a -> m b -> m b
- return :: a -> m a
-
- m >> k = m >>= \_ -> k
+{-
+data Bool = False | True
+data Ordering = LT | EQ | GT
+data Char = C# Char#
+type String = [Char]
+data Int = I# Int#
+data () = ()
+data [] a = MkNil
-class (Monad m) => MonadZero m where
- zero :: m a
+not True = False
+(&&) True True = True
+otherwise = True
-class (MonadZero m) => MonadPlus m where
- (++) :: m a -> m a -> m a
+build = error "urk"
+foldr = error "urk"
+
+unpackCString# :: Addr# -> [Char]
+unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
+unpackAppendCString# :: Addr# -> [Char] -> [Char]
+unpackCStringUtf8# :: Addr# -> [Char]
+unpackCString# a = error "urk"
+unpackFoldrCString# a = error "urk"
+unpackAppendCString# a = error "urk"
+unpackCStringUtf8# a = error "urk"
+-}
\end{code}
%*********************************************************
%* *
-\subsection{Classes @Num@ and @Enum@}
+\subsection{Standard classes @Eq@, @Ord@}
%* *
%*********************************************************
\begin{code}
-class Enum a where
- toEnum :: Int -> a
- fromEnum :: a -> Int
- enumFrom :: a -> [a] -- [n..]
- enumFromThen :: a -> a -> [a] -- [n,n'..]
- enumFromTo :: a -> a -> [a] -- [n..m]
- enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
-
- enumFromTo n m = map toEnum [fromEnum n .. fromEnum m]
- enumFromThenTo n n' m
- = map toEnum [fromEnum n, fromEnum n' .. fromEnum m]
-
-class (Eq a, Show a, Eval a) => Num a where
- (+), (-), (*) :: a -> a -> a
- negate :: a -> a
- abs, signum :: a -> a
- fromInteger :: Integer -> a
- fromInt :: Int -> a -- partain: Glasgow extension
-
- x - y = x + negate y
- fromInt (I# i#) = fromInteger (int2Integer# i#)
- -- Go via the standard class-op if the
- -- non-standard one ain't provided
-\end{code}
+class Eq a where
+ (==), (/=) :: a -> a -> Bool
-\begin{code}
-succ, pred :: Enum a => a -> a
-succ = toEnum . (+1) . fromEnum
-pred = toEnum . (subtract 1) . fromEnum
+ x /= y = not (x == y)
+ x == y = not (x /= y)
-chr = (toEnum :: Int -> Char)
-ord = (fromEnum :: Char -> Int)
+class (Eq a) => Ord a where
+ compare :: a -> a -> Ordering
+ (<), (<=), (>), (>=) :: a -> a -> Bool
+ max, min :: a -> a -> a
-ord_0 :: Num a => a
-ord_0 = fromInt (ord '0')
+ -- An instance of Ord should define either 'compare' or '<='.
+ -- Using 'compare' can be more efficient for complex types.
-{-# GENERATE_SPECS subtract a{Int#,Double#,Int,Double,Complex(Double#),Complex(Double)} #-}
-subtract :: (Num a) => a -> a -> a
-subtract x y = y - x
+ 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 { 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 y else x
+ min x y = if x <= y then x else y
\end{code}
-
%*********************************************************
%* *
-\subsection{The @Show@ class}
+\subsection{Monadic classes @Functor@, @Monad@ }
%* *
%*********************************************************
\begin{code}
-type ShowS = String -> String
+class Functor f where
+ fmap :: (a -> b) -> f a -> f b
-class Show a where
- showsPrec :: Int -> a -> ShowS
- showList :: [a] -> ShowS
+class Monad m where
+ (>>=) :: m a -> (a -> m b) -> m b
+ (>>) :: m a -> m b -> m b
+ return :: a -> m a
+ fail :: String -> m a
- showList ls = showList__ (showsPrec 0) ls
+ m >> k = m >>= \_ -> k
+ fail s = error s
\end{code}
+
%*********************************************************
%* *
\subsection{The list type}
data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord)
-- to avoid weird names like con2tag_[]#
-instance (Eq a) => Eq [a] where
- [] == [] = True
+
+instance (Eq a) => Eq [a] where
+ {-# SPECIALISE instance Eq [Char] #-}
+ [] == [] = 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
- 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 }
-
- max a b = case compare a b of { LT -> b; EQ -> a; GT -> a }
- min a b = case compare a b of { LT -> a; EQ -> a; GT -> b }
-
+ {-# SPECIALISE instance Ord [Char] #-}
compare [] [] = EQ
- compare (x:xs) [] = GT
- compare [] (y:ys) = LT
+ 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
- map f [] = []
- map f (x:xs) = f x : map f xs
+ fmap = map
instance Monad [] where
m >>= k = foldr ((++) . k) [] m
m >> k = foldr ((++) . (\ _ -> k)) [] m
return x = [x]
-
-instance MonadZero [] where
- zero = []
-
-instance MonadPlus [] where
-#ifdef USE_REPORT_PRELUDE
- xs ++ ys = foldr (:) ys xs
-#else
- [] ++ ys = ys
- (x:xs) ++ ys = x : (xs ++ ys)
-#endif
-
-instance (Show a) => Show [a] where
- showsPrec p = showList
- showList ls = showList__ (showsPrec 0) ls
-\end{code}
-
+ fail _ = []
\end{code}
A few list functions that appear here because they are used here.
The rest of the prelude list functions are in PrelList.
+----------------------------------------------
+-- foldr/build/augment
+----------------------------------------------
+
\begin{code}
-foldr :: (a -> b -> b) -> b -> [a] -> b
-foldr f z [] = z
-foldr f z (x:xs) = f x (foldr f z xs)
-
--- takeWhile, applied to a predicate p and a list xs, returns the longest
--- prefix (possibly empty) of xs of elements that satisfy p. dropWhile p xs
--- returns the remaining suffix. Span p xs is equivalent to
--- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.
-
-takeWhile :: (a -> Bool) -> [a] -> [a]
-takeWhile p [] = []
-takeWhile p (x:xs)
- | p x = x : takeWhile p xs
- | otherwise = []
-
-dropWhile :: (a -> Bool) -> [a] -> [a]
-dropWhile p [] = []
-dropWhile p xs@(x:xs')
- | p x = dropWhile p xs'
- | otherwise = xs
-
--- List index (subscript) operator, 0-origin
-(!!) :: [a] -> Int -> a
-#ifdef USE_REPORT_PRELUDE
-(x:_) !! 0 = x
-(_:xs) !! n | n > 0 = xs !! (n-1)
-(_:_) !! _ = error "PreludeList.!!: negative index"
-[] !! _ = error "PreludeList.!!: index too large"
-#else
--- HBC version (stolen), then unboxified
--- The semantics is not quite the same for error conditions
--- in the more efficient version.
---
-_ !! n | n < 0 = error "(!!){PreludeList}: negative index\n"
-xs !! n = sub xs (case n of { I# n# -> n# })
- where sub :: [a] -> Int# -> a
- sub [] _ = error "(!!){PreludeList}: index too large\n"
- sub (x:xs) n# = if n# ==# 0#
- then x
- else sub xs (n# -# 1#)
-#endif
+foldr :: (a -> b -> b) -> b -> [a] -> b
+-- foldr _ z [] = z
+-- foldr f z (x:xs) = f x (foldr f z xs)
+{-# INLINE [0] foldr #-}
+-- Inline only in the final stage, after the foldr/cons rule has had a chance
+foldr k z xs = go xs
+ where
+ go [] = z
+ go (y:ys) = y `k` go ys
+
+build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
+{-# INLINE [1] build #-}
+ -- The INLINE is important, even though build is tiny,
+ -- because it prevents [] getting inlined in the version that
+ -- appears in the interface file. If [] *is* inlined, it
+ -- won't match with [] appearing in rules in an importing module.
+ --
+ -- The "1" says to inline in phase 1
+
+build g = g (:) []
+
+augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]
+{-# INLINE [1] augment #-}
+augment g xs = g (:) xs
+
+{-# RULES
+"fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) .
+ foldr k z (build g) = g k z
+
+"foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) .
+ foldr k z (augment g xs) = g k (foldr k z xs)
+
+"foldr/id" foldr (:) [] = \x->x
+"foldr/app" [1] forall xs ys. foldr (:) ys xs = xs ++ ys
+ -- Only activate this from phase 1, because that's
+ -- when we disable the rule that expands (++) into foldr
+
+-- The foldr/cons rule looks nice, but it can give disastrously
+-- bloated code when commpiling
+-- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ]
+-- i.e. when there are very very long literal lists
+-- So I've disabled it for now. We could have special cases
+-- for short lists, I suppose.
+-- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)
+
+"foldr/single" forall k z x. foldr k z [x] = k x z
+"foldr/nil" forall k z. foldr k z [] = z
+
+"augment/build" forall (g::forall b. (a->b->b) -> b -> b)
+ (h::forall b. (a->b->b) -> b -> b) .
+ augment g (build h) = build (\c n -> g c (h c n))
+"augment/nil" forall (g::forall b. (a->b->b) -> b -> b) .
+ augment g [] = build g
+ #-}
+
+-- This rule is true, but not (I think) useful:
+-- augment g (augment h t) = augment (\cn -> g c (h c n)) t
\end{code}
-%*********************************************************
-%* *
-\subsection{Type @Void@}
-%* *
-%*********************************************************
+----------------------------------------------
+-- map
+----------------------------------------------
+
+\begin{code}
+map :: (a -> b) -> [a] -> [b]
+map _ [] = []
+map f (x:xs) = f x : map f xs
+
+-- Note eta expanded
+mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst
+{-# INLINE [0] mapFB #-}
+mapFB c f x ys = c (f x) ys
+
+-- The rules for map work like this.
+--
+-- Up to (but not including) phase 1, we use the "map" rule to
+-- rewrite all saturated applications of map with its build/fold
+-- form, hoping for fusion to happen.
+-- In phase 1 and 0, we switch off that rule, inline build, and
+-- switch on the "mapList" rule, which rewrites the foldr/mapFB
+-- thing back into plain map.
+--
+-- It's important that these two rules aren't both active at once
+-- (along with build's unfolding) else we'd get an infinite loop
+-- in the rules. Hence the activation control below.
+--
+-- The "mapFB" rule optimises compositions of map.
+--
+-- This same pattern is followed by many other functions:
+-- e.g. append, filter, iterate, repeat, etc.
+
+{-# RULES
+"map" [~1] forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs)
+"mapList" [1] forall f. foldr (mapFB (:) f) [] = map f
+"mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g)
+ #-}
+\end{code}
-The type @Void@ is built in, but it needs a @Show@ instance.
+----------------------------------------------
+-- append
+----------------------------------------------
\begin{code}
-void :: Void
-void = error "You tried to evaluate void"
+(++) :: [a] -> [a] -> [a]
+(++) [] ys = ys
+(++) (x:xs) ys = x : xs ++ ys
+
+{-# RULES
+"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys
+ #-}
-instance Show Void where
- showsPrec p f = showString "<<void>>"
- showList ls = showList__ (showsPrec 0) ls
\end{code}
%*********************************************************
\begin{code}
-data Bool = False | True deriving (Eq, Ord, Enum, Bounded, Show {- Read -})
+data Bool = False | True deriving (Eq, Ord)
+ -- Read in PrelRead, Show in PrelShow
-- Boolean functions
(&&), (||) :: Bool -> Bool -> Bool
True && x = x
-False && x = False
-True || x = True
+False && _ = False
+True || _ = True
False || x = x
not :: Bool -> Bool
the renamer currently *always* asks for () to be in scope, so that
ccalls can use () as their default type; so when compiling PrelBase we
need (). (We could arrange suck in () only if -fglasgow-exts, but putting
-it here seems more direct.
+it here seems more direct.)
\begin{code}
-data () = () --easier to do explicitly: deriving (Eq, Ord, Enum, Show, Bounded)
- -- (avoids weird-named functions, e.g., con2tag_()#
+data () = ()
instance Eq () where
() == () = True
max () () = ()
min () () = ()
compare () () = EQ
-
-instance Enum () where
- toEnum 0 = ()
- toEnum _ = error "Prelude.Enum.().toEnum: argument not 0"
- fromEnum () = 0
- enumFrom () = [()]
- enumFromThen () () = [()]
- enumFromTo () () = [()]
- enumFromThenTo () () () = [()]
-
-instance Show () where
- showsPrec p () = showString "()"
- showList ls = showList__ (showsPrec 0) ls
\end{code}
+
%*********************************************************
%* *
\subsection{Type @Ordering@}
%*********************************************************
\begin{code}
-data Ordering = LT | EQ | GT deriving (Eq, Ord, Enum, Bounded, Show {- Read -})
+data Ordering = LT | EQ | GT deriving (Eq, Ord)
+ -- Read in PrelRead, Show in PrelShow
\end{code}
%*********************************************************
\begin{code}
-type String = [Char]
-
-data Char = C# Char# deriving (Eq, Ord)
-
-instance Enum Char where
- toEnum (I# i) | i >=# 0# && i <=# 255# = C# (chr# i)
- | otherwise = error ("Prelude.Enum.Char.toEnum:out of range: " ++ show (I# i))
- fromEnum (C# c) = I# (ord# c)
-
- enumFrom (C# c) = efttCh (ord# c) 1# (># 255#)
- enumFromTo (C# c1) (C# c2) = efttCh (ord# c1) 1# (># (ord# c2))
-
- enumFromThen (C# c1) (C# c2)
- | c1 `leChar#` c2 = efttCh (ord# c1) (ord# c2 -# ord# c1) (># 255#)
- | otherwise = efttCh (ord# c1) (ord# c2 -# ord# c1) (<# 0#)
-
- enumFromThenTo (C# c1) (C# c2) (C# c3)
- | c1 `leChar#` c2 = efttCh (ord# c1) (ord# c2 -# ord# c1) (># (ord# c3))
- | otherwise = efttCh (ord# c1) (ord# c2 -# ord# c1) (<# (ord# c3))
-
-efttCh :: Int# -> Int# -> (Int# -> Bool) -> [Char]
-efttCh now step done
- = go now
- where
- go now | done now = []
- | otherwise = C# (chr# now) : go (now +# step)
-
-instance Show Char where
- showsPrec p '\'' = showString "'\\''"
- showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
-
- showList cs = showChar '"' . showl cs
- where showl "" = showChar '"'
- showl ('"':cs) = showString "\\\"" . showl cs
- showl (c:cs) = showLitChar c . showl cs
+type String = [Char]
+
+data Char = C# Char#
+
+-- We don't use deriving for Eq and Ord, because for Ord the derived
+-- instance defines only compare, which takes two primops. Then
+-- '>' uses compare, and therefore takes two primops instead of one.
+
+instance Eq Char where
+ (C# c1) == (C# c2) = c1 `eqChar#` c2
+ (C# c1) /= (C# c2) = c1 `neChar#` c2
+
+instance Ord Char where
+ (C# c1) > (C# c2) = c1 `gtChar#` c2
+ (C# c1) >= (C# c2) = c1 `geChar#` c2
+ (C# c1) <= (C# c2) = c1 `leChar#` c2
+ (C# c1) < (C# c2) = c1 `ltChar#` c2
+
+{-# RULES
+"x# `eqChar#` x#" forall x#. x# `eqChar#` x# = True
+"x# `neChar#` x#" forall x#. x# `neChar#` x# = False
+"x# `gtChar#` x#" forall x#. x# `gtChar#` x# = False
+"x# `geChar#` x#" forall x#. x# `geChar#` x# = True
+"x# `leChar#` x#" forall x#. x# `leChar#` x# = True
+"x# `ltChar#` x#" forall x#. x# `ltChar#` x# = False
+ #-}
+
+chr :: Int -> Char
+chr (I# i#) | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#)
+ | otherwise = error "Prelude.chr: bad argument"
+
+unsafeChr :: Int -> Char
+unsafeChr (I# i#) = C# (chr# i#)
+
+ord :: Char -> Int
+ord (C# c#) = I# (ord# c#)
\end{code}
+String equality is used when desugaring pattern-matches against strings.
\begin{code}
-isAscii, isLatin1, isControl, isPrint, isSpace, isUpper,
- isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum :: Char -> Bool
-isAscii c = fromEnum c < 128
-isLatin1 c = c <= '\xff'
-isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f'
-isPrint c = not (isControl c)
-
--- isSpace includes non-breaking space
--- Done with explicit equalities both for efficiency, and to avoid a tiresome
--- recursion with PrelList elem
-isSpace c = c == ' ' ||
- c == '\t' ||
- c == '\n' ||
- c == '\r' ||
- c == '\f' ||
- c == '\v' ||
- c == '\xa0'
-
--- The upper case ISO characters have the multiplication sign dumped
--- randomly in the middle of the range. Go figure.
-isUpper c = c >= 'A' && c <= 'Z' ||
- c >= '\xC0' && c <= '\xD6' ||
- c >= '\xD8' && c <= '\xDE'
--- The lower case ISO characters have the division sign dumped
--- randomly in the middle of the range. Go figure.
-isLower c = c >= 'a' && c <= 'z' ||
- c >= '\xDF' && c <= '\xF6' ||
- c >= '\xF8' && c <= '\xFF'
-isAlpha c = isLower c || isUpper c
-isDigit c = c >= '0' && c <= '9'
-isOctDigit c = c >= '0' && c <= '7'
-isHexDigit c = isDigit c || c >= 'A' && c <= 'F' ||
- c >= 'a' && c <= 'f'
-isAlphanum c = isAlpha c || isDigit c
-
--- Case-changing operations
-
-toUpper, toLower :: Char -> Char
-toUpper c | isLower c && c /= '\xDF' && c /= '\xFF'
- = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
- | otherwise = c
-
-toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A'
- + fromEnum 'a')
- | otherwise = c
-
-asciiTab = -- Using an array drags in the array module. listArray ('\NUL', ' ')
- ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
- "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
- "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
- "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
- "SP"]
+eqString :: String -> String -> Bool
+eqString [] [] = True
+eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2
+eqString cs1 cs2 = False
+
+{-# RULES "eqString" (==) = eqString #-}
\end{code}
+
%*********************************************************
%* *
\subsection{Type @Int@}
\begin{code}
data Int = I# Int#
-instance Eq Int where
- (==) x y = x `eqInt` y
- (/=) x y = x `neInt` y
-
-instance Ord Int where
- compare x y = compareInt x y
-
- (<) x y = ltInt x y
- (<=) x y = leInt x y
- (>=) x y = geInt x y
- (>) x y = gtInt x y
- max x y = case (compareInt x y) of { LT -> y ; EQ -> x ; GT -> x }
- min x y = case (compareInt x y) of { LT -> x ; EQ -> x ; GT -> y }
-
-(I# x) `compareInt` (I# y) | x <# y = LT
- | x ==# y = EQ
- | otherwise = GT
-
-instance Enum Int where
- toEnum x = x
- fromEnum x = x
-
-#ifndef USE_FOLDR_BUILD
- enumFrom (I# c) = eftInt c 1#
- enumFromTo (I# c1) (I# c2) = efttInt c1 1# (># c2)
- enumFromThen (I# c1) (I# c2) = eftInt c1 (c2 -# c1)
-
- enumFromThenTo (I# c1) (I# c2) (I# c3)
- | c1 <=# c2 = efttInt c1 (c2 -# c1) (># c3)
- | otherwise = efttInt c1 (c2 -# c1) (<# c3)
-
-#else
- {-# INLINE enumFrom #-}
- {-# INLINE enumFromTo #-}
- enumFrom x = build (\ c _ ->
- let g x = x `c` g (x `plusInt` 1) in g x)
- enumFromTo x y = build (\ c n ->
- let g x = if x <= y then x `c` g (x `plusInt` 1) else n in g x)
+zeroInt, oneInt, twoInt, maxInt, minInt :: Int
+zeroInt = I# 0#
+oneInt = I# 1#
+twoInt = I# 2#
+
+{- Seems clumsy. Should perhaps put minInt and MaxInt directly into MachDeps.h -}
+#if WORD_SIZE_IN_BITS == 31
+minInt = I# (-0x40000000#)
+maxInt = I# 0x3FFFFFFF#
+#elif WORD_SIZE_IN_BITS == 32
+minInt = I# (-0x80000000#)
+maxInt = I# 0x7FFFFFFF#
+#else
+minInt = I# (-0x8000000000000000#)
+maxInt = I# 0x7FFFFFFFFFFFFFFF#
#endif
-efttInt :: Int# -> Int# -> (Int# -> Bool) -> [Int]
-efttInt now step done
- = go now
- where
- go now | done now = []
- | otherwise = I# now : go (now +# step)
-
-eftInt :: Int# -> Int# -> [Int]
-eftInt now step
- = go now
- where
- go now = I# now : go (now +# step)
-
-
-instance Num Int where
- (+) x y = plusInt x y
- (-) x y = minusInt x y
- negate x = negateInt x
- (*) x y = timesInt x y
- abs n = if n `geInt` 0 then n else (negateInt n)
-
- signum n | n `ltInt` 0 = negateInt 1
- | n `eqInt` 0 = 0
- | otherwise = 1
-
- fromInteger (J# a# s# d#)
- = case (integer2Int# a# s# d#) of { i# -> I# i# }
-
- fromInt n = n
-
-instance Show Int where
- showsPrec p n = showSignedInt p n
- showList ls = showList__ (showsPrec 0) ls
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Type @Integer@, @Float@, @Double@}
-%* *
-%*********************************************************
-
-Just the type declarations. If we don't actually use any @Integers@ we'd
-rather not link the @Integer@ module at all; and the default-decl stuff
-in the renamer tends to slurp in @Double@ regardless.
+instance Eq Int where
+ (==) = eqInt
+ (/=) = neInt
-\begin{code}
-data Float = F# Float#
-data Double = D# Double#
-data Integer = J# Int# Int# ByteArray#
+instance Ord Int where
+ compare = compareInt
+ (<) = ltInt
+ (<=) = leInt
+ (>=) = geInt
+ (>) = gtInt
+
+compareInt :: Int -> Int -> Ordering
+(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}
%*********************************************************
\begin{code}
-instance Eval (a -> b)
-
-instance Show (a -> b) where
- showsPrec p f = showString "<<function>>"
- showList ls = showList__ (showsPrec 0) ls
-
-
-- identity function
id :: a -> a
id x = x
-- function composition
{-# INLINE (.) #-}
-{-# GENERATE_SPECS (.) a b c #-}
(.) :: (b -> c) -> (a -> b) -> a -> c
(.) f g x = f (g x)
-- right-associating infix application operator (useful in continuation-
-- passing style)
+{-# INLINE ($) #-}
($) :: (a -> b) -> a -> b
f $ x = f x
asTypeOf = const
\end{code}
-
%*********************************************************
%* *
-\subsection{Miscellaneous}
+\subsection{CCallable instances}
%* *
%*********************************************************
+Defined here to avoid orphans
\begin{code}
-data Lift a = Lift a
-{-# GENERATE_SPECS data a :: Lift a #-}
-\end{code}
+instance CCallable Char
+instance CReturnable Char
+instance CCallable Int
+instance CReturnable Int
+instance CReturnable () -- Why, exactly?
+\end{code}
%*********************************************************
%* *
-\subsection{Support code for @Show@}
+\subsection{Generics}
%* *
%*********************************************************
\begin{code}
-shows :: (Show a) => a -> ShowS
-shows = showsPrec 0
+data Unit = Unit
+data (:+:) a b = Inl a | Inr b
+data (:*:) a b = a :*: b
+\end{code}
-show :: (Show a) => a -> String
-show x = shows x ""
-showChar :: Char -> ShowS
-showChar = (:)
+%*********************************************************
+%* *
+\subsection{Numeric primops}
+%* *
+%*********************************************************
-showString :: String -> ShowS
-showString = (++)
+\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}
-showParen :: Bool -> ShowS -> ShowS
-showParen b p = if b then showChar '(' . p . showChar ')' else p
+Definitions of the boxed PrimOps; these will be
+used in the case of partial applications, etc.
-{-# GENERATE_SPECS showList__ a #-}
-showList__ :: (a -> ShowS) -> [a] -> ShowS
+\begin{code}
+{-# INLINE eqInt #-}
+{-# INLINE neInt #-}
+{-# INLINE gtInt #-}
+{-# INLINE geInt #-}
+{-# INLINE ltInt #-}
+{-# INLINE leInt #-}
+{-# INLINE plusInt #-}
+{-# INLINE minusInt #-}
+{-# INLINE timesInt #-}
+{-# INLINE quotInt #-}
+{-# INLINE remInt #-}
+{-# INLINE negateInt #-}
+
+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)
+
+{-# RULES
+"x# +# 0#" forall x#. x# +# 0# = x#
+"0# +# x#" forall x#. 0# +# x# = x#
+"x# -# 0#" forall x#. x# -# 0# = x#
+"x# -# x#" forall x#. x# -# x# = 0#
+"x# *# 0#" forall x#. x# *# 0# = 0#
+"0# *# x#" forall x#. 0# *# x# = 0#
+"x# *# 1#" forall x#. x# *# 1# = x#
+"1# *# x#" forall x#. 1# *# x# = x#
+ #-}
+
+gcdInt (I# a) (I# b) = g a b
+ where g 0# 0# = error "PrelBase.gcdInt: gcd 0 0 is undefined"
+ g 0# _ = I# absB
+ g _ 0# = I# absA
+ g _ _ = I# (gcdInt# absA absB)
+
+ absInt x = if x <# 0# then negateInt# x else x
+
+ absA = absInt a
+ absB = absInt b
+
+negateInt :: Int -> Int
+negateInt (I# x) = I# (negateInt# x)
+
+gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool
+(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
+
+{-# RULES
+"x# ># x#" forall x#. x# ># x# = False
+"x# >=# x#" forall x#. x# >=# x# = True
+"x# ==# x#" forall x#. x# ==# x# = True
+"x# /=# x#" forall x#. x# /=# x# = False
+"x# <# x#" forall x#. x# <# x# = False
+"x# <=# x#" forall x#. x# <=# x# = True
+ #-}
+
+-- Wrappers for the shift operations. The uncheckedShift# family are
+-- undefined when the amount being shifted by is greater than the size
+-- in bits of Int#, so these wrappers perform a check and return
+-- either zero or -1 appropriately.
+--
+-- Note that these wrappers still produce undefined results when the
+-- second argument (the shift amount) is negative.
-showList__ showx [] = showString "[]"
-showList__ showx (x:xs) = showChar '[' . showx x . showl xs
- where
- showl [] = showChar ']'
- showl (x:xs) = showString ", " . showx x . showl xs
+shiftL#, shiftRL# :: Word# -> Int# -> Word#
-showSpace :: ShowS
-showSpace = {-showChar ' '-} \ xs -> ' ' : xs
-\end{code}
+a `shiftL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0#
+ | otherwise = a `uncheckedShiftL#` b
-Code specific for characters
+a `shiftRL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0#
+ | otherwise = a `uncheckedShiftRL#` b
-\begin{code}
-showLitChar :: Char -> ShowS
-showLitChar c | c > '\DEL' = showChar '\\' . protectEsc isDigit (shows (ord c))
-showLitChar '\DEL' = showString "\\DEL"
-showLitChar '\\' = showString "\\\\"
-showLitChar c | c >= ' ' = showChar c
-showLitChar '\a' = showString "\\a"
-showLitChar '\b' = showString "\\b"
-showLitChar '\f' = showString "\\f"
-showLitChar '\n' = showString "\\n"
-showLitChar '\r' = showString "\\r"
-showLitChar '\t' = showString "\\t"
-showLitChar '\v' = showString "\\v"
-showLitChar '\SO' = protectEsc (== 'H') (showString "\\SO")
-showLitChar c = showString ('\\' : asciiTab!!ord c)
-
-protectEsc p f = f . cont
- where cont s@(c:_) | p c = "\\&" ++ s
- cont s = s
-
-intToDigit :: Int -> Char
-intToDigit i
- | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
- | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i -10)
- | otherwise = error ("Char.intToDigit: not a digit" ++ show i)
+iShiftL#, iShiftRA#, iShiftRL# :: Int# -> Int# -> Int#
-\end{code}
+a `iShiftL#` b | b >=# WORD_SIZE_IN_BITS# = 0#
+ | otherwise = a `uncheckedIShiftL#` b
-Code specific for Ints.
+a `iShiftRA#` b | b >=# WORD_SIZE_IN_BITS# = if a <# 0# then (-1#) else 0#
+ | otherwise = a `uncheckedIShiftRA#` b
-\begin{code}
-showSignedInt :: Int -> Int -> ShowS
-showSignedInt p (I# n) r
- = -- from HBC version; support code follows
- if n <# 0# && p > 6 then '(':itos n++(')':r) else itos n ++ r
-
-itos :: Int# -> String
-itos n =
- if n <# 0# then
- if negateInt# n <# 0# then
- -- n is minInt, a difficult number
- itos (n `quotInt#` 10#) ++ itos' (negateInt# (n `remInt#` 10#)) []
- else
- '-':itos' (negateInt# n) []
- else
- itos' n []
- where
- itos' :: Int# -> String -> String
- itos' n cs =
- if n <# 10# then
- C# (chr# (n +# ord# '0'#)) : cs
- else
- itos' (n `quotInt#` 10#) (C# (chr# (n `remInt#` 10# +# ord# '0'#)) : cs)
+a `iShiftRL#` b | b >=# WORD_SIZE_IN_BITS# = 0#
+ | otherwise = a `uncheckedIShiftRL#` b
+
+#if WORD_SIZE_IN_BITS == 32
+{-# RULES
+"narrow32Int#" forall x#. narrow32Int# x# = x#
+"narrow32Word#" forall x#. narrow32Word# x# = x#
+ #-}
+#endif
+
+{-# RULES
+"int2Word2Int" forall x#. int2Word# (word2Int# x#) = x#
+"word2Int2Word" forall x#. word2Int# (int2Word# x#) = x#
+ #-}
\end{code}
-%*********************************************************
+
+%********************************************************
%* *
-\subsection{Numeric primops}
+\subsection{Unpacking C strings}
%* *
-%*********************************************************
+%********************************************************
-Definitions of the boxed PrimOps; these will be
-used in the case of partial applications, etc.
+This code is needed for virtually all programs, since it's used for
+unpacking the strings of error messages.
\begin{code}
-{-# INLINE eqInt #-}
-{-# INLINE neInt #-}
+unpackCString# :: Addr# -> [Char]
+{-# NOINLINE [1] unpackCString# #-}
+unpackCString# a = unpackCStringList# a
-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)
-negateInt (I# x) = I# (negateInt# x)
-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
+unpackCStringList# :: Addr# -> [Char]
+unpackCStringList# addr
+ = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = []
+ | otherwise = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharOffAddr# addr nh
+
+unpackAppendCString# :: Addr# -> [Char] -> [Char]
+unpackAppendCString# addr rest
+ = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = rest
+ | otherwise = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharOffAddr# addr nh
+
+unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
+{-# NOINLINE [0] unpackFoldrCString# #-}
+-- Don't inline till right at the end;
+-- usually the unpack-list rule turns it into unpackCStringList
+unpackFoldrCString# addr f z
+ = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = z
+ | otherwise = C# ch `f` unpack (nh +# 1#)
+ where
+ ch = indexCharOffAddr# addr nh
+
+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#) `uncheckedIShiftL#` 6# +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) :
+ unpack (nh +# 2#)
+ | ch `leChar#` '\xEF'# =
+ C# (chr# ((ord# ch -# 0xE0#) `uncheckedIShiftL#` 12# +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 6# +#
+ (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) :
+ unpack (nh +# 3#)
+ | otherwise =
+ C# (chr# ((ord# ch -# 0xF0#) `uncheckedIShiftL#` 18# +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12# +#
+ (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#` 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
+ unpack acc i#
+ | i# <# 0# = acc
+ | otherwise =
+ case indexCharOffAddr# addr i# of
+ ch -> unpack (C# ch : acc) (i# -# 1#)
+
+{-# RULES
+"unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a)
+"unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCStringList# a
+"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n
+
+-- There's a built-in rule (in PrelRules.lhs) for
+-- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n
+
+ #-}
\end{code}
projects / ghc-hetmet.git / blobdiff