-module Prelude (
-
-#include "../includes/ieee-flpt.h"
-
---partain: 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,
-
---partain:module PreludeText,
- ReadS, ShowS,
- Read(readsPrec, readList),
- Show(showsPrec, showList),
- reads, shows, show, read, lex,
- showChar, showString, readParen, showParen,
---partain:module PreludeIO,
- FilePath, IOError, fail, userError, catch,
- putChar, putStr, putStrLn, print,
- getChar, getLine, getContents, interact,
- readFile, writeFile, appendFile, readIO, readLn,
-
- Bool(False, True),
- Maybe(Nothing, Just),
- Either(Left, Right), either,
- Ordering(LT, EQ, GT),
- Char, String, Int, Integer, Float, Double, IO, Void,
- [](..), -- List type
- ()(..), -- Trivial type
- -- Tuple types: (,), (,,), etc.
- (,)(..),
- (,,)(..),
- (,,,)(..),
- (,,,,)(..),
- (,,,,,)(..),
- (,,,,,,)(..),
- (,,,,,,,)(..),
- (,,,,,,,,)(..),
- (,,,,,,,,,)(..),
- (,,,,,,,,,,)(..),
- (,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..),
- (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..),
--- Functions: (->)
- Eq((==), (/=)),
- Ord(compare, (<), (<=), (>=), (>), max, min),
- Enum(toEnum, fromEnum, enumFrom, enumFromThen,
- enumFromTo, enumFromThenTo),
- Bounded(minBound, maxBound),
- Eval(..{-seq, strict-}), seq, strict, -- NB: glasgow hack
- Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt{-partain-}),
- Real(toRational),
- Integral(quot, rem, div, mod, quotRem, divMod, toInteger, toInt{-partain-}),
- 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,
- (&&), (||), not, otherwise,
- subtract, even, odd, gcd, lcm, (^), (^^),
- fromIntegral, fromRealFrac, atan2,
- fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
- asTypeOf, error, undefined ) where
-
-import GHCbase -- all the GHC basics
-import GHCio -- I/O basics
-import Ratio(Ratio, Rational, (%), numerator, denominator)
-
---PreludeText:
-import Char ( isSpace )
-import IO ( hPutChar, hPutStr, hGetChar, hGetContents )
-
-infixl 9 !!
-infix 4 `elem`, `notElem`
-{- :PreludeList -}
-
-infixr 9 .
-infixr 8 ^, ^^, **
-infixl 7 *, /, `quot`, `rem`, `div`, `mod`
-infixl 6 +, -
-infixr 5 :, ++
-infix 4 ==, /=, <, <=, >=, >
-infixr 3 &&
-infixr 2 ||
-infixr 1 >>, >>=
-infixr 0 $
-
--- Standard types, classes, instances and related functions
-
--- Equality and Ordered classes
-
-class Eq a where
- (==), (/=) :: a -> a -> Bool
-
- 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
- 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 }
-
--- Enumeration and Bounded classes
-
-class (Ord a) => 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 = takeWhile (<= m) (enumFrom n)
- enumFromThenTo n n' m
- = takeWhile (if n' >= n then (<= m) else (>= m))
- (enumFromThen n n')
-
-succ, pred :: Enum a => a -> a
-succ = toEnum . (+1) . fromEnum
-pred = toEnum . (subtract 1) . fromEnum
-
-class Bounded a where
- minBound, maxBound :: a
-
--- Numeric classes
-
-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 = fromInteger (int2Integer i)
- where
- int2Integer (I# i#) = int2Integer# i#
- -- Go via the standard class-op if the
- -- non-standard one ain't provided
-
-class (Num a, Ord a) => Real a where
- toRational :: a -> Rational
-
-class (Real a, Enum a) => Integral a where
- quot, rem, div, mod :: a -> a -> a
- quotRem, divMod :: a -> a -> (a,a)
- toInteger :: a -> Integer
- toInt :: a -> Int -- partain: Glasgow extension
-
- 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 == negate (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
-
- 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 -> Integer
- floatDigits :: a -> Int
- floatRange :: a -> (Int,Int)
- decodeFloat :: a -> (Integer,Int)
- encodeFloat :: Integer -> 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 (negate (floatDigits x))
- where (m,_) = decodeFloat x
-
- scaleFloat k x = encodeFloat m (n+k)
- where (m,n) = decodeFloat x
-
--- Numeric functions
-
-{-# GENERATE_SPECS subtract a{Int#,Double#,Int,Double,Complex(Double#),Complex(Double)} #-}
-subtract :: (Num a) => a -> a -> a
-subtract x y = y - x
-
-even, odd :: (Integral a) => a -> Bool
-even n = n `rem` 2 == 0
-odd = not . even
-
-{-# GENERATE_SPECS gcd a{Int#,Int,Integer} #-}
-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)
-
-{-# GENERATE_SPECS lcm a{Int#,Int,Integer} #-}
-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^(negate 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) -> (negate 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 [] = return []
-accumulate (m:ms) = do { x <- m; xs <- accumulate ms; return (x:xs) }
-{- partain: this may be right, but I'm going w/ a more-certainly-right version
-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
-
-
--- Eval Class
-
-class Eval a {-not Glasgow: where
- seq :: a -> b -> b
- strict :: (a -> b) -> a -> b
- strict f x = x `seq` f x -}
-
--- seq: in GHCbase
-strict :: Eval a => (a -> b) -> a -> b
-strict f x = x `seq` f x
-
----------------------------------------------------------------
--- Trivial type
-
-data () = () --easier to do explicitly: deriving (Eq, Ord, Enum, Bounded)
- -- (avoids weird-named functions, e.g., con2tag_()#
-
-instance CReturnable () -- Why, exactly?
-
-instance Eq () where
- () == () = True
- () /= () = False
-
-instance Ord () where
- () <= () = True
- () < () = False
- () >= () = True
- () > () = False
- max () () = ()
- min () () = ()
- compare () () = EQ
-
-instance Enum () where
- toEnum 0 = ()
- toEnum _ = error "Prelude.Enum.().toEnum: argument not 0"
- fromEnum () = 0
- enumFrom () = [()]
- enumFromThen () () = [()]
- enumFromTo () () = [()]
- enumFromThenTo () () () = [()]
-
-instance Bounded () where
- minBound = ()
- maxBound = ()
-
-instance Show () where
- showsPrec p () = showString "()"
-
-instance Read () where
- readsPrec p = readParen False
- (\r -> [((),t) | ("(",s) <- lex r,
- (")",t) <- lex s ] )
-
----------------------------------------------------------------
--- Function type
-
---data a -> b -- No constructor for functions is exported.
-
-instance Show (a -> b) where
- showsPrec p f = showString "<<function>>"
- showList = showList__ (showsPrec 0)
-
----------------------------------------------------------------
--- Empty type
-
---partain:data Void -- No constructor for Void is exported. Import/Export
- -- lists must use Void instead of Void(..) or Void()
-
----------------------------------------------------------------
--- 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
-
-data Char = C# Char# deriving (Eq, Ord)
---partain:data Char = ... 'a' | 'b' ... -- 265 ISO values
-instance CCallable Char
-instance CReturnable Char
-
-instance Enum Char where
- toEnum (I# i) | i >=# 0# && i <=# 255# = C# (chr# i)
- | otherwise = error "Prelude.Enum.Char.toEnum:out of range"
- fromEnum (C# c) = I# (ord# c)
- 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'
- maxBound = '\255'
-
-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 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]
-
----------------------------------------------------------------
--- 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 a) = Just (f a)
-
-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: moved to GHCbase
-
---partain: data IO a = -- abstract
-
----------------------------------------------------------------
--- 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 (standard) Haskell since the
--- constructor lists would be far too large.
-
----------------------------------------------------------------
-data Int = I# Int# deriving (Eq,Ord)
---partain:data Int = minBound ... -1 | 0 | 1 ... maxBound
-
-instance CCallable Int
-instance CReturnable Int
-
-instance Bounded Int where
- minBound = negate 2147483647 -- **********************
- maxBound = 2147483647 -- **********************
-
-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 Real Int where
- toRational x = toInteger x % 1
-
-instance Integral Int where
- a@(I# _) `quotRem` b@(I# _) = (a `quotInt` b, a `remInt` b)
- -- OK, so I made it a little stricter. Shoot me. (WDP 94/10)
-
- -- following chks for zero divisor are non-standard (WDP)
- a `quot` b = if b /= 0
- then a `quotInt` b
- else error "Integral.Int.quot{PreludeCore}: divide by 0\n"
- a `rem` b = if b /= 0
- then a `remInt` b
- else error "Integral.Int.rem{PreludeCore}: divide by 0\n"
-
- x `div` y = if x > 0 && y < 0 then quotInt (x-y-1) y
- else if x < 0 && y > 0 then quotInt (x-y+1) y
- else quotInt x y
- x `mod` y = if x > 0 && y < 0 || x < 0 && y > 0 then
- if r/=0 then r+y else 0
- else
- r
- where r = remInt x y
-
- divMod x@(I# _) y@(I# _) = (x `div` y, x `mod` y)
- -- Stricter. Sorry if you don't like it. (WDP 94/10)
-
---OLD: even x = eqInt (x `mod` 2) 0
---OLD: odd x = neInt (x `mod` 2) 0
-
- toInteger (I# n#) = int2Integer# n# -- give back a full-blown Integer
- toInt x = x
-
-instance Enum Int where
- toEnum x = x
- fromEnum x = x
-#ifndef USE_FOLDR_BUILD
- enumFrom x = x : enumFrom (x `plusInt` 1)
- enumFromTo n m = takeWhile (<= m) (enumFrom n)
-#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)
-#endif
- enumFromThen m n = en' m (n `minusInt` m)
- where en' m n = m : en' (m `plusInt` n) n
- enumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p))
- (enumFromThen n m)
-
-instance Read Int where
- readsPrec p x = readSigned readDec x
- readList = readList__ (readsPrec 0)
-
-instance Show Int where
- showsPrec x = showSigned showInt x
- showList = showList__ (showsPrec 0)
-
----------------------------------------------------------------
-data Integer = J# Int# Int# ByteArray#
---partain:data Integer = ... -1 | 0 | 1 ...
-
-instance Eq Integer where
- (J# a1 s1 d1) == (J# a2 s2 d2)
- = (cmpInteger# a1 s1 d1 a2 s2 d2) ==# 0#
-
- (J# a1 s1 d1) /= (J# a2 s2 d2)
- = (cmpInteger# a1 s1 d1 a2 s2 d2) /=# 0#
-
-instance Ord Integer where
- (J# a1 s1 d1) <= (J# a2 s2 d2)
- = (cmpInteger# a1 s1 d1 a2 s2 d2) <=# 0#
-
- (J# a1 s1 d1) < (J# a2 s2 d2)
- = (cmpInteger# a1 s1 d1 a2 s2 d2) <# 0#
-
- (J# a1 s1 d1) >= (J# a2 s2 d2)
- = (cmpInteger# a1 s1 d1 a2 s2 d2) >=# 0#
-
- (J# a1 s1 d1) > (J# a2 s2 d2)
- = (cmpInteger# a1 s1 d1 a2 s2 d2) ># 0#
-
- x@(J# a1 s1 d1) `max` y@(J# a2 s2 d2)
- = if ((cmpInteger# a1 s1 d1 a2 s2 d2) ># 0#) then x else y
-
- x@(J# a1 s1 d1) `min` y@(J# a2 s2 d2)
- = if ((cmpInteger# a1 s1 d1 a2 s2 d2) <# 0#) then x else y
-
- compare (J# a1 s1 d1) (J# a2 s2 d2)
- = case cmpInteger# a1 s1 d1 a2 s2 d2 of { res# ->
- if res# <# 0# then LT else
- if res# ># 0# then GT else EQ
- }
-
-instance Num Integer where
- (+) (J# a1 s1 d1) (J# a2 s2 d2)
- = plusInteger# a1 s1 d1 a2 s2 d2
-
- (-) (J# a1 s1 d1) (J# a2 s2 d2)
- = minusInteger# a1 s1 d1 a2 s2 d2
-
- negate (J# a s d) = negateInteger# a s d
-
- (*) (J# a1 s1 d1) (J# a2 s2 d2)
- = timesInteger# a1 s1 d1 a2 s2 d2
-
- -- ORIG: abs n = if n >= 0 then n else -n
-
- abs n@(J# a1 s1 d1)
- = case 0 of { J# a2 s2 d2 ->
- if (cmpInteger# a1 s1 d1 a2 s2 d2) >=# 0#
- then n
- else negateInteger# a1 s1 d1
- }
-
- signum n@(J# a1 s1 d1)
- = case 0 of { J# a2 s2 d2 ->
- let
- cmp = cmpInteger# a1 s1 d1 a2 s2 d2
- in
- if cmp ># 0# then 1
- else if cmp ==# 0# then 0
- else (negate 1)
- }
-
- fromInteger x = x
-
- fromInt (I# n#) = int2Integer# n# -- gives back a full-blown Integer
-
-instance Real Integer where
- toRational x = x % 1
-
-instance Integral Integer where
- quotRem (J# a1 s1 d1) (J# a2 s2 d2)
- = case (quotRemInteger# a1 s1 d1 a2 s2 d2) of
- Return2GMPs a3 s3 d3 a4 s4 d4
- -> (J# a3 s3 d3, J# a4 s4 d4)
-
-{- USING THE UNDERLYING "GMP" CODE IS DUBIOUS FOR NOW:
-
- divMod (J# a1 s1 d1) (J# a2 s2 d2)
- = case (divModInteger# a1 s1 d1 a2 s2 d2) of
- Return2GMPs a3 s3 d3 a4 s4 d4
- -> (J# a3 s3 d3, J# a4 s4 d4)
--}
- toInteger n = n
- toInt (J# a s d) = case (integer2Int# a s d) of { n# -> I# n# }
-
- -- the rest are identical to the report default methods;
- -- you get slightly better code if you let the compiler
- -- see them right here:
- 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 = case (quotRem n d) of { qr@(q,r) ->
- if signum r == negate (signum d) then (q - 1, r+d) else qr }
- -- Case-ified by WDP 94/10
-
-instance Enum Integer where
- enumFrom n = n : enumFrom (n + 1)
- enumFromThen m n = en' m (n - m)
- where en' m n = m : en' (m + n) n
- enumFromTo n m = takeWhile (<= m) (enumFrom n)
- enumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p))
- (enumFromThen n m)
-
-instance Read Integer where
- readsPrec p x = readSigned readDec x
- readList = readList__ (readsPrec 0)
-
-instance Show Integer where
- showsPrec x = showSigned showInt x
- showList = showList__ (showsPrec 0)
-
----------------------------------------------------------------
-data Float = F# Float# deriving (Eq, Ord)
-instance CCallable Float
-instance CReturnable Float
-
----------------------------------------------------------------
-
-instance Num Float where
- (+) x y = plusFloat x y
- (-) x y = minusFloat x y
- negate x = negateFloat x
- (*) x y = timesFloat x y
- abs x | x >= 0.0 = x
- | otherwise = negateFloat x
- signum x | x == 0.0 = 0
- | x > 0.0 = 1
- | otherwise = negate 1
- fromInteger n = encodeFloat n 0
- fromInt i = int2Float i
-
-instance Real Float where
- toRational x = (m%1)*(b%1)^^n
- where (m,n) = decodeFloat x
- b = floatRadix x
-
-instance Fractional Float where
- (/) x y = divideFloat x y
- fromRational x = fromRational__ x
- recip x = 1.0 / x
-
-instance Floating Float where
- pi = 3.141592653589793238
- exp x = expFloat x
- log x = logFloat x
- sqrt x = sqrtFloat x
- sin x = sinFloat x
- cos x = cosFloat x
- tan x = tanFloat x
- asin x = asinFloat x
- acos x = acosFloat x
- atan x = atanFloat x
- sinh x = sinhFloat x
- cosh x = coshFloat x
- tanh x = tanhFloat x
- (**) x y = powerFloat x y
- logBase x y = log y / log x
-
- asinh x = log (x + sqrt (1.0+x*x))
- acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
- atanh x = log ((x+1.0) / sqrt (1.0-x*x))
-
-instance RealFrac Float where
-
- {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-}
- {-# SPECIALIZE truncate :: Float -> Int #-}
- {-# SPECIALIZE round :: Float -> Int #-}
- {-# SPECIALIZE ceiling :: Float -> Int #-}
- {-# SPECIALIZE floor :: Float -> Int #-}
-
- {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-}
- {-# SPECIALIZE truncate :: Float -> Integer #-}
- {-# SPECIALIZE round :: Float -> Integer #-}
- {-# SPECIALIZE ceiling :: Float -> Integer #-}
- {-# SPECIALIZE floor :: Float -> Integer #-}
-
- properFraction x
- = case (decodeFloat x) of { (m,n) ->
- let b = floatRadix x in
- if n >= 0 then
- (fromInteger m * fromInteger b ^ n, 0.0)
- else
- case (quotRem m (b^(negate n))) of { (w,r) ->
- (fromInteger w, encodeFloat r n)
- }
- }
-
- truncate x = case properFraction x of
- (n,_) -> n
-
- round x = case properFraction x of
- (n,r) -> let
- m = if r < 0.0 then n - 1 else n + 1
- half_down = abs r - 0.5
- in
- case (compare half_down 0.0) of
- LT -> n
- EQ -> if even n then n else m
- GT -> m
-
- ceiling x = case properFraction x of
- (n,r) -> if r > 0.0 then n + 1 else n
-
- floor x = case properFraction x of
- (n,r) -> if r < 0.0 then n - 1 else n
-
-instance RealFloat Float where
- floatRadix _ = FLT_RADIX -- from float.h
- floatDigits _ = FLT_MANT_DIG -- ditto
- floatRange _ = (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto
-
- decodeFloat (F# f#)
- = case decodeFloat# f# of
- ReturnIntAndGMP exp# a# s# d# ->
- (J# a# s# d#, I# exp#)
-
- encodeFloat (J# a# s# d#) (I# e#)
- = case encodeFloat# a# s# d# e# of { flt# -> F# flt# }
-
- exponent x = case decodeFloat x of
- (m,n) -> if m == 0 then 0 else n + floatDigits x
-
- significand x = case decodeFloat x of
- (m,_) -> encodeFloat m (negate (floatDigits x))
-
- scaleFloat k x = case decodeFloat x of
- (m,n) -> encodeFloat m (n+k)
-
-instance Read Float where
- readsPrec p x = readSigned readFloat x
- readList = readList__ (readsPrec 0)
-
-instance Show Float where
- showsPrec x = showSigned showFloat x
- showList = showList__ (showsPrec 0)
-
----------------------------------------------------------------
-data Double = D# Double# deriving (Eq, Ord)
-instance CCallable Double
-instance CReturnable Double
-
----------------------------------------------------------------
-
-instance Num Double where
- (+) x y = plusDouble x y
- (-) x y = minusDouble x y
- negate x = negateDouble x
- (*) x y = timesDouble x y
- abs x | x >= 0.0 = x
- | otherwise = negateDouble x
- signum x | x == 0.0 = 0
- | x > 0.0 = 1
- | otherwise = negate 1
- fromInteger n = encodeFloat n 0
- fromInt (I# n#) = case (int2Double# n#) of { d# -> D# d# }
-
-instance Real Double where
- toRational x = (m%1)*(b%1)^^n
- where (m,n) = decodeFloat x
- b = floatRadix x
-
-instance Fractional Double where
- (/) x y = divideDouble x y
- fromRational x = fromRational__ x
- recip x = 1.0 / x
-
-instance Floating Double where
- pi = 3.141592653589793238
- exp x = expDouble x
- log x = logDouble x
- sqrt x = sqrtDouble x
- sin x = sinDouble x
- cos x = cosDouble x
- tan x = tanDouble x
- asin x = asinDouble x
- acos x = acosDouble x
- atan x = atanDouble x
- sinh x = sinhDouble x
- cosh x = coshDouble x
- tanh x = tanhDouble x
- (**) x y = powerDouble x y
- logBase x y = log y / log x
-
- asinh x = log (x + sqrt (1.0+x*x))
- acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
- atanh x = log ((x+1.0) / sqrt (1.0-x*x))
-
-instance RealFrac Double where
-
- {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-}
- {-# SPECIALIZE truncate :: Double -> Int #-}
- {-# SPECIALIZE round :: Double -> Int #-}
- {-# SPECIALIZE ceiling :: Double -> Int #-}
- {-# SPECIALIZE floor :: Double -> Int #-}
-
- {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-}
- {-# SPECIALIZE truncate :: Double -> Integer #-}
- {-# SPECIALIZE round :: Double -> Integer #-}
- {-# SPECIALIZE ceiling :: Double -> Integer #-}
- {-# SPECIALIZE floor :: Double -> Integer #-}
-
-#if defined(__UNBOXED_INSTANCES__)
- {-# SPECIALIZE properFraction :: Double -> (Int#, Double) #-}
- {-# SPECIALIZE truncate :: Double -> Int# #-}
- {-# SPECIALIZE round :: Double -> Int# #-}
- {-# SPECIALIZE ceiling :: Double -> Int# #-}
- {-# SPECIALIZE floor :: Double -> Int# #-}
-#endif
-
- properFraction x
- = case (decodeFloat x) of { (m,n) ->
- let b = floatRadix x in
- if n >= 0 then
- (fromInteger m * fromInteger b ^ n, 0.0)
- else
- case (quotRem m (b^(negate n))) of { (w,r) ->
- (fromInteger w, encodeFloat r n)
- }
- }
-
- truncate x = case properFraction x of
- (n,_) -> n
-
- round x = case properFraction x of
- (n,r) -> let
- m = if r < 0.0 then n - 1 else n + 1
- half_down = abs r - 0.5
- in
- case (compare half_down 0.0) of
- LT -> n
- EQ -> if even n then n else m
- GT -> m
-
- ceiling x = case properFraction x of
- (n,r) -> if r > 0.0 then n + 1 else n
-
- floor x = case properFraction x of
- (n,r) -> if r < 0.0 then n - 1 else n
-
-instance RealFloat Double where
- floatRadix _ = FLT_RADIX -- from float.h
- floatDigits _ = DBL_MANT_DIG -- ditto
- floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto
-
- decodeFloat (D# d#)
- = case decodeDouble# d# of
- ReturnIntAndGMP exp# a# s# d# ->
- (J# a# s# d#, I# exp#)
-
- encodeFloat (J# a# s# d#) (I# e#)
- = case encodeDouble# a# s# d# e# of { dbl# -> D# dbl# }
-
- exponent x = case decodeFloat x of
- (m,n) -> if m == 0 then 0 else n + floatDigits x
-
- significand x = case decodeFloat x of
- (m,_) -> encodeFloat m (negate (floatDigits x))
-
- scaleFloat k x = case decodeFloat x of
- (m,n) -> encodeFloat m (n+k)
-
-instance Read Double where
- readsPrec p x = readSigned readFloat x
- readList = readList__ (readsPrec 0)
-
-instance Show Double where
- showsPrec x = showSigned showFloat x
- showList = showList__ (showsPrec 0)
-
----------------------------------------------------------------
--- 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
-
-instance Enum Double where
- toEnum = fromIntegral
- fromEnum = fromInteger . truncate -- may overflow
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
-
-numericEnumFrom :: (Real a) => a -> [a]
-numericEnumFromThen :: (Real a) => a -> a -> [a]
-numericEnumFrom = iterate (+1)
-numericEnumFromThen n m = iterate (+(m-n)) n
-
----------------------------------------------------------------
--- Lists
-
-data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord)
- -- to avoid weird names like con2tag_[]#
-
-instance CCallable [Char]
-instance CReturnable [Char]
-
-instance (Eq a) => Eq [a] where
- [] == [] = True
- (x:xs) == (y:ys) = x == y && xs == ys
- [] == ys = False
- xs == [] = False
- xs /= ys = if (xs == ys) then False else True
-
-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 }
-
- compare [] [] = EQ
- compare (x:xs) [] = GT
- compare [] (y:ys) = LT
- compare (x:xs) (y:ys) = case compare x y of
- LT -> LT
- GT -> GT
- EQ -> compare xs ys
-
-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
-
-instance (Show a) => Show [a] where
- showsPrec p = showList
- showList = showList__ (showsPrec 0)
-
-instance (Read a) => Read [a] where
- readsPrec p = readList
- readList = readList__ (readsPrec 0)
-
----------------------------------------------------------------
--- Tuples
-
-data (,) a b = (,) a b deriving (Eq, Ord, Bounded)
-data (,,) a b c = (,,) a b c deriving (Eq, Ord, Bounded)
-data (,,,) a b c d = (,,,) a b c d deriving (Eq, Ord, Bounded)
-data (,,,,) a b c d e = (,,,,) a b c d e deriving (Eq, Ord, Bounded)
-data (,,,,,) a b c d e f = (,,,,,) a b c d e f
-data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g
-data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h
-data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i
-data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j
-data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k
-data (,,,,,,,,,,,) a b c d e f g h i j k l = (,,,,,,,,,,,) a b c d e f g h i j k l
-data (,,,,,,,,,,,,) a b c d e f g h i j k l m = (,,,,,,,,,,,,) a b c d e f g h i j k l m
-data (,,,,,,,,,,,,,) a b c d e f g h i j k l m n = (,,,,,,,,,,,,,) a b c d e f g h i j k l m n
-data (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o = (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o
-data (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p = (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p
-data (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q
- = (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q
-data (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r
- = (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r
-data (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s
- = (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s
-data (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t
- = (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t
-data (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u
- = (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u
-data (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v
- = (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v
-data (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w
- = (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w
-data (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x
- = (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x
-data (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y
- = (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y
-data (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z
- = (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_
-data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_
- = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_
- -- if you add more tuples, you need to change the compiler, too
- -- (it has a wired-in number: 37)
-
-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 ] )
- readList = readList__ (readsPrec 0)
-
-instance (Read a, Read b, Read c) => Read (a, b, c) where
- readsPrec p = readParen False
- (\a -> [((x,y,z), h) | ("(",b) <- lex a,
- (x,c) <- readsPrec 0 b,
- (",",d) <- lex c,
- (y,e) <- readsPrec 0 d,
- (",",f) <- lex e,
- (z,g) <- readsPrec 0 f,
- (")",h) <- lex g ] )
- readList = readList__ (readsPrec 0)
-
-instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where
- readsPrec p = readParen False
- (\a -> [((w,x,y,z), j) | ("(",b) <- lex a,
- (w,c) <- readsPrec 0 b,
- (",",d) <- lex c,
- (x,e) <- readsPrec 0 d,
- (",",f) <- lex e,
- (y,g) <- readsPrec 0 f,
- (",",h) <- lex g,
- (z,i) <- readsPrec 0 h,
- (")",j) <- lex i ] )
- readList = readList__ (readsPrec 0)
-
-instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where
- readsPrec p = readParen False
- (\a -> [((w,x,y,z,v), l) | ("(",b) <- lex a,
- (w,c) <- readsPrec 0 b,
- (",",d) <- lex c,
- (x,e) <- readsPrec 0 d,
- (",",f) <- lex e,
- (y,g) <- readsPrec 0 f,
- (",",h) <- lex g,
- (z,i) <- readsPrec 0 h,
- (",",j) <- lex i,
- (v,k) <- readsPrec 0 j,
- (")",l) <- lex k ] )
- readList = readList__ (readsPrec 0)
-
-instance (Show a, Show b) => Show (a,b) where
- showsPrec p (x,y) = showChar '(' . shows x . showString ", " .
- shows y . showChar ')'
- showList = showList__ (showsPrec 0)
-
-instance (Show a, Show b, Show c) => Show (a, b, c) where
- showsPrec p (x,y,z) = showChar '(' . showsPrec 0 x . showString ", " .
- showsPrec 0 y . showString ", " .
- showsPrec 0 z . showChar ')'
- showList = showList__ (showsPrec 0)
-
-instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where
- showsPrec p (w,x,y,z) = showChar '(' . showsPrec 0 w . showString ", " .
- showsPrec 0 x . showString ", " .
- showsPrec 0 y . showString ", " .
- showsPrec 0 z . showChar ')'
-
- showList = showList__ (showsPrec 0)
-
-instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where
- showsPrec p (v,w,x,y,z) = showChar '(' . showsPrec 0 v . showString ", " .
- showsPrec 0 w . showString ", " .
- showsPrec 0 x . showString ", " .
- showsPrec 0 y . showString ", " .
- showsPrec 0 z . showChar ')'
- showList = showList__ (showsPrec 0)
-
----------------------------------------------------------------------
--- 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)
-
--- Functions
-
--- Standard value bindings
-
--- identity function
-id :: a -> a
-id x = x
-
--- constant function
-const :: a -> b -> a
-const x _ = x
-
--- function composition
-{-# INLINE (.) #-}
-{-# GENERATE_SPECS (.) a b c #-}
-(.) :: (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
-
--- 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
-
-error :: String -> a
-error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) s
-
--- It is expected that compilers will recognize this and insert error
--- messages which are more appropriate to the context in which undefined
--- appears.
-
-undefined :: a
-undefined = error "Prelude.undefined"
-
--- ============================================================
--- Standard list functions
--- ============================================================
-
-{- module PreludeList -}
-
--- 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; it is an instance
--- of the more general genericLength, the result type of which may be
--- any kind of number.
-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]
-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 = let (ys,zs) = span p xs' in (x:ys,zs)
- | otherwise = ([],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]
-words s = case dropWhile {-partain:Char.-}isSpace s of
- "" -> []
- s' -> w : words s''
- where (w, s'') =
- break {-partain:Char.-}isSpace s'
-
-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 (not . (/= 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))
- ([],[],[])
-
-{- module PreludeText -}
-
-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) = showString ", " . 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 ]
-
--- lex: moved to GHCbase
-
-{- module PreludeIO -}
-
--- in GHCio: type FilePath = String
-
-fail :: IOError -> IO a
-fail err = IO $ ST $ \ s -> (Left err, s)
-
-userError :: String -> IOError
-userError str = UserError str
-
-catch :: IO a -> (IOError -> IO a) -> IO a
-catch (IO (ST m)) k = IO $ ST $ \ s ->
- case (m s) of { (r, new_s) ->
- case r of
- Right _ -> (r, new_s)
- Left err -> case (k err) of { IO (ST k_err) ->
- (k_err new_s) }}
-
-putChar :: Char -> IO ()
-putChar c = hPutChar stdout c
-
-putStr :: String -> IO ()
-putStr s = hPutStr stdout s
-
-putStrLn :: String -> IO ()
-putStrLn s = do putStr s
- putChar '\n'
-
-print :: Show a => a -> IO ()
-print x = putStrLn (show x)
-
-getChar :: IO Char
-getChar = hGetChar stdin
-
-getLine :: IO String
-getLine = do c <- getChar
- if c == '\n' then return "" else
- do s <- getLine
- return (c:s)
-
-getContents :: IO String
-getContents = hGetContents stdin
-
-interact :: (String -> String) -> IO ()
-interact f = do s <- getContents
- putStr (f s)
-
-readFile :: FilePath -> IO String
-readFile name = openFile name ReadMode >>= hGetContents
-
-writeFile :: FilePath -> String -> IO ()
-writeFile name str
- = openFile name WriteMode >>= \hdl -> hPutStr hdl str >> hClose hdl
-
-appendFile :: FilePath -> String -> IO ()
-appendFile name str
- = openFile name AppendMode >>= \hdl -> hPutStr hdl str >> hClose hdl
-
-readIO :: Read a => String -> IO a
- -- raises an exception instead of an error
-readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
- [x] -> return x
- [] -> fail (userError "PreludeIO.readIO: no parse")
- _ -> fail (userError
- "PreludeIO.readIO: ambiguous parse")
-
-readLn :: Read a => IO a
-readLn = do l <- getLine
- r <- readIO l
- return r