hat-2.8.0.0: libraries/PreludeBasic.hs
-- Contains all parts of the Prelude and Char (both are mutually
-- recursive) that can be expressed in Haskell (assuming
-- nhc98's ability to derive instances of [],(,,,) etc).
-- Hand-generated from Haskell
module PreludeBasic
(module PreludeBasic, module PreludeBuiltin)
where
-- import PreludeBuiltin -- Contains all `prim' values
-- import PreludeList
-- import PreludeText
-- import PreludeIO
-- import Ratio( Rational )
import PreludeBuiltinTypes
import PreludeBuiltin
import PreludeBuiltin as PreludeBasic -- for PreludeBasic.undefined
infixr 9 .
infixr 8 ^, ^^, **
infixl 7 *, /, `quot`, `rem`, `div`, `mod`
infixl 6 +, -
-- The (:) operator is built-in syntax, and cannot legally be given
-- a fixity declaration; but its fixity is given by:
-- infixr 5 :
infix 4 ==, /=, <, <=, >=, >
infixr 3 &&
infixr 2 ||
infixl 1 >>, >>=
infixr 1 =<<
infixr 0 $, $! --, `seq`
-- Internal functions used by the transformation in desugaring
-- and deriving of instances.
-- Not exported from Prelude itself.
yield :: a -> ReadS a
yield x r = [(x,r)]
lift :: (a -> b -> ReadS c) -> ReadS a -> ReadS b -> ReadS c
lift c f g r = concatMap (\(x,s) -> concatMap (\(y,t) -> c x y t) (g s)) (f r)
thenAp :: ReadS (a -> b) -> ReadS a -> ReadS b
thenAp = lift (\h x t -> [(h x,t)])
thenLex :: ReadS a -> String -> ReadS a
thenLex f xs = lift (\x y t -> if y==xs then [(x,t)] else []) f lex
alt :: ReadS a -> ReadS a -> ReadS a
alt f g r = f r ++ g r
-- For desugaring list comprehensions:
guard :: Bool -> [()]
guard p = if p then [()] else []
-- Standard types, classes, instances and related functions
-- Equality and Ordered classes
class Eq a where
(==), (/=) :: a -> a -> Bool
-- Minimal complete definition:
-- (==) or (/=)
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
-- Minimal complete definition:
-- (<=) or compare
-- 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 = y
| otherwise = x
min x y
| x <= y = x
| otherwise = y
-- Enumeration and Bounded classes
class Enum a where
succ, pred :: a -> a
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]
-- Minimal complete definition:
-- toEnum, fromEnum
--
-- NOTE: these default methods only make sense for types
-- that map injectively into Int using fromEnum
-- and toEnum.
succ = toEnum . (+1) . fromEnum
pred = toEnum . (subtract 1) . fromEnum
enumFrom x = map toEnum [fromEnum x ..]
enumFromTo x y = map toEnum [fromEnum x .. fromEnum y]
enumFromThen x y = map toEnum [fromEnum x, fromEnum y ..]
enumFromThenTo x y z =
map toEnum [fromEnum x, fromEnum y .. fromEnum z]
class Bounded a where
minBound :: a
maxBound :: a
-- Numeric classes
class (Eq a, Show a) => Num a where
(+), (-), (*) :: a -> a -> a
negate :: a -> a
abs, signum :: a -> a
fromInteger :: Integer -> a
-- Minimal complete definition:
-- All, except negate or (-)
x - y = x + negate y
negate x = 0 - x
class (Num a, Ord a) => Real a where
toRational :: a -> Rational
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 -> Integer
-- Minimal complete definition:
-- quotRem, toInteger
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
-- replaced prefix - by negate
-- to make AuxFixity of nhc98 happy
where qr@(q,r) = quotRem n d
class (Num a) => Fractional a where
(/) :: a -> a -> a
recip :: a -> a
fromRational :: Rational -> a
-- Minimal complete definition:
-- fromRational and (recip or (/))
recip x = 1 / x
x / y = x * recip y
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
-- Minimal complete definition:
-- pi, exp, log, sin, cos, sinh, cosh
-- asin, acos, atan
-- asinh, acosh, atanh
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
-- Minimal complete definition:
-- properFraction
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) `compare` 0 of
LT -> n
EQ -> if even n then n else m
GT -> m
-- original version
-- nhc doesn't like prefix - when prelude is not imported unqualified
-- 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
atan2 :: a -> a -> a
-- Minimal complete definition:
-- All except exponent, significand,
-- scaleFloat, atan2
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
atan2 y x
| x>0 = atan (y/x)
| x==0 && y>0 = pi/2
| x<0 && y>0 = pi + atan (y/x)
|(x<=0 && y<0) ||
(x<0 && isNegativeZero y) ||
(isNegativeZero x && isNegativeZero y)
= -atan2 (-y) x
| y==0 && (x<0 || isNegativeZero x)
= pi -- must be after the previous test on zero y
| x==0 && y==0 = y -- must be after the other double zero tests
| otherwise = x + y -- x or y is a NaN, return a NaN (via +)
-- 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
realToFrac :: (Real a, Fractional b) => a -> b
realToFrac = fromRational . toRational
-- Monadic classes
class Functor f where
fmap :: (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
fail :: String -> m a
-- Minimal complete definition:
-- (>>=), return
m >> k = m >>= \_ -> k
fail s = error s
sequence :: Monad m => [m a] -> m [a]
sequence = foldr mcons (return [])
where mcons p q = p >>= \x -> q >>= \y -> return (x:y)
sequence_ :: Monad m => [m a] -> m ()
sequence_ = foldr (>>) (return ())
-- The xxxM functions take list arguments, but lift the function or
-- list element to a monad type
mapM :: Monad m => (a -> m b) -> [a] -> m [b]
mapM f as = sequence (map f as)
mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
mapM_ f as = sequence_ (map f as)
(=<<) :: Monad m => (a -> m b) -> m a -> m b
f =<< x = x >>= f
-- Trivial type
-- data () = () deriving (Eq, Ord, Enum, Bounded)
instance Eq () where
() == () = True
instance Ord () where
compare () () = EQ
instance Enum () where
fromEnum () = 0
toEnum n | n==0 = ()
toEnum n = error ("Prelude.Enum_Prelude.Unit_toEnum on " ++ show n)
instance Bounded () where
minBound = ()
maxBound = ()
-- Function type
-- data a -> b -- No constructor for functions is exported.
-- 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
-- seq :: a -> b -> b
-- seq = ... -- Primitive
-- right-associating infix application operators
-- (useful in continuation-passing style)
($), ($!) :: (a -> b) -> a -> b
f $ x = f x
f $! x = x `seq` f x
-- Boolean type
-- data Bool = False | True deriving (Eq, Ord, Enum, Read, Show, Bounded)
instance Eq Bool where
True == True = True
False == False = True
_ == _ = False
instance Ord Bool where
compare False False = EQ
compare False True = LT
compare True False = GT
compare True True = EQ
instance Enum Bool where
fromEnum False = 0
fromEnum True = 1
toEnum 0 = False
toEnum 1 = True
toEnum n = error ("(Prelude.toEnum "++show n++" :: Bool) is wrong")
enumFrom b = enumFromTo b True
enumFromThen b1 b2 = enumFromThenTo b1 b2 (b2 >= b1)
instance Read Bool where
readsPrec p = readParen False
( \r -> [(False,s) | ("False",s) <- lex r] ++
[(True,s) | ("True",s) <- lex r])
instance Show Bool where
showsPrec p False = showString "False"
showsPrec p True = showString "True"
instance Bounded Bool where
minBound = False
maxBound = True
-- 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 = ... 'a' | 'b' ... -- 2^16 unicode values
instance Eq Char where
c == c' = fromEnum c == fromEnum c'
instance Ord Char where
c <= c' = fromEnum c <= fromEnum c'
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'
maxBound = primUnicodeMaxBound
-- 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
fmap f Nothing = Nothing
fmap f (Just x) = Just (f x)
instance Monad Maybe where
(Just x) >>= k = k x
Nothing >>= k = Nothing
return = Just
fail s = Nothing
-- 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
-- data IO a -- abstract
instance Functor IO where
fmap f x = x >>= (return . f)
instance Monad IO where
(>>=) = primIOBind
return = primIOReturn
fail s = ioError (userError s)
-- 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.
-- data Int = minBound ... -1 | 0 | 1 ... maxBound
instance Eq Int where
a == b = primIntEq a b
a /= b = primIntNe a b
instance Ord Int where
a < b = primIntLt a b
a <= b = primIntLe a b
a >= b = primIntGe a b
a > b = primIntGt a b
instance Num Int where
a + b = primIntPlus a b
a - b = primIntMinus a b
a * b = primIntTimes a b
negate a = primIntNegate a
abs a = primIntAbs a
signum a = primIntSignum a
fromInteger i = primIntFromInteger i
instance Real Int where
toRational i = (toInteger i) % 1
instance Integral Int where
n `quot` d = primIntQuot n d
n `rem` d = primIntRem n d
n `quotRem` d = (n `quot` d, n `rem` d)
toInteger n = primIntegerFromInt n
instance Enum Int where
toEnum = id
fromEnum = id
enumFrom x = enumFromTo x maxBound
enumFromThen x y = enumFromThenTo x y (if y >= x then maxBound else minBound)
enumFromTo n m = intEnumFromByTo n 1 m
enumFromThenTo n n' m = intEnumFromByTo n (n'-n) m
-- need to avoid evaluating number beyond m,
-- because m can be maxBound or minBound
intEnumFromByTo :: Int -> Int -> Int -> [Int]
intEnumFromByTo n d m =
case d `compare` 0 of
GT -> if n > m then [] else go (<= m-d) n
EQ -> repeat n
LT -> if n < m then [] else go (>= m-d) n
where
go :: (Int -> Bool) -> Int -> [Int]
go continue n = n : if (continue n) then go continue (n+d) else []
instance Bounded Int where
minBound = primIntMinBound
maxBound = primIntMaxBound
-- data Integer = ... -1 | 0 | 1 ...
instance Eq Integer where
a == b = primIntegerEq a b
a /= b = primIntegerNe a b
instance Ord Integer where
a < b = primIntegerLt a b
a <= b = primIntegerLe a b
a >= b = primIntegerGe a b
a > b = primIntegerGt a b
instance Num Integer where
a + b = primIntegerAdd a b
a - b = primIntegerSub a b
a * b = primIntegerMul a b
negate a = primIntegerNeg a
abs i = if i < 0 then negate i else i
signum i = case compare i 0 of
LT -> negate 1
EQ -> 0
GT -> 1
fromInteger a = a -- id a
instance Real Integer where
toRational i = i % 1
instance Integral Integer where
n `quot` d = primIntegerQuot n d
n `rem` d = primIntegerRem n d
n `div` d = fst (divMod n d)
n `mod` d = snd (divMod n d)
n `quotRem` d = primIntegerQuotRem n d
toInteger n = n
instance Enum Integer where
succ x = x+1
pred x = x-1
toEnum x = toInteger x
fromEnum x = fromInteger x
enumFrom = iterate (+1)
enumFromThen n n' = iterate (+(n'-n)) n
enumFromTo n m = takeWhile (<= m) (iterate (+1) n)
enumFromThenTo n n' m =
let d = n'-n in
(if d >= 0 then takeWhile (<= m) (iterate (+d) n)
else takeWhile (>= m) (iterate (+d) n) )
-- data Float
instance Eq Float where
a == b = primFloatEq a b
a /= b = primFloatNe a b
instance Ord Float where
a < b = primFloatLt a b
a <= b = primFloatLe a b
a >= b = primFloatGe a b
a > b = primFloatGt a b
instance Num Float where
a + b = primFloatAdd a b
a - b = primFloatSub a b
a * b = primFloatMul a b
negate a = 0 - a
abs a = primFloatAbs a
signum a = primFloatSignum a
fromInteger i = primFloatFromInteger i
instance Real Float where
toRational x = case decodeFloat x of (m,n) -> (m%1)*(bf%1)^^n
where bf = floatRadix x
instance Fractional Float where
x / y = primFloatDiv x y
fromRational x = x0
where x0 = ff ef
ff ef = if ef' == ef then yf else ff ef'
where yf :: Float
yf = encodeFloat (round (x * (1 % bf) ^^ ef)) ef
(_,ef') = decodeFloat yf
bf = floatRadix x0
(_,ef) = decodeFloat (fromInteger (numerator x) `asTypeOf` x0
/ fromInteger (denominator x))
instance Floating Float where
pi = primFloatPi
exp x = primFloatExp x
log x = primFloatLog x
sqrt x = primFloatSqrt x
sin x = primFloatSin x
cos x = primFloatCos x
tan x = primFloatTan x
asin x = primFloatAsin x
acos x = primFloatAcos x
atan x = primFloatAtan x
sinh x = 0.5 * (exp x - exp (-x))
cosh x = 0.5 * (exp x + exp (-x))
tanh x = (af-bf)/(af+bf) where af = exp x ; bf = exp (-x)
asinh x = log (x + sqrt (1+x*x))
acosh x = log (x + (x+1) * sqrt ((x-1)/(x+1)))
atanh x = log ((x+1) / sqrt (1 - x*x))
instance RealFrac Float where
properFraction x =
case decodeFloat x of
(m,n) -> if n >= 0 then
(fromInteger m * fromInteger (floatRadix x) ^ n, 0)
else
case quotRem m ((floatRadix x)^(negate n)) of
(w,r) -> (fromInteger w, encodeFloat r n)
instance RealFloat Float where
floatRadix = primFloatRadix
floatDigits = primFloatDigits
floatRange = primFloatRange
decodeFloat x = primDecodeFloat x
encodeFloat x y = primEncodeFloat x y
isNaN = primFloatIsNaN
isInfinite = primFloatIsInfinite
isDenormalized = primFloatIsDenormalized
isNegativeZero = primFloatIsNegativeZero
isIEEE = primFloatIsIEEE
-- data Double
instance Eq Double where
a == b = primDoubleEq a b
a /= b = primDoubleNe a b
instance Ord Double where
a < b = primDoubleLt a b
a <= b = primDoubleLe a b
a >= b = primDoubleGe a b
a > b = primDoubleGt a b
instance Num Double where
a + b = primDoubleAdd a b
a - b = primDoubleSub a b
a * b = primDoubleMul a b
negate a = (0 - a)
abs a = primDoubleAbs a
signum a = primDoubleSignum a
fromInteger i = primDoubleFromInteger i
instance Real Double where
toRational x = case decodeFloat x of (m,n) -> (m%1)*(b%1)^^n
where b = floatRadix x
instance Fractional Double where
x / y = primDoubleDiv x y
fromRational x =
let f ex = let y :: Double
y = encodeFloat (round (x * (1 % bd) ^^ ex)) ex
e' = snd (decodeFloat y)
bd = floatRadix x'
in if e' == ex then y else f e'
e = snd (decodeFloat (fromInteger (numerator x) `asTypeOf` x'
/ fromInteger (denominator x)))
x' = f e
in x'
instance Floating Double where
pi = primDoublePi
exp x = primDoubleExp x
log x = primDoubleLog x
sqrt x = primDoubleSqrt x
sin x = primDoubleSin x
cos x = primDoubleCos x
tan x = primDoubleTan x
asin x = primDoubleAsin x
acos x = primDoubleAcos x
atan x = primDoubleAtan x
sinh x = fromRational (1%2) * (exp x - exp (-x))
cosh x = fromRational (1%2) * (exp x + exp (-x))
tanh x = (a-b)/(a+b) where a = exp x ; b = exp (-x)
asinh x = log (x + sqrt (1+x*x))
acosh x = log (x + (x+1) * sqrt ((x-1)/(x+1)))
atanh x = log ((x+1) / sqrt (1 - x*x))
instance RealFrac Double where
properFraction x =
case decodeFloat x of
(m,n) -> if n >= 0 then
(fromInteger m * fromInteger (floatRadix x) ^ n, 0)
else
case quotRem m ((floatRadix x)^(negate n)) of
(w,r) -> (fromInteger w, encodeFloat r n)
instance RealFloat Double where
floatRadix = primDoubleRadix
floatDigits = primDoubleDigits
floatRange = primDoubleRange
decodeFloat x = primDecodeDouble x
encodeFloat x y = primEncodeDouble x y
isNaN = primDoubleIsNaN
isInfinite = primDoubleIsInfinite
isDenormalized = primDoubleIsDenormalized
isNegativeZero = primDoubleIsNegativeZero
isIEEE = primDoubleIsIEEE
-- 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 .. 0.95]. 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
succ x = x+1
pred x = x-1
toEnum = fromIntegral
fromEnum = fromInteger . truncate -- may overflow
enumFrom = numericEnumFrom
enumFromThen = numericEnumFromThen
enumFromTo = numericEnumFromTo
enumFromThenTo = numericEnumFromThenTo
instance Enum Double where
succ x = x+1
pred x = x-1
toEnum = fromIntegral
fromEnum = fromInteger . truncate -- may overflow
enumFrom = numericEnumFrom
enumFromThen = numericEnumFromThen
enumFromTo = numericEnumFromTo
enumFromThenTo = numericEnumFromThenTo
numericEnumFrom :: (Fractional a) => a -> [a]
numericEnumFromThen :: (Fractional a) => a -> a -> [a]
numericEnumFromTo :: (Fractional a, Ord a) => a -> a -> [a]
numericEnumFromThenTo :: (Fractional a, Ord a) => a -> a -> a -> [a]
numericEnumFrom = iterate (+1)
numericEnumFromThen n m = iterate (+(m-n)) n
numericEnumFromTo n m = takeWhile (<= m+1/2) (numericEnumFrom n)
numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
where
p | n' > n = (<= m + (n'-n)/2)
| otherwise = (>= m + (n'-n)/2)
-- Lists
-- This data declaration is not legal Haskell
-- but it indicates the idea
-- data [] a = [] | a : [a] deriving (Eq, Ord)
instance Eq a => Eq [a] where
[] == [] = True
(a:as) == (b:bs) = a == b && as == bs
_ == _ = False
instance Ord a => Ord [a] where
compare [] [] = EQ
compare [] (b:bs) = LT
compare (a:as) [] = GT
compare (a:as) (b:bs) =
case compare a b of
LT -> LT
EQ -> compare as bs
GT -> GT
instance Functor [] where
fmap = map
instance Monad [] where
m >>= k = concat (map k m)
return x = [x]
fail s = []
-- Tuples
-- data (,) a b = (,) a b
-- deriving (Eq, Ord, Bounded)
-- the types are defined in Hat to refer to them via T
-- hence instances cannot be derived
instance (Eq a,Eq b) => Eq (a,b) where
(a,b) == (a',b') = a == a' && b == b'
instance (Ord a,Ord b) => Ord (a,b) where
compare (a,b) (a',b') =
case compare a a' of
LT -> LT
EQ -> compare b b'
GT -> GT
instance (Bounded a, Bounded b) => Bounded (a,b) where
minBound = (minBound, minBound)
maxBound = (maxBound, maxBound)
instance (Eq a,Eq b,Eq c) => Eq (a,b,c) where
(a,b,c) == (a',b',c') = a == a' && b == b' && c == c'
instance (Ord a,Ord b,Ord c) => Ord (a,b,c) where
compare (a,b,c) (a',b',c') =
case compare a a' of
EQ -> case compare b b' of
EQ -> compare c c'
x -> x
x -> x
instance (Bounded a,Bounded b,Bounded c) => Bounded (a,b,c) where
minBound = (minBound,minBound,minBound)
maxBound = (maxBound,maxBound,maxBound)
instance (Eq a,Eq b,Eq c,Eq d) => Eq (a,b,c,d) where
(a,b,c,d) == (a',b',c',d') = a == a' && b == b' && c == c' && d == d'
instance (Ord a,Ord b,Ord c,Ord d) => Ord (a,b,c,d) where
compare (a,b,c,d) (a',b',c',d') =
case compare a a' of
EQ -> case compare b b' of
EQ -> case compare c c' of
EQ -> compare d d'
x -> x
x -> x
x -> x
instance (Bounded a,Bounded b,Bounded c,Bounded d) => Bounded (a,b,c,d) where
minBound = (minBound,minBound,minBound,minBound)
maxBound = (maxBound,maxBound,maxBound,maxBound)
instance (Eq a,Eq b,Eq c,Eq d,Eq e) => Eq (a,b,c,d,e) where
(a,b,c,d,e) == (a',b',c',d',e') =
a == a' && b == b' && c == c' && d == d' && e == e'
instance (Ord a,Ord b,Ord c,Ord d,Ord e) => Ord (a,b,c,d,e) where
compare (a,b,c,d,e) (a',b',c',d',e') =
case compare a a' of
EQ -> case compare b b' of
EQ -> case compare c c' of
EQ -> case compare d d' of
EQ -> compare e e'
x -> x
x -> x
x -> x
x -> x
instance (Bounded a,Bounded b,Bounded c,Bounded d,Bounded e)
=> Bounded (a,b,c,d,e) where
minBound = (minBound,minBound,minBound,minBound,minBound)
maxBound = (maxBound,maxBound,maxBound,maxBound,maxBound)
instance (Eq a,Eq b,Eq c,Eq d,Eq e,Eq f) => Eq (a,b,c,d,e,f) where
(a,b,c,d,e,f) == (a',b',c',d',e',f') =
a == a' && b == b' && c == c' && d == d' && e == e' && f == f'
instance (Ord a,Ord b,Ord c,Ord d,Ord e,Ord f) => Ord (a,b,c,d,e,f) where
compare (a,b,c,d,e,f) (a',b',c',d',e',f') =
case compare a a' of
EQ -> case compare b b' of
EQ -> case compare c c' of
EQ -> case compare d d' of
EQ -> case compare e e' of
EQ -> compare f f'
x -> x
x -> x
x -> x
x -> x
x -> x
instance (Bounded a,Bounded b,Bounded c,Bounded d,Bounded e,Bounded f)
=> Bounded (a,b,c,d,e,f) where
minBound = (minBound,minBound,minBound,minBound,minBound,minBound)
maxBound = (maxBound,maxBound,maxBound,maxBound,maxBound,maxBound)
instance (Eq a,Eq b,Eq c,Eq d,Eq e,Eq f,Eq g) => Eq (a,b,c,d,e,f,g) where
(a,b,c,d,e,f,g) == (a',b',c',d',e',f',g') =
a == a' && b == b' && c == c' && d == d' && e == e' && f == f' && g == g'
instance (Ord a,Ord b,Ord c,Ord d,Ord e,Ord f,Ord g)
=> Ord (a,b,c,d,e,f,g) where
compare (a,b,c,d,e,f,g) (a',b',c',d',e',f',g') =
case compare a a' of
EQ -> case compare b b' of
EQ -> case compare c c' of
EQ -> case compare d d' of
EQ -> case compare e e' of
EQ -> case compare f f' of
EQ -> compare g g'
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
instance (Bounded a,Bounded b,Bounded c,Bounded d,Bounded e,Bounded f
,Bounded g)
=> Bounded (a,b,c,d,e,f,g) where
minBound = (minBound,minBound,minBound,minBound,minBound,minBound,minBound)
maxBound = (maxBound,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound)
instance (Eq a,Eq b,Eq c,Eq d,Eq e,Eq f,Eq g,Eq h)
=> Eq (a,b,c,d,e,f,g,h) where
(a,b,c,d,e,f,g,h) == (a',b',c',d',e',f',g',h') =
a == a' && b == b' && c == c' && d == d' && e == e' && f == f' && g == g'
&& h == h'
instance (Ord a,Ord b,Ord c,Ord d,Ord e,Ord f,Ord g,Ord h)
=> Ord (a,b,c,d,e,f,g,h) where
compare (a,b,c,d,e,f,g,h) (a',b',c',d',e',f',g',h') =
case compare a a' of
EQ -> case compare b b' of
EQ -> case compare c c' of
EQ -> case compare d d' of
EQ -> case compare e e' of
EQ -> case compare f f' of
EQ -> case compare g g' of
EQ -> compare h h'
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
instance (Bounded a,Bounded b,Bounded c,Bounded d,Bounded e,Bounded f
,Bounded g,Bounded h)
=> Bounded (a,b,c,d,e,f,g,h) where
minBound = (minBound,minBound,minBound,minBound,minBound,minBound,minBound
,minBound)
maxBound = (maxBound,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound
,maxBound)
instance (Eq a,Eq b,Eq c,Eq d,Eq e,Eq f,Eq g,Eq h,Eq i)
=> Eq (a,b,c,d,e,f,g,h,i) where
(a,b,c,d,e,f,g,h,i) == (a',b',c',d',e',f',g',h',i') =
a == a' && b == b' && c == c' && d == d' && e == e' && f == f' && g == g'
&& h == h' && i == i'
instance (Ord a,Ord b,Ord c,Ord d,Ord e,Ord f,Ord g,Ord h,Ord i)
=> Ord (a,b,c,d,e,f,g,h,i) where
compare (a,b,c,d,e,f,g,h,i) (a',b',c',d',e',f',g',h',i') =
case compare a a' of
EQ -> case compare b b' of
EQ -> case compare c c' of
EQ -> case compare d d' of
EQ -> case compare e e' of
EQ -> case compare f f' of
EQ -> case compare g g' of
EQ -> case compare h h' of
EQ -> compare i i'
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
instance (Bounded a,Bounded b,Bounded c,Bounded d,Bounded e,Bounded f
,Bounded g,Bounded h,Bounded i)
=> Bounded (a,b,c,d,e,f,g,h,i) where
minBound = (minBound,minBound,minBound,minBound,minBound,minBound,minBound
,minBound,minBound)
maxBound = (maxBound,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound
,maxBound,maxBound)
instance (Eq a,Eq b,Eq c,Eq d,Eq e,Eq f,Eq g,Eq h,Eq i,Eq j)
=> Eq (a,b,c,d,e,f,g,h,i,j) where
(a,b,c,d,e,f,g,h,i,j) == (a',b',c',d',e',f',g',h',i',j') =
a == a' && b == b' && c == c' && d == d' && e == e' && f == f' && g == g'
&& h == h' && i == i' && j == j'
instance (Ord a,Ord b,Ord c,Ord d,Ord e,Ord f,Ord g,Ord h,Ord i,Ord j)
=> Ord (a,b,c,d,e,f,g,h,i,j) where
compare (a,b,c,d,e,f,g,h,i,j) (a',b',c',d',e',f',g',h',i',j') =
case compare a a' of
EQ -> case compare b b' of
EQ -> case compare c c' of
EQ -> case compare d d' of
EQ -> case compare e e' of
EQ -> case compare f f' of
EQ -> case compare g g' of
EQ -> case compare h h' of
EQ -> case compare i i' of
EQ -> compare j j'
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
instance (Bounded a,Bounded b,Bounded c,Bounded d,Bounded e,Bounded f
,Bounded g,Bounded h,Bounded i,Bounded j)
=> Bounded (a,b,c,d,e,f,g,h,i,j) where
minBound = (minBound,minBound,minBound,minBound,minBound,minBound,minBound
,minBound,minBound,minBound)
maxBound = (maxBound,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound
,maxBound,maxBound,maxBound)
instance (Eq a,Eq b,Eq c,Eq d,Eq e,Eq f,Eq g,Eq h,Eq i,Eq j,Eq k)
=> Eq (a,b,c,d,e,f,g,h,i,j,k) where
(a,b,c,d,e,f,g,h,i,j,k) == (a',b',c',d',e',f',g',h',i',j',k') =
a == a' && b == b' && c == c' && d == d' && e == e' && f == f' && g == g'
&& h == h' && i == i' && j == j' && k == k'
instance (Ord a,Ord b,Ord c,Ord d,Ord e,Ord f,Ord g,Ord h,Ord i,Ord j,Ord k)
=> Ord (a,b,c,d,e,f,g,h,i,j,k) where
compare (a,b,c,d,e,f,g,h,i,j,k) (a',b',c',d',e',f',g',h',i',j',k') =
case compare a a' of
EQ -> case compare b b' of
EQ -> case compare c c' of
EQ -> case compare d d' of
EQ -> case compare e e' of
EQ -> case compare f f' of
EQ -> case compare g g' of
EQ -> case compare h h' of
EQ -> case compare i i' of
EQ -> case compare j j' of
EQ -> compare k k'
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
instance (Bounded a,Bounded b,Bounded c,Bounded d,Bounded e,Bounded f
,Bounded g,Bounded h,Bounded i,Bounded j,Bounded k)
=> Bounded (a,b,c,d,e,f,g,h,i,j,k) where
minBound = (minBound,minBound,minBound,minBound,minBound,minBound,minBound
,minBound,minBound,minBound,minBound)
maxBound = (maxBound,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound
,maxBound,maxBound,maxBound,maxBound)
instance (Eq a,Eq b,Eq c,Eq d,Eq e,Eq f,Eq g,Eq h,Eq i,Eq j,Eq k,Eq l)
=> Eq (a,b,c,d,e,f,g,h,i,j,k,l) where
(a,b,c,d,e,f,g,h,i,j,k,l) == (a',b',c',d',e',f',g',h',i',j',k',l') =
a == a' && b == b' && c == c' && d == d' && e == e' && f == f' && g == g'
&& h == h' && i == i' && j == j' && k == k' && l == l'
instance (Ord a,Ord b,Ord c,Ord d,Ord e,Ord f,Ord g,Ord h,Ord i,Ord j,Ord k
,Ord l)
=> Ord (a,b,c,d,e,f,g,h,i,j,k,l) where
compare (a,b,c,d,e,f,g,h,i,j,k,l) (a',b',c',d',e',f',g',h',i',j',k',l') =
case compare a a' of
EQ -> case compare b b' of
EQ -> case compare c c' of
EQ -> case compare d d' of
EQ -> case compare e e' of
EQ -> case compare f f' of
EQ -> case compare g g' of
EQ -> case compare h h' of
EQ -> case compare i i' of
EQ -> case compare j j' of
EQ -> case compare k k' of
EQ -> compare l l'
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
instance (Bounded a,Bounded b,Bounded c,Bounded d,Bounded e,Bounded f
,Bounded g,Bounded h,Bounded i,Bounded j,Bounded k,Bounded l)
=> Bounded (a,b,c,d,e,f,g,h,i,j,k,l) where
minBound = (minBound,minBound,minBound,minBound,minBound,minBound,minBound
,minBound,minBound,minBound,minBound,minBound)
maxBound = (maxBound,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound
,maxBound,maxBound,maxBound,maxBound,maxBound)
instance (Eq a,Eq b,Eq c,Eq d,Eq e,Eq f,Eq g,Eq h,Eq i,Eq j,Eq k,Eq l,Eq m)
=> Eq (a,b,c,d,e,f,g,h,i,j,k,l,m) where
(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') =
a == a' && b == b' && c == c' && d == d' && e == e' && f == f' && g == g'
&& h == h' && i == i' && j == j' && k == k' && l == l' && m == m'
instance (Ord a,Ord b,Ord c,Ord d,Ord e,Ord f,Ord g,Ord h,Ord i,Ord j,Ord k
,Ord l,Ord m)
=> Ord (a,b,c,d,e,f,g,h,i,j,k,l,m) where
compare (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') =
case compare a a' of
EQ -> case compare b b' of
EQ -> case compare c c' of
EQ -> case compare d d' of
EQ -> case compare e e' of
EQ -> case compare f f' of
EQ -> case compare g g' of
EQ -> case compare h h' of
EQ -> case compare i i' of
EQ -> case compare j j' of
EQ -> case compare k k' of
EQ -> case compare l l' of
EQ -> compare m m'
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
instance (Bounded a,Bounded b,Bounded c,Bounded d,Bounded e,Bounded f
,Bounded g,Bounded h,Bounded i,Bounded j,Bounded k,Bounded l
,Bounded m)
=> Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m) where
minBound = (minBound,minBound,minBound,minBound,minBound,minBound,minBound
,minBound,minBound,minBound,minBound,minBound,minBound)
maxBound = (maxBound,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound
,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound)
instance (Eq a,Eq b,Eq c,Eq d,Eq e,Eq f,Eq g,Eq h,Eq i,Eq j,Eq k,Eq l,Eq m
,Eq n)
=> Eq (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
(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') =
a == a' && b == b' && c == c' && d == d' && e == e' && f == f' && g == g'
&& h == h' && i == i' && j == j' && k == k' && l == l' && m == m'
&& n == n'
instance (Ord a,Ord b,Ord c,Ord d,Ord e,Ord f,Ord g,Ord h,Ord i,Ord j,Ord k
,Ord l,Ord m,Ord n)
=> Ord (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
compare (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') =
case compare a a' of
EQ -> case compare b b' of
EQ -> case compare c c' of
EQ -> case compare d d' of
EQ -> case compare e e' of
EQ -> case compare f f' of
EQ -> case compare g g' of
EQ -> case compare h h' of
EQ -> case compare i i' of
EQ -> case compare j j' of
EQ -> case compare k k' of
EQ -> case compare l l' of
EQ -> case compare m m' of
EQ -> compare n n'
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
instance (Bounded a,Bounded b,Bounded c,Bounded d,Bounded e,Bounded f
,Bounded g,Bounded h,Bounded i,Bounded j,Bounded k,Bounded l
,Bounded m,Bounded n)
=> Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
minBound = (minBound,minBound,minBound,minBound,minBound,minBound,minBound
,minBound,minBound,minBound,minBound,minBound,minBound,minBound)
maxBound = (maxBound,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound
,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound)
instance (Eq a,Eq b,Eq c,Eq d,Eq e,Eq f,Eq g,Eq h,Eq i,Eq j,Eq k,Eq l,Eq m
,Eq n,Eq o)
=> Eq (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
(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') =
a == a' && b == b' && c == c' && d == d' && e == e' && f == f' && g == g'
&& h == h' && i == i' && j == j' && k == k' && l == l' && m == m'
&& n == n' && o == o'
instance (Ord a,Ord b,Ord c,Ord d,Ord e,Ord f,Ord g,Ord h,Ord i,Ord j,Ord k
,Ord l,Ord m,Ord n,Ord o)
=> Ord (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
compare (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') =
case compare a a' of
EQ -> case compare b b' of
EQ -> case compare c c' of
EQ -> case compare d d' of
EQ -> case compare e e' of
EQ -> case compare f f' of
EQ -> case compare g g' of
EQ -> case compare h h' of
EQ -> case compare i i' of
EQ -> case compare j j' of
EQ -> case compare k k' of
EQ -> case compare l l' of
EQ -> case compare m m' of
EQ -> case compare n n' of
EQ -> compare o o'
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
x -> x
instance (Bounded a,Bounded b,Bounded c,Bounded d,Bounded e,Bounded f
,Bounded g,Bounded h,Bounded i,Bounded j,Bounded k,Bounded l
,Bounded m,Bounded n,Bounded o)
=> Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
minBound = (minBound,minBound,minBound,minBound,minBound,minBound,minBound
,minBound,minBound,minBound,minBound,minBound,minBound,minBound
,minBound)
maxBound = (maxBound,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound
,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound,maxBound
,maxBound)
-- 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
-- error :: String -> a
-- error = primError
-- 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"
-- A.1 Prelude PreludeList
-- Standard list functions
-- module PreludeList (
-- map, (++), filter, concat,
-- 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
-- HACK: for desugared list comprehensions
_foldr :: (a -> b -> b) -> [a] -> b -> b
_foldr f [] d = d
_foldr f ((:) x xs) d = f x (_foldr f xs d)
_filter :: Bool -> ([a]->[a]) -> [a] -> [a]
_filter b e r = if b then e r else r
infixl 9 !!
infixr 5 ++
infix 4 `elem`, `notElem`
-- Map and append
map :: (a -> b) -> [a] -> [b]
map f [] = []
map f (x:xs) = f x : map f xs
(++) :: [a] -> [a] -> [a]
[] ++ ys = ys
(x:xs) ++ ys = x : (xs ++ ys)
filter :: (a -> Bool) -> [a] -> [a]
filter p [] = []
filter p (x:xs) | p x = x : filter p xs
| otherwise = filter p xs
concat :: [[a]] -> [a]
concat xss = foldr (++) [] xss
-- 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 "Prelude.head: empty list"
last :: [a] -> a
last [x] = x
last (_:xs) = last xs
last [] = error "Prelude.last: empty list"
tail :: [a] -> [a]
tail (_:xs) = xs
tail [] = error "Prelude.tail: empty list"
init :: [a] -> [a]
init [x] = []
init (x:xs) = x : init xs
init [] = error "Prelude.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
xs !! n | n < 0 = error "Prelude.!!: negative index"
[] !! _ = error "Prelude.!!: index too large"
(x:_) !! 0 = x
(_:xs) !! n = xs !! (n-1)
-- 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 "Prelude.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 _ [] = []
-- 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 "Prelude.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 [] = []
scanr1 f [x] = [x]
scanr1 f (x:xs) = f x q : qs
where qs@(q:_) = scanr1 f xs
-- 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 [] = error "Prelude.cycle: empty list"
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 n _ | n <= 0 = []
take _ [] = []
take n (x:xs) = x : take (n-1) xs
drop :: Int -> [a] -> [a]
drop n xs | n <= 0 = xs
drop _ [] = []
drop n (_:xs) = drop (n-1) xs
splitAt :: Int -> [a] -> ([a],[a])
splitAt n xs = (take n xs, drop n xs)
-- takeWhile, applied to a predicate p and a list xs, returns the longest
-- prefix (possibly empty) of xs of elements that satisfy p. dropWhile p xs
-- returns the remaining suffix. span p xs is equivalent to
-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.
takeWhile :: (a -> Bool) -> [a] -> [a]
takeWhile p [] = []
takeWhile p (x:xs)
| p x = x : takeWhile p xs
| otherwise = []
dropWhile :: (a -> Bool) -> [a] -> [a]
dropWhile p [] = []
dropWhile p xs@(x:xs')
| p x = dropWhile p xs'
| otherwise = xs
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]
words s = case dropWhile isSpace s of
"" -> []
s' -> w : words s''
where (w, s'') = break 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 (/= 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 "Prelude.maximum: empty list"
maximum xs = foldl1 max xs
minimum [] = error "Prelude.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))
([],[],[])
-- A.2 Prelude PreludeText
-- module PreludeText (
-- ReadS, ShowS,
-- Read(readsPrec, readList),
-- Show(showsPrec, showList),
-- reads, shows, show, read, lex,
-- showChar, showString, readParen, showParen ) where
-- The instances of Read and Show for
-- Bool, Char, Maybe, Either, Ordering
-- are done via "deriving" clauses in Prelude.hs
type ReadS a = String -> [(a,String)]
type ShowS = String -> String
class Read a where
readsPrec :: Int -> ReadS a
readList :: ReadS [a]
-- Minimal complete definition:
-- readsPrec
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
show :: a -> String
showList :: [a] -> ShowS
-- Mimimal complete definition:
-- show or showsPrec
showsPrec _ x s = show x ++ s
show x = showsPrec 0 x ""
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 "Prelude.read: no parse"
_ -> error "Prelude.read: ambiguous parse"
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
-- Octal and hexidecimal numerics are not recognized as a single token
-- Comments are not treated properly
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 = c `elem` "!@#$%&*+./<=>?\\^|:-~"
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 = lexExp 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)]
instance Show Int where
showsPrec n = showsPrec n . toInteger
-- Converting to Integer avoids
-- possible difficulty with minInt
instance Read Int where
readsPrec p r = [(fromInteger i, t) | (i,t) <- readsPrec p r]
-- Reading at the Integer type avoids
-- possible difficulty with minInt
instance Show Integer where
showsPrec = showSigned showInt
instance Read Integer where
readsPrec p = readSigned readDec
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
instance (Show a, Show b) => Show (a,b) where
showsPrec p (x,y) = showChar '(' . shows x . showChar ',' .
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 ] )
instance (Read a, Read b, Read c) => Read (a,b,c) where
readsPrec p = readParen False
(\r0 -> [((x1,x2,x3), w) |
("(",s1) <- lex r0,
(x1, r1) <- reads s1,
(",",s2) <- lex r1,
(x2, r2) <- reads s2,
(",",s3) <- lex r2,
(x3, r3) <- reads s3,
(")",w) <- lex r3 ] )
instance (Read a, Read b, Read c, Read d) => Read (a,b,c,d) where
readsPrec p = readParen False
(\r0 -> [((x1,x2,x3,x4), w) |
("(",s1) <- lex r0,
(x1, r1) <- reads s1,
(",",s2) <- lex r1,
(x2, r2) <- reads s2,
(",",s3) <- lex r2,
(x3, r3) <- reads s3,
(",",s4) <- lex r3,
(x4, r4) <- reads s4,
(")",w) <- lex r4 ] )
instance (Read a, Read b, Read c, Read d, Read e) => Read (a,b,c,d,e) where
readsPrec p = readParen False
(\r0 -> [((x1,x2,x3,x4,x5), w) |
("(",s1) <- lex r0,
(x1, r1) <- reads s1,
(",",s2) <- lex r1,
(x2, r2) <- reads s2,
(",",s3) <- lex r2,
(x3, r3) <- reads s3,
(",",s4) <- lex r3,
(x4, r4) <- reads s4,
(",",s5) <- lex r4,
(x5, r5) <- reads s5,
(")",w) <- lex r5 ] )
instance (Read a, Read b, Read c, Read d, Read e, Read f) =>
Read (a,b,c,d,e,f) where
readsPrec p = readParen False
(\r0 -> [((x1,x2,x3,x4,x5,x6), w) |
("(",s1) <- lex r0,
(x1, r1) <- reads s1,
(",",s2) <- lex r1,
(x2, r2) <- reads s2,
(",",s3) <- lex r2,
(x3, r3) <- reads s3,
(",",s4) <- lex r3,
(x4, r4) <- reads s4,
(",",s5) <- lex r4,
(x5, r5) <- reads s5,
(",",s6) <- lex r5,
(x6, r6) <- reads s6,
(")",w) <- lex r6 ] )
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g) =>
Read (a,b,c,d,e,f,g) where
readsPrec p = readParen False
(\r0 -> [((x1,x2,x3,x4,x5,x6,x7), w) |
("(",s1) <- lex r0,
(x1, r1) <- reads s1,
(",",s2) <- lex r1,
(x2, r2) <- reads s2,
(",",s3) <- lex r2,
(x3, r3) <- reads s3,
(",",s4) <- lex r3,
(x4, r4) <- reads s4,
(",",s5) <- lex r4,
(x5, r5) <- reads s5,
(",",s6) <- lex r5,
(x6, r6) <- reads s6,
(",",s7) <- lex r6,
(x7, r7) <- reads s7,
(")",w) <- lex r7 ] )
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g,
Read h) =>
Read (a,b,c,d,e,f,g,h) where
readsPrec p = readParen False
(\r0 -> [((x1,x2,x3,x4,x5,x6,x7,x8), w) |
("(",s1) <- lex r0,
(x1, r1) <- reads s1,
(",",s2) <- lex r1,
(x2, r2) <- reads s2,
(",",s3) <- lex r2,
(x3, r3) <- reads s3,
(",",s4) <- lex r3,
(x4, r4) <- reads s4,
(",",s5) <- lex r4,
(x5, r5) <- reads s5,
(",",s6) <- lex r5,
(x6, r6) <- reads s6,
(",",s7) <- lex r6,
(x7, r7) <- reads s7,
(",",s8) <- lex r7,
(x8, r8) <- reads s8,
(")",w) <- lex r8 ] )
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g,
Read h, Read i) =>
Read (a,b,c,d,e,f,g,h,i) where
readsPrec p = readParen False
(\r0 -> [((x1,x2,x3,x4,x5,x6,x7,x8,x9), w) |
("(",s1) <- lex r0,
(x1, r1) <- reads s1,
(",",s2) <- lex r1,
(x2, r2) <- reads s2,
(",",s3) <- lex r2,
(x3, r3) <- reads s3,
(",",s4) <- lex r3,
(x4, r4) <- reads s4,
(",",s5) <- lex r4,
(x5, r5) <- reads s5,
(",",s6) <- lex r5,
(x6, r6) <- reads s6,
(",",s7) <- lex r6,
(x7, r7) <- reads s7,
(",",s8) <- lex r7,
(x8, r8) <- reads s8,
(",",s9) <- lex r8,
(x9, r9) <- reads s9,
(")",w) <- lex r9 ] )
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g,
Read h, Read i, Read j) =>
Read (a,b,c,d,e,f,g,h,i,j) where
readsPrec p = readParen False
(\r0 -> [((x1,x2,x3,x4,x5,x6,x7,x8,x9,x10), w) |
("(",s1) <- lex r0,
(x1, r1) <- reads s1,
(",",s2) <- lex r1,
(x2, r2) <- reads s2,
(",",s3) <- lex r2,
(x3, r3) <- reads s3,
(",",s4) <- lex r3,
(x4, r4) <- reads s4,
(",",s5) <- lex r4,
(x5, r5) <- reads s5,
(",",s6) <- lex r5,
(x6, r6) <- reads s6,
(",",s7) <- lex r6,
(x7, r7) <- reads s7,
(",",s8) <- lex r7,
(x8, r8) <- reads s8,
(",",s9) <- lex r8,
(x9, r9) <- reads s9,
(",",s10) <- lex r9,
(x10, r10) <- reads s10,
(")",w) <- lex r10 ] )
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g,
Read h, Read i, Read j, Read k) =>
Read (a,b,c,d,e,f,g,h,i,j,k) where
readsPrec p = readParen False
(\r0 -> [((x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11), w) |
("(",s1) <- lex r0,
(x1, r1) <- reads s1,
(",",s2) <- lex r1,
(x2, r2) <- reads s2,
(",",s3) <- lex r2,
(x3, r3) <- reads s3,
(",",s4) <- lex r3,
(x4, r4) <- reads s4,
(",",s5) <- lex r4,
(x5, r5) <- reads s5,
(",",s6) <- lex r5,
(x6, r6) <- reads s6,
(",",s7) <- lex r6,
(x7, r7) <- reads s7,
(",",s8) <- lex r7,
(x8, r8) <- reads s8,
(",",s9) <- lex r8,
(x9, r9) <- reads s9,
(",",s10) <- lex r9,
(x10, r10) <- reads s10,
(",",s11) <- lex r10,
(x11, r11) <- reads s11,
(")",w) <- lex r11 ] )
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g,
Read h, Read i, Read j, Read k, Read l) =>
Read (a,b,c,d,e,f,g,h,i,j,k,l) where
readsPrec p = readParen False
(\r0 -> [((x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12), w) |
("(",s1) <- lex r0,
(x1, r1) <- reads s1,
(",",s2) <- lex r1,
(x2, r2) <- reads s2,
(",",s3) <- lex r2,
(x3, r3) <- reads s3,
(",",s4) <- lex r3,
(x4, r4) <- reads s4,
(",",s5) <- lex r4,
(x5, r5) <- reads s5,
(",",s6) <- lex r5,
(x6, r6) <- reads s6,
(",",s7) <- lex r6,
(x7, r7) <- reads s7,
(",",s8) <- lex r7,
(x8, r8) <- reads s8,
(",",s9) <- lex r8,
(x9, r9) <- reads s9,
(",",s10) <- lex r9,
(x10, r10) <- reads s10,
(",",s11) <- lex r10,
(x11, r11) <- reads s11,
(",",s12) <- lex r11,
(x12, r12) <- reads s12,
(")",w) <- lex r12 ] )
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g,
Read h, Read i, Read j, Read k, Read l, Read m) =>
Read (a,b,c,d,e,f,g,h,i,j,k,l,m) where
readsPrec p = readParen False
(\r0 -> [((x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13), w) |
("(",s1) <- lex r0,
(x1, r1) <- reads s1,
(",",s2) <- lex r1,
(x2, r2) <- reads s2,
(",",s3) <- lex r2,
(x3, r3) <- reads s3,
(",",s4) <- lex r3,
(x4, r4) <- reads s4,
(",",s5) <- lex r4,
(x5, r5) <- reads s5,
(",",s6) <- lex r5,
(x6, r6) <- reads s6,
(",",s7) <- lex r6,
(x7, r7) <- reads s7,
(",",s8) <- lex r7,
(x8, r8) <- reads s8,
(",",s9) <- lex r8,
(x9, r9) <- reads s9,
(",",s10) <- lex r9,
(x10, r10) <- reads s10,
(",",s11) <- lex r10,
(x11, r11) <- reads s11,
(",",s12) <- lex r11,
(x12, r12) <- reads s12,
(",",s13) <- lex r12,
(x13, r13) <- reads s13,
(")",w) <- lex r13 ] )
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g,
Read h, Read i, Read j, Read k, Read l, Read m, Read n) =>
Read (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
readsPrec p = readParen False
(\r0 -> [((x1,x2,x3,x4,x5,x6,x7
,x8,x9,x10,x11,x12,x13,x14), w) |
("(",s1) <- lex r0,
(x1, r1) <- reads s1,
(",",s2) <- lex r1,
(x2, r2) <- reads s2,
(",",s3) <- lex r2,
(x3, r3) <- reads s3,
(",",s4) <- lex r3,
(x4, r4) <- reads s4,
(",",s5) <- lex r4,
(x5, r5) <- reads s5,
(",",s6) <- lex r5,
(x6, r6) <- reads s6,
(",",s7) <- lex r6,
(x7, r7) <- reads s7,
(",",s8) <- lex r7,
(x8, r8) <- reads s8,
(",",s9) <- lex r8,
(x9, r9) <- reads s9,
(",",s10) <- lex r9,
(x10, r10) <- reads s10,
(",",s11) <- lex r10,
(x11, r11) <- reads s11,
(",",s12) <- lex r11,
(x12, r12) <- reads s12,
(",",s13) <- lex r12,
(x13, r13) <- reads s13,
(",",s14) <- lex r13,
(x14, r14) <- reads s14,
(")",w) <- lex r14 ] )
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g,
Read h, Read i, Read j, Read k, Read l, Read m, Read n, Read o) =>
Read (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
readsPrec p = readParen False
(\r0 -> [((x1,x2,x3,x4,x5,x6,x7
,x8,x9,x10,x11,x12,x13,x14,x15), w) |
("(",s1) <- lex r0,
(x1, r1) <- reads s1,
(",",s2) <- lex r1,
(x2, r2) <- reads s2,
(",",s3) <- lex r2,
(x3, r3) <- reads s3,
(",",s4) <- lex r3,
(x4, r4) <- reads s4,
(",",s5) <- lex r4,
(x5, r5) <- reads s5,
(",",s6) <- lex r5,
(x6, r6) <- reads s6,
(",",s7) <- lex r6,
(x7, r7) <- reads s7,
(",",s8) <- lex r7,
(x8, r8) <- reads s8,
(",",s9) <- lex r8,
(x9, r9) <- reads s9,
(",",s10) <- lex r9,
(x10, r10) <- reads s10,
(",",s11) <- lex r10,
(x11, r11) <- reads s11,
(",",s12) <- lex r11,
(x12, r12) <- reads s12,
(",",s13) <- lex r12,
(x13, r13) <- reads s13,
(",",s14) <- lex r13,
(x14, r14) <- reads s14,
(",",s15) <- lex r14,
(x15, r15) <- reads s15,
(")",w) <- lex r15 ] )
instance (Show a, Show b, Show c) => Show (a,b,c) where
showsPrec p (x,y,z) = showChar '(' . shows x . showString "," .
shows y . showString "," .
shows z . showChar ')'
-- showsType ~(x,y,z) = showChar '(' . showsType x . showChar ',' .
-- showsType y . showChar ',' .
-- showsType z . showChar ')'
instance (Show a, Show b, Show c, Show d) => Show (a,b,c,d) where
showsPrec p (x,y,z,u) = showChar '(' . shows x . showString "," .
shows y . showString "," .
shows z . showString "," .
shows u . showChar ')'
-- showsType ~(x,y,z,u) = showChar '(' . showsType x . showChar ',' .
-- showsType y . showChar ',' .
-- showsType z . showChar ',' .
-- showsType u . showChar ')'
instance (Show a, Show b, Show c, Show d, Show e) => Show (a,b,c,d,e) where
showsPrec p (x,y,z,u,v) = showChar '(' . shows x . showString "," .
shows y . showString "," .
shows z . showString "," .
shows u . showString "," .
shows v . showChar ')'
-- showsType ~(x,y,z,u,v) = showChar '(' . showsType x . showChar ',' .
-- showsType y . showChar ',' .
-- showsType z . showChar ',' .
-- showsType u . showChar ',' .
-- showsType v . showChar ')'
instance (Show a, Show b, Show c, Show d, Show e, Show f) =>
Show (a,b,c,d,e,f) where
showsPrec p (x,y,z,u,v,w) = showChar '(' . shows x . showString "," .
shows y . showString "," .
shows z . showString "," .
shows u . showString "," .
shows v . showString "," .
shows w . showChar ')'
-- showsType ~(x,y,z,u,v,w) = showChar '(' . showsType x . showChar ',' .
-- showsType y . showChar ',' .
-- showsType z . showChar ',' .
-- showsType u . showChar ',' .
-- showsType v . showChar ',' .
-- showsType w . showChar ')'
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g) =>
Show (a,b,c,d,e,f,g) where
showsPrec p (x,y,z,u,v,w,t) = showChar '(' . shows x . showString "," .
shows y . showString "," .
shows z . showString "," .
shows u . showString "," .
shows v . showString "," .
shows w . showString "," .
shows t . showChar ')'
-- showsType ~(x,y,z,u,v,w,t) = showChar '(' . showsType x . showChar ',' .
-- showsType y . showChar ',' .
-- showsType z . showChar ',' .
-- showsType u . showChar ',' .
-- showsType v . showChar ',' .
-- showsType w . showChar ',' .
-- showsType t . showChar ')'
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g,
Show h) =>
Show (a,b,c,d,e,f,g,h) where
showsPrec p (x,y,z,u,v,w,t,a) = showChar '(' . shows x . showString "," .
shows y . showString "," .
shows z . showString "," .
shows u . showString "," .
shows v . showString "," .
shows w . showString "," .
shows t . showString "," .
shows a . showChar ')'
-- showsType ~(x,y,z,u,v,w,t,a) = showChar '(' . showsType x . showChar ',' .
-- showsType y . showChar ',' .
-- showsType z . showChar ',' .
-- showsType u . showChar ',' .
-- showsType v . showChar ',' .
-- showsType w . showChar ',' .
-- showsType t . showChar ',' .
-- showsType a . showChar ')'
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g,
Show h, Show i) =>
Show (a,b,c,d,e,f,g,h,i) where
showsPrec p (x,y,z,u,v,w,t,a,b) =
showChar '(' . shows x . showString "," .
shows y . showString "," .
shows z . showString "," .
shows u . showString "," .
shows v . showString "," .
shows w . showString "," .
shows t . showString "," .
shows a . showString "," .
shows b . showChar ')'
-- showsType ~(x,y,z,u,v,w,t,a,b) =
-- showChar '(' . showsType x . showChar ',' .
-- showsType y . showChar ',' .
-- showsType z . showChar ',' .
-- showsType u . showChar ',' .
-- showsType v . showChar ',' .
-- showsType w . showChar ',' .
-- showsType t . showChar ',' .
-- showsType a . showChar ',' .
-- showsType b . showChar ')'
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g,
Show h, Show i, Show j) =>
Show (a,b,c,d,e,f,g,h,i,j) where
showsPrec p (x,y,z,u,v,w,t,a,b,c) =
showChar '(' . shows x . showString "," .
shows y . showString "," .
shows z . showString "," .
shows u . showString "," .
shows v . showString "," .
shows w . showString "," .
shows t . showString "," .
shows a . showString "," .
shows b . showString "," .
shows c . showChar ')'
-- showsType ~(x,y,z,u,v,w,t,a,b,c) =
-- showChar '(' . showsType x . showChar ',' .
-- showsType y . showChar ',' .
-- showsType z . showChar ',' .
-- showsType u . showChar ',' .
-- showsType v . showChar ',' .
-- showsType w . showChar ',' .
-- showsType t . showChar ',' .
-- showsType a . showChar ',' .
-- showsType b . showChar ',' .
-- showsType c . showChar ')'
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g,
Show h, Show i, Show j, Show k) =>
Show (a,b,c,d,e,f,g,h,i,j,k) where
showsPrec p (x,y,z,u,v,w,t,a,b,c,d) =
showChar '(' . shows x . showString "," .
shows y . showString "," .
shows z . showString "," .
shows u . showString "," .
shows v . showString "," .
shows w . showString "," .
shows t . showString "," .
shows a . showString "," .
shows b . showString "," .
shows c . showString "," .
shows d . showChar ')'
-- showsType ~(x,y,z,u,v,w,t,a,b,c,d) =
-- showChar '(' . showsType x . showChar ',' .
-- showsType y . showChar ',' .
-- showsType z . showChar ',' .
-- showsType u . showChar ',' .
-- showsType v . showChar ',' .
-- showsType w . showChar ',' .
-- showsType t . showChar ',' .
-- showsType a . showChar ',' .
-- showsType b . showChar ',' .
-- showsType c . showChar ',' .
-- showsType d . showChar ')'
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g,
Show h, Show i, Show j, Show k, Show l) =>
Show (a,b,c,d,e,f,g,h,i,j,k,l) where
showsPrec p (x,y,z,u,v,w,t,a,b,c,d,e) =
showChar '(' . shows x . showString "," .
shows y . showString "," .
shows z . showString "," .
shows u . showString "," .
shows v . showString "," .
shows w . showString "," .
shows t . showString "," .
shows a . showString "," .
shows b . showString "," .
shows c . showString "," .
shows d . showString "," .
shows e . showChar ')'
-- showsType ~(x,y,z,u,v,w,t,a,b,c,d,e) =
-- showChar '(' . showsType x . showChar ',' .
-- showsType y . showChar ',' .
-- showsType z . showChar ',' .
-- showsType u . showChar ',' .
-- showsType v . showChar ',' .
-- showsType w . showChar ',' .
-- showsType t . showChar ',' .
-- showsType a . showChar ',' .
-- showsType b . showChar ',' .
-- showsType c . showChar ',' .
-- showsType d . showChar ',' .
-- showsType e . showChar ')'
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g,
Show h, Show i, Show j, Show k, Show l, Show m) =>
Show (a,b,c,d,e,f,g,h,i,j,k,l,m) where
showsPrec p (x,y,z,u,v,w,t,a,b,c,d,e,f) =
showChar '(' . shows x . showString "," .
shows y . showString "," .
shows z . showString "," .
shows u . showString "," .
shows v . showString "," .
shows w . showString "," .
shows t . showString "," .
shows a . showString "," .
shows b . showString "," .
shows c . showString "," .
shows d . showString "," .
shows e . showString "," .
shows f . showChar ')'
-- showsType ~(x,y,z,u,v,w,t,a,b,c,d,e,f) =
-- showChar '(' . showsType x . showChar ',' .
-- showsType y . showChar ',' .
-- showsType z . showChar ',' .
-- showsType u . showChar ',' .
-- showsType v . showChar ',' .
-- showsType w . showChar ',' .
-- showsType t . showChar ',' .
-- showsType a . showChar ',' .
-- showsType b . showChar ',' .
-- showsType c . showChar ',' .
-- showsType d . showChar ',' .
-- showsType e . showChar ',' .
-- showsType f . showChar ')'
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g,
Show h, Show i, Show j, Show k, Show l, Show m, Show n) =>
Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
showsPrec p (x,y,z,u,v,w,t,a,b,c,d,e,f,g) =
showChar '(' . shows x . showString "," .
shows y . showString "," .
shows z . showString "," .
shows u . showString "," .
shows v . showString "," .
shows w . showString "," .
shows t . showString "," .
shows a . showString "," .
shows b . showString "," .
shows c . showString "," .
shows d . showString "," .
shows e . showString "," .
shows f . showString "," .
shows g . showChar ')'
-- showsType ~(x,y,z,u,v,w,t,a,b,c,d,e,f,g) =
-- showChar '(' . showsType x . showChar ',' .
-- showsType y . showChar ',' .
-- showsType z . showChar ',' .
-- showsType u . showChar ',' .
-- showsType v . showChar ',' .
-- showsType w . showChar ',' .
-- showsType t . showChar ',' .
-- showsType a . showChar ',' .
-- showsType b . showChar ',' .
-- showsType c . showChar ',' .
-- showsType d . showChar ',' .
-- showsType e . showChar ',' .
-- showsType f . showChar ',' .
-- showsType g . showChar ')'
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g,
Show h, Show i, Show j, Show k, Show l, Show m, Show n, Show o) =>
Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
showsPrec p (x,y,z,u,v,w,t,a,b,c,d,e,f,g,h) =
showChar '(' . shows x . showString "," .
shows y . showString "," .
shows z . showString "," .
shows u . showString "," .
shows v . showString "," .
shows w . showString "," .
shows t . showString "," .
shows a . showString "," .
shows b . showString "," .
shows c . showString "," .
shows d . showString "," .
shows e . showString "," .
shows f . showString "," .
shows g . showString "," .
shows h . showChar ')'
-- showsType ~(x,y,z,u,v,w,t,a,b,c,d,e,f,g,h) =
-- showChar '(' . showsType x . showChar ',' .
-- showsType y . showChar ',' .
-- showsType z . showChar ',' .
-- showsType u . showChar ',' .
-- showsType v . showChar ',' .
-- showsType w . showChar ',' .
-- showsType t . showChar ',' .
-- showsType a . showChar ',' .
-- showsType b . showChar ',' .
-- showsType c . showChar ',' .
-- showsType d . showChar ',' .
-- showsType e . showChar ',' .
-- showsType f . showChar ',' .
-- showsType g . showChar ',' .
-- showsType h . showChar ')'
-- A.3 Prelude PreludeIO
-- module PreludeIO (
-- FilePath, IOError, ioError, userError, catch,
-- putChar, putStr, putStrLn, print,
-- getChar, getLine, getContents, interact,
-- readFile, writeFile, appendFile, readIO, readLn
-- ) where
type FilePath = String
-- data IOError -- The internals of this type are system dependent
{- not needed, because IOError = Prelude.IOError and instance available from Prelude
instance Show IOError where
show = primIOErrorShow
-}
{- currently excluded because instance Eq IOError missing in ghc 5.02
instance Eq IOError where
(==) = primIOErrorEq
-}
-- ioError :: IOError -> IO a
-- ioError = primIOError
-- userError :: String -> IOError
-- userError = primUserError
-- catch :: IO a -> (IOError -> IO a) -> IO a
-- catch = primCatch
-- putChar :: Char -> IO ()
-- putChar = primPutChar
putStr :: String -> IO ()
putStr s = mapM_ putChar s
putStrLn :: String -> IO ()
putStrLn s = do putStr s
putStr "\n"
print :: Show a => a -> IO ()
print x = putStrLn (show x)
-- getChar :: IO Char
-- getChar = primGetChar
getLine :: IO String
getLine = do c <- getChar
if c == '\n' then return "" else
do s <- getLine
return (c:s)
-- getContents :: IO String
-- getContents = primGetContents
interact :: (String -> String) -> IO ()
interact f = do s <- getContents
putStr (f s)
-- readFile :: FilePath -> IO String
-- readFile = primReadFile
-- writeFile :: FilePath -> String -> IO ()
-- writeFile = primWriteFile
-- appendFile :: FilePath -> String -> IO ()
-- appendFile = primAppendFile
-- raises an exception instead of an error
readIO :: Read a => String -> IO a
readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
[x] -> return x
[] -> ioError (userError "Prelude.readIO: no parse")
_ -> ioError (userError "Prelude.readIO: ambiguous parse")
readLn :: Read a => IO a
readLn = do l <- getLine
r <- readIO l
return r
-- import Char(isSpace, isAlpha, isDigit, isAlphaNum,
-- showLitChar, readLitChar, lexLitChar)
-- module Char (
-- isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,
-- isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
-- digitToInt, intToDigit,
-- toUpper, toLower,
-- ord, chr,
-- readLitChar, showLitChar, lexLitChar,
--
-- ...and what the Prelude exports
-- Char, String
-- ) where
-- import Array -- used for character name table.
-- Digit conversion operations
digitToInt :: Char -> Int
digitToInt c
| isDigit c = fromEnum c - fromEnum '0'
| c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
| c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
| otherwise = error "Char.digitToInt: not a digit"
intToDigit :: Int -> Char
intToDigit i
| i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
| i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
| otherwise = error "Char.intToDigit: not a digit"
-- Character code functions
ord :: Char -> Int
ord = fromEnum
chr :: Int -> Char
chr = toEnum
-- Text functions
readLitChar :: ReadS Char
readLitChar ('\\':s) = readEsc s
where
readEsc ('a':s) = [('\a',s)]
readEsc ('b':s) = [('\b',s)]
readEsc ('f':s) = [('\f',s)]
readEsc ('n':s) = [('\n',s)]
readEsc ('r':s) = [('\r',s)]
readEsc ('t':s) = [('\t',s)]
readEsc ('v':s) = [('\v',s)]
readEsc ('\\':s) = [('\\',s)]
readEsc ('"':s) = [('"',s)]
readEsc ('\'':s) = [('\'',s)]
readEsc ('^':c:s) | c >= '@' && c <= '_'
= [(chr (ord c - ord '@'), s)]
readEsc s@(d:_) | isDigit d
= [(chr n, t) | (n,t) <- readDec s]
readEsc ('o':s) = [(chr n, t) | (n,t) <- readOct s]
readEsc ('x':s) = [(chr n, t) | (n,t) <- readHex s]
readEsc s@(c:_) | isUpper c
= let table = ('\DEL', "DEL") : {- assocs -} asciiTab
in case [(c,s') | (c, mne) <- table,
([],s') <- [match mne s]]
of (pr:_) -> [pr]
[] -> []
readEsc _ = []
match :: (Eq a) => [a] -> [a] -> ([a],[a])
match (x:xs) (y:ys) | x == y = match xs ys
match xs ys = (xs,ys)
readLitChar (c:s) = [(c,s)]
showLitChar :: Char -> ShowS
showLitChar c | c > '\DEL' = showChar '\\' .
protectEsc isDigit (shows (ord c))
showLitChar '\DEL' = showString "\\DEL"
showLitChar '\\' = showString "\\\\"
showLitChar c | c >= ' ' = showChar c
showLitChar '\a' = showString "\\a"
showLitChar '\b' = showString "\\b"
showLitChar '\f' = showString "\\f"
showLitChar '\n' = showString "\\n"
showLitChar '\r' = showString "\\r"
showLitChar '\t' = showString "\\t"
showLitChar '\v' = showString "\\v"
showLitChar '\SO' = protectEsc (== 'H') (showString "\\SO")
showLitChar c = showString ('\\' : snd (asciiTab !! ord c){-!c-})
protectEsc p f = f . cont
where cont s@(c:_) | p c = "\\&" ++ s
cont s = s
asciiTab = {- listArray ('\NUL', ' ') -}
zip ['\NUL'..' ']
["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
"BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
"DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
"CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
"SP"]
lexLitChar :: ReadS String
lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
where
lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
lexEsc s@(d:_) | isDigit d = lexDigits s
lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
-- Very crude approximation to \XYZ. Let readers work this out.
lexEsc s@(c:_) | isUpper c = [span isCharName s]
lexEsc _ = []
isCharName c = isUpper c || isDigit c
lexLitChar (c:s) = [([c],s)]
lexLitChar "" = []
-- import Numeric(showSigned, showInt, readSigned, readDec, showFloat,
-- readFloat, lexDigits)
-- import Numeric (readDec, readOct, lexDigits, readHex)
-- module Numeric(fromRat,
-- showSigned, showInt,
-- readSigned, readInt,
-- readDec, readOct, readHex,
-- floatToDigits,
-- showEFloat, showFFloat, showGFloat, showFloat,
-- readFloat, lexDigits) where
-- import Ratio ( (%), numerator, denominator )
-- import Array ( (!), Array, array )
-- This converts a rational to a floating. This should be used in the
-- Fractional instances of Float and Double.
fromRat :: (RealFloat a) => Rational -> a
fromRat x =
if x == 0 then encodeFloat 0 0 -- Handle exceptional cases
else if x < 0 then - fromRat' (-x) -- first.
else fromRat' x
-- Conversion process:
-- Scale the rational number by the RealFloat base until
-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).
-- Then round the rational to an Integer and encode it with the exponent
-- that we got from the scaling.
-- To speed up the scaling process we compute the log2 of the number to get
-- a first guess of the exponent.
fromRat' :: (RealFloat a) => Rational -> a
fromRat' x = r
where b = floatRadix r
p = floatDigits r
(minExp0, _) = floatRange r
minExp = minExp0 - p -- the real minimum exponent
xMin = toRational (expt b (p-1))
xMax = toRational (expt b p)
p0 = (integerLogBase b (numerator x) -
integerLogBase b (denominator x) - p) `max` minExp
f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
(x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
r = encodeFloat (round x') p'
-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
scaleRat :: Rational -> Int -> Rational -> Rational ->
Int -> Rational -> (Rational, Int)
scaleRat b minExp xMin xMax p x =
if p <= minExp then
(x, p)
else if x >= xMax then
scaleRat b minExp xMin xMax (p+1) (x/b)
else if x < xMin then
scaleRat b minExp xMin xMax (p-1) (x*b)
else
(x, p)
-- Exponentiation with a cache for the most common numbers.
minExpt = 0::Int
maxExpt = 1100::Int
expt :: Integer -> Int -> Integer
expt base n =
if base == 2 && n >= minExpt && n <= maxExpt then
expts {-!n-} !! (n-minExpt)
else
base^n
expts :: {- Array Int Integer -} [Integer]
expts = [2^n | n <- [minExpt .. maxExpt]]
{- array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]] -}
-- Compute the (floor of the) log of i in base b.
-- Simplest way would be just divide i by b until it's smaller then b,
-- but that would be very slow! We are just slightly more clever.
integerLogBase :: Integer -> Integer -> Int
integerLogBase b i =
if i < b then
0
else
-- Try squaring the base first to cut down the number of divisions.
let l = 2 * integerLogBase (b*b) i
doDiv :: Integer -> Int -> Int
doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
in doDiv (i `div` (b^l)) l
-- Misc utilities to show integers and floats
showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
showSigned showPos p x | x < 0 = showParen (p > 6)
(showChar '-' . showPos (-x))
| otherwise = showPos x
-- showInt, showOct, showHex are used for positive numbers only
showInt, showOct, showHex :: Integral a => a -> ShowS
showOct = showIntAtBase 8 intToDigit
showInt = showIntAtBase 10 intToDigit
showHex = showIntAtBase 16 intToDigit
showIntAtBase :: Integral a
=> a -- base
-> (Int -> Char) -- digit to char
-> a -- number to show
-> ShowS
showIntAtBase base intToDig n rest
| n < 0 = error "Numeric.showIntAtBase: can't show negative numbers"
| n' == 0 = rest'
| otherwise = showIntAtBase base intToDig n' rest'
where
(n',d) = quotRem n base
rest' = intToDig (fromIntegral d) : rest
readSigned :: (Real a) => ReadS a -> ReadS a
readSigned readPos = readParen False read'
where read' r = read'' r ++
[(-x,t) | ("-",s) <- lex r,
(x,t) <- read'' s]
read'' r = [(n,s) | (str,s) <- lex r,
(n,"") <- readPos str]
-- readInt reads a string of digits using an arbitrary base.
-- Leading minus signs must be handled elsewhere.
readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
readInt radix isDig digToInt s =
[(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
| (ds,r) <- nonnull isDig s ]
-- Unsigned readers for various bases
readDec, readOct, readHex :: (Integral a) => ReadS a
readDec = readInt 10 isDigit digitToInt
readOct = readInt 8 isOctDigit digitToInt
readHex = readInt 16 isHexDigit digitToInt
showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
showFloat :: (RealFloat a) => a -> ShowS
showEFloat d x = showString (formatRealFloat FFExponent d x)
showFFloat d x = showString (formatRealFloat FFFixed d x)
showGFloat d x = showString (formatRealFloat FFGeneric d x)
showFloat = showGFloat Nothing
-- These are the format types. This type is not exported.
data FFFormat = FFExponent | FFFixed | FFGeneric
formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
formatRealFloat fmt decs x
= s
where
base = 10
s = if isNaN x then
"NaN"
else if isInfinite x then
if x < 0 then "-Infinity" else "Infinity"
else if x < 0 || isNegativeZero x then
'-' : doFmt fmt (floatToDigits (toInteger base) (-x))
else
doFmt fmt (floatToDigits (toInteger base) x)
doFmt fmt (is, e)
= let
ds = map intToDigit is
in
case fmt of
FFGeneric ->
doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
(is, e)
FFExponent ->
case decs of
Nothing ->
case ds of
[] -> "0.0e0"
[d] -> d : ".0e" ++ show (e-1)
d:ds -> d : '.' : ds ++ 'e':show (e-1)
Just dec ->
let dec' = max dec 1 in
case is of
[] -> '0':'.':take dec' (repeat '0') ++ "e0"
_ ->
let (ei, is') = roundTo base (dec'+1) is
d:ds = map intToDigit
(if ei > 0 then init is' else is')
in d:'.':ds ++ "e" ++ show (e-1+ei)
FFFixed ->
case decs of
Nothing -- Always prints a decimal point
| e > 0 -> take e (ds ++ repeat '0')
++ '.' : mk0 (drop e ds)
| otherwise -> "0." ++ mk0 (replicate (-e) '0' ++ ds)
Just dec -> -- Print decimal point iff dec > 0
let dec' = max dec 0 in
if e >= 0 then
let (ei, is') = roundTo base (dec' + e) is
(ls, rs) = splitAt (e+ei)
(map intToDigit is')
in mk0 ls ++ mkdot0 rs
else
let (ei, is') = roundTo base dec'
(replicate (-e) 0 ++ is)
d : ds = map intToDigit
(if ei > 0 then is' else 0:is')
in d : mkdot0 ds
where
mk0 "" = "0" -- Print 0.34, not .34
mk0 s = s
mkdot0 "" = "" -- Print 34, not 34.
mkdot0 s = '.' : s -- when the format specifies no
-- digits after the decimal point
roundTo :: Int -> Int -> [Int] -> (Int, [Int])
roundTo base d is = case f d is of
(0, is) -> (0, is)
(1, is) -> (1, 1 : is)
where b2 = base `div` 2
f n [] = (0, replicate n 0)
f 0 (i:_) = (if i >= b2 then 1 else 0, [])
f d (i:is) =
let (c, ds) = f (d-1) is
i' = c + i
in if i' == base then (1, 0:ds) else (0, i':ds)
--
-- Based on "Printing Floating-Point Numbers Quickly and Accurately"
-- by R.G. Burger and R. K. Dybvig, in PLDI 96.
-- The version here uses a much slower logarithm estimator.
-- It should be improved.
-- This function returns a non-empty list of digits (Ints in [0..base-1])
-- and an exponent. In general, if
-- floatToDigits r = ([a, b, ... z], e)
-- then
-- r = 0.ab..z * base^e
--
floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
floatToDigits _ 0 = ([], 0)
floatToDigits base x =
let (f0, e0) = decodeFloat x
(minExp0, _) = floatRange x
p = floatDigits x
b = floatRadix x
minExp = minExp0 - p -- the real minimum exponent
-- Haskell requires that f be adjusted so denormalized numbers
-- will have an impossibly low exponent. Adjust for this.
f :: Integer
e :: Int
(f, e) = let n = minExp - e0
in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
(r, s, mUp, mDn) =
if e >= 0 then
let be = b^e in
if f == b^(p-1) then
(f*be*b*2, 2*b, be*b, b)
else
(f*be*2, 2, be, be)
else
if e > minExp && f == b^(p-1) then
(f*b*2, b^(-e+1)*2, b, 1)
else
(f*2, b^(-e)*2, 1, 1)
k =
let k0 =
if b==2 && base==10 then
-- logBase 10 2 is slightly bigger than 3/10 so
-- the following will err on the low side. Ignoring
-- the fraction will make it err even more.
-- Haskell promises that p-1 <= logBase b f < p.
(p - 1 + e0) * 3 `div` 10
else
ceiling (((log (fromInteger (f+1)) +
fromIntegral e * log (fromInteger b)) /
log (fromInteger base))
:: Double {-DEFAULT-})
fixup n =
if n >= 0 then
if r + mUp <= expt base n * s then n else fixup (n+1)
else
if expt base (-n) * (r + mUp) <= s then n
else fixup (n+1)
in fixup k0
gen ds rn sN mUpN mDnN =
let (dn, rn') = (rn * base) `divMod` sN
mUpN' = mUpN * base
mDnN' = mDnN * base
in case (rn' < mDnN', rn' + mUpN' > sN) of
(True, False) -> dn : ds
(False, True) -> dn+1 : ds
(True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
(False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
rds =
if k >= 0 then
gen [] r (s * expt base k) mUp mDn
else
let bk = expt base (-k)
in gen [] (r * bk) s (mUp * bk) (mDn * bk)
in (map fromIntegral (reverse rds), k)
-- This floating point reader uses a less restrictive syntax for floating
-- point than the Haskell lexer. The `.' is optional.
readFloat :: (RealFloat a) => ReadS a
readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
(k,t) <- readExp s] ++
[ (0/0, t) | ("NaN",t) <- lex r] ++
[ (1/0, t) | ("Infinity",t) <- lex r]
where
readFix r = [(read (ds++ds'), length ds', t)
| (ds,d) <- lexDigits r,
(ds',t) <- lexFrac d ]
lexFrac ('.':ds) = lexDigits ds
lexFrac s = [("",s)]
readExp (e:s) | e `elem` "eE" = readExp' s
readExp s = [(0,s)]
readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
readExp' ('+':s) = readDec s
readExp' s = readDec s
lexDigits :: ReadS String
lexDigits = nonnull isDigit
nonnull :: (Char -> Bool) -> ReadS String
nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
-- module Ratio (
-- Ratio, Rational, (%), numerator, denominator, approxRational ) where
infixl 7 %
prec = 7 :: Int
data Ratio a = !a :% !a deriving (Eq) -- no class Integral a class context in 2010
type Rational = Ratio Integer
(%) :: (Integral a) => a -> a -> Ratio a
numerator, denominator :: (Integral a) => Ratio a -> a
approxRational :: (RealFrac a) => a -> a -> Rational
-- "reduce" is a subsidiary function used only in this module.
-- It normalises a ratio by dividing both numerator
-- and denominator by their greatest common divisor.
--
-- E.g., 12 `reduce` 8 == 3 :% 2
-- 12 `reduce` (-8) == 3 :% (-2)
reduce _ 0 = error "Ratio.% : zero denominator"
reduce x y = (x `quot` d) :% (y `quot` d)
where d = gcd x y
x % y = reduce (x * signum y) (abs y)
numerator (x :% _) = x
denominator (_ :% y) = y
instance (Integral a) => Ord (Ratio a) where
(x:%y) <= (x':%y') = x * y' <= x' * y
(x:%y) < (x':%y') = x * y' < x' * y
instance (Integral a) => Num (Ratio a) where
(x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
(x:%y) * (x':%y') = reduce (x * x') (y * y')
negate (x:%y) = (-x) :% y
abs (x:%y) = abs x :% y
signum (x:%y) = signum x :% 1
fromInteger x = fromInteger x :% 1
instance (Integral a) => Real (Ratio a) where
toRational (x:%y) = toInteger x :% toInteger y
instance (Integral a) => Fractional (Ratio a) where
(x:%y) / (x':%y') = (x*y') % (y*x')
recip (x:%y) = y % x
fromRational (x:%y) = fromInteger x :% fromInteger y
instance (Integral a) => RealFrac (Ratio a) where
properFraction (x:%y) = (fromIntegral q, r:%y)
where (q,r) = quotRem x y
instance (Integral a) => Enum (Ratio a) where
toEnum = fromIntegral
fromEnum = fromInteger . truncate -- May overflow
enumFrom = numericEnumFrom -- These numericEnumXXX functions
enumFromThen = numericEnumFromThen -- are as defined in Prelude.hs
enumFromTo = numericEnumFromTo -- but not exported from it!
enumFromThenTo = numericEnumFromThenTo
instance (Read a, Integral a) => Read (Ratio a) where
readsPrec p = readParen (p > prec)
(\r -> [(x%y,u) | (x,s) <- reads r,
("%",t) <- lex s,
(y,u) <- reads t ])
instance (Integral a) => Show (Ratio a) where
showsPrec p (x:%y) = showParen (p > prec)
(shows x . showString " % " . shows y)
approxRational x eps = simplest (x-eps) (x+eps)
where simplest x y | y < x = simplest y x
| x == y = xr
| x > 0 = simplest' n d n' d'
| y < 0 = - simplest' (-n') d' (-n) d
| otherwise = 0 :% 1
where xr@(n:%d) = toRational x
(n':%d') = toRational y
simplest' n d n' d' -- assumes 0 < n%d < n'%d'
| r == 0 = q :% 1
| q /= q' = (q+1) :% 1
| otherwise = (q*n''+d'') :% n''
where (q,r) = quotRem n d
(q',r') = quotRem n' d'
(n'':%d'') = simplest' d' r' d r