1 {----------------------------------------------------------------------------
2 __ __ __ __ ____ ___ _______________________________________________
3 || || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system
4 ||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999
5 ||---|| ___|| World Wide Web: http://haskell.org/hugs
6 || || Report bugs to: hugs-bugs@haskell.org
7 || || Version: January 1999 _______________________________________________
9 This is the Hugs 98 Standard Prelude, based very closely on the Standard
10 Prelude for Haskell 98.
12 WARNING: This file is an integral part of the Hugs source code. Changes to
13 the definitions in this file without corresponding modifications in other
14 parts of the program may cause the interpreter to fail unexpectedly. Under
15 normal circumstances, you should not attempt to modify this file in any way!
17 -----------------------------------------------------------------------------
18 Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell
19 Group 1994-99, and is distributed as Open Source software under the
20 Artistic License; see the file "Artistic" that is included in the
21 distribution for details.
22 ----------------------------------------------------------------------------}
25 -- module PreludeList,
26 map, (++), concat, filter,
27 head, last, tail, init, null, length, (!!),
28 foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
29 iterate, repeat, replicate, cycle,
30 take, drop, splitAt, takeWhile, dropWhile, span, break,
31 lines, words, unlines, unwords, reverse, and, or,
32 any, all, elem, notElem, lookup,
33 sum, product, maximum, minimum, concatMap,
34 zip, zip3, zipWith, zipWith3, unzip, unzip3,
35 -- module PreludeText,
37 Read(readsPrec, readList),
38 Show(show, showsPrec, showList),
39 reads, shows, read, lex,
40 showChar, showString, readParen, showParen,
42 FilePath, IOError, ioError, userError, catch,
43 putChar, putStr, putStrLn, print,
44 getChar, getLine, getContents, interact,
45 readFile, writeFile, appendFile, readIO, readLn,
47 Ix(range, index, inRange, rangeSize),
49 isAscii, isControl, isPrint, isSpace, isUpper, isLower,
50 isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
51 digitToInt, intToDigit,
54 readLitChar, showLitChar, lexLitChar,
58 readDec, readOct, readHex, readSigned,
61 Ratio, Rational, (%), numerator, denominator, approxRational,
62 -- Non-standard exports
63 IO(..), IOResult(..), Addr,
69 Char, String, Int, Integer, Float, Double, IO,
70 -- List type: []((:), [])
72 -- Tuple types: (,), (,,), etc.
75 Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
77 Ord(compare, (<), (<=), (>=), (>), max, min),
78 Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
79 enumFromTo, enumFromThenTo),
80 Bounded(minBound, maxBound),
81 -- Num((+), (-), (*), negate, abs, signum, fromInteger),
82 Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
84 -- Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
85 Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
86 -- Fractional((/), recip, fromRational),
87 Fractional((/), recip, fromRational, fromDouble),
88 Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
89 asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
90 RealFrac(properFraction, truncate, round, ceiling, floor),
91 RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
92 encodeFloat, exponent, significand, scaleFloat, isNaN,
93 isInfinite, isDenormalized, isIEEE, isNegativeZero),
94 Monad((>>=), (>>), return, fail),
96 mapM, mapM_, accumulate, sequence, (=<<),
98 (&&), (||), not, otherwise,
99 subtract, even, odd, gcd, lcm, (^), (^^),
100 fromIntegral, realToFrac, atan2,
101 fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
102 asTypeOf, error, undefined,
106 -- Arrrggghhh!!! Help! Help! Help!
107 -- What?! Prelude.hs doesn't even _define_ most of these things!
108 ,primCompAux,PrimArray,primRunST,primNewArray,primWriteArray
109 ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv
110 ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open
111 ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar
112 ,unsafeInterleaveIO,nh_write,primCharToInt
114 -- ToDo: rm -- these are only for debugging
115 ,primPlusInt,primEqChar,primRunIO
118 -- Standard value bindings {Prelude} ----------------------------------------
123 infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
125 --infixr 5 : -- this fixity declaration is hard-wired into Hugs
127 infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
132 infixr 0 $, $!, `seq`
134 -- Equality and Ordered classes ---------------------------------------------
137 (==), (/=) :: a -> a -> Bool
139 -- Minimal complete definition: (==) or (/=)
143 class (Eq a) => Ord a where
144 compare :: a -> a -> Ordering
145 (<), (<=), (>=), (>) :: a -> a -> Bool
146 max, min :: a -> a -> a
148 -- Minimal complete definition: (<=) or compare
149 -- using compare can be more efficient for complex types
150 compare x y | x==y = EQ
154 x <= y = compare x y /= GT
155 x < y = compare x y == LT
156 x >= y = compare x y /= LT
157 x > y = compare x y == GT
164 class Bounded a where
165 minBound, maxBound :: a
166 -- Minimal complete definition: All
168 -- Numeric classes ----------------------------------------------------------
170 class (Eq a, Show a) => Num a where
171 (+), (-), (*) :: a -> a -> a
173 abs, signum :: a -> a
174 fromInteger :: Integer -> a
177 -- Minimal complete definition: All, except negate or (-)
179 fromInt = fromIntegral
182 class (Num a, Ord a) => Real a where
183 toRational :: a -> Rational
185 class (Real a, Enum a) => Integral a where
186 quot, rem, div, mod :: a -> a -> a
187 quotRem, divMod :: a -> a -> (a,a)
188 even, odd :: a -> Bool
189 toInteger :: a -> Integer
192 -- Minimal complete definition: quotRem and toInteger
193 n `quot` d = q where (q,r) = quotRem n d
194 n `rem` d = r where (q,r) = quotRem n d
195 n `div` d = q where (q,r) = divMod n d
196 n `mod` d = r where (q,r) = divMod n d
197 divMod n d = if signum r == - signum d then (q-1, r+d) else qr
198 where qr@(q,r) = quotRem n d
199 even n = n `rem` 2 == 0
201 toInt = toInt . toInteger
203 class (Num a) => Fractional a where
206 fromRational :: Rational -> a
207 fromDouble :: Double -> a
209 -- Minimal complete definition: fromRational and ((/) or recip)
211 fromDouble = fromRational . toRational
215 class (Fractional a) => Floating a where
217 exp, log, sqrt :: a -> a
218 (**), logBase :: a -> a -> a
219 sin, cos, tan :: a -> a
220 asin, acos, atan :: a -> a
221 sinh, cosh, tanh :: a -> a
222 asinh, acosh, atanh :: a -> a
224 -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
225 -- asinh, acosh, atanh
226 x ** y = exp (log x * y)
227 logBase x y = log y / log x
229 tan x = sin x / cos x
230 sinh x = (exp x - exp (-x)) / 2
231 cosh x = (exp x + exp (-x)) / 2
232 tanh x = sinh x / cosh x
233 asinh x = log (x + sqrt (x*x + 1))
234 acosh x = log (x + sqrt (x*x - 1))
235 atanh x = (log (1 + x) - log (1 - x)) / 2
237 class (Real a, Fractional a) => RealFrac a where
238 properFraction :: (Integral b) => a -> (b,a)
239 truncate, round :: (Integral b) => a -> b
240 ceiling, floor :: (Integral b) => a -> b
242 -- Minimal complete definition: properFraction
243 truncate x = m where (m,_) = properFraction x
245 round x = let (n,r) = properFraction x
246 m = if r < 0 then n - 1 else n + 1
247 in case signum (abs r - 0.5) of
249 0 -> if even n then n else m
252 ceiling x = if r > 0 then n + 1 else n
253 where (n,r) = properFraction x
255 floor x = if r < 0 then n - 1 else n
256 where (n,r) = properFraction x
258 class (RealFrac a, Floating a) => RealFloat a where
259 floatRadix :: a -> Integer
260 floatDigits :: a -> Int
261 floatRange :: a -> (Int,Int)
262 decodeFloat :: a -> (Integer,Int)
263 encodeFloat :: Integer -> Int -> a
265 significand :: a -> a
266 scaleFloat :: Int -> a -> a
267 isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
271 -- Minimal complete definition: All, except exponent, signficand,
273 exponent x = if m==0 then 0 else n + floatDigits x
274 where (m,n) = decodeFloat x
275 significand x = encodeFloat m (- floatDigits x)
276 where (m,_) = decodeFloat x
277 scaleFloat k x = encodeFloat m (n+k)
278 where (m,n) = decodeFloat x
282 | x<0 && y>0 = pi + atan (y/x)
284 (x<0 && isNegativeZero y) ||
285 (isNegativeZero x && isNegativeZero y)
287 | y==0 && (x<0 || isNegativeZero x)
288 = pi -- must be after the previous test on zero y
289 | x==0 && y==0 = y -- must be after the other double zero tests
290 | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
292 -- Numeric functions --------------------------------------------------------
294 subtract :: Num a => a -> a -> a
297 gcd :: Integral a => a -> a -> a
298 gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
299 gcd x y = gcd' (abs x) (abs y)
301 gcd' x y = gcd' y (x `rem` y)
303 lcm :: (Integral a) => a -> a -> a
306 lcm x y = abs ((x `quot` gcd x y) * y)
308 (^) :: (Num a, Integral b) => a -> b -> a
310 x ^ n | n > 0 = f x (n-1) x
312 f x n y = g x n where
313 g x n | even n = g (x*x) (n`quot`2)
314 | otherwise = f x (n-1) (x*y)
315 _ ^ _ = error "Prelude.^: negative exponent"
317 (^^) :: (Fractional a, Integral b) => a -> b -> a
318 x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
320 fromIntegral :: (Integral a, Num b) => a -> b
321 fromIntegral = fromInteger . toInteger
323 realToFrac :: (Real a, Fractional b) => a -> b
324 realToFrac = fromRational . toRational
326 -- Index and Enumeration classes --------------------------------------------
328 class (Ord a) => Ix a where
329 range :: (a,a) -> [a]
330 index :: (a,a) -> a -> Int
331 inRange :: (a,a) -> a -> Bool
332 rangeSize :: (a,a) -> Int
336 | otherwise = index r u + 1
342 enumFrom :: a -> [a] -- [n..]
343 enumFromThen :: a -> a -> [a] -- [n,m..]
344 enumFromTo :: a -> a -> [a] -- [n..m]
345 enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
347 -- Minimal complete definition: toEnum, fromEnum
348 succ = toEnum . (1+) . fromEnum
349 pred = toEnum . subtract 1 . fromEnum
350 enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
351 enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
353 -- Read and Show classes ------------------------------------------------------
355 type ReadS a = String -> [(a,String)]
356 type ShowS = String -> String
359 readsPrec :: Int -> ReadS a
360 readList :: ReadS [a]
362 -- Minimal complete definition: readsPrec
363 readList = readParen False (\r -> [pr | ("[",s) <- lex r,
365 where readl s = [([],t) | ("]",t) <- lex s] ++
366 [(x:xs,u) | (x,t) <- reads s,
368 readl' s = [([],t) | ("]",t) <- lex s] ++
369 [(x:xs,v) | (",",t) <- lex s,
375 showsPrec :: Int -> a -> ShowS
376 showList :: [a] -> ShowS
378 -- Minimal complete definition: show or showsPrec
379 show x = showsPrec 0 x ""
380 showsPrec _ x s = show x ++ s
381 showList [] = showString "[]"
382 showList (x:xs) = showChar '[' . shows x . showl xs
383 where showl [] = showChar ']'
384 showl (x:xs) = showChar ',' . shows x . showl xs
386 -- Monad classes ------------------------------------------------------------
388 class Functor f where
389 fmap :: (a -> b) -> (f a -> f b)
393 (>>=) :: m a -> (a -> m b) -> m b
394 (>>) :: m a -> m b -> m b
395 fail :: String -> m a
397 -- Minimal complete definition: (>>=), return
398 p >> q = p >>= \ _ -> q
401 accumulate :: Monad m => [m a] -> m [a]
402 accumulate [] = return []
403 accumulate (c:cs) = do x <- c
407 sequence :: Monad m => [m a] -> m ()
408 sequence = foldr (>>) (return ())
410 mapM :: Monad m => (a -> m b) -> [a] -> m [b]
411 mapM f = accumulate . map f
413 mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
414 mapM_ f = sequence . map f
416 (=<<) :: Monad m => (a -> m b) -> m a -> m b
419 -- Evaluation and strictness ------------------------------------------------
422 seq x y = primSeq x y
424 ($!) :: (a -> b) -> a -> b
425 f $! x = x `primSeq` f x
427 -- Trivial type -------------------------------------------------------------
429 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
434 instance Ord () where
440 inRange ((),()) () = True
442 instance Enum () where
446 enumFromThen () () = [()]
448 instance Read () where
449 readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
452 instance Show () where
453 showsPrec p () = showString "()"
455 instance Bounded () where
459 -- Boolean type -------------------------------------------------------------
461 data Bool = False | True
462 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
464 (&&), (||) :: Bool -> Bool -> Bool
477 -- Character type -----------------------------------------------------------
479 data Char -- builtin datatype of ISO Latin characters
480 type String = [Char] -- strings are lists of characters
482 instance Eq Char where (==) = primEqChar
483 instance Ord Char where (<=) = primLeChar
485 instance Enum Char where
486 toEnum = primIntToChar
487 fromEnum = primCharToInt
488 enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
489 enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
490 where lastChar = if d < c then minBound else maxBound
492 instance Ix Char where
493 range (c,c') = [c..c']
495 | inRange b ci = fromEnum ci - fromEnum c
496 | otherwise = error "Ix.index: Index out of range."
497 inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
498 where i = fromEnum ci
500 instance Read Char where
501 readsPrec p = readParen False
502 (\r -> [(c,t) | ('\'':s,t) <- lex r,
503 (c,"\'") <- readLitChar s ])
504 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
506 where readl ('"':s) = [("",s)]
507 readl ('\\':'&':s) = readl s
508 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
510 instance Show Char where
511 showsPrec p '\'' = showString "'\\''"
512 showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
514 showList cs = showChar '"' . showl cs
515 where showl "" = showChar '"'
516 showl ('"':cs) = showString "\\\"" . showl cs
517 showl (c:cs) = showLitChar c . showl cs
519 instance Bounded Char where
523 isAscii, isControl, isPrint, isSpace :: Char -> Bool
524 isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
526 isAscii c = fromEnum c < 128
527 isControl c = c < ' ' || c == '\DEL'
528 isPrint c = c >= ' ' && c <= '~'
529 isSpace c = c == ' ' || c == '\t' || c == '\n' ||
530 c == '\r' || c == '\f' || c == '\v'
531 isUpper c = c >= 'A' && c <= 'Z'
532 isLower c = c >= 'a' && c <= 'z'
533 isAlpha c = isUpper c || isLower c
534 isDigit c = c >= '0' && c <= '9'
535 isAlphaNum c = isAlpha c || isDigit c
537 -- Digit conversion operations
538 digitToInt :: Char -> Int
540 | isDigit c = fromEnum c - fromEnum '0'
541 | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
542 | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
543 | otherwise = error "Char.digitToInt: not a digit"
545 intToDigit :: Int -> Char
547 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
548 | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
549 | otherwise = error "Char.intToDigit: not a digit"
551 toUpper, toLower :: Char -> Char
552 toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
555 toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
564 -- Maybe type ---------------------------------------------------------------
566 data Maybe a = Nothing | Just a
567 deriving (Eq, Ord, Read, Show)
569 maybe :: b -> (a -> b) -> Maybe a -> b
570 maybe n f Nothing = n
571 maybe n f (Just x) = f x
573 instance Functor Maybe where
574 fmap f Nothing = Nothing
575 fmap f (Just x) = Just (f x)
577 instance Monad Maybe where
579 Nothing >>= k = Nothing
583 -- Either type --------------------------------------------------------------
585 data Either a b = Left a | Right b
586 deriving (Eq, Ord, Read, Show)
588 either :: (a -> c) -> (b -> c) -> Either a b -> c
589 either l r (Left x) = l x
590 either l r (Right y) = r y
592 -- Ordering type ------------------------------------------------------------
594 data Ordering = LT | EQ | GT
595 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
597 -- Lists --------------------------------------------------------------------
599 --data [a] = [] | a : [a] deriving (Eq, Ord)
601 instance Eq a => Eq [a] where
603 (x:xs) == (y:ys) = x==y && xs==ys
606 instance Ord a => Ord [a] where
607 compare [] (_:_) = LT
609 compare (_:_) [] = GT
610 compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
612 instance Functor [] where
615 instance Monad [ ] where
616 (x:xs) >>= f = f x ++ (xs >>= f)
621 instance Read a => Read [a] where
622 readsPrec p = readList
624 instance Show a => Show [a] where
625 showsPrec p = showList
627 -- Tuples -------------------------------------------------------------------
629 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
632 -- Functions ----------------------------------------------------------------
634 instance Show (a -> b) where
635 showsPrec p f = showString "<<function>>"
637 instance Functor ((->) a) where
640 -- Standard Integral types --------------------------------------------------
642 data Int -- builtin datatype of fixed size integers
643 data Integer -- builtin datatype of arbitrary size integers
645 instance Eq Integer where
646 (==) x y = primCompareInteger x y == 0
648 instance Ord Integer where
649 compare x y = case primCompareInteger x y of
654 instance Eq Int where
658 instance Ord Int where
664 instance Num Int where
667 negate = primNegateInt
671 fromInteger = primIntegerToInt
674 instance Bounded Int where
675 minBound = primMinInt
676 maxBound = primMaxInt
678 instance Num Integer where
679 (+) = primPlusInteger
680 (-) = primMinusInteger
681 negate = primNegateInteger
682 (*) = primTimesInteger
686 fromInt = primIntToInteger
688 absReal x | x >= 0 = x
691 signumReal x | x == 0 = 0
695 instance Real Int where
696 toRational x = toInteger x % 1
698 instance Real Integer where
701 instance Integral Int where
702 quotRem = primQuotRemInt
703 toInteger = primIntToInteger
706 instance Integral Integer where
707 quotRem = primQuotRemInteger
708 --divMod = primDivModInteger
710 toInt = primIntegerToInt
712 instance Ix Int where
715 | inRange b i = i - m
716 | otherwise = error "index: Index out of range"
717 inRange (m,n) i = m <= i && i <= n
719 instance Ix Integer where
722 | inRange b i = fromInteger (i - m)
723 | otherwise = error "index: Index out of range"
724 inRange (m,n) i = m <= i && i <= n
726 instance Enum Int where
729 enumFrom = numericEnumFrom
730 enumFromTo = numericEnumFromTo
731 enumFromThen = numericEnumFromThen
732 enumFromThenTo = numericEnumFromThenTo
734 instance Enum Integer where
735 toEnum = primIntToInteger
736 fromEnum = primIntegerToInt
737 enumFrom = numericEnumFrom
738 enumFromTo = numericEnumFromTo
739 enumFromThen = numericEnumFromThen
740 enumFromThenTo = numericEnumFromThenTo
742 numericEnumFrom :: Real a => a -> [a]
743 numericEnumFromThen :: Real a => a -> a -> [a]
744 numericEnumFromTo :: Real a => a -> a -> [a]
745 numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
746 numericEnumFrom n = n : (numericEnumFrom $! (n+1))
747 numericEnumFromThen n m = iterate ((m-n)+) n
748 numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
749 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
750 where p | n' >= n = (<= m)
753 instance Read Int where
754 readsPrec p = readSigned readDec
756 instance Show Int where
758 | n == minBound = showSigned showInt p (toInteger n)
759 | otherwise = showSigned showInt p n
761 instance Read Integer where
762 readsPrec p = readSigned readDec
764 instance Show Integer where
765 showsPrec = showSigned showInt
768 -- Standard Floating types --------------------------------------------------
770 data Float -- builtin datatype of single precision floating point numbers
771 data Double -- builtin datatype of double precision floating point numbers
773 instance Eq Float where
777 instance Ord Float where
783 instance Num Float where
786 negate = primNegateFloat
790 fromInteger = primIntegerToFloat
791 fromInt = primIntToFloat
795 instance Eq Double where
799 instance Ord Double where
805 instance Num Double where
807 (-) = primMinusDouble
808 negate = primNegateDouble
809 (*) = primTimesDouble
812 fromInteger = primIntegerToDouble
813 fromInt = primIntToDouble
817 instance Real Float where
818 toRational = floatToRational
820 instance Real Double where
821 toRational = doubleToRational
823 -- Calls to these functions are optimised when passed as arguments to
825 floatToRational :: Float -> Rational
826 doubleToRational :: Double -> Rational
827 floatToRational x = realFloatToRational x
828 doubleToRational x = realFloatToRational x
830 realFloatToRational x = (m%1)*(b%1)^^n
831 where (m,n) = decodeFloat x
834 instance Fractional Float where
835 (/) = primDivideFloat
836 fromRational = rationalToRealFloat
837 fromDouble = primDoubleToFloat
840 instance Fractional Double where
841 (/) = primDivideDouble
842 fromRational = rationalToRealFloat
845 rationalToRealFloat x = x'
847 f e = if e' == e then y else f e'
848 where y = encodeFloat (round (x * (1%b)^^e)) e
849 (_,e') = decodeFloat y
850 (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
851 / fromInteger (denominator x))
854 instance Floating Float where
855 pi = 3.14159265358979323846
866 instance Floating Double where
867 pi = 3.14159265358979323846
870 sqrt = primSqrtDouble
874 asin = primAsinDouble
875 acos = primAcosDouble
876 atan = primAtanDouble
878 instance RealFrac Float where
879 properFraction = floatProperFraction
881 instance RealFrac Double where
882 properFraction = floatProperFraction
884 floatProperFraction x
885 | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
886 | otherwise = (fromInteger w, encodeFloat r n)
887 where (m,n) = decodeFloat x
889 (w,r) = quotRem m (b^(-n))
891 instance RealFloat Float where
892 floatRadix _ = toInteger primRadixFloat
893 floatDigits _ = primDigitsFloat
894 floatRange _ = (primMinExpFloat,primMaxExpFloat)
895 encodeFloat = primEncodeFloatZ
896 decodeFloat = primDecodeFloatZ
897 isNaN = primIsNaNFloat
898 isInfinite = primIsInfiniteFloat
899 isDenormalized= primIsDenormalizedFloat
900 isNegativeZero= primIsNegativeZeroFloat
901 isIEEE = const primIsIEEEFloat
903 instance RealFloat Double where
904 floatRadix _ = toInteger primRadixDouble
905 floatDigits _ = primDigitsDouble
906 floatRange _ = (primMinExpDouble,primMaxExpDouble)
907 encodeFloat = primEncodeDoubleZ
908 decodeFloat = primDecodeDoubleZ
909 isNaN = primIsNaNDouble
910 isInfinite = primIsInfiniteDouble
911 isDenormalized= primIsDenormalizedDouble
912 isNegativeZero= primIsNegativeZeroDouble
913 isIEEE = const primIsIEEEDouble
915 instance Enum Float where
916 toEnum = primIntToFloat
918 enumFrom = numericEnumFrom
919 enumFromThen = numericEnumFromThen
920 enumFromTo n m = numericEnumFromTo n (m+1/2)
921 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
923 instance Enum Double where
924 toEnum = primIntToDouble
926 enumFrom = numericEnumFrom
927 enumFromThen = numericEnumFromThen
928 enumFromTo n m = numericEnumFromTo n (m+1/2)
929 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
931 instance Read Float where
932 readsPrec p = readSigned readFloat
934 instance Show Float where
935 showsPrec p = showSigned showFloat p
937 instance Read Double where
938 readsPrec p = readSigned readFloat
940 instance Show Double where
941 showsPrec p = showSigned showFloat p
944 -- Some standard functions --------------------------------------------------
952 curry :: ((a,b) -> c) -> (a -> b -> c)
953 curry f x y = f (x,y)
955 uncurry :: (a -> b -> c) -> ((a,b) -> c)
956 uncurry f p = f (fst p) (snd p)
964 (.) :: (b -> c) -> (a -> b) -> (a -> c)
967 flip :: (a -> b -> c) -> b -> a -> c
970 ($) :: (a -> b) -> a -> b
973 until :: (a -> Bool) -> (a -> a) -> a -> a
974 until p f x = if p x then x else until p f (f x)
976 asTypeOf :: a -> a -> a
980 error msg = primRaise (ErrorCall msg)
983 undefined | False = undefined
985 -- Standard functions on rational numbers {PreludeRatio} --------------------
987 data Integral a => Ratio a = a :% a deriving (Eq)
988 type Rational = Ratio Integer
990 (%) :: Integral a => a -> a -> Ratio a
991 x % y = reduce (x * signum y) (abs y)
993 reduce :: Integral a => a -> a -> Ratio a
994 reduce x y | y == 0 = error "Ratio.%: zero denominator"
995 | otherwise = (x `quot` d) :% (y `quot` d)
998 numerator, denominator :: Integral a => Ratio a -> a
999 numerator (x :% y) = x
1000 denominator (x :% y) = y
1002 instance Integral a => Ord (Ratio a) where
1003 compare (x:%y) (x':%y') = compare (x*y') (x'*y)
1005 instance Integral a => Num (Ratio a) where
1006 (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
1007 (x:%y) * (x':%y') = reduce (x*x') (y*y')
1008 negate (x :% y) = negate x :% y
1009 abs (x :% y) = abs x :% y
1010 signum (x :% y) = signum x :% 1
1011 fromInteger x = fromInteger x :% 1
1012 fromInt = intToRatio
1014 -- Hugs optimises code of the form fromRational (intToRatio x)
1015 intToRatio :: Integral a => Int -> Ratio a
1016 intToRatio x = fromInt x :% 1
1018 instance Integral a => Real (Ratio a) where
1019 toRational (x:%y) = toInteger x :% toInteger y
1021 instance Integral a => Fractional (Ratio a) where
1022 (x:%y) / (x':%y') = (x*y') % (y*x')
1023 recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
1024 fromRational (x:%y) = fromInteger x :% fromInteger y
1025 fromDouble = doubleToRatio
1027 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1028 doubleToRatio :: Integral a => Double -> Ratio a
1030 | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
1031 | otherwise = fromInteger m % (fromInteger b ^ (-n))
1032 where (m,n) = decodeFloat x
1035 instance Integral a => RealFrac (Ratio a) where
1036 properFraction (x:%y) = (fromIntegral q, r:%y)
1037 where (q,r) = quotRem x y
1039 instance Integral a => Enum (Ratio a) where
1042 enumFrom = numericEnumFrom
1043 enumFromThen = numericEnumFromThen
1045 instance (Read a, Integral a) => Read (Ratio a) where
1046 readsPrec p = readParen (p > 7)
1047 (\r -> [(x%y,u) | (x,s) <- reads r,
1051 instance Integral a => Show (Ratio a) where
1052 showsPrec p (x:%y) = showParen (p > 7)
1053 (shows x . showString " % " . shows y)
1055 approxRational :: RealFrac a => a -> a -> Rational
1056 approxRational x eps = simplest (x-eps) (x+eps)
1057 where simplest x y | y < x = simplest y x
1059 | x > 0 = simplest' n d n' d'
1060 | y < 0 = - simplest' (-n') d' (-n) d
1061 | otherwise = 0 :% 1
1062 where xr@(n:%d) = toRational x
1063 (n':%d') = toRational y
1064 simplest' n d n' d' -- assumes 0 < n%d < n'%d'
1066 | q /= q' = (q+1) :% 1
1067 | otherwise = (q*n''+d'') :% n''
1068 where (q,r) = quotRem n d
1069 (q',r') = quotRem n' d'
1070 (n'':%d'') = simplest' d' r' d r
1072 -- Standard list functions {PreludeList} ------------------------------------
1079 last (_:xs) = last xs
1086 init (x:xs) = x : init xs
1092 (++) :: [a] -> [a] -> [a]
1094 (x:xs) ++ ys = x : (xs ++ ys)
1096 map :: (a -> b) -> [a] -> [b]
1097 --map f xs = [ f x | x <- xs ]
1099 map f (x:xs) = f x : map f xs
1102 filter :: (a -> Bool) -> [a] -> [a]
1103 --filter p xs = [ x | x <- xs, p x ]
1105 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1108 concat :: [[a]] -> [a]
1109 --concat = foldr (++) []
1111 concat (xs:xss) = xs ++ concat xss
1113 length :: [a] -> Int
1114 --length = foldl' (\n _ -> n + 1) 0
1116 length (x:xs) = let n = length xs in primSeq n (1+n)
1118 (!!) :: [b] -> Int -> b
1120 (_:xs) !! n | n>0 = xs !! (n-1)
1121 (_:_) !! _ = error "Prelude.!!: negative index"
1122 [] !! _ = error "Prelude.!!: index too large"
1124 foldl :: (a -> b -> a) -> a -> [b] -> a
1126 foldl f z (x:xs) = foldl f (f z x) xs
1128 foldl' :: (a -> b -> a) -> a -> [b] -> a
1130 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1132 foldl1 :: (a -> a -> a) -> [a] -> a
1133 foldl1 f (x:xs) = foldl f x xs
1135 scanl :: (a -> b -> a) -> a -> [b] -> [a]
1136 scanl f q xs = q : (case xs of
1138 x:xs -> scanl f (f q x) xs)
1140 scanl1 :: (a -> a -> a) -> [a] -> [a]
1141 scanl1 f (x:xs) = scanl f x xs
1143 foldr :: (a -> b -> b) -> b -> [a] -> b
1145 foldr f z (x:xs) = f x (foldr f z xs)
1147 foldr1 :: (a -> a -> a) -> [a] -> a
1149 foldr1 f (x:xs) = f x (foldr1 f xs)
1151 scanr :: (a -> b -> b) -> b -> [a] -> [b]
1152 scanr f q0 [] = [q0]
1153 scanr f q0 (x:xs) = f x q : qs
1154 where qs@(q:_) = scanr f q0 xs
1156 scanr1 :: (a -> a -> a) -> [a] -> [a]
1158 scanr1 f (x:xs) = f x q : qs
1159 where qs@(q:_) = scanr1 f xs
1161 iterate :: (a -> a) -> a -> [a]
1162 iterate f x = x : iterate f (f x)
1165 repeat x = xs where xs = x:xs
1167 replicate :: Int -> a -> [a]
1168 replicate n x = take n (repeat x)
1171 cycle [] = error "Prelude.cycle: empty list"
1172 cycle xs = xs' where xs'=xs++xs'
1174 take :: Int -> [a] -> [a]
1177 take n (x:xs) | n>0 = x : take (n-1) xs
1178 take _ _ = error "Prelude.take: negative argument"
1180 drop :: Int -> [a] -> [a]
1183 drop n (_:xs) | n>0 = drop (n-1) xs
1184 drop _ _ = error "Prelude.drop: negative argument"
1186 splitAt :: Int -> [a] -> ([a], [a])
1187 splitAt 0 xs = ([],xs)
1188 splitAt _ [] = ([],[])
1189 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1190 splitAt _ _ = error "Prelude.splitAt: negative argument"
1192 takeWhile :: (a -> Bool) -> [a] -> [a]
1195 | p x = x : takeWhile p xs
1198 dropWhile :: (a -> Bool) -> [a] -> [a]
1200 dropWhile p xs@(x:xs')
1201 | p x = dropWhile p xs'
1204 span, break :: (a -> Bool) -> [a] -> ([a],[a])
1208 | otherwise = ([],xs)
1209 where (ys,zs) = span p xs'
1210 break p = span (not . p)
1212 lines :: String -> [String]
1214 lines s = let (l,s') = break ('\n'==) s
1215 in l : case s' of [] -> []
1216 (_:s'') -> lines s''
1218 words :: String -> [String]
1219 words s = case dropWhile isSpace s of
1222 where (w,s'') = break isSpace s'
1224 unlines :: [String] -> String
1225 unlines = concatMap (\l -> l ++ "\n")
1227 unwords :: [String] -> String
1229 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1231 reverse :: [a] -> [a]
1232 --reverse = foldl (flip (:)) []
1233 reverse xs = ri [] xs
1234 where ri acc [] = acc
1235 ri acc (x:xs) = ri (x:acc) xs
1237 and, or :: [Bool] -> Bool
1238 --and = foldr (&&) True
1239 --or = foldr (||) False
1241 and (x:xs) = if x then and xs else x
1243 or (x:xs) = if x then x else or xs
1245 any, all :: (a -> Bool) -> [a] -> Bool
1246 --any p = or . map p
1247 --all p = and . map p
1249 any p (x:xs) = if p x then True else any p xs
1251 all p (x:xs) = if p x then all p xs else False
1253 elem, notElem :: Eq a => a -> [a] -> Bool
1255 --notElem = all . (/=)
1257 elem x (y:ys) = if x==y then True else elem x ys
1259 notElem x (y:ys) = if x==y then False else notElem x ys
1261 lookup :: Eq a => a -> [(a,b)] -> Maybe b
1262 lookup k [] = Nothing
1263 lookup k ((x,y):xys)
1265 | otherwise = lookup k xys
1267 sum, product :: Num a => [a] -> a
1269 product = foldl' (*) 1
1271 maximum, minimum :: Ord a => [a] -> a
1272 maximum = foldl1 max
1273 minimum = foldl1 min
1275 concatMap :: (a -> [b]) -> [a] -> [b]
1276 concatMap f = concat . map f
1278 zip :: [a] -> [b] -> [(a,b)]
1279 zip = zipWith (\a b -> (a,b))
1281 zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
1282 zip3 = zipWith3 (\a b c -> (a,b,c))
1284 zipWith :: (a->b->c) -> [a]->[b]->[c]
1285 zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
1288 zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1289 zipWith3 z (a:as) (b:bs) (c:cs)
1290 = z a b c : zipWith3 z as bs cs
1291 zipWith3 _ _ _ _ = []
1293 unzip :: [(a,b)] -> ([a],[b])
1294 unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1296 unzip3 :: [(a,b,c)] -> ([a],[b],[c])
1297 unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1300 -- PreludeText ----------------------------------------------------------------
1302 reads :: Read a => ReadS a
1305 shows :: Show a => a -> ShowS
1308 read :: Read a => String -> a
1309 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1311 [] -> error "Prelude.read: no parse"
1312 _ -> error "Prelude.read: ambiguous parse"
1314 showChar :: Char -> ShowS
1317 showString :: String -> ShowS
1320 showParen :: Bool -> ShowS -> ShowS
1321 showParen b p = if b then showChar '(' . p . showChar ')' else p
1323 showField :: Show a => String -> a -> ShowS
1324 showField m v = showString m . showChar '=' . shows v
1326 readParen :: Bool -> ReadS a -> ReadS a
1327 readParen b g = if b then mandatory else optional
1328 where optional r = g r ++ mandatory r
1329 mandatory r = [(x,u) | ("(",s) <- lex r,
1330 (x,t) <- optional s,
1334 readField :: Read a => String -> ReadS a
1335 readField m s0 = [ r | (t, s1) <- lex s0, t == m,
1341 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1342 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1344 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1346 lexString ('"':s) = [("\"",s)]
1347 lexString s = [(ch++str, u)
1348 | (ch,t) <- lexStrItem s,
1349 (str,u) <- lexString t ]
1351 lexStrItem ('\\':'&':s) = [("\\&",s)]
1352 lexStrItem ('\\':c:s) | isSpace c
1353 = [("",t) | '\\':t <- [dropWhile isSpace s]]
1354 lexStrItem s = lexLitChar s
1356 lex (c:s) | isSingle c = [([c],s)]
1357 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
1358 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
1359 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
1360 (fe,t) <- lexFracExp s ]
1361 | otherwise = [] -- bad character
1363 isSingle c = c `elem` ",;()[]{}_`"
1364 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1365 isIdChar c = isAlphaNum c || c `elem` "_'"
1367 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1369 lexFracExp s = [("",s)]
1371 lexExp (e:s) | e `elem` "eE"
1372 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
1373 (ds,u) <- lexDigits t] ++
1374 [(e:ds,t) | (ds,t) <- lexDigits s]
1377 lexDigits :: ReadS String
1378 lexDigits = nonnull isDigit
1380 nonnull :: (Char -> Bool) -> ReadS String
1381 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1383 lexLitChar :: ReadS String
1384 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1386 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
1387 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
1388 lexEsc s@(d:_) | isDigit d = lexDigits s
1389 lexEsc s@(c:_) | isUpper c
1390 = let table = ('\DEL',"DEL") : asciiTab
1391 in case [(mne,s') | (c, mne) <- table,
1392 ([],s') <- [lexmatch mne s]]
1396 lexLitChar (c:s) = [([c],s)]
1399 isOctDigit c = c >= '0' && c <= '7'
1400 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
1401 || c >= 'a' && c <= 'f'
1403 lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
1404 lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
1405 lexmatch xs ys = (xs,ys)
1407 asciiTab = zip ['\NUL'..' ']
1408 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1409 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
1410 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1411 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
1414 readLitChar :: ReadS Char
1415 readLitChar ('\\':s) = readEsc s
1417 readEsc ('a':s) = [('\a',s)]
1418 readEsc ('b':s) = [('\b',s)]
1419 readEsc ('f':s) = [('\f',s)]
1420 readEsc ('n':s) = [('\n',s)]
1421 readEsc ('r':s) = [('\r',s)]
1422 readEsc ('t':s) = [('\t',s)]
1423 readEsc ('v':s) = [('\v',s)]
1424 readEsc ('\\':s) = [('\\',s)]
1425 readEsc ('"':s) = [('"',s)]
1426 readEsc ('\'':s) = [('\'',s)]
1427 readEsc ('^':c:s) | c >= '@' && c <= '_'
1428 = [(toEnum (fromEnum c - fromEnum '@'), s)]
1429 readEsc s@(d:_) | isDigit d
1430 = [(toEnum n, t) | (n,t) <- readDec s]
1431 readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
1432 readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
1433 readEsc s@(c:_) | isUpper c
1434 = let table = ('\DEL',"DEL") : asciiTab
1435 in case [(c,s') | (c, mne) <- table,
1436 ([],s') <- [lexmatch mne s]]
1440 readLitChar (c:s) = [(c,s)]
1442 showLitChar :: Char -> ShowS
1443 showLitChar c | c > '\DEL' = showChar '\\' .
1444 protectEsc isDigit (shows (fromEnum c))
1445 showLitChar '\DEL' = showString "\\DEL"
1446 showLitChar '\\' = showString "\\\\"
1447 showLitChar c | c >= ' ' = showChar c
1448 showLitChar '\a' = showString "\\a"
1449 showLitChar '\b' = showString "\\b"
1450 showLitChar '\f' = showString "\\f"
1451 showLitChar '\n' = showString "\\n"
1452 showLitChar '\r' = showString "\\r"
1453 showLitChar '\t' = showString "\\t"
1454 showLitChar '\v' = showString "\\v"
1455 showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
1456 showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
1458 protectEsc p f = f . cont
1459 where cont s@(c:_) | p c = "\\&" ++ s
1462 -- Unsigned readers for various bases
1463 readDec, readOct, readHex :: Integral a => ReadS a
1464 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1465 readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1466 readHex = readInt 16 isHexDigit hex
1467 where hex d = fromEnum d -
1470 else fromEnum (if isUpper d then 'A' else 'a') - 10)
1472 -- readInt reads a string of digits using an arbitrary base.
1473 -- Leading minus signs must be handled elsewhere.
1475 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1476 readInt radix isDig digToInt s =
1477 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1478 | (ds,r) <- nonnull isDig s ]
1480 -- showInt is used for positive numbers only
1481 showInt :: Integral a => a -> ShowS
1484 = error "Numeric.showInt: can't show negative numbers"
1487 = let (n',d) = quotRem n 10
1488 r' = toEnum (fromEnum '0' + fromIntegral d) : r
1489 in if n' == 0 then r' else showInt n' r'
1491 = case quotRem n 10 of { (n',d) ->
1492 let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1493 in if n' == 0 then r' else showInt n' r'
1497 readSigned:: Real a => ReadS a -> ReadS a
1498 readSigned readPos = readParen False read'
1499 where read' r = read'' r ++
1500 [(-x,t) | ("-",s) <- lex r,
1502 read'' r = [(n,s) | (str,s) <- lex r,
1503 (n,"") <- readPos str]
1505 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1506 showSigned showPos p x = if x < 0 then showParen (p > 6)
1507 (showChar '-' . showPos (-x))
1510 readFloat :: RealFloat a => ReadS a
1511 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1513 where readFix r = [(read (ds++ds'), length ds', t)
1514 | (ds, s) <- lexDigits r
1515 , (ds',t) <- lexFrac s ]
1517 lexFrac ('.':s) = lexDigits s
1518 lexFrac s = [("",s)]
1520 readExp (e:s) | e `elem` "eE" = readExp' s
1523 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1524 readExp' ('+':s) = readDec s
1525 readExp' s = readDec s
1528 -- Hooks for primitives: -----------------------------------------------------
1529 -- Do not mess with these!
1531 primCompAux :: Ord a => a -> a -> Ordering -> Ordering
1532 primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1534 primPmInt :: Num a => Int -> a -> Bool
1535 primPmInt n x = fromInt n == x
1537 primPmInteger :: Num a => Integer -> a -> Bool
1538 primPmInteger n x = fromInteger n == x
1540 primPmFlt :: Fractional a => Double -> a -> Bool
1541 primPmFlt n x = fromDouble n == x
1543 -- ToDo: make the message more informative.
1545 primPmFail = error "Pattern Match Failure"
1547 -- used in desugaring Foreign functions
1548 primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1551 -- The following primitives are only needed if (n+k) patterns are enabled:
1552 primPmNpk :: Integral a => Int -> a -> Maybe a
1553 primPmNpk n x = if n'<=x then Just (x-n') else Nothing
1554 where n' = fromInt n
1556 primPmSub :: Integral a => Int -> a -> a
1557 primPmSub n x = x - fromInt n
1559 -- Unpack strings generated by the Hugs code generator.
1560 -- Strings can contain \0 provided they're coded right.
1562 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1564 primUnpackString :: Addr -> String
1565 primUnpackString a = unpack 0
1567 -- The following decoding is based on evalString in the old machine.c
1570 | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1571 then '\\' : unpack (i+2)
1572 else '\0' : unpack (i+2)
1573 | otherwise = c : unpack (i+1)
1575 c = primIndexCharOffAddr a i
1578 -- Monadic I/O: --------------------------------------------------------------
1580 type FilePath = String
1582 --data IOError = ...
1583 --instance Eq IOError ...
1584 --instance Show IOError ...
1586 data IOError = IOError String
1587 instance Show IOError where
1588 showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1590 ioError :: IOError -> IO a
1591 ioError (IOError s) = primRaise (IOExcept s)
1593 userError :: String -> IOError
1594 userError s = primRaise (ErrorCall s)
1596 catch :: IO a -> (IOError -> IO a) -> IO a
1598 = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
1600 e2ioe (IOExcept s) = IOError s
1601 e2ioe other = IOError (show other)
1603 putChar :: Char -> IO ()
1604 putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c)
1606 putStr :: String -> IO ()
1607 putStr s = --mapM_ putChar s -- correct, but slow
1609 let loop [] = return ()
1610 loop (c:cs) = nh_write h (primCharToInt c) >> loop cs
1613 putStrLn :: String -> IO ()
1614 putStrLn s = do { putStr s; putChar '\n' }
1616 print :: Show a => a -> IO ()
1617 print = putStrLn . show
1620 getChar = unsafeInterleaveIO (
1622 nh_read h >>= \ci ->
1623 return (primIntToChar ci)
1626 getLine :: IO String
1627 getLine = do c <- getChar
1628 if c=='\n' then return ""
1629 else do cs <- getLine
1632 getContents :: IO String
1633 getContents = nh_stdin >>= \h -> readfromhandle h
1635 interact :: (String -> String) -> IO ()
1636 interact f = getContents >>= (putStr . f)
1638 readFile :: FilePath -> IO String
1640 = copy_String_to_cstring fname >>= \ptr ->
1641 nh_open ptr 0 >>= \h ->
1643 nh_errno >>= \errno ->
1644 if (h == 0 || errno /= 0)
1645 then (ioError.IOError) ("readFile: can't open file " ++ fname)
1646 else readfromhandle h
1648 writeFile :: FilePath -> String -> IO ()
1649 writeFile fname contents
1650 = copy_String_to_cstring fname >>= \ptr ->
1651 nh_open ptr 1 >>= \h ->
1653 nh_errno >>= \errno ->
1654 if (h == 0 || errno /= 0)
1655 then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1656 else writetohandle fname h contents
1659 appendFile :: FilePath -> String -> IO ()
1660 appendFile fname contents
1661 = copy_String_to_cstring fname >>= \ptr ->
1662 nh_open ptr 2 >>= \h ->
1664 nh_errno >>= \errno ->
1665 if (h == 0 || errno /= 0)
1666 then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1667 else writetohandle fname h contents
1670 -- raises an exception instead of an error
1671 readIO :: Read a => String -> IO a
1672 readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1674 [] -> ioError (userError "PreludeIO.readIO: no parse")
1675 _ -> ioError (userError
1676 "PreludeIO.readIO: ambiguous parse")
1678 readLn :: Read a => IO a
1679 readLn = do l <- getLine
1684 -- End of Hugs standard prelude ----------------------------------------------
1690 instance Show Exception where
1691 showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1692 showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
1694 data IOResult = IOResult deriving (Show)
1696 type FILE_STAR = Int -- FILE *
1697 type Ptr = Int -- char *
1699 foreign import stdcall "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR
1700 foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR
1701 foreign import stdcall "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR
1702 foreign import stdcall "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO ()
1703 foreign import stdcall "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int
1704 foreign import stdcall "nHandle.so" "nh_open" nh_open :: Int -> Int -> IO FILE_STAR
1705 foreign import stdcall "nHandle.so" "nh_flush" nh_flush :: FILE_STAR -> IO ()
1706 foreign import stdcall "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO ()
1707 foreign import stdcall "nHandle.so" "nh_errno" nh_errno :: IO Int
1709 foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Ptr
1710 foreign import stdcall "nHandle.so" "nh_free" nh_free :: Ptr -> IO ()
1711 foreign import stdcall "nHandle.so" "nh_store" nh_store :: Ptr -> Int -> IO ()
1712 foreign import stdcall "nHandle.so" "nh_load" nh_load :: Ptr -> IO Int
1714 foreign import stdcall "nHandle.so" "nh_argc" nh_argc :: IO Int
1715 foreign import stdcall "nHandle.so" "nh_argvb" nh_argvb :: Int -> Int -> IO Int
1716 foreign import stdcall "nHandle.so" "nh_getenv" nh_getenv :: Ptr -> IO Ptr
1718 copy_String_to_cstring :: String -> IO Ptr
1719 copy_String_to_cstring s
1720 = nh_malloc (1 + length s) >>= \ptr0 ->
1721 let loop ptr [] = nh_store ptr 0 >> return ptr0
1722 loop ptr (c:cs) = --trace ("Out `" ++ [c] ++ "'") (
1723 nh_store ptr (primCharToInt c) >> loop (ptr+1) cs
1728 copy_cstring_to_String :: Ptr -> IO String
1729 copy_cstring_to_String ptr
1730 = nh_load ptr >>= \ci ->
1733 else copy_cstring_to_String (ptr+1) >>= \cs ->
1734 --trace ("In " ++ show ci) (
1735 return ((primIntToChar ci) : cs)
1738 readfromhandle :: FILE_STAR -> IO String
1740 = unsafeInterleaveIO (
1741 nh_read h >>= \ci ->
1742 if ci == -1 {-EOF-} then return "" else
1743 readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1746 writetohandle :: String -> FILE_STAR -> String -> IO ()
1747 writetohandle fname h []
1749 nh_errno >>= \errno ->
1752 else error ( "writeFile/appendFile: error closing file " ++ fname)
1753 writetohandle fname h (c:cs)
1754 = nh_write h (primCharToInt c) >>
1755 writetohandle fname h cs
1757 primGetRawArgs :: IO [String]
1759 = nh_argc >>= \argc ->
1760 accumulate (map (get_one_arg 0) [0 .. argc-1])
1762 get_one_arg :: Int -> Int -> IO String
1763 get_one_arg offset argno
1764 = nh_argvb argno offset >>= \cb ->
1767 else get_one_arg (offset+1) argno >>= \s ->
1768 return ((primIntToChar cb):s)
1770 primGetEnv :: String -> IO String
1772 = copy_String_to_cstring v >>= \ptr ->
1773 nh_getenv ptr >>= \ptr2 ->
1778 copy_cstring_to_String ptr2 >>= \result ->
1782 ------------------------------------------------------------------------------
1783 -- ST, IO --------------------------------------------------------------------
1784 ------------------------------------------------------------------------------
1786 newtype ST s a = ST (s -> (a,s))
1789 type IO a = ST RealWorld a
1792 --primRunST :: (forall s. ST s a) -> a
1793 primRunST :: ST RealWorld a -> a
1794 primRunST m = fst (unST m theWorld)
1796 theWorld :: RealWorld
1797 theWorld = error "primRunST: entered the RealWorld"
1801 instance Functor (ST s) where
1802 fmap f x = x >>= (return . f)
1804 instance Monad (ST s) where
1805 m >> k = m >>= \ _ -> k
1806 return x = ST $ \ s -> (x,s)
1807 m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' }
1810 -- used when Hugs invokes top level function
1811 primRunIO :: IO () -> ()
1813 = protect (fst (unST m realWorld))
1815 realWorld = error "panic: Hugs entered the real world"
1818 = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1820 trace :: String -> a -> a
1822 = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x
1824 unsafeInterleaveST :: ST s a -> ST s a
1825 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1827 unsafeInterleaveIO :: IO a -> IO a
1828 unsafeInterleaveIO = unsafeInterleaveST
1831 ------------------------------------------------------------------------------
1832 -- Word, Addr, ForeignObj, Prim*Array ----------------------------------------
1833 ------------------------------------------------------------------------------
1837 nullAddr = primIntToAddr 0
1839 instance Eq Addr where
1843 instance Ord Addr where
1852 instance Eq Word where
1856 instance Ord Word where
1864 --makeForeignObj :: Addr -> IO ForeignObj
1865 --makeForeignObj = primMakeForeignObj
1868 data PrimArray a -- immutable arrays with Int indices
1871 data Ref s a -- mutable variables
1872 data PrimMutableArray s a -- mutable arrays with Int indices
1873 data PrimMutableByteArray s
1877 ------------------------------------------------------------------------------
1878 -- hooks to call libHS_cbits -------------------------------------------------
1879 ------------------------------------------------------------------------------
1881 type FILE_OBJ = ForeignObj -- as passed into functions
1882 type CString = PrimByteArray
1885 type OpenFlags = Int
1886 type IOFileAddr = Addr -- as returned from functions
1888 type OpenStdFlags = Int
1889 type Readable = Int -- really Bool
1890 type Exclusive = Int -- really Bool
1891 type RC = Int -- standard return code
1892 type Bytes = PrimMutableByteArray RealWorld
1893 type Flush = Int -- really Bool
1895 foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
1896 freeStdFileObject :: ForeignObj -> IO ()
1898 foreign import stdcall "libHS_cbits.so" "freeFileObject"
1899 freeFileObject :: ForeignObj -> IO ()
1901 foreign import stdcall "libHS_cbits.so" "setBuf"
1902 prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO ()
1904 foreign import stdcall "libHS_cbits.so" "getBufSize"
1905 prim_getBufSize :: FILE_OBJ -> IO Int
1907 foreign import stdcall "libHS_cbits.so" "inputReady"
1908 prim_inputReady :: FILE_OBJ -> Int -> IO RC
1910 foreign import stdcall "libHS_cbits.so" "fileGetc"
1911 prim_fileGetc :: FILE_OBJ -> IO Int
1913 foreign import stdcall "libHS_cbits.so" "fileLookAhead"
1914 prim_fileLookAhead :: FILE_OBJ -> IO Int
1916 foreign import stdcall "libHS_cbits.so" "readBlock"
1917 prim_readBlock :: FILE_OBJ -> IO Int
1919 foreign import stdcall "libHS_cbits.so" "readLine"
1920 prim_readLine :: FILE_OBJ -> IO Int
1922 foreign import stdcall "libHS_cbits.so" "readChar"
1923 prim_readChar :: FILE_OBJ -> IO Int
1925 foreign import stdcall "libHS_cbits.so" "writeFileObject"
1926 prim_writeFileObject :: FILE_OBJ -> Int -> IO RC
1928 foreign import stdcall "libHS_cbits.so" "filePutc"
1929 prim_filePutc :: FILE_OBJ -> Char -> IO RC
1931 foreign import stdcall "libHS_cbits.so" "getBufStart"
1932 prim_getBufStart :: FILE_OBJ -> Int -> IO Addr
1934 foreign import stdcall "libHS_cbits.so" "getWriteableBuf"
1935 prim_getWriteableBuf :: FILE_OBJ -> IO Addr
1937 foreign import stdcall "libHS_cbits.so" "getBufWPtr"
1938 prim_getBufWPtr :: FILE_OBJ -> IO Int
1940 foreign import stdcall "libHS_cbits.so" "setBufWPtr"
1941 prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
1943 foreign import stdcall "libHS_cbits.so" "closeFile"
1944 prim_closeFile :: FILE_OBJ -> Flush -> IO RC
1946 foreign import stdcall "libHS_cbits.so" "fileEOF"
1947 prim_fileEOF :: FILE_OBJ -> IO RC
1949 foreign import stdcall "libHS_cbits.so" "setBuffering"
1950 prim_setBuffering :: FILE_OBJ -> Int -> IO RC
1952 foreign import stdcall "libHS_cbits.so" "flushFile"
1953 prim_flushFile :: FILE_OBJ -> IO RC
1955 foreign import stdcall "libHS_cbits.so" "getBufferMode"
1956 prim_getBufferMode :: FILE_OBJ -> IO RC
1958 foreign import stdcall "libHS_cbits.so" "seekFileP"
1959 prim_seekFileP :: FILE_OBJ -> IO RC
1961 foreign import stdcall "libHS_cbits.so" "setTerminalEcho"
1962 prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
1964 foreign import stdcall "libHS_cbits.so" "getTerminalEcho"
1965 prim_getTerminalEcho :: FILE_OBJ -> IO RC
1967 foreign import stdcall "libHS_cbits.so" "isTerminalDevice"
1968 prim_isTerminalDevice :: FILE_OBJ -> IO RC
1970 foreign import stdcall "libHS_cbits.so" "setConnectedTo"
1971 prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
1973 foreign import stdcall "libHS_cbits.so" "ungetChar"
1974 prim_ungetChar :: FILE_OBJ -> Char -> IO RC
1976 foreign import stdcall "libHS_cbits.so" "readChunk"
1977 prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC
1979 foreign import stdcall "libHS_cbits.so" "writeBuf"
1980 prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC
1982 foreign import stdcall "libHS_cbits.so" "getFileFd"
1983 prim_getFileFd :: FILE_OBJ -> IO FD
1985 foreign import stdcall "libHS_cbits.so" "fileSize_int64"
1986 prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC
1988 foreign import stdcall "libHS_cbits.so" "getFilePosn"
1989 prim_getFilePosn :: FILE_OBJ -> IO Int
1991 foreign import stdcall "libHS_cbits.so" "setFilePosn"
1992 prim_setFilePosn :: FILE_OBJ -> Int -> IO Int
1994 foreign import stdcall "libHS_cbits.so" "getConnFileFd"
1995 prim_getConnFileFd :: FILE_OBJ -> IO FD
1997 foreign import stdcall "libHS_cbits.so" "allocMemory__"
1998 prim_allocMemory__ :: Int -> IO Addr
2000 foreign import stdcall "libHS_cbits.so" "getLock"
2001 prim_getLock :: FD -> Exclusive -> IO RC
2003 foreign import stdcall "libHS_cbits.so" "openStdFile"
2004 prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
2006 foreign import stdcall "libHS_cbits.so" "openFile"
2007 prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
2009 foreign import stdcall "libHS_cbits.so" "freeFileObject"
2010 prim_freeFileObject :: FILE_OBJ -> IO ()
2012 foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
2013 prim_freeStdFileObject :: FILE_OBJ -> IO ()
2015 foreign import stdcall "libHS_cbits.so" "const_BUFSIZ"
2018 foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__"
2019 prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
2021 foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__"
2022 prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
2024 foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__"
2025 prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
2027 foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__"
2028 prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
2030 foreign import stdcall "libHS_cbits.so" "getErrStr__"
2031 prim_getErrStr__ :: IO Addr
2033 foreign import stdcall "libHS_cbits.so" "getErrNo__"
2034 prim_getErrNo__ :: IO Int
2036 foreign import stdcall "libHS_cbits.so" "getErrType__"
2037 prim_getErrType__ :: IO Int
2039 --foreign import stdcall "libHS_cbits.so" "seekFile_int64"
2040 -- prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
2043 -- showFloat ------------------------------------------------------------------
2045 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2046 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2047 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2048 showFloat :: (RealFloat a) => a -> ShowS
2050 showEFloat d x = showString (formatRealFloat FFExponent d x)
2051 showFFloat d x = showString (formatRealFloat FFFixed d x)
2052 showGFloat d x = showString (formatRealFloat FFGeneric d x)
2053 showFloat = showGFloat Nothing
2055 -- These are the format types. This type is not exported.
2057 data FFFormat = FFExponent | FFFixed | FFGeneric
2059 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2060 formatRealFloat fmt decs x = s
2064 else if isInfinite x then
2065 if x < 0 then "-Infinity" else "Infinity"
2066 else if x < 0 || isNegativeZero x then
2067 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2069 doFmt fmt (floatToDigits (toInteger base) x)
2071 let ds = map intToDigit is
2074 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2081 [d] -> d : ".0e" ++ show (e-1)
2082 d:ds -> d : '.' : ds ++ 'e':show (e-1)
2084 let dec' = max dec 1 in
2086 [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2088 let (ei, is') = roundTo base (dec'+1) is
2089 d:ds = map intToDigit
2090 (if ei > 0 then init is' else is')
2091 in d:'.':ds ++ "e" ++ show (e-1+ei)
2095 let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2096 f n s "" = f (n-1) (s++"0") ""
2097 f n s (d:ds) = f (n-1) (s++[d]) ds
2102 let dec' = max dec 0 in
2104 let (ei, is') = roundTo base (dec' + e) is
2105 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2106 in (if null ls then "0" else ls) ++
2107 (if null rs then "" else '.' : rs)
2109 let (ei, is') = roundTo base dec'
2110 (replicate (-e) 0 ++ is)
2111 d : ds = map intToDigit
2112 (if ei > 0 then is' else 0:is')
2115 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2116 roundTo base d is = case f d is of
2118 (1, is) -> (1, 1 : is)
2119 where b2 = base `div` 2
2120 f n [] = (0, replicate n 0)
2121 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2123 let (c, ds) = f (d-1) is
2125 in if i' == base then (1, 0:ds) else (0, i':ds)
2127 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2128 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2129 -- This version uses a much slower logarithm estimator. It should be improved.
2131 -- This function returns a list of digits (Ints in [0..base-1]) and an
2134 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2136 floatToDigits _ 0 = ([0], 0)
2137 floatToDigits base x =
2138 let (f0, e0) = decodeFloat x
2139 (minExp0, _) = floatRange x
2142 minExp = minExp0 - p -- the real minimum exponent
2143 -- Haskell requires that f be adjusted so denormalized numbers
2144 -- will have an impossibly low exponent. Adjust for this.
2145 (f, e) = let n = minExp - e0
2146 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2151 if f == b^(p-1) then
2152 (f*be*b*2, 2*b, be*b, b)
2156 if e > minExp && f == b^(p-1) then
2157 (f*b*2, b^(-e+1)*2, b, 1)
2159 (f*2, b^(-e)*2, 1, 1)
2162 if b == 2 && base == 10 then
2163 -- logBase 10 2 is slightly bigger than 3/10 so
2164 -- the following will err on the low side. Ignoring
2165 -- the fraction will make it err even more.
2166 -- Haskell promises that p-1 <= logBase b f < p.
2167 (p - 1 + e0) * 3 `div` 10
2169 ceiling ((log (fromInteger (f+1)) +
2170 fromInt e * log (fromInteger b)) /
2171 log (fromInteger base))
2174 if r + mUp <= expt base n * s then n else fixup (n+1)
2176 if expt base (-n) * (r + mUp) <= s then n
2180 gen ds rn sN mUpN mDnN =
2181 let (dn, rn') = (rn * base) `divMod` sN
2184 in case (rn' < mDnN', rn' + mUpN' > sN) of
2185 (True, False) -> dn : ds
2186 (False, True) -> dn+1 : ds
2187 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2188 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2191 gen [] r (s * expt base k) mUp mDn
2193 let bk = expt base (-k)
2194 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
2195 in (map toInt (reverse rds), k)
2198 -- Exponentiation with(out) a cache for the most common numbers.
2199 expt :: Integer -> Int -> Integer
2200 expt base n = base^n
2204 -- Exponentiation with a cache for the most common numbers.
2207 expt :: Integer -> Int -> Integer
2209 if base == 2 && n >= minExpt && n <= maxExpt then
2210 expts !! (n-minExpt)
2215 expts = [2^n | n <- [minExpt .. maxExpt]]