+++ /dev/null
-{----------------------------------------------------------------------------
-__ __ __ __ ____ ___ _______________________________________________
-|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system
-||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999
-||---|| ___|| World Wide Web: http://haskell.org/hugs
-|| || Report bugs to: hugs-bugs@haskell.org
-|| || Version: January 1999 _______________________________________________
-
- This is the Hugs 98 Standard Prelude, based very closely on the Standard
- Prelude for Haskell 98.
-
- WARNING: This file is an integral part of the Hugs source code. Changes to
- the definitions in this file without corresponding modifications in other
- parts of the program may cause the interpreter to fail unexpectedly. Under
- normal circumstances, you should not attempt to modify this file in any way!
-
------------------------------------------------------------------------------
- Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell
- Group 1994-99, and is distributed as Open Source software under the
- Artistic License; see the file "Artistic" that is included in the
- distribution for details.
-----------------------------------------------------------------------------}
-
-module Prelude (
--- module PreludeList,
- map, (++), concat, filter,
- 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,
--- module PreludeText,
- ReadS, ShowS,
- Read(readsPrec, readList),
- Show(show, showsPrec, showList),
- reads, shows, read, lex,
- showChar, showString, readParen, showParen,
--- module PreludeIO,
- FilePath, IOError, ioError, userError, catch,
- putChar, putStr, putStrLn, print,
- getChar, getLine, getContents, interact,
- readFile, writeFile, appendFile, readIO, readLn,
--- module Ix,
- Ix(range, index, inRange, rangeSize),
--- module Char,
- isAscii, isControl, isPrint, isSpace, isUpper, isLower,
- isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
- digitToInt, intToDigit,
- toUpper, toLower,
- ord, chr,
- readLitChar, showLitChar, lexLitChar,
--- module Numeric
- showSigned, showInt,
- readSigned, readInt,
- readDec, readOct, readHex, readSigned,
- readFloat, lexDigits,
--- module Ratio,
- Ratio, Rational, (%), numerator, denominator, approxRational,
--- Non-standard exports
- IO(..), IOResult(..), Addr,
-
- Bool(False, True),
- Maybe(Nothing, Just),
- Either(Left, Right),
- Ordering(LT, EQ, GT),
- Char, String, Int, Integer, Float, Double, IO,
--- List type: []((:), [])
- (:),
--- Tuple types: (,), (,,), etc.
--- Trivial type: ()
--- Functions: (->)
- Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
- Eq((==), (/=)),
- Ord(compare, (<), (<=), (>=), (>), max, min),
- Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
- enumFromTo, enumFromThenTo),
- Bounded(minBound, maxBound),
--- Num((+), (-), (*), negate, abs, signum, fromInteger),
- Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
- Real(toRational),
--- Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
- Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
--- Fractional((/), recip, fromRational),
- Fractional((/), recip, fromRational, fromDouble),
- 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, fail),
- Functor(fmap),
- mapM, mapM_, accumulate, sequence, (=<<),
- maybe, either,
- (&&), (||), not, otherwise,
- subtract, even, odd, gcd, lcm, (^), (^^),
- fromIntegral, realToFrac, atan2,
- fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
- asTypeOf, error, undefined,
- seq, ($!)
-
- ,primCompAux
- ) where
-
--- Standard value bindings {Prelude} ----------------------------------------
-
-infixr 9 .
-infixl 9 !!
-infixr 8 ^, ^^, **
-infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
-infixl 6 +, -
---infixr 5 : -- this fixity declaration is hard-wired into Hugs
-infixr 5 ++
-infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
-infixr 3 &&
-infixr 2 ||
-infixl 1 >>, >>=
-infixr 1 =<<
-infixr 0 $, $!, `seq`
-
--- 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
-
- max x y | x >= y = x
- | otherwise = y
- min x y | x <= y = x
- | otherwise = y
-
-class Bounded a where
- minBound, maxBound :: a
- -- Minimal complete definition: All
-
--- Numeric classes ----------------------------------------------------------
-
-class (Eq a, Show a) => Num a where
- (+), (-), (*) :: a -> a -> a
- negate :: a -> a
- abs, signum :: a -> a
- fromInteger :: Integer -> a
- fromInt :: Int -> a
-
- -- Minimal complete definition: All, except negate or (-)
- x - y = x + negate y
- fromInt = fromIntegral
- 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, div, mod :: a -> a -> a
- quotRem, divMod :: a -> a -> (a,a)
- even, odd :: a -> Bool
- toInteger :: a -> Integer
- toInt :: a -> Int
-
- -- Minimal complete definition: quotRem and 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 == - signum d then (q-1, r+d) else qr
- where qr@(q,r) = quotRem n d
- even n = n `rem` 2 == 0
- odd = not . even
- toInt = toInt . toInteger
-
-class (Num a) => Fractional a where
- (/) :: a -> a -> a
- recip :: a -> a
- fromRational :: Rational -> a
- fromDouble :: Double -> a
-
- -- Minimal complete definition: fromRational and ((/) or recip)
- recip x = 1 / x
- fromDouble = fromRational . toRational
- 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,
- -- 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
- sinh x = (exp x - exp (-x)) / 2
- cosh x = (exp x + exp (-x)) / 2
- tanh x = sinh x / cosh x
- asinh x = log (x + sqrt (x*x + 1))
- acosh x = log (x + sqrt (x*x - 1))
- atanh x = (log (1 + x) - log (1 - x)) / 2
-
-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) 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, signficand,
- -- 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 (-)
-
-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
-
--- Index and Enumeration classes --------------------------------------------
-
-class (Ord a) => Ix a where
- range :: (a,a) -> [a]
- index :: (a,a) -> a -> Int
- inRange :: (a,a) -> a -> Bool
- rangeSize :: (a,a) -> Int
-
- rangeSize r@(l,u)
- | l > u = 0
- | otherwise = index r u + 1
-
-class Enum a where
- succ, pred :: a -> a
- toEnum :: Int -> a
- fromEnum :: a -> Int
- enumFrom :: a -> [a] -- [n..]
- enumFromThen :: a -> a -> [a] -- [n,m..]
- enumFromTo :: a -> a -> [a] -- [n..m]
- enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
-
- -- Minimal complete definition: toEnum, fromEnum
- succ = toEnum . (1+) . fromEnum
- pred = toEnum . subtract 1 . fromEnum
- enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
- enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
-
--- Read and Show classes ------------------------------------------------------
-
-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
- show :: a -> String
- showsPrec :: Int -> a -> ShowS
- showList :: [a] -> ShowS
-
- -- Minimal complete definition: show or showsPrec
- show x = showsPrec 0 x ""
- showsPrec _ x s = show x ++ s
- showList [] = showString "[]"
- showList (x:xs) = showChar '[' . shows x . showl xs
- where showl [] = showChar ']'
- showl (x:xs) = showChar ',' . shows x . showl xs
-
--- Monad classes ------------------------------------------------------------
-
-class Functor f where
- fmap :: (a -> b) -> (f a -> f b)
-
-class Monad m where
- return :: a -> m a
- (>>=) :: m a -> (a -> m b) -> m b
- (>>) :: m a -> m b -> m b
- fail :: String -> m a
-
- -- Minimal complete definition: (>>=), return
- p >> q = p >>= \ _ -> q
- fail s = error s
-
-accumulate :: Monad m => [m a] -> m [a]
-accumulate [] = return []
-accumulate (c:cs) = do x <- c
- xs <- accumulate cs
- return (x:xs)
-
-sequence :: Monad m => [m a] -> m ()
-sequence = foldr (>>) (return ())
-
-mapM :: Monad m => (a -> m b) -> [a] -> m [b]
-mapM f = accumulate . map f
-
-mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
-mapM_ f = sequence . map f
-
-(=<<) :: Monad m => (a -> m b) -> m a -> m b
-f =<< x = x >>= f
-
--- Evaluation and strictness ------------------------------------------------
-
-seq :: a -> b -> b
-seq x y = --case primForce x of () -> y
- primSeq x y
-
-($!) :: (a -> b) -> a -> b
-f $! x = x `seq` f x
-
--- Trivial type -------------------------------------------------------------
-
--- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
-
-instance Eq () where
- () == () = True
-
-instance Ord () where
- compare () () = EQ
-
-instance Ix () where
- range ((),()) = [()]
- index ((),()) () = 0
- inRange ((),()) () = True
-
-instance Enum () where
- toEnum 0 = ()
- fromEnum () = 0
- enumFrom () = [()]
- enumFromThen () () = [()]
-
-instance Read () where
- readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
- (")",t) <- lex s ])
-
-instance Show () where
- showsPrec p () = showString "()"
-
-instance Bounded () where
- minBound = ()
- maxBound = ()
-
--- Boolean type -------------------------------------------------------------
-
-data Bool = False | True
- deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
-
-(&&), (||) :: Bool -> Bool -> Bool
-False && x = False
-True && x = x
-False || x = x
-True || x = True
-
-not :: Bool -> Bool
-not True = False
-not False = True
-
-otherwise :: Bool
-otherwise = True
-
--- Character type -----------------------------------------------------------
-
-data Char -- builtin datatype of ISO Latin characters
-type String = [Char] -- strings are lists of characters
-
-instance Eq Char where (==) = primEqChar
-instance Ord Char where (<=) = primLeChar
-
-instance Enum Char where
- toEnum = primIntToChar
- fromEnum = primCharToInt
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
- where lastChar = if d < c then minBound else maxBound
-
-instance Ix Char where
- range (c,c') = [c..c']
- index b@(c,c') ci
- | inRange b ci = fromEnum ci - fromEnum c
- | otherwise = error "Ix.index: Index out of range."
- inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
- where i = fromEnum ci
-
-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
-
-instance Bounded Char where
- minBound = '\0'
- maxBound = '\255'
-
-isAscii, isControl, isPrint, isSpace :: Char -> Bool
-isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
-
-isAscii c = fromEnum c < 128
-isControl c = c < ' ' || c == '\DEL'
-isPrint c = c >= ' ' && c <= '~'
-isSpace c = c == ' ' || c == '\t' || c == '\n' ||
- c == '\r' || c == '\f' || c == '\v'
-isUpper c = c >= 'A' && c <= 'Z'
-isLower c = c >= 'a' && c <= 'z'
-isAlpha c = isUpper c || isLower c
-isDigit c = c >= '0' && c <= '9'
-isAlphaNum c = isAlpha c || isDigit c
-
--- 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"
-
-toUpper, toLower :: Char -> Char
-toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
- | otherwise = c
-
-toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
- | otherwise = c
-
-ord :: Char -> Int
-ord = fromEnum
-
-chr :: Int -> Char
-chr = toEnum
-
--- 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 l r (Left x) = l x
-either l r (Right y) = r y
-
--- Ordering type ------------------------------------------------------------
-
-data Ordering = LT | EQ | GT
- deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
-
--- Lists --------------------------------------------------------------------
-
---data [a] = [] | a : [a] deriving (Eq, Ord)
-
-instance Eq a => Eq [a] where
- [] == [] = True
- (x:xs) == (y:ys) = x==y && xs==ys
- _ == _ = False
-
-instance Ord a => Ord [a] where
- compare [] (_:_) = LT
- compare [] [] = EQ
- compare (_:_) [] = GT
- compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
-
-instance Functor [] where
- fmap = map
-
-instance Monad [ ] where
- (x:xs) >>= f = f x ++ (xs >>= f)
- [] >>= f = []
- return x = [x]
- fail s = []
-
-instance Read a => Read [a] where
- readsPrec p = readList
-
-instance Show a => Show [a] where
- showsPrec p = showList
-
--- Tuples -------------------------------------------------------------------
-
--- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
--- etc..
-
--- Functions ----------------------------------------------------------------
-
-instance Show (a -> b) where
- showsPrec p f = showString "<<function>>"
-
-instance Functor ((->) a) where
- fmap = (.)
-
--- Standard Integral types --------------------------------------------------
-
-data Int -- builtin datatype of fixed size integers
-data Integer -- builtin datatype of arbitrary size integers
-
-instance Eq Integer where
- (==) x y = primCompareInteger x y == 0
-
-instance Ord Integer where
- compare x y = case primCompareInteger x y of
- -1 -> LT
- 0 -> EQ
- 1 -> GT
-
-instance Eq Int where
- (==) = primEqInt
- (/=) = primNeInt
-
-instance Ord Int where
- (<) = primLtInt
- (<=) = primLeInt
- (>=) = primGeInt
- (>) = primGtInt
-
-instance Num Int where
- (+) = primPlusInt
- (-) = primMinusInt
- negate = primNegateInt
- (*) = primTimesInt
- abs = absReal
- signum = signumReal
- fromInteger = primIntegerToInt
- fromInt x = x
-
-instance Bounded Int where
- minBound = primMinInt
- maxBound = primMaxInt
-
-instance Num Integer where
- (+) = primPlusInteger
- (-) = primMinusInteger
- negate = primNegateInteger
- (*) = primTimesInteger
- abs = absReal
- signum = signumReal
- fromInteger x = x
- fromInt = primIntToInteger
-
-absReal x | x >= 0 = x
- | otherwise = -x
-
-signumReal x | x == 0 = 0
- | x > 0 = 1
- | otherwise = -1
-
-instance Real Int where
- toRational x = toInteger x % 1
-
-instance Real Integer where
- toRational x = x % 1
-
-instance Integral Int where
- quotRem = primQuotRemInt
- toInteger = primIntToInteger
- toInt x = x
-
-instance Integral Integer where
- quotRem = primQuotRemInteger
- divMod = primDivModInteger
- toInteger = id
- toInt = primIntegerToInt
-
-instance Ix Int where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = i - m
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Ix Integer where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = fromInteger (i - m)
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Int where
- toEnum = id
- fromEnum = id
- enumFrom = numericEnumFrom
- enumFromTo = numericEnumFromTo
- enumFromThen = numericEnumFromThen
- enumFromThenTo = numericEnumFromThenTo
-
-instance Enum Integer where
- toEnum = primIntToInteger
- fromEnum = primIntegerToInt
- enumFrom = numericEnumFrom
- enumFromTo = numericEnumFromTo
- enumFromThen = numericEnumFromThen
- enumFromThenTo = numericEnumFromThenTo
-
-numericEnumFrom :: Real a => a -> [a]
-numericEnumFromThen :: Real a => a -> a -> [a]
-numericEnumFromTo :: Real a => a -> a -> [a]
-numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
-numericEnumFrom n = n : (numericEnumFrom $! (n+1))
-numericEnumFromThen n m = iterate ((m-n)+) n
-numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
-numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
- where p | n' > n = (<= m)
- | otherwise = (>= m)
-
-instance Read Int where
- readsPrec p = readSigned readDec
-
-instance Show Int where
- showsPrec p n
- | n == minBound = showSigned showInt p (toInteger n)
- | otherwise = showSigned showInt p n
-
-instance Read Integer where
- readsPrec p = readSigned readDec
-
-instance Show Integer where
- showsPrec = showSigned showInt
-
--- Standard Floating types --------------------------------------------------
-
-data Float -- builtin datatype of single precision floating point numbers
-data Double -- builtin datatype of double precision floating point numbers
-
-instance Eq Float where
- (==) = primEqFloat
- (/=) = primNeFloat
-
-instance Ord Float where
- (<) = primLtFloat
- (<=) = primLeFloat
- (>=) = primGeFloat
- (>) = primGtFloat
-
-instance Num Float where
- (+) = primPlusFloat
- (-) = primMinusFloat
- negate = primNegateFloat
- (*) = primTimesFloat
- abs = absReal
- signum = signumReal
- fromInteger = primIntegerToFloat
- fromInt = primIntToFloat
-
-
-
-instance Eq Double where
- (==) = primEqDouble
- (/=) = primNeDouble
-
-instance Ord Double where
- (<) = primLtDouble
- (<=) = primLeDouble
- (>=) = primGeDouble
- (>) = primGtDouble
-
-instance Num Double where
- (+) = primPlusDouble
- (-) = primMinusDouble
- negate = primNegateDouble
- (*) = primTimesDouble
- abs = absReal
- signum = signumReal
- fromInteger = primIntegerToDouble
- fromInt = primIntToDouble
-
-
-
-instance Real Float where
- toRational = floatToRational
-
-instance Real Double where
- toRational = doubleToRational
-
--- Calls to these functions are optimised when passed as arguments to
--- fromRational.
-floatToRational :: Float -> Rational
-doubleToRational :: Double -> Rational
-floatToRational x = realFloatToRational x
-doubleToRational x = realFloatToRational x
-
-realFloatToRational x = (m%1)*(b%1)^^n
- where (m,n) = decodeFloat x
- b = floatRadix x
-
-instance Fractional Float where
- (/) = primDivideFloat
- fromRational = rationalToRealFloat
- fromDouble = primDoubleToFloat
-
-
-instance Fractional Double where
- (/) = primDivideDouble
- fromRational = rationalToRealFloat
- fromDouble x = x
-
-rationalToRealFloat x = x'
- where x' = f e
- f e = if e' == e then y else f e'
- where y = encodeFloat (round (x * (1%b)^^e)) e
- (_,e') = decodeFloat y
- (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
- / fromInteger (denominator x))
- b = floatRadix x'
-
-instance Floating Float where
- pi = 3.14159265358979323846
- exp = primExpFloat
- log = primLogFloat
- sqrt = primSqrtFloat
- sin = primSinFloat
- cos = primCosFloat
- tan = primTanFloat
- asin = primAsinFloat
- acos = primAcosFloat
- atan = primAtanFloat
-
-instance Floating Double where
- pi = 3.14159265358979323846
- exp = primExpDouble
- log = primLogDouble
- sqrt = primSqrtDouble
- sin = primSinDouble
- cos = primCosDouble
- tan = primTanDouble
- asin = primAsinDouble
- acos = primAcosDouble
- atan = primAtanDouble
-
-instance RealFrac Float where
- properFraction = floatProperFraction
-
-instance RealFrac Double where
- properFraction = floatProperFraction
-
-floatProperFraction x
- | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
- | otherwise = (fromInteger w, encodeFloat r n)
- where (m,n) = decodeFloat x
- b = floatRadix x
- (w,r) = quotRem m (b^(-n))
-
-instance RealFloat Float where
- floatRadix _ = toInteger primRadixFloat
- floatDigits _ = primDigitsFloat
- floatRange _ = (primMinExpFloat,primMaxExpFloat)
- encodeFloat = primEncodeFloatZ
- decodeFloat = primDecodeFloatZ
- isNaN = primIsNaNFloat
- isInfinite = primIsInfiniteFloat
- isDenormalized= primIsDenormalizedFloat
- isNegativeZero= primIsNegativeZeroFloat
- isIEEE = const primIsIEEEFloat
-
-instance RealFloat Double where
- floatRadix _ = toInteger primRadixDouble
- floatDigits _ = primDigitsDouble
- floatRange _ = (primMinExpDouble,primMaxExpDouble)
- encodeFloat = primEncodeDoubleZ
- decodeFloat = primDecodeDoubleZ
- isNaN = primIsNaNDouble
- isInfinite = primIsInfiniteDouble
- isDenormalized= primIsDenormalizedDouble
- isNegativeZero= primIsNegativeZeroDouble
- isIEEE = const primIsIEEEDouble
-
-instance Enum Float where
- toEnum = primIntToFloat
- fromEnum = truncate
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo n m = numericEnumFromTo n (m+1/2)
- enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
-
-instance Enum Double where
- toEnum = primIntToDouble
- fromEnum = truncate
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo n m = numericEnumFromTo n (m+1/2)
- enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
-
-instance Read Float where
- readsPrec p = readSigned readFloat
-
-instance Show Float where
- showsPrec p = showFloat
- --error "should call showFloat"
-
-instance Read Double where
- readsPrec p = readSigned readFloat
-
--- Note that showFloat in Numeric isn't used here
-instance Show Double where
- showsPrec p = showFloat
- --error "should call showFloat"
-
--- Some standard functions --------------------------------------------------
-
-fst :: (a,b) -> a
-fst (x,_) = x
-
-snd :: (a,b) -> b
-snd (_,y) = y
-
-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)
-
-id :: a -> a
-id x = x
-
-const :: a -> b -> a
-const k _ = k
-
-(.) :: (b -> c) -> (a -> b) -> (a -> c)
-(f . g) x = f (g x)
-
-flip :: (a -> b -> c) -> b -> a -> c
-flip f x y = f y x
-
-($) :: (a -> b) -> a -> b
-f $ x = f x
-
-until :: (a -> Bool) -> (a -> a) -> a -> a
-until p f x = if p x then x else until p f (f x)
-
-asTypeOf :: a -> a -> a
-asTypeOf = const
-
-error :: String -> a
-error msg = primRaise (ErrorCall msg)
-
-undefined :: a
-undefined | False = undefined
-
--- Standard functions on rational numbers {PreludeRatio} --------------------
-
-data Integral a => Ratio a = a :% a deriving (Eq)
-type Rational = Ratio Integer
-
-(%) :: Integral a => a -> a -> Ratio a
-x % y = reduce (x * signum y) (abs y)
-
-reduce :: Integral a => a -> a -> Ratio a
-reduce x y | y == 0 = error "Ratio.%: zero denominator"
- | otherwise = (x `quot` d) :% (y `quot` d)
- where d = gcd x y
-
-numerator, denominator :: Integral a => Ratio a -> a
-numerator (x :% y) = x
-denominator (x :% y) = y
-
-instance Integral a => Ord (Ratio a) where
- compare (x:%y) (x':%y') = compare (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) = negate x :% y
- abs (x :% y) = abs x :% y
- signum (x :% y) = signum x :% 1
- fromInteger x = fromInteger x :% 1
- fromInt = intToRatio
-
--- Hugs optimises code of the form fromRational (intToRatio x)
-intToRatio :: Integral a => Int -> Ratio a
-intToRatio x = fromInt 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) = if x < 0 then (-y) :% (-x) else y :% x
- fromRational (x:%y) = fromInteger x :% fromInteger y
- fromDouble = doubleToRatio
-
--- Hugs optimises code of the form fromRational (doubleToRatio x)
-doubleToRatio :: Integral a => Double -> Ratio a
-doubleToRatio x
- | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
- | otherwise = fromInteger m % (fromInteger b ^ (-n))
- where (m,n) = decodeFloat x
- b = floatRadix x
-
-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 = fromInt
- fromEnum = truncate
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
-
-instance (Read a, Integral a) => Read (Ratio a) where
- readsPrec p = readParen (p > 7)
- (\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 > 7)
- (shows x . showString " % " . shows y)
-
-approxRational :: RealFrac a => a -> a -> Rational
-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
-
--- Standard list functions {PreludeList} ------------------------------------
-
-head :: [a] -> a
-head (x:_) = x
-
-last :: [a] -> a
-last [x] = x
-last (_:xs) = last xs
-
-tail :: [a] -> [a]
-tail (_:xs) = xs
-
-init :: [a] -> [a]
-init [x] = []
-init (x:xs) = x : init xs
-
-null :: [a] -> Bool
-null [] = True
-null (_:_) = False
-
-(++) :: [a] -> [a] -> [a]
-[] ++ ys = ys
-(x:xs) ++ ys = x : (xs ++ ys)
-
-map :: (a -> b) -> [a] -> [b]
-map f xs = [ f x | x <- xs ]
-
-filter :: (a -> Bool) -> [a] -> [a]
-filter p xs = [ x | x <- xs, p x ]
-
-concat :: [[a]] -> [a]
-concat = foldr (++) []
-
-length :: [a] -> Int
-length = foldl' (\n _ -> n + 1) 0
-
-(!!) :: [b] -> Int -> b
-(x:_) !! 0 = x
-(_:xs) !! n | n>0 = xs !! (n-1)
-(_:_) !! _ = error "Prelude.!!: negative index"
-[] !! _ = error "Prelude.!!: index too large"
-
-foldl :: (a -> b -> a) -> a -> [b] -> a
-foldl f z [] = z
-foldl f z (x:xs) = foldl f (f z x) xs
-
-foldl' :: (a -> b -> a) -> a -> [b] -> a
-foldl' f a [] = a
-foldl' f a (x:xs) = (foldl' f $! f a x) xs
-
-foldl1 :: (a -> a -> a) -> [a] -> a
-foldl1 f (x:xs) = foldl f x xs
-
-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
-
-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)
-
-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
-
-iterate :: (a -> a) -> a -> [a]
-iterate f x = x : iterate f (f x)
-
-repeat :: a -> [a]
-repeat x = xs where xs = x:xs
-
-replicate :: Int -> a -> [a]
-replicate n x = take n (repeat x)
-
-cycle :: [a] -> [a]
-cycle [] = error "Prelude.cycle: empty list"
-cycle xs = xs' where xs'=xs++xs'
-
-take :: Int -> [a] -> [a]
-take 0 _ = []
-take _ [] = []
-take n (x:xs) | n>0 = x : take (n-1) xs
-take _ _ = error "Prelude.take: negative argument"
-
-drop :: Int -> [a] -> [a]
-drop 0 xs = xs
-drop _ [] = []
-drop n (_:xs) | n>0 = drop (n-1) xs
-drop _ _ = error "Prelude.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 "Prelude.splitAt: negative argument"
-
-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 :: 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 (\l -> l ++ "\n")
-
-unwords :: [String] -> String
-unwords [] = []
-unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
-
-reverse :: [a] -> [a]
-reverse = foldl (flip (:)) []
-
-and, or :: [Bool] -> Bool
-and = foldr (&&) True
-or = foldr (||) False
-
-any, all :: (a -> Bool) -> [a] -> Bool
-any p = or . map p
-all p = and . map p
-
-elem, notElem :: Eq a => a -> [a] -> Bool
-elem = any . (==)
-notElem = all . (/=)
-
-lookup :: Eq a => a -> [(a,b)] -> Maybe b
-lookup k [] = Nothing
-lookup k ((x,y):xys)
- | k==x = Just y
- | otherwise = lookup k xys
-
-sum, product :: Num a => [a] -> a
-sum = foldl' (+) 0
-product = foldl' (*) 1
-
-maximum, minimum :: Ord a => [a] -> a
-maximum = foldl1 max
-minimum = foldl1 min
-
-concatMap :: (a -> [b]) -> [a] -> [b]
-concatMap f = concat . map f
-
-zip :: [a] -> [b] -> [(a,b)]
-zip = zipWith (\a b -> (a,b))
-
-zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
-zip3 = zipWith3 (\a b c -> (a,b,c))
-
-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 :: [(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))
- ([],[],[])
-
--- PreludeText ----------------------------------------------------------------
-
-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
-
-showField :: Show a => String -> a -> ShowS
-showField m v = showString m . showChar '=' . shows v
-
-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 ]
-
-
-readField :: Read a => String -> ReadS a
-readField m s0 = [ r | (t, s1) <- lex s0, t == m,
- ("=",s2) <- lex s1,
- r <- reads s2 ]
-
-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 ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
- (e,u) <- lexExp t ]
- lexFracExp s = [("",s)]
-
- lexExp (e:s) | e `elem` "eE"
- = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
- (ds,u) <- lexDigits t] ++
- [(e:ds,t) | (ds,t) <- lexDigits s]
- lexExp s = [("",s)]
-
-lexDigits :: ReadS String
-lexDigits = nonnull isDigit
-
-nonnull :: (Char -> Bool) -> ReadS String
-nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
-
-lexLitChar :: ReadS String
-lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
- where
- lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
- lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
- lexEsc s@(d:_) | isDigit d = lexDigits s
- lexEsc s@(c:_) | isUpper c
- = let table = ('\DEL',"DEL") : asciiTab
- in case [(mne,s') | (c, mne) <- table,
- ([],s') <- [lexmatch mne s]]
- of (pr:_) -> [pr]
- [] -> []
- lexEsc _ = []
-lexLitChar (c:s) = [([c],s)]
-lexLitChar "" = []
-
-isOctDigit c = c >= '0' && c <= '7'
-isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
- || c >= 'a' && c <= 'f'
-
-lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
-lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
-lexmatch xs ys = (xs,ys)
-
-asciiTab = 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"]
-
-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 <= '_'
- = [(toEnum (fromEnum c - fromEnum '@'), s)]
- readEsc s@(d:_) | isDigit d
- = [(toEnum n, t) | (n,t) <- readDec s]
- readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
- readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
- readEsc s@(c:_) | isUpper c
- = let table = ('\DEL',"DEL") : asciiTab
- in case [(c,s') | (c, mne) <- table,
- ([],s') <- [lexmatch mne s]]
- of (pr:_) -> [pr]
- [] -> []
- readEsc _ = []
-readLitChar (c:s) = [(c,s)]
-
-showLitChar :: Char -> ShowS
-showLitChar c | c > '\DEL' = showChar '\\' .
- protectEsc isDigit (shows (fromEnum 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!!fromEnum c))
-
-protectEsc p f = f . cont
- where cont s@(c:_) | p c = "\\&" ++ s
- cont s = s
-
--- Unsigned readers for various bases
-readDec, readOct, readHex :: Integral a => ReadS a
-readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
-readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
-readHex = readInt 16 isHexDigit hex
- where hex d = fromEnum d -
- (if isDigit d
- then fromEnum '0'
- else fromEnum (if isUpper d then 'A' else 'a') - 10)
-
--- 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 ]
-
--- showInt is used for positive numbers only
-showInt :: Integral a => a -> ShowS
-showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers"
- | otherwise =
- let (n',d) = quotRem n 10
- r' = toEnum (fromEnum '0' + fromIntegral d) : r
- in if n' == 0 then r' else showInt n' r'
-
-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]
-
-showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
-showSigned showPos p x = if x < 0 then showParen (p > 6)
- (showChar '-' . showPos (-x))
- else showPos x
-
-readFloat :: RealFloat a => ReadS a
-readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
- (k,t) <- readExp s]
- where readFix r = [(read (ds++ds'), length ds', t)
- | (ds, s) <- lexDigits r
- , (ds',t) <- lexFrac s ]
-
- lexFrac ('.':s) = lexDigits s
- 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
-
-
--- Hooks for primitives: -----------------------------------------------------
--- Do not mess with these!
-
-primCompAux :: Ord a => a -> a -> Ordering -> Ordering
-primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
-
-primPmInt :: Num a => Int -> a -> Bool
-primPmInt n x = fromInt n == x
-
-primPmInteger :: Num a => Integer -> a -> Bool
-primPmInteger n x = fromInteger n == x
-
-primPmFlt :: Fractional a => Double -> a -> Bool
-primPmFlt n x = fromDouble n == x
-
--- ToDo: make the message more informative.
-primPmFail :: a
-primPmFail = error "Pattern Match Failure"
-
--- used in desugaring Foreign functions
-primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
-primMkIO = ST
-
--- The following primitives are only needed if (n+k) patterns are enabled:
-primPmNpk :: Integral a => Int -> a -> Maybe a
-primPmNpk n x = if n'<=x then Just (x-n') else Nothing
- where n' = fromInt n
-
-primPmSub :: Integral a => Int -> a -> a
-primPmSub n x = x - fromInt n
-
--- Unpack strings generated by the Hugs code generator.
--- Strings can contain \0 provided they're coded right.
---
--- ToDo: change this (and Hugs code generator) to use ByteArrays
-
-primUnpackString :: Addr -> String
-primUnpackString a = unpack 0
- where
- -- The following decoding is based on evalString in the old machine.c
- unpack i
- | c == '\0' = []
- | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
- then '\\' : unpack (i+2)
- else '\0' : unpack (i+2)
- | otherwise = c : unpack (i+1)
- where
- c = primIndexCharOffAddr a i
-
-apply f x = f x
-
-
--- Monadic I/O: --------------------------------------------------------------
-
-type FilePath = String
-
---data IOError = ...
---instance Eq IOError ...
---instance Show IOError ...
-
-data IOError = IOError String
-instance Show IOError where
- showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
-
-ioError :: IOError -> IO a
-ioError (IOError s) = --trace ("ioError: " ++ s) (
- primRaise (IOExcept s)
- --)
-
-userError :: String -> IOError
-userError s = primRaise (ErrorCall s)
-
-catch :: IO a -> (IOError -> IO a) -> IO a
-catch x eh = primCatch x (eh.exception2ioerror)
- where
- exception2ioerror (IOExcept s) = IOError s
- exception2ioerror other = IOError (show other)
-
-putChar :: Char -> IO ()
-putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c)
-
-putStr :: String -> IO ()
-putStr s = mapM_ putChar s -- correct, but slow
- --nh_stdout >>= \h ->
- --let loop [] = return ()
- -- loop (c:cs) = nh_write h (primCharToInt c) >> loop cs
- --in loop s
-
-putStrLn :: String -> IO ()
-putStrLn s = do { putStr s; putChar '\n' }
-
-print :: Show a => a -> IO ()
-print = putStrLn . show
-
-getChar :: IO Char
-getChar = nh_stdin >>= \h ->
- nh_read h >>= \ci ->
- return (primIntToChar ci)
-
-getLine :: IO String
-getLine = do c <- getChar
- if c=='\n' then return ""
- else do cs <- getLine
- return (c:cs)
-
-getContents :: IO String
-getContents = nh_stdin >>= \h -> readfromhandle h
-
-interact :: (String -> String) -> IO ()
-interact f = getContents >>= (putStr . f)
-
-readFile :: FilePath -> IO String
-readFile fname
- = fileopen_sendname fname >>= \ptr ->
- nh_open ptr 0 >>= \h ->
- nh_free ptr >>
- nh_errno >>= \errno ->
- if (h == 0 || errno /= 0)
- then (ioError.IOError) ("readFile: can't open file " ++ fname)
- else readfromhandle h
-
-writeFile :: FilePath -> String -> IO ()
-writeFile fname contents
- = fileopen_sendname fname >>= \ptr ->
- nh_open ptr 1 >>= \h ->
- nh_free ptr >>
- nh_errno >>= \errno ->
- if (h == 0 || errno /= 0)
- then (ioError.IOError) ("writeFile: can't create file " ++ fname)
- else writetohandle fname h contents
-
-
-appendFile :: FilePath -> String -> IO ()
-appendFile fname contents
- = fileopen_sendname fname >>= \ptr ->
- nh_open ptr 2 >>= \h ->
- nh_free ptr >>
- nh_errno >>= \errno ->
- if (h == 0 || errno /= 0)
- then (ioError.IOError) ("appendFile: can't open file " ++ fname)
- else writetohandle fname h contents
-
-
--- 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 "PreludeIO.readIO: no parse")
- _ -> ioError (userError
- "PreludeIO.readIO: ambiguous parse")
-
-readLn :: Read a => IO a
-readLn = do l <- getLine
- r <- readIO l
- return r
-
-
--- End of Hugs standard prelude ----------------------------------------------
-
-data Exception
- = ErrorCall String
- | IOExcept String
-
-instance Show Exception where
- showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
- showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
-
-data IOResult = IOResult deriving (Show)
-
-type FILE_STAR = Int
-
-foreign import stdcall "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO ()
-foreign import stdcall "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int
-foreign import stdcall "nHandle.so" "nh_open" nh_open :: Int -> Int -> IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO ()
-foreign import stdcall "nHandle.so" "nh_errno" nh_errno :: IO Int
-
-foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Int
-foreign import stdcall "nHandle.so" "nh_free" nh_free :: Int -> IO ()
-foreign import stdcall "nHandle.so" "nh_assign" nh_assign :: Int -> Int -> Int -> IO Int
-
-fileopen_sendname :: String -> IO Int
-fileopen_sendname fname
- = nh_malloc (1 + length fname) >>= \ptr ->
- let loop i [] = nh_assign ptr i 0 >> return ptr
- loop i (c:cs) = nh_assign ptr i (primCharToInt c) >> loop (i+1) cs
- in
- loop 0 fname
-
-readfromhandle :: FILE_STAR -> IO String
-readfromhandle h
- = nh_read h >>= \ci ->
- if ci == -1 {-EOF-} then return "" else
- readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
-
-writetohandle :: String -> FILE_STAR -> String -> IO ()
-writetohandle fname h []
- = nh_close h >>
- nh_errno >>= \errno ->
- if errno == 0
- then return ()
- else error ( "writeFile/appendFile: error closing file " ++ fname)
-writetohandle fname h (c:cs)
- = nh_write h (primCharToInt c) >>
- writetohandle fname h cs
-
-
-------------------------------------------------------------------------------
--- ST, IO --------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-newtype ST s a = ST (s -> (a,s))
---data ST s a = ST (s -> (a,s))
-
-data RealWorld
-type IO a = ST RealWorld a
-
-
---runST :: (forall s. ST s a) -> a
-runST :: ST RealWorld a -> a
-runST m = fst (unST m theWorld)
- where
- theWorld :: RealWorld
- theWorld = error "runST: entered the RealWorld"
-
-unST (ST a) = a
-
-instance Functor (ST s) where
- fmap f x = x >>= (return . f)
-
-instance Monad (ST s) where
- m >> k = m >>= \ _ -> k
- return x = ST $ \ s -> (x,s)
- m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' }
-
-
--- used when Hugs invokes top level function
-{-
-primRunIO :: IO () -> ()
-primRunIO m
- = fst (unST (protect 5 m) realWorld)
- where
- realWorld = error "panic: Hugs entered the RealWorld"
-
- protect :: Int -> IO () -> IO ()
- protect n x
- | n < 5 && trace ("protect " ++ show n) False = error "???"
- protect 0 x
- = putStr "\nerror: too many nested errors\n"
- protect n x
- = --primCatch x (\e -> protect (n-1) (putStrSPEC (show e)))
- primCatch x (\e -> trace (show e) (return ()))
--}
-
-primRunIO :: IO () -> ()
-primRunIO m
- = protect (fst (unST m realWorld))
- where
- realWorld = error "panic: Hugs entered the real world"
- protect :: () -> ()
- protect comp
- = primCatch comp (\e -> fst (unST (putStr (show e)) realWorld))
-
-trace :: String -> a -> a
-trace s x
- = (runST (putStr ("trace: " ++ s ++ "\n"))) `seq` x
-
-
-------------------------------------------------------------------------------
--- Addr, ForeignObj, Prim*Array ----------------------------------------------
-------------------------------------------------------------------------------
-
-data Addr
-
-nullAddr = primIntToAddr 0
-
-instance Eq Addr where
- (==) = primEqAddr
- (/=) = primNeAddr
-
-instance Ord Addr where
- (<) = primLtAddr
- (<=) = primLeAddr
- (>=) = primGeAddr
- (>) = primGtAddr
-
-
-data ForeignObj
-makeForeignObj :: Addr -> IO ForeignObj
-makeForeignObj = primMakeForeignObj
-
-
-data PrimArray a -- immutable arrays with Int indices
-data PrimByteArray
-
-data Ref s a -- mutable variables
-data PrimMutableArray s a -- mutable arrays with Int indices
-data PrimMutableByteArray s
-
-
-------------------------------------------------------------------------------
--- hooks to call libHS_cbits -------------------------------------------------
-------------------------------------------------------------------------------
-{-
-type FILE_OBJ = ForeignObj -- as passed into functions
-type CString = PrimByteArray
-type How = Int
-type Binary = Int
-type OpenFlags = Int
-type IOFileAddr = Addr -- as returned from functions
-type FD = Int
-type OpenStdFlags = Int
-type Readable = Int -- really Bool
-type Exclusive = Int -- really Bool
-type RC = Int -- standard return code
-type Bytes = PrimMutableByteArray RealWorld
-type Flush = Int -- really Bool
-
-foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
- freeStdFileObject :: ForeignObj -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "freeFileObject"
- freeFileObject :: ForeignObj -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "setBuf"
- prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "getBufSize"
- prim_getBufSize :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "inputReady"
- prim_inputReady :: FILE_OBJ -> Int -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "fileGetc"
- prim_fileGetc :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "fileLookAhead"
- prim_fileLookAhead :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "readBlock"
- prim_readBlock :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "readLine"
- prim_readLine :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "readChar"
- prim_readChar :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "writeFileObject"
- prim_writeFileObject :: FILE_OBJ -> Int -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "filePutc"
- prim_filePutc :: FILE_OBJ -> Char -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "getBufStart"
- prim_getBufStart :: FILE_OBJ -> Int -> IO Addr
-
-foreign import stdcall "libHS_cbits.so" "getWriteableBuf"
- prim_getWriteableBuf :: FILE_OBJ -> IO Addr
-
-foreign import stdcall "libHS_cbits.so" "getBufWPtr"
- prim_getBufWPtr :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "setBufWPtr"
- prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "closeFile"
- prim_closeFile :: FILE_OBJ -> Flush -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "fileEOF"
- prim_fileEOF :: FILE_OBJ -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "setBuffering"
- prim_setBuffering :: FILE_OBJ -> Int -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "flushFile"
- prim_flushFile :: FILE_OBJ -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "getBufferMode"
- prim_getBufferMode :: FILE_OBJ -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "seekFileP"
- prim_seekFileP :: FILE_OBJ -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "setTerminalEcho"
- prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "getTerminalEcho"
- prim_getTerminalEcho :: FILE_OBJ -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "isTerminalDevice"
- prim_isTerminalDevice :: FILE_OBJ -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "setConnectedTo"
- prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "ungetChar"
- prim_ungetChar :: FILE_OBJ -> Char -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "readChunk"
- prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "writeBuf"
- prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "getFileFd"
- prim_getFileFd :: FILE_OBJ -> IO FD
-
-foreign import stdcall "libHS_cbits.so" "fileSize_int64"
- prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "getFilePosn"
- prim_getFilePosn :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "setFilePosn"
- prim_setFilePosn :: FILE_OBJ -> Int -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "getConnFileFd"
- prim_getConnFileFd :: FILE_OBJ -> IO FD
-
-foreign import stdcall "libHS_cbits.so" "allocMemory__"
- prim_allocMemory__ :: Int -> IO Addr
-
-foreign import stdcall "libHS_cbits.so" "getLock"
- prim_getLock :: FD -> Exclusive -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "openStdFile"
- prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
-
-foreign import stdcall "libHS_cbits.so" "openFile"
- prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
-
-foreign import stdcall "libHS_cbits.so" "freeFileObject"
- prim_freeFileObject :: FILE_OBJ -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
- prim_freeStdFileObject :: FILE_OBJ -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "const_BUFSIZ"
- const_BUFSIZ :: Int
-
-foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__"
- prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__"
- prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__"
- prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__"
- prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "getErrStr__"
- prim_getErrStr__ :: IO Addr
-
-foreign import stdcall "libHS_cbits.so" "getErrNo__"
- prim_getErrNo__ :: IO Int
-
-foreign import stdcall "libHS_cbits.so" "getErrType__"
- prim_getErrType__ :: IO Int
-
---foreign import stdcall "libHS_cbits.so" "seekFile_int64"
--- prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
--}
-
--- showFloat ------------------------------------------------------------------
-
-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'] -> "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] -> '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 ->
- let f 0 s ds = mk0 s ++ "." ++ mk0 ds
- f n s "" = f (n-1) (s++"0") ""
- f n s (d:ds) = f (n-1) (s++[d]) ds
- mk0 "" = "0"
- mk0 s = s
- in f e "" ds
- Just dec ->
- 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 (if null ls then "0" else ls) ++
- (if null rs then "" else '.' : 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 : '.' : ds
-
-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.
--- This version uses a much slower logarithm estimator. It should be improved.
-
--- This function returns a list of digits (Ints in [0..base-1]) and an
--- exponent.
-
-floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
-
-floatToDigits _ 0 = ([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, 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 =
-
- 0
-
- 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 toInt (reverse rds), k)
-
--- Exponentiation with(out) a cache for the most common numbers.
-expt :: Integer -> Int -> Integer
-expt base n = base^n
-