+++ /dev/null
-#include "options.h"
-
-#if BIGNUM_IS_INT64
-#define primToBignum(t) prim/**/t/**/ToInt64
-#define primFromBignum(t) primInt64To/**/t
-#define primInt64ToInt64 id
-#define primEncodeFloat primEncodeFloatz
-#define primDecodeFloat primDecodeFloatz
-#define primEncodeDouble primEncodeDoublez
-#define primDecodeDouble primDecodeDoublez
-#elif BIGNUM_IS_INTEGER
-#define primToBignum(t) prim/**/t/**/ToInteger
-#define primFromBignum(t) primIntegerTo/**/t
-#define primIntegerToInteger id
-#define primEncodeFloat primEncodeFloatZ
-#define primDecodeFloat primDecodeFloatZ
-#define primEncodeDouble primEncodeDoubleZ
-#define primDecodeDouble primDecodeDoubleZ
-#else
-#warning No BIGNUM type
-#endif
-
-#ifdef HEAD
-module Prelude (
- module PreludeList, module PreludeText, module PreludeIO,
- Bool(False, True),
- Maybe(Nothing, Just),
- Either(Left, Right),
- Ordering(LT, EQ, GT),
- Char, String, Int,
-#ifdef PROVIDE_INTEGER
- Integer,
-#endif
- Float, Double, IO,
-#if STD_PRELUDE
-#else
- Void,
-#endif
- Ratio, Rational,
-#if STD_PRELUDE
--- List type: []((:), [])
-#else
- (:),
-#endif
--- Tuple types: (,), (,,), etc.
--- Trivial type: ()
--- Functions: (->)
- Eq((==), (/=)),
- Ord(compare, (<), (<=), (>=), (>), max, min),
- Enum(toEnum, fromEnum, enumFrom, enumFromThen,
- enumFromTo, enumFromThenTo),
- Bounded(minBound, maxBound),
-#if EVAL_INSTANCES
- Eval(seq, strict),
-#else
- seq, strict,
-#endif
- Num((+), (-), (*), negate, abs, signum, fromInteger),
- Real(toRational),
- Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
- Fractional((/), recip, fromRational),
- Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
- asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
- RealFrac(properFraction, truncate, round, ceiling, floor),
- RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
- encodeFloat, exponent, significand, scaleFloat, isNaN,
- isInfinite, isDenormalized, isIEEE, isNegativeZero),
- Monad((>>=), (>>), return),
- MonadZero(zero),
- MonadPlus((++)),
- Functor(map),
- succ, pred,
- mapM, mapM_, guard, accumulate, sequence, filter, concat, applyM,
- maybe, either,
- (&&), (||), not, otherwise,
- subtract, even, odd, gcd, lcm, (^), (^^),
- fromIntegral, fromRealFrac, atan2,
- fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
- asTypeOf, error, undefined ) where
-
-import PreludeBuiltin -- Contains all `prim' values
-import PreludeList
-import PreludeText
-import PreludeIO
-import Ratio(Ratio, Rational, (%), numerator, denominator)
-
-#endif /* HEAD */
-#ifdef BODY
-module PreludeBuiltin
- ( module PreludeBuiltin
- ) where
-
-#if STD_PRELUDE
-import PreludeBuiltin -- Contains all `prim' values
-import PreludeList
-import PreludeText
-import PreludeIO
-import Ratio(Ratio, Rational, (%), numerator, denominator)
-#endif
-
-infixr 9 .
-infixr 8 ^, ^^, **
-infixl 7 *, /, `quot`, `rem`, `div`, `mod`
-infixl 6 +, -
-infixr 5 :, ++
-infix 4 ==, /=, <, <=, >=, >
-infixr 3 &&
-infixr 2 ||
-infixl 1 >>, >>=
-infixr 0 $, `seq`
-
-#if STD_PRELUDE
-#else
--- Fixities from List
-infix 5 \\
--- Fixities from PreludeList
-infixl 9 !!
-infix 4 `elem`, `notElem`
--- Fixities from Ratio (why do I have the :% fixity??)
-infixl 7 %, :%
--- Fixities from Array
-infixl 9 !, //
-
-#include "PreludeList.hs"
-#include "PreludeText.hs"
-#include "PreludeIO.hs"
-#include "Ratio.hs"
-#include "Ix.hs"
-#include "Char.hs"
-#include "Numeric.hs"
-#include "Array.hs"
-#include "List.hs"
-#include "Maybe.hs"
-#include "UnicodePrims.hs"
-#include "PreludePackString.hs"
-#include "PrelConc.hs"
-
--- The following bits of GHC are too good to pass up!
-#include "PrelIOBase.unlit"
-#include "PrelHandle.unlit"
-#include "PrelException.unlit"
-#include "PrelDynamic.unlit"
-#include "IO.unlit"
-#endif
-
--- Standard types, classes, instances and related functions
-
--- Equality and Ordered classes
-
-class Eq a where
- (==), (/=) :: a -> a -> Bool
-
- 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
-
--- 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
-
- x <= y = compare x y /= GT
- x < y = compare x y == LT
- x >= y = compare x y /= LT
- x > y = compare x y == GT
-
--- note that (min x y, max x y) = (x,y) or (y,x)
- max x y
- | x >= y = x
- | otherwise = y
- min x y
- | x < y = x
- | otherwise = y
-
--- Enumeration and Bounded classes
-
-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 x y = map toEnum [fromEnum x .. fromEnum y]
- enumFromThenTo x y z =
- map toEnum [fromEnum x, fromEnum y .. fromEnum z]
-
-succ, pred :: Enum a => a -> a
-succ = toEnum . (+1) . fromEnum
-pred = toEnum . (subtract 1) . fromEnum
-
-class Bounded a where
- minBound :: a
- maxBound :: a
-
--- Numeric classes
-
-#if EVAL_INSTANCES
-class (Eq a, Show a, Eval a) => Num a where
-#else
-class (Eq a, Show a) => Num a where
-#endif
- (+), (-), (*) :: a -> a -> a
- negate :: a -> a
- abs, signum :: a -> a
- fromInteger :: BIGNUMTYPE -> a
-#if STD_PRELUDE
-#else
- fromInt :: Int -> a
- fromInt = fromInteger . primToBignum(Int)
-#endif
-
- x - y = x + negate y
-
-class (Num a, Ord a) => Real a where
- toRational :: a -> Rational
-#if STD_PRELUDE
-#else
- toDouble :: a -> Double
- toDouble = rationalToRealFloat . toRational
-#endif
-
-class (Real a, Enum a) => Integral a where
- quot, rem :: a -> a -> a
- div, mod :: a -> a -> a
- quotRem, divMod :: a -> a -> (a,a)
- toInteger :: a -> BIGNUMTYPE
-#if STD_PRELUDE
-#else
- toInt :: a -> Int
- toInt = fromInteger . toInteger
-#endif
-
- n `quot` d = q where (q,r) = quotRem n d
- n `rem` d = r where (q,r) = quotRem n d
- n `div` d = q where (q,r) = divMod n d
- n `mod` d = r where (q,r) = divMod n d
- divMod n d = if signum r == - signum d then (q-1, r+d) else qr
- where qr@(q,r) = quotRem n d
-
-class (Num a) => Fractional a where
- (/) :: a -> a -> a
- recip :: a -> a
- fromRational :: Rational -> a
-#if STD_PRELUDE
-#else
- fromDouble :: Double -> a
- fromDouble = fromRational . realFloatToRational
-#endif
-
- recip x = 1 / x
-
-class (Fractional a) => Floating a where
- pi :: a
- exp, log, sqrt :: a -> a
- (**), logBase :: a -> a -> a
- sin, cos, tan :: a -> a
- asin, acos, atan :: a -> a
- sinh, cosh, tanh :: a -> a
- asinh, acosh, atanh :: a -> a
-
- x ** y = exp (log x * y)
- logBase x y = log y / log x
- sqrt x = x ** 0.5
- tan x = sin x / cos x
- tanh x = sinh x / cosh x
-
-class (Real a, Fractional a) => RealFrac a where
- properFraction :: (Integral b) => a -> (b,a)
- truncate, round :: (Integral b) => a -> b
- ceiling, floor :: (Integral b) => a -> b
-
- truncate x = m where (m,_) = properFraction x
-
- round x = let (n,r) = properFraction x
- m = if r < 0 then n - 1 else n + 1
- in case signum (abs r - 0.5) of
- -1 -> n
- 0 -> if even n then n else m
- 1 -> m
-
- ceiling x = if r > 0 then n + 1 else n
- where (n,r) = properFraction x
-
- floor x = if r < 0 then n - 1 else n
- where (n,r) = properFraction x
-
-class (RealFrac a, Floating a) => RealFloat a where
- floatRadix :: a -> BIGNUMTYPE
- floatDigits :: a -> Int
- floatRange :: a -> (Int,Int)
- decodeFloat :: a -> (BIGNUMTYPE,Int)
- encodeFloat :: BIGNUMTYPE -> Int -> a
- exponent :: a -> Int
- significand :: a -> a
- scaleFloat :: Int -> a -> a
- isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
- :: a -> Bool
-
- exponent x = if m == 0 then 0 else n + floatDigits x
- where (m,n) = decodeFloat x
-
- significand x = encodeFloat m (- floatDigits x)
- where (m,_) = decodeFloat x
-
- scaleFloat k x = encodeFloat m (n+k)
- where (m,n) = decodeFloat x
-
--- Numeric functions
-
-subtract :: (Num a) => a -> a -> a
-subtract = flip (-)
-
-even, odd :: (Integral a) => a -> Bool
-even n = n `rem` 2 == 0
-odd = not . even
-
-gcd :: (Integral a) => a -> a -> a
-gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
-gcd x y = gcd' (abs x) (abs y)
- where gcd' x 0 = x
- gcd' x y = gcd' y (x `rem` y)
-
-lcm :: (Integral a) => a -> a -> a
-lcm _ 0 = 0
-lcm 0 _ = 0
-lcm x y = abs ((x `quot` (gcd x y)) * y)
-
-(^) :: (Num a, Integral b) => a -> b -> a
-x ^ 0 = 1
-x ^ n | n > 0 = f x (n-1) x
- where f _ 0 y = y
- f x n y = g x n where
- g x n | even n = g (x*x) (n `quot` 2)
- | otherwise = f x (n-1) (x*y)
-_ ^ _ = error "Prelude.^: negative exponent"
-
-(^^) :: (Fractional a, Integral b) => a -> b -> a
-x ^^ n = if n >= 0 then x^n else recip (x^(-n))
-
-fromIntegral :: (Integral a, Num b) => a -> b
-fromIntegral = fromInteger . toInteger
-
-fromRealFrac :: (RealFrac a, Fractional b) => a -> b
-fromRealFrac = fromRational . toRational
-
-atan2 :: (RealFloat a) => a -> a -> a
-atan2 y x = case (signum y, signum x) of
- ( 0, 1) -> 0
- ( 1, 0) -> pi/2
- ( 0,-1) -> pi
- (-1, 0) -> -pi/2
- ( _, 1) -> atan (y/x)
- ( _,-1) -> atan (y/x) + pi
- ( 0, 0) -> error "Prelude.atan2: atan2 of origin"
-
-
--- Monadic classes
-
-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
-
-class (Monad m) => MonadZero m where
- zero :: m a
-
-class (MonadZero m) => MonadPlus m where
- (++) :: m a -> m a -> m a
-
-accumulate :: Monad m => [m a] -> m [a]
-accumulate = foldr mcons (return [])
- where mcons p q = p >>= \x -> q >>= \y -> return (x:y)
-
-sequence :: Monad m => [m a] -> m ()
-sequence = foldr (>>) (return ())
-
-mapM :: Monad m => (a -> m b) -> [a] -> m [b]
-mapM f as = accumulate (map f as)
-
-mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
-mapM_ f as = sequence (map f as)
-
-guard :: MonadZero m => Bool -> m ()
-guard p = if p then return () else zero
-
--- This subsumes the list-based filter function.
-
-filter :: MonadZero m => (a -> Bool) -> m a -> m a
-filter p = applyM (\x -> if p x then return x else zero)
-
--- This subsumes the list-based concat function.
-
-concat :: MonadPlus m => [m a] -> m a
-concat = foldr (++) zero
-
-applyM :: Monad m => (a -> m b) -> m a -> m b
-applyM f x = x >>= f
-
-#if EVAL_INSTANCES
--- Eval Class
-
-class Eval a where
- seq :: a -> b -> b
- strict :: (a -> b) -> a -> b
-
- seq x y = case primForce x of () -> y
- strict f x = case primForce x of () -> f x
-
-#else
-
-seq :: a -> b -> b
-strict :: (a -> b) -> a -> b
-
-seq x y = case primForce x of () -> y
-strict f x = case primForce x of () -> f x
-
-#endif
-
--- Trivial type
-
-#if STD_PRELUDE
-data () = () deriving (Eq, Ord, Enum, Bounded)
-#else
-data () => () = () deriving (Eq, Ord, Enum, Bounded)
-#endif
-
--- Function type
-
-#if STD_PRELUDE
-data a -> b -- No constructor for functions is exported.
-#endif
-
--- identity function
-id :: a -> a
-id x = x
-
--- constant function
-const :: a -> b -> a
-const x _ = x
-
--- function composition
-(.) :: (b -> c) -> (a -> b) -> a -> c
-f . g = \ x -> f (g x)
-
--- flip f takes its (first) two arguments in the reverse order of f.
-flip :: (a -> b -> c) -> b -> a -> c
-flip f x y = f y x
-
--- right-associating infix application operator (useful in continuation-
--- passing style)
-($) :: (a -> b) -> a -> b
-f $ x = f x
-
-#if STD_PRELUDE
-#else
--- Empty type
-
-data Void -- No constructor for Void is exported. Import/Export
- -- lists must use Void instead of Void(..) or Void()
-#endif
-
--- Boolean type
-
-data Bool = False | True deriving (Eq, Ord, Enum, Read, Show, Bounded)
-
--- Boolean functions
-
-(&&), (||) :: Bool -> Bool -> Bool
-True && x = x
-False && _ = False
-True || _ = True
-False || x = x
-
-not :: Bool -> Bool
-not True = False
-not False = True
-
-otherwise :: Bool
-otherwise = True
-
-
--- Character type
-
-#if STD_PRELUDE
-data Char = ... 'a' | 'b' ... -- 2^16 unicode values
-#else
-data Char
-#endif
-
-instance Eq Char where
- c == c' = fromEnum c == fromEnum c'
-#if STD_PRELUDE
-#else
---#warning "Could use primEqChar and primNeChar"
-#endif
-
-instance Ord Char where
- c <= c' = fromEnum c <= fromEnum c'
-#if STD_PRELUDE
-#else
---#warning "Could use primLeChar and friends"
-#endif
-
-instance Enum Char where
- toEnum = primIntToChar
- fromEnum = primCharToInt
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
- enumFromThen c c' = map toEnum [fromEnum c,
- fromEnum c' .. fromEnum lastChar]
- where lastChar :: Char
- lastChar | c' < c = minBound
- | otherwise = maxBound
-
-instance Bounded Char where
- minBound = '\0'
-#if STD_PRELUDE
- maxBound = '\xffff'
-#else
---#warning "literal char constants too small"
- maxBound = '\xff'
-#endif
-
-type String = [Char]
-
-
--- Maybe type
-
-data Maybe a = Nothing | Just a deriving (Eq, Ord, Read, Show)
-
-maybe :: b -> (a -> b) -> Maybe a -> b
-maybe n f Nothing = n
-maybe n f (Just x) = f x
-
-instance Functor Maybe where
- map f Nothing = Nothing
- map f (Just x) = Just (f x)
-
-instance Monad Maybe where
- (Just x) >>= k = k x
- Nothing >>= k = Nothing
- return = Just
-
-instance MonadZero Maybe where
- zero = Nothing
-
-instance MonadPlus Maybe where
- Nothing ++ ys = ys
- xs ++ ys = xs
-
--- Either type
-
-data Either a b = Left a | Right b deriving (Eq, Ord, Read, Show)
-
-either :: (a -> c) -> (b -> c) -> Either a b -> c
-either f g (Left x) = f x
-either f g (Right y) = g y
-
--- IO type
-
-#if STD_PRELUDE
-data IO a -- abstract
-
-instance Functor IO where
- map f x = x >>= (return . f)
-
-instance Monad IO where ...
-#else
-newtype ST s a = ST (s -> (a,s))
-
-runST :: (forall s. ST s a) -> a
-runST m = fst (unST m theWorld)
- where
- theWorld :: RealWorld
- theWorld = error "runST: entered the world"
-
-unST (ST a) = a
-
-instance Functor (ST s) where
- map f x = x >>= (return . f)
-
-instance Monad (ST s) where
- m >> k = m >>= \ _ -> k
- return x = ST $ \ s -> (x,s)
- m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' }
-
-fixST :: (a -> ST s a) -> ST s a
-fixST k = ST $ \ s ->
- let
- result = unST (k (fst result)) s
- in
- result
-
-unsafeInterleaveST :: ST s a -> ST s a
-unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
-
-fixIO :: (a -> IO a) -> IO a
-fixIO = fixST
-
-unsafePerformIO :: IO a -> a
-unsafePerformIO m = fst (unST m realWorld)
- where
- realWorld :: RealWorld
- realWorld = error "panic: Hugs shouldnae enter the real world"
-
-unsafeInterleaveIO :: IO a -> IO a
-unsafeInterleaveIO = unsafeInterleaveST
-
--- This is one of the main uses of unsafeInterleaveIO
-mkLazyList :: IO (Maybe a) -> IO [a]
-mkLazyList m = unsafeInterleaveIO $ do
- mx <- m
- case mx of
- Nothing -> return []
- Just x -> do
- xs <- mkLazyList m
- return (x:xs)
-
--- used in desugaring Foreign functions
-primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
-primMkIO = ST
-
--- used when Hugs invokes top level function
-primRunIO :: IO () -> ()
-primRunIO m = fst (unST (protect 5 m) realWorld)
- where
- realWorld :: RealWorld
- realWorld = error "panic: Hugs shouldnae enter the real world"
-
- -- make sure there's always an error handler on the stack
- protect :: Int -> IO () -> IO ()
- protect 0 m = putStr "\nProgram error: too many nested errors\n"
- protect (n+1) m = m `catchException` \ e -> protect n (putStr "\nProgram error: " >> print e)
-
-data RealWorld -- no constructors
-type IO a = ST RealWorld a
-#endif
-
--- Ordering type
-
-data Ordering = LT | EQ | GT
- deriving (Eq, Ord, Enum, Read, Show, Bounded)
-
-
--- Standard numeric types. The data declarations for these types cannot
--- be expressed directly in Haskell since the constructor lists would be
--- far too large.
-
-#if STD_PRELUDE
-data Int = minBound ... -1 | 0 | 1 ... maxBound
-instance Eq Int where ...
-instance Ord Int where ...
-instance Num Int where ...
-instance Real Int where ...
-instance Integral Int where ...
-instance Enum Int where ...
-instance Bounded Int where ...
-#else
-data Int
-
-instance Eq Int where
- (==) = primEqInt
- (/=) = primNeInt
-
-instance Ord Int where
- (<) = primLtInt
- (<=) = primLeInt
- (>=) = primGeInt
- (>) = primGtInt
-
-instance Num Int where
- (+) = primPlusInt
- (-) = primMinusInt
- negate = primNegateInt
- (*) = primTimesInt
- abs = absReal
- signum = signumReal
- fromInteger = primFromBignum(Int)
- fromInt = id
-
-instance Real Int where
- toRational x = toInteger x % 1
-
-instance Integral Int where
- quotRem = primQuotRemInt
- toInteger = primToBignum(Int)
- toInt x = x
-
-instance Enum Int where
- toEnum = id
- fromEnum = id
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo = numericEnumFromTo
- enumFromThenTo= numericEnumFromThenTo
-
-instance Bounded Int where
- minBound = primMinInt
- maxBound = primMaxInt
-#endif
-
-#ifdef PROVIDE_WORD
-data Word
-
-instance Eq Word where
- (==) = primEqWord
- (/=) = primNeWord
-
-instance Ord Word where
- (<) = primLtWord
- (<=) = primLeWord
- (>=) = primGeWord
- (>) = primGtWord
-
---and = primAndWord
---or = primOrWord
---not = primNotWord
---shiftL = primShiftL
---shiftRA = primShiftRA
---shiftRL = primShiftRL
---toInt = primWord2Int
---fromInt = primInt2Word
-#endif
-
-#ifdef PROVIDE_ADDR
-data Addr
-
-nullAddr = primIntToAddr 0
-
-instance Eq Addr where
- (==) = primEqAddr
- (/=) = primNeAddr
-
-instance Ord Addr where
- (<) = primLtAddr
- (<=) = primLeAddr
- (>=) = primGeAddr
- (>) = primGtAddr
-
---toInt = addr2Int
---fromInt = int2Addr
-#endif
-
-#if STD_PRELUDE
-data Integer = ... -1 | 0 | 1 ...
-instance Eq Integer where ...
-instance Ord Integer where ...
-instance Num Integer where ...
-instance Real Integer where ...
-instance Integral Integer where ...
-instance Enum Integer where ...
-#else
-#ifdef PROVIDE_INTEGER
-data Integer
-
-instance Eq Integer where
- (==) x y = primCompareInteger x y == 0
-
-instance Ord Integer where
- compare x y = case primCompareInteger x y of
- -1 -> LT
- 0 -> EQ
- 1 -> GT
-
-instance Num Integer where
- (+) = primPlusInteger
- (-) = primMinusInteger
- negate = primNegateInteger
- (*) = primTimesInteger
- abs = absReal
- signum = signumReal
- fromInteger = primFromBignum(Integer)
- fromInt = primIntToInteger
-
-instance Real Integer where
- toRational x = toInteger x % 1
-
-instance Integral Integer where
- quotRem = primQuotRemInteger
- divMod = primDivModInteger
- toInteger = primToBignum(Integer)
- toInt = primIntegerToInt
-
-instance Enum Integer where
- toEnum = primIntToInteger
- fromEnum = primIntegerToInt
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo = numericEnumFromTo
- enumFromThenTo= numericEnumFromThenTo
-#endif /* PROVIDE_INTEGER */
-#endif
-
-#ifdef PROVIDE_INT64
-data Int64
-
-instance Eq Int64 where
- (==) = primEqInt64
- (/=) = primNeInt64
-
-instance Ord Int64 where
- (<) = primLtInt64
- (<=) = primLeInt64
- (>=) = primGeInt64
- (>) = primGtInt64
- compare x y
- | x `primLtInt64` y = LT
- | x `primEqInt64` y = EQ
- | otherwise = GT
-
-instance Num Int64 where
- (+) = primPlusInt64
- (-) = primMinusInt64
- negate = primNegateInt64
- (*) = primTimesInt64
- abs = absReal
- signum = signumReal
- fromInteger = primFromBignum(Int64)
- fromInt = primIntToInt64
-
-instance Real Int64 where
- toRational x = toInteger x % 1
-
-instance Integral Int64 where
- quotRem = primQuotRemInt64
- toInteger = primToBignum(Int64)
- toInt = primInt64ToInt
-
-instance Enum Int64 where
- toEnum = primIntToInt64
- fromEnum = primInt64ToInt
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo = numericEnumFromTo
- enumFromThenTo= numericEnumFromThenTo
-#endif /* PROVIDE_INT64 */
-
-#if STD_PRELUDE
-#else
-absReal x | x >= 0 = x
- | otherwise = -x
-
-signumReal x | x == 0 = 0
- | x > 0 = 1
- | otherwise = -1
-#endif
-
-#if STD_PRELUDE
-data Float
-instance Eq Float where ...
-instance Ord Float where ...
-instance Num Float where ...
-instance Real Float where ...
-instance Fractional Float where ...
-instance Floating Float where ...
-instance RealFrac Float where ...
-instance RealFloat Float where ...
-#else
-data Float
-
-instance Eq Float where
- (==) = primEqFloat
- (/=) = primNeFloat
-
-instance Ord Float where
- (<) = primLtFloat
- (<=) = primLeFloat
- (>=) = primGeFloat
- (>) = primGtFloat
-
-instance Num Float where
- (+) = primPlusFloat
- (-) = primMinusFloat
- negate = primNegateFloat
- (*) = primTimesFloat
- abs = absReal
- signum = signumReal
- fromInteger = primFromBignum(Float)
- fromInt = primIntToFloat
-
-instance Bounded Float where
- minBound = primMinFloat
- maxBound = primMaxFloat
-
-instance Real Float where
- toRational = realFloatToRational
-
-instance Fractional Float where
- (/) = primDivideFloat
- fromRational = rationalToRealFloat
- fromDouble = primDoubleToFloat
-
-instance Floating Float where
- pi = 3.14159265358979323846
- exp = primExpFloat
- log = primLogFloat
- sqrt = primSqrtFloat
- sin = primSinFloat
- cos = primCosFloat
- tan = primTanFloat
- asin = primAsinFloat
- acos = primAcosFloat
- atan = primAtanFloat
-
-instance RealFrac Float where
- properFraction = floatProperFraction
-
-instance RealFloat Float where
- floatRadix _ = toInteger primRadixFloat
- floatDigits _ = primDigitsFloat
- floatRange _ = (primMinExpFloat,primMaxExpFloat)
- encodeFloat = primEncodeFloat
- decodeFloat = primDecodeFloat
- isNaN = primIsNaNFloat
- isInfinite = primIsInfiniteFloat
- isDenormalized= primIsDenormalizedFloat
- isNegativeZero= primIsNegativeZeroFloat
- isIEEE = const primIsIEEEFloat
-#endif
-
-#if STD_PRELUDE
-data Double
-instance Eq Double where ...
-instance Ord Double where ...
-instance Num Double where ...
-instance Real Double where ...
-instance Fractional Double where ...
-instance Floating Double where ...
-instance RealFrac Double where ...
-instance RealFloat Double where ...
-#else
-data Double
-
-instance Eq Double where
- (==) = primEqDouble
- (/=) = primNeDouble
-
-instance Ord Double where
- (<) = primLtDouble
- (<=) = primLeDouble
- (>=) = primGeDouble
- (>) = primGtDouble
-
-instance Num Double where
- (+) = primPlusDouble
- (-) = primMinusDouble
- negate = primNegateDouble
- (*) = primTimesDouble
- abs = absReal
- signum = signumReal
- fromInteger = primFromBignum(Double)
- fromInt = primIntToDouble
-
-instance Bounded Double where
- minBound = primMinDouble
- maxBound = primMaxDouble
-
-instance Real Double where
- toRational = realFloatToRational
-
-realFloatToRational x = (m%1)*(b%1)^^n
- where (m,n) = decodeFloat x
- b = floatRadix x
-
-instance Fractional Double where
- (/) = primDivideDouble
- fromRational = rationalToRealFloat
- fromDouble x = x
-
-rationalToRealFloat x = x'
- where x' = f e
- f e = if e' == e then y else f e'
- where y = encodeFloat (round (x * (1%b)^^e)) e
- (_,e') = decodeFloat y
- (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
- / fromInteger (denominator x))
- b = floatRadix x'
-
-instance Floating Double where
- pi = 3.14159265358979323846
- exp = primExpDouble
- log = primLogDouble
- sqrt = primSqrtDouble
- sin = primSinDouble
- cos = primCosDouble
- tan = primTanDouble
- asin = primAsinDouble
- acos = primAcosDouble
- atan = primAtanDouble
-
-instance RealFrac Double where
- properFraction = floatProperFraction
-
-floatProperFraction x
- | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
- | otherwise = (fromInteger w, encodeFloat r n)
- where (m,n) = decodeFloat x
- b = floatRadix x
- (w,r) = quotRem m (b^(-n))
-
-instance RealFloat Double where
- floatRadix _ = toInteger primRadixDouble
- floatDigits _ = primDigitsDouble
- floatRange _ = (primMinExpDouble,primMaxExpDouble)
- encodeFloat = primEncodeDouble
- decodeFloat = primDecodeDouble
- isNaN = primIsNaNDouble
- isInfinite = primIsInfiniteDouble
- isDenormalized= primIsDenormalizedDouble
- isNegativeZero= primIsNegativeZeroDouble
- isIEEE = const primIsIEEEDouble
-#endif
-
--- The Enum instances for Floats and Doubles are slightly unusual.
--- The `toEnum' function truncates numbers to Int. The definitions
--- of enumFrom and enumFromThen allow floats to be used in arithmetic
--- series: [0,0.1 .. 1.0]. However, roundoff errors make these somewhat
--- dubious. This example may have either 10 or 11 elements, depending on
--- how 0.1 is represented.
-
-instance Enum Float where
- toEnum = fromIntegral
- fromEnum = fromInteger . truncate -- may overflow
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo = numericEnumFromTo
- enumFromThenTo = numericEnumFromThenTo
-
-instance Enum Double where
- toEnum = fromIntegral
- fromEnum = fromInteger . truncate -- may overflow
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo = numericEnumFromTo
- enumFromThenTo = numericEnumFromThenTo
-
-numericEnumFrom :: (Real a) => a -> [a]
-numericEnumFromThen :: (Real a) => a -> a -> [a]
-numericEnumFromTo :: (Real a) => a -> a -> [a]
-numericEnumFromThenTo :: (Real a) => a -> a -> a -> [a]
-numericEnumFrom = iterate (+1)
-numericEnumFromThen n m = iterate (+(m-n)) n
-numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
-numericEnumFromThenTo n n' m
- = takeWhile (if n' >= n then (<= m) else (>= m))
- (numericEnumFromThen n n')
-
-
--- Lists
-
-#if STD_PRELUDE
-data [a] = [] | a : [a] deriving (Eq, Ord)
-#else
-data () => [a] = [] | a : [a] deriving (Eq, Ord)
-#endif
-
-instance Functor [] where
- map f [] = []
- map f (x:xs) = f x : map f xs
-
-instance Monad [] where
- m >>= k = concat (map k m)
- return x = [x]
-
-instance MonadZero [] where
- zero = []
-
-instance MonadPlus [] where
- xs ++ ys = foldr (:) ys xs
-
--- Tuples
-
-#if STD_PRELUDE
-data (a,b) = (a,b) deriving (Eq, Ord, Bounded)
-data (a,b,c) = (a,b,c) deriving (Eq, Ord, Bounded)
-#endif
-
-
--- component projections for pairs:
--- (NB: not provided for triples, quadruples, etc.)
-fst :: (a,b) -> a
-fst (x,y) = x
-
-snd :: (a,b) -> b
-snd (x,y) = y
-
--- curry converts an uncurried function to a curried function;
--- uncurry converts a curried function to a function on pairs.
-curry :: ((a, b) -> c) -> a -> b -> c
-curry f x y = f (x, y)
-
-uncurry :: (a -> b -> c) -> ((a, b) -> c)
-uncurry f p = f (fst p) (snd p)
-
--- Misc functions
-
--- until p f yields the result of applying f until p holds.
-until :: (a -> Bool) -> (a -> a) -> a -> a
-until p f x
- | p x = x
- | otherwise = until p f (f x)
-
--- asTypeOf is a type-restricted version of const. It is usually used
--- as an infix operator, and its typing forces its first argument
--- (which is usually overloaded) to have the same type as the second.
-asTypeOf :: a -> a -> a
-asTypeOf = const
-
--- error stops execution and displays an error message
-
-#if STD_PRELUDE
-error :: String -> a
-error = primError
-#else
-error :: String -> a
-error msg = primRaise (IOException (userError msg))
-#endif
-
--- It is expected that compilers will recognize this and insert error
--- messages that are more appropriate to the context in which undefined
--- appears.
-
-undefined :: a
-undefined = error "Prelude.undefined"
-
-#if STD_PRELUDE
-#else
---Missing primOps and magic funs
-
--- Used for pattern match failure.
--- ToDo: make the message more informative.
-primPmFail :: a
-primPmFail = error "Pattern Match Failure"
-
--- used in derived compare functions, must be exported from Prelude
-primCompAux :: Ord a => a -> a -> Ordering -> Ordering
-primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
-
--- used in derived show functions, must be exported from Prelude
-primShowField :: Show a => String -> a -> ShowS
-primShowField m v = showString m . showChar '=' . shows v
-
--- used in derived read functions, must be exported from Prelude
-primReadField :: Read a => String -> ReadS a
-primReadField m s0 = [ r | (t, s1) <- lex s0, t == m,
- ("=",s2) <- lex s1,
- r <- readsPrec 10 s2 ]
-
--- These 4 primitives are used in pattern matching.
-primPmInt :: Num a => Int -> a -> Bool
-primPmInt x y = fromInt x == y
-
-primPmInteger :: Num a => BIGNUMTYPE -> a -> Bool
-primPmInteger x y = fromInteger x == y
-
-primPmDouble :: Fractional a => Double -> a -> Bool
-primPmDouble x y = fromDouble x == y
-
--- The following primitives are only needed if (n+k) patterns are enabled
--- The first two look trivial but they're selecting a method from a
--- superclass of their argument...
-primPmLe :: Integral a => a -> a -> Bool
-primPmLe x y = x <= y
-
-primPmSubtract :: Integral a => a -> a -> a
-primPmSubtract x y = x - y
-
-primPmFromInteger :: Integral a => BIGNUMTYPE -> a
-primPmFromInteger = fromInteger
-
-primPmSub :: Integral a => Int -> a -> a
-primPmSub n x = x - fromInt n
-
-#ifdef PROVIDE_STABLE
-data StablePtr a
-#endif
-#ifdef PROVIDE_FOREIGN
-data ForeignObj
-
-mkForeignObj :: Addr -> IO ForeignObj
-mkForeignObj = primMkForeignObj
-
-#endif
-#ifdef PROVIDE_WEAK
-data Weak a
-
-mkWeak :: k -- key
- -> v -- value
- -> IO () -- finaliser
- -> IO (Weak v) -- weak pointer
-
-mkWeak k v f = primMakeWeak k v (unsafePerformIO f)
-
-deRefWeak :: Weak v -> IO (Maybe v)
-deRefWeak w = do
- { (stillThere,v) <- primDeRefWeak w
- -- Warning: you'd better ignore v unless stillThere is 1
- ; return (if stillThere == 0 then Nothing else Just v)
- }
-
-mkWeakPtr :: k -> IO () -> IO (Weak k)
-mkWeakPtr key finaliser = mkWeak key key finaliser
-
-mkWeakPair :: k -> v -> IO () -> IO (Weak (k,v))
-mkWeakPair key val finaliser = mkWeak key (key,val) finaliser
-
-addFinaliser :: key -> IO () -> IO ()
-addFinaliser key finaliser = do
- mkWeakPtr key finaliser -- throw it away
- return ()
-
-addForeignFinaliser :: ForeignObj -> IO () -> IO ()
-addForeignFinaliser fo finaliser = addFinaliser fo finaliser
-
-{-
-finalise :: Weak v -> IO ()
-finalise (Weak w) = finaliseWeak# w
-
-instance Eq (Weak v) where
- (Weak w1) == (Weak w2) = w1 `sameWeak#` w2
--}
-
-#endif
-
-#endif
-#endif /* BODY */
+++ /dev/null
--- Standard list functions
-
-#ifdef HEAD
-module PreludeList (
- head, last, tail, init, null, length, (!!),
- foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
- iterate, repeat, replicate, cycle,
- take, drop, splitAt, takeWhile, dropWhile, span, break,
- lines, words, unlines, unwords, reverse, and, or,
- any, all, elem, notElem, lookup,
- sum, product, maximum, minimum, concatMap,
- zip, zip3, zipWith, zipWith3, unzip, unzip3)
- where
-
-import qualified Char(isSpace)
-import PreludeBuiltin
-#endif /* HEAD */
-#ifdef BODY
-
-infixl 9 !!
-infix 4 `elem`, `notElem`
-
--- head and tail extract the first element and remaining elements,
--- respectively, of a list, which must be non-empty. last and init
--- are the dual functions working from the end of a finite list,
--- rather than the beginning.
-
-head :: [a] -> a
-head (x:_) = x
-head [] = error "PreludeList.head: empty list"
-
-last :: [a] -> a
-last [x] = x
-last (_:xs) = last xs
-last [] = error "PreludeList.last: empty list"
-
-tail :: [a] -> [a]
-tail (_:xs) = xs
-tail [] = error "PreludeList.tail: empty list"
-
-init :: [a] -> [a]
-init [x] = []
-init (x:xs) = x : init xs
-init [] = error "PreludeList.init: empty list"
-
-null :: [a] -> Bool
-null [] = True
-null (_:_) = False
-
--- length returns the length of a finite list as an Int.
-length :: [a] -> Int
-length [] = 0
-length (_:l) = 1 + length l
-
--- List index (subscript) operator, 0-origin
-(!!) :: [a] -> Int -> a
-(x:_) !! 0 = x
-(_:xs) !! n | n > 0 = xs !! (n-1)
-(_:_) !! _ = error "PreludeList.!!: negative index"
-[] !! _ = error "PreludeList.!!: index too large"
-
--- foldl, applied to a binary operator, a starting value (typically the
--- left-identity of the operator), and a list, reduces the list using
--- the binary operator, from left to right:
--- foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
--- foldl1 is a variant that has no starting value argument, and thus must
--- be applied to non-empty lists. scanl is similar to foldl, but returns
--- a list of successive reduced values from the left:
--- scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
--- Note that last (scanl f z xs) == foldl f z xs.
--- scanl1 is similar, again without the starting element:
--- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
-
-foldl :: (a -> b -> a) -> a -> [b] -> a
-foldl f z [] = z
-foldl f z (x:xs) = foldl f (f z x) xs
-
-foldl1 :: (a -> a -> a) -> [a] -> a
-foldl1 f (x:xs) = foldl f x xs
-foldl1 _ [] = error "PreludeList.foldl1: empty list"
-
-scanl :: (a -> b -> a) -> a -> [b] -> [a]
-scanl f q xs = q : (case xs of
- [] -> []
- x:xs -> scanl f (f q x) xs)
-
-scanl1 :: (a -> a -> a) -> [a] -> [a]
-scanl1 f (x:xs) = scanl f x xs
-scanl1 _ [] = error "PreludeList.scanl1: empty list"
-
--- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
--- above functions.
-
-foldr :: (a -> b -> b) -> b -> [a] -> b
-foldr f z [] = z
-foldr f z (x:xs) = f x (foldr f z xs)
-
-foldr1 :: (a -> a -> a) -> [a] -> a
-foldr1 f [x] = x
-foldr1 f (x:xs) = f x (foldr1 f xs)
-foldr1 _ [] = error "PreludeList.foldr1: empty list"
-
-scanr :: (a -> b -> b) -> b -> [a] -> [b]
-scanr f q0 [] = [q0]
-scanr f q0 (x:xs) = f x q : qs
- where qs@(q:_) = scanr f q0 xs
-
-scanr1 :: (a -> a -> a) -> [a] -> [a]
-scanr1 f [x] = [x]
-scanr1 f (x:xs) = f x q : qs
- where qs@(q:_) = scanr1 f xs
-scanr1 _ [] = error "PreludeList.scanr1: empty list"
-
--- iterate f x returns an infinite list of repeated applications of f to x:
--- iterate f x == [x, f x, f (f x), ...]
-iterate :: (a -> a) -> a -> [a]
-iterate f x = x : iterate f (f x)
-
--- repeat x is an infinite list, with x the value of every element.
-repeat :: a -> [a]
-repeat x = xs where xs = x:xs
-
--- replicate n x is a list of length n with x the value of every element
-replicate :: Int -> a -> [a]
-replicate n x = take n (repeat x)
-
--- cycle ties a finite list into a circular one, or equivalently,
--- the infinite repetition of the original list. It is the identity
--- on infinite lists.
-
-cycle :: [a] -> [a]
-#if STD_PRELUDE
-#else
--- check proposed by Friedhelm Wrensch <fwr@1772228662.hostid.net>
--- doesn't seem to affect strictness
-cycle [] = error "PreludeList.cycle []"
-#endif
-cycle xs = xs' where xs' = xs ++ xs'
-
--- take n, applied to a list xs, returns the prefix of xs of length n,
--- or xs itself if n > length xs. drop n xs returns the suffix of xs
--- after the first n elements, or [] if n > length xs. splitAt n xs
--- is equivalent to (take n xs, drop n xs).
-
-take :: Int -> [a] -> [a]
-take 0 _ = []
-take _ [] = []
-take n (x:xs) | n > 0 = x : take (n-1) xs
-take _ _ = error "PreludeList.take: negative argument"
-
-drop :: Int -> [a] -> [a]
-drop 0 xs = xs
-drop _ [] = []
-drop n (_:xs) | n > 0 = drop (n-1) xs
-drop _ _ = error "PreludeList.drop: negative argument"
-
-splitAt :: Int -> [a] -> ([a],[a])
-splitAt 0 xs = ([],xs)
-splitAt _ [] = ([],[])
-splitAt n (x:xs) | n > 0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
-splitAt _ _ = error "PreludeList.splitAt: negative argument"
-
--- 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
-
-span, break :: (a -> Bool) -> [a] -> ([a],[a])
-span p [] = ([],[])
-span p xs@(x:xs')
- | p x = (x:ys,zs)
- | otherwise = ([],xs)
- where (ys,zs) = span p xs'
-break p = span (not . p)
-
--- lines breaks a string up into a list of strings at newline characters.
--- The resulting strings do not contain newlines. Similary, words
--- breaks a string up into a list of words, which were delimited by
--- white space. unlines and unwords are the inverse operations.
--- unlines joins lines with terminating newlines, and unwords joins
--- words with separating spaces.
-
-lines :: String -> [String]
-lines "" = []
-lines s = let (l, s') = break (== '\n') s
- in l : case s' of
- [] -> []
- (_:s'') -> lines s''
-
-words :: String -> [String]
-#if STD_PRELUDE
-words s = case dropWhile Char.isSpace s of
-#else
-words s = case dropWhile isSpace s of
-#endif
- "" -> []
- s' -> w : words s''
-#if STD_PRELUDE
- where (w, s'') = break Char.isSpace s'
-#else
- where (w, s'') = break isSpace s'
-#endif
-
-unlines :: [String] -> String
-unlines = concatMap (++ "\n")
-
-unwords :: [String] -> String
-unwords [] = ""
-unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
-
--- reverse xs returns the elements of xs in reverse order. xs must be finite.
-reverse :: [a] -> [a]
-reverse = foldl (flip (:)) []
-
--- and returns the conjunction of a Boolean list. For the result to be
--- True, the list must be finite; False, however, results from a False
--- value at a finite index of a finite or infinite list. or is the
--- disjunctive dual of and.
-and, or :: [Bool] -> Bool
-and = foldr (&&) True
-or = foldr (||) False
-
--- Applied to a predicate and a list, any determines if any element
--- of the list satisfies the predicate. Similarly, for all.
-any, all :: (a -> Bool) -> [a] -> Bool
-any p = or . map p
-all p = and . map p
-
--- elem is the list membership predicate, usually written in infix form,
--- e.g., x `elem` xs. notElem is the negation.
-elem, notElem :: (Eq a) => a -> [a] -> Bool
-elem x = any (== x)
-notElem x = all (/= x)
-
--- lookup key assocs looks up a key in an association list.
-lookup :: (Eq a) => a -> [(a,b)] -> Maybe b
-lookup key [] = Nothing
-lookup key ((x,y):xys)
- | key == x = Just y
- | otherwise = lookup key xys
-
--- sum and product compute the sum or product of a finite list of numbers.
-sum, product :: (Num a) => [a] -> a
-sum = foldl (+) 0
-product = foldl (*) 1
-
--- maximum and minimum return the maximum or minimum value from a list,
--- which must be non-empty, finite, and of an ordered type.
-maximum, minimum :: (Ord a) => [a] -> a
-maximum [] = error "PreludeList.maximum: empty list"
-maximum xs = foldl1 max xs
-
-minimum [] = error "PreludeList.minimum: empty list"
-minimum xs = foldl1 min xs
-
-concatMap :: (a -> [b]) -> [a] -> [b]
-concatMap f = concat . map f
-
--- zip takes two lists and returns a list of corresponding pairs. If one
--- input list is short, excess elements of the longer list are discarded.
--- zip3 takes three lists and returns a list of triples. Zips for larger
--- tuples are in the List library
-
-zip :: [a] -> [b] -> [(a,b)]
-zip = zipWith (,)
-
-zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
-zip3 = zipWith3 (,,)
-
--- The zipWith family generalises the zip family by zipping with the
--- function given as the first argument, instead of a tupling function.
--- For example, zipWith (+) is applied to two lists to produce the list
--- of corresponding sums.
-
-zipWith :: (a->b->c) -> [a]->[b]->[c]
-zipWith z (a:as) (b:bs)
- = z a b : zipWith z as bs
-zipWith _ _ _ = []
-
-zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
-zipWith3 z (a:as) (b:bs) (c:cs)
- = z a b c : zipWith3 z as bs cs
-zipWith3 _ _ _ _ = []
-
-
--- unzip transforms a list of pairs into a pair of lists.
-
-unzip :: [(a,b)] -> ([a],[b])
-unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
-
-unzip3 :: [(a,b,c)] -> ([a],[b],[c])
-unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
- ([],[],[])
-
-
-#endif /* BODY */
\ No newline at end of file
+++ /dev/null
-#ifdef HEAD
-module PreludeText (
- ReadS, ShowS,
- Read(readsPrec, readList),
- Show(showsPrec, showList),
- reads, shows, show, read, lex,
- showChar, showString, readParen, showParen ) where
-
--- The omitted instances can be implemented in standard Haskell but
--- they have been omitted for the sake of brevity
-
-#if STD_PRELUDE
-import Char(isSpace, isAlpha, isDigit, isAlphanum, isHexDigit,
- showLitChar, readLitChar, lexLitChar)
-
-import Numeric(showSigned, showInt, readSigned, readDec, showFloat,
- readFloat, lexDigits)
-#endif
-
-import PreludeBuiltin
-#endif /* HEAD */
-#ifdef BODY
-
-type ReadS a = String -> [(a,String)]
-type ShowS = String -> String
-
-class Read a where
- readsPrec :: Int -> ReadS a
- readList :: ReadS [a]
-
- readList = readParen False (\r -> [pr | ("[",s) <- lex r,
- pr <- readl s])
- where readl s = [([],t) | ("]",t) <- lex s] ++
- [(x:xs,u) | (x,t) <- reads s,
- (xs,u) <- readl' t]
- readl' s = [([],t) | ("]",t) <- lex s] ++
- [(x:xs,v) | (",",t) <- lex s,
- (x,u) <- reads t,
- (xs,v) <- readl' u]
-
-class Show a where
- showsPrec :: Int -> a -> ShowS
- showList :: [a] -> ShowS
-
- showList [] = showString "[]"
- showList (x:xs) = showChar '[' . shows x . showl xs
- where showl [] = showChar ']'
- showl (x:xs) = showChar ',' . shows x .
- showl xs
-
-reads :: (Read a) => ReadS a
-reads = readsPrec 0
-
-shows :: (Show a) => a -> ShowS
-shows = showsPrec 0
-
-read :: (Read a) => String -> a
-read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
- [x] -> x
- [] -> error "PreludeText.read: no parse"
- _ -> error "PreludeText.read: ambiguous parse"
-
-show :: (Show a) => a -> String
-show x = shows x ""
-
-showChar :: Char -> ShowS
-showChar = (:)
-
-showString :: String -> ShowS
-showString = (++)
-
-showParen :: Bool -> ShowS -> ShowS
-showParen b p = if b then showChar '(' . p . showChar ')' else p
-
-readParen :: Bool -> ReadS a -> ReadS a
-readParen b g = if b then mandatory else optional
- where optional r = g r ++ mandatory r
- mandatory r = [(x,u) | ("(",s) <- lex r,
- (x,t) <- optional s,
- (")",u) <- lex t ]
-
--- This lexer is not completely faithful to the Haskell lexical syntax.
--- Current limitations:
--- Qualified names are not handled properly
--- A `--' does not terminate a symbol
--- Octal and hexidecimal numerics are not recognized as a single token
-
-lex :: ReadS String
-lex "" = [("","")]
-lex (c:s)
- | isSpace c = lex (dropWhile isSpace s)
-lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
- ch /= "'" ]
-lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
- where
- lexString ('"':s) = [("\"",s)]
- lexString s = [(ch++str, u)
- | (ch,t) <- lexStrItem s,
- (str,u) <- lexString t ]
-
- lexStrItem ('\\':'&':s) = [("\\&",s)]
- lexStrItem ('\\':c:s) | isSpace c
- = [("\\&",t) |
- '\\':t <-
- [dropWhile isSpace s]]
- lexStrItem s = lexLitChar s
-
-lex (c:s) | isSingle c = [([c],s)]
- | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
- | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
- | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
- (fe,t) <- lexFracExp s ]
- | otherwise = [] -- bad character
- where
- isSingle c = c `elem` ",;()[]{}_`"
- isSym c = isPrint c && not (isAlphaNum c) &&
- not (isSingle c) && not (c `elem` "_'")
- && not (isSpace c)
- isIdChar c = isAlphaNum c || c `elem` "_'"
-
- lexFracExp ('.':c:cs) | isDigit c
- = [('.':ds++e,u) | (ds,t) <- lexDigits (c:cs),
- (e,u) <- lexExp t]
- lexFracExp s = [("",s)]
-
- lexExp (e:s) | e `elem` "eE"
- = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
- (ds,u) <- lexDigits t] ++
- [(e:ds,t) | (ds,t) <- lexDigits s]
- lexExp s = [("",s)]
-
-#if 1
-instance Show Int where
- showsPrec p n
- | n == minBound = showSigned showInt p (toInteger n)
- | otherwise = showSigned showInt p n
-#else /* This version only goes slightly faster */
-instance Show Int where
- showsPrec p n
- | n == minBound = showSigned showInt p (toInteger n)
- | otherwise = showSigned primShowInt p n
-
-primShowInt n r = unsafeUnpackCString (primShowInt' n) ++ r
-
-foreign import stdcall "" "prim_showInt" primShowInt' :: Int -> Addr
-#endif
-
-instance Read Int where
- readsPrec p = readSigned readDec
-
-#ifdef PROVIDE_INTEGER
-instance Show Integer where
- showsPrec = showSigned showInt
-
-instance Read Integer where
- readsPrec p = readSigned readDec
-#endif
-
-#ifdef PROVIDE_INT64
-instance Show Int64 where
- showsPrec = showSigned showInt
-
-instance Read Int64 where
- readsPrec p = readSigned readDec
-#endif
-
-instance Show Float where
- showsPrec p = showFloat
-
-instance Read Float where
- readsPrec p = readSigned readFloat
-
-instance Show Double where
- showsPrec p = showFloat
-
-instance Read Double where
- readsPrec p = readSigned readFloat
-
-instance Show () where
- showsPrec p () = showString "()"
-
-instance Read () where
- readsPrec p = readParen False
- (\r -> [((),t) | ("(",s) <- lex r,
- (")",t) <- lex s ] )
-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
-
-instance Read Char where
- readsPrec p = readParen False
- (\r -> [(c,t) | ('\'':s,t)<- lex r,
- (c,"\'") <- readLitChar s])
-
- readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
- (l,_) <- readl s ])
- where readl ('"':s) = [("",s)]
- readl ('\\':'&':s) = readl s
- readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
- (cs,u) <- readl t ]
-
-instance (Show a) => Show [a] where
- showsPrec p = showList
-
-instance (Read a) => Read [a] where
- readsPrec p = readList
-
--- Tuples
-
-#if STD_PRELUDE
-instance (Show a, Show b) => Show (a,b) where
- showsPrec p (x,y) = showChar '(' . shows x . showString ", " .
- shows y . showChar ')'
-
-instance (Read a, Read b) => Read (a,b) where
- readsPrec p = readParen False
- (\r -> [((x,y), w) | ("(",s) <- lex r,
- (x,t) <- reads s,
- (",",u) <- lex t,
- (y,v) <- reads u,
- (")",w) <- lex v ] )
-
--- Other tuples have similar Read and Show instances
-#endif
-
--- Functions
-
-instance Show (a->b) where
- showsPrec p f = showString "<<function>>"
-
-
-instance Show (IO a) where
- showsPrec p f = showString "<<IO action>>"
-
-#endif /* BODY */
\ No newline at end of file
projects / ghc-hetmet.git / commitdiff