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, StablePtr,
64 makeStablePtr, freeStablePtr, deRefStablePtr,
70 Char, String, Int, Integer, Float, Double, IO,
71 -- List type: []((:), [])
73 -- Tuple types: (,), (,,), etc.
76 Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
78 Ord(compare, (<), (<=), (>=), (>), max, min),
79 Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
80 enumFromTo, enumFromThenTo),
81 Bounded(minBound, maxBound),
82 -- Num((+), (-), (*), negate, abs, signum, fromInteger),
83 Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
85 -- Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
86 Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
87 -- Fractional((/), recip, fromRational),
88 Fractional((/), recip, fromRational, fromDouble),
89 Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
90 asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
91 RealFrac(properFraction, truncate, round, ceiling, floor),
92 RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
93 encodeFloat, exponent, significand, scaleFloat, isNaN,
94 isInfinite, isDenormalized, isIEEE, isNegativeZero),
95 Monad((>>=), (>>), return, fail),
97 mapM, mapM_, sequence, sequence_, (=<<),
99 (&&), (||), not, otherwise,
100 subtract, even, odd, gcd, lcm, (^), (^^),
101 fromIntegral, realToFrac, atan2,
102 fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
103 asTypeOf, error, undefined,
106 , MVar, newMVar, putMVar, takeMVar
109 -- Arrrggghhh!!! Help! Help! Help!
110 -- What?! Prelude.hs doesn't even _define_ most of these things!
111 ,primCompAux,PrimArray,primRunST,primNewArray,primWriteArray
112 ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv
113 ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open
114 ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar
115 ,unsafeInterleaveIO,nh_write,primCharToInt,
116 nullAddr, incAddr, isNullAddr,
119 primGtWord, primGeWord, primEqWord, primNeWord,
120 primLtWord, primLeWord, primMinWord, primMaxWord,
121 primPlusWord, primMinusWord, primTimesWord, primQuotWord,
122 primRemWord, primQuotRemWord, primNegateWord, primAndWord,
123 primOrWord, primXorWord, primNotWord, primShiftLWord,
124 primShiftRAWord, primShiftRLWord, primIntToWord, primWordToInt,
126 primAndInt, primOrInt, primXorInt, primNotInt,
127 primShiftLInt, primShiftRAInt, primShiftRLInt,
129 primAddrToInt, primIntToAddr,
131 primDoubleToFloat, primFloatToDouble,
139 -- Standard value bindings {Prelude} ----------------------------------------
144 infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
146 --infixr 5 : -- this fixity declaration is hard-wired into Hugs
148 infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
153 infixr 0 $, $!, `seq`
155 -- Equality and Ordered classes ---------------------------------------------
158 (==), (/=) :: a -> a -> Bool
160 -- Minimal complete definition: (==) or (/=)
164 class (Eq a) => Ord a where
165 compare :: a -> a -> Ordering
166 (<), (<=), (>=), (>) :: a -> a -> Bool
167 max, min :: a -> a -> a
169 -- Minimal complete definition: (<=) or compare
170 -- using compare can be more efficient for complex types
171 compare x y | x==y = EQ
175 x <= y = compare x y /= GT
176 x < y = compare x y == LT
177 x >= y = compare x y /= LT
178 x > y = compare x y == GT
185 class Bounded a where
186 minBound, maxBound :: a
187 -- Minimal complete definition: All
189 -- Numeric classes ----------------------------------------------------------
191 class (Eq a, Show a) => Num a where
192 (+), (-), (*) :: a -> a -> a
194 abs, signum :: a -> a
195 fromInteger :: Integer -> a
198 -- Minimal complete definition: All, except negate or (-)
200 fromInt = fromIntegral
203 class (Num a, Ord a) => Real a where
204 toRational :: a -> Rational
206 class (Real a, Enum a) => Integral a where
207 quot, rem, div, mod :: a -> a -> a
208 quotRem, divMod :: a -> a -> (a,a)
209 even, odd :: a -> Bool
210 toInteger :: a -> Integer
213 -- Minimal complete definition: quotRem and toInteger
214 n `quot` d = q where (q,r) = quotRem n d
215 n `rem` d = r where (q,r) = quotRem n d
216 n `div` d = q where (q,r) = divMod n d
217 n `mod` d = r where (q,r) = divMod n d
218 divMod n d = if signum r == - signum d then (q-1, r+d) else qr
219 where qr@(q,r) = quotRem n d
220 even n = n `rem` 2 == 0
222 toInt = toInt . toInteger
224 class (Num a) => Fractional a where
227 fromRational :: Rational -> a
228 fromDouble :: Double -> a
230 -- Minimal complete definition: fromRational and ((/) or recip)
232 fromDouble = fromRational . toRational
236 class (Fractional a) => Floating a where
238 exp, log, sqrt :: a -> a
239 (**), logBase :: a -> a -> a
240 sin, cos, tan :: a -> a
241 asin, acos, atan :: a -> a
242 sinh, cosh, tanh :: a -> a
243 asinh, acosh, atanh :: a -> a
245 -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
246 -- asinh, acosh, atanh
247 x ** y = exp (log x * y)
248 logBase x y = log y / log x
250 tan x = sin x / cos x
251 sinh x = (exp x - exp (-x)) / 2
252 cosh x = (exp x + exp (-x)) / 2
253 tanh x = sinh x / cosh x
254 asinh x = log (x + sqrt (x*x + 1))
255 acosh x = log (x + sqrt (x*x - 1))
256 atanh x = (log (1 + x) - log (1 - x)) / 2
258 class (Real a, Fractional a) => RealFrac a where
259 properFraction :: (Integral b) => a -> (b,a)
260 truncate, round :: (Integral b) => a -> b
261 ceiling, floor :: (Integral b) => a -> b
263 -- Minimal complete definition: properFraction
264 truncate x = m where (m,_) = properFraction x
266 round x = let (n,r) = properFraction x
267 m = if r < 0 then n - 1 else n + 1
268 in case signum (abs r - 0.5) of
270 0 -> if even n then n else m
273 ceiling x = if r > 0 then n + 1 else n
274 where (n,r) = properFraction x
276 floor x = if r < 0 then n - 1 else n
277 where (n,r) = properFraction x
279 class (RealFrac a, Floating a) => RealFloat a where
280 floatRadix :: a -> Integer
281 floatDigits :: a -> Int
282 floatRange :: a -> (Int,Int)
283 decodeFloat :: a -> (Integer,Int)
284 encodeFloat :: Integer -> Int -> a
286 significand :: a -> a
287 scaleFloat :: Int -> a -> a
288 isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
292 -- Minimal complete definition: All, except exponent, signficand,
294 exponent x = if m==0 then 0 else n + floatDigits x
295 where (m,n) = decodeFloat x
296 significand x = encodeFloat m (- floatDigits x)
297 where (m,_) = decodeFloat x
298 scaleFloat k x = encodeFloat m (n+k)
299 where (m,n) = decodeFloat x
303 | x<0 && y>0 = pi + atan (y/x)
305 (x<0 && isNegativeZero y) ||
306 (isNegativeZero x && isNegativeZero y)
308 | y==0 && (x<0 || isNegativeZero x)
309 = pi -- must be after the previous test on zero y
310 | x==0 && y==0 = y -- must be after the other double zero tests
311 | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
313 -- Numeric functions --------------------------------------------------------
315 subtract :: Num a => a -> a -> a
318 gcd :: Integral a => a -> a -> a
319 gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
320 gcd x y = gcd' (abs x) (abs y)
322 gcd' x y = gcd' y (x `rem` y)
324 lcm :: (Integral a) => a -> a -> a
327 lcm x y = abs ((x `quot` gcd x y) * y)
329 (^) :: (Num a, Integral b) => a -> b -> a
331 x ^ n | n > 0 = f x (n-1) x
333 f x n y = g x n where
334 g x n | even n = g (x*x) (n`quot`2)
335 | otherwise = f x (n-1) (x*y)
336 _ ^ _ = error "Prelude.^: negative exponent"
338 (^^) :: (Fractional a, Integral b) => a -> b -> a
339 x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
341 fromIntegral :: (Integral a, Num b) => a -> b
342 fromIntegral = fromInteger . toInteger
344 realToFrac :: (Real a, Fractional b) => a -> b
345 realToFrac = fromRational . toRational
347 -- Index and Enumeration classes --------------------------------------------
349 class (Ord a) => Ix a where
350 range :: (a,a) -> [a]
351 index :: (a,a) -> a -> Int
352 inRange :: (a,a) -> a -> Bool
353 rangeSize :: (a,a) -> Int
357 | otherwise = index r u + 1
363 enumFrom :: a -> [a] -- [n..]
364 enumFromThen :: a -> a -> [a] -- [n,m..]
365 enumFromTo :: a -> a -> [a] -- [n..m]
366 enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
368 -- Minimal complete definition: toEnum, fromEnum
369 succ = toEnum . (1+) . fromEnum
370 pred = toEnum . subtract 1 . fromEnum
371 enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
372 enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
374 -- Read and Show classes ------------------------------------------------------
376 type ReadS a = String -> [(a,String)]
377 type ShowS = String -> String
380 readsPrec :: Int -> ReadS a
381 readList :: ReadS [a]
383 -- Minimal complete definition: readsPrec
384 readList = readParen False (\r -> [pr | ("[",s) <- lex r,
386 where readl s = [([],t) | ("]",t) <- lex s] ++
387 [(x:xs,u) | (x,t) <- reads s,
389 readl' s = [([],t) | ("]",t) <- lex s] ++
390 [(x:xs,v) | (",",t) <- lex s,
396 showsPrec :: Int -> a -> ShowS
397 showList :: [a] -> ShowS
399 -- Minimal complete definition: show or showsPrec
400 show x = showsPrec 0 x ""
401 showsPrec _ x s = show x ++ s
402 showList [] = showString "[]"
403 showList (x:xs) = showChar '[' . shows x . showl xs
404 where showl [] = showChar ']'
405 showl (x:xs) = showChar ',' . shows x . showl xs
407 -- Monad classes ------------------------------------------------------------
409 class Functor f where
410 fmap :: (a -> b) -> (f a -> f b)
414 (>>=) :: m a -> (a -> m b) -> m b
415 (>>) :: m a -> m b -> m b
416 fail :: String -> m a
418 -- Minimal complete definition: (>>=), return
419 p >> q = p >>= \ _ -> q
422 sequence :: Monad m => [m a] -> m [a]
423 sequence [] = return []
424 sequence (c:cs) = do x <- c
428 sequence_ :: Monad m => [m a] -> m ()
429 sequence_ = foldr (>>) (return ())
431 mapM :: Monad m => (a -> m b) -> [a] -> m [b]
432 mapM f = sequence . map f
434 mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
435 mapM_ f = sequence_ . map f
437 (=<<) :: Monad m => (a -> m b) -> m a -> m b
440 -- Evaluation and strictness ------------------------------------------------
443 seq x y = primSeq x y
445 ($!) :: (a -> b) -> a -> b
446 f $! x = x `primSeq` f x
448 -- Trivial type -------------------------------------------------------------
450 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
455 instance Ord () where
461 inRange ((),()) () = True
463 instance Enum () where
467 enumFromThen () () = [()]
469 instance Read () where
470 readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
473 instance Show () where
474 showsPrec p () = showString "()"
476 instance Bounded () where
480 -- Boolean type -------------------------------------------------------------
482 data Bool = False | True
483 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
485 (&&), (||) :: Bool -> Bool -> Bool
498 -- Character type -----------------------------------------------------------
500 data Char -- builtin datatype of ISO Latin characters
501 type String = [Char] -- strings are lists of characters
503 instance Eq Char where (==) = primEqChar
504 instance Ord Char where (<=) = primLeChar
506 instance Enum Char where
507 toEnum = primIntToChar
508 fromEnum = primCharToInt
509 enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
510 enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
511 where lastChar = if d < c then minBound else maxBound
513 instance Ix Char where
514 range (c,c') = [c..c']
516 | inRange b ci = fromEnum ci - fromEnum c
517 | otherwise = error "Ix.index: Index out of range."
518 inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
519 where i = fromEnum ci
521 instance Read Char where
522 readsPrec p = readParen False
523 (\r -> [(c,t) | ('\'':s,t) <- lex r,
524 (c,"\'") <- readLitChar s ])
525 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
527 where readl ('"':s) = [("",s)]
528 readl ('\\':'&':s) = readl s
529 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
531 instance Show Char where
532 showsPrec p '\'' = showString "'\\''"
533 showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
535 showList cs = showChar '"' . showl cs
536 where showl "" = showChar '"'
537 showl ('"':cs) = showString "\\\"" . showl cs
538 showl (c:cs) = showLitChar c . showl cs
540 instance Bounded Char where
544 isAscii, isControl, isPrint, isSpace :: Char -> Bool
545 isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
547 isAscii c = fromEnum c < 128
548 isControl c = c < ' ' || c == '\DEL'
549 isPrint c = c >= ' ' && c <= '~'
550 isSpace c = c == ' ' || c == '\t' || c == '\n' ||
551 c == '\r' || c == '\f' || c == '\v'
552 isUpper c = c >= 'A' && c <= 'Z'
553 isLower c = c >= 'a' && c <= 'z'
554 isAlpha c = isUpper c || isLower c
555 isDigit c = c >= '0' && c <= '9'
556 isAlphaNum c = isAlpha c || isDigit c
558 -- Digit conversion operations
559 digitToInt :: Char -> Int
561 | isDigit c = fromEnum c - fromEnum '0'
562 | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
563 | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
564 | otherwise = error "Char.digitToInt: not a digit"
566 intToDigit :: Int -> Char
568 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
569 | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
570 | otherwise = error "Char.intToDigit: not a digit"
572 toUpper, toLower :: Char -> Char
573 toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
576 toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
585 -- Maybe type ---------------------------------------------------------------
587 data Maybe a = Nothing | Just a
588 deriving (Eq, Ord, Read, Show)
590 maybe :: b -> (a -> b) -> Maybe a -> b
591 maybe n f Nothing = n
592 maybe n f (Just x) = f x
594 instance Functor Maybe where
595 fmap f Nothing = Nothing
596 fmap f (Just x) = Just (f x)
598 instance Monad Maybe where
600 Nothing >>= k = Nothing
604 -- Either type --------------------------------------------------------------
606 data Either a b = Left a | Right b
607 deriving (Eq, Ord, Read, Show)
609 either :: (a -> c) -> (b -> c) -> Either a b -> c
610 either l r (Left x) = l x
611 either l r (Right y) = r y
613 -- Ordering type ------------------------------------------------------------
615 data Ordering = LT | EQ | GT
616 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
618 -- Lists --------------------------------------------------------------------
620 --data [a] = [] | a : [a] deriving (Eq, Ord)
622 instance Eq a => Eq [a] where
624 (x:xs) == (y:ys) = x==y && xs==ys
627 instance Ord a => Ord [a] where
628 compare [] (_:_) = LT
630 compare (_:_) [] = GT
631 compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
633 instance Functor [] where
636 instance Monad [ ] where
637 (x:xs) >>= f = f x ++ (xs >>= f)
642 instance Read a => Read [a] where
643 readsPrec p = readList
645 instance Show a => Show [a] where
646 showsPrec p = showList
648 -- Tuples -------------------------------------------------------------------
650 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
653 -- Standard Integral types --------------------------------------------------
655 data Int -- builtin datatype of fixed size integers
656 data Integer -- builtin datatype of arbitrary size integers
658 instance Eq Integer where
659 (==) x y = primCompareInteger x y == 0
661 instance Ord Integer where
662 compare x y = case primCompareInteger x y of
667 instance Eq Int where
671 instance Ord Int where
677 instance Num Int where
680 negate = primNegateInt
684 fromInteger = primIntegerToInt
687 instance Bounded Int where
688 minBound = primMinInt
689 maxBound = primMaxInt
691 instance Num Integer where
692 (+) = primPlusInteger
693 (-) = primMinusInteger
694 negate = primNegateInteger
695 (*) = primTimesInteger
699 fromInt = primIntToInteger
701 absReal x | x >= 0 = x
704 signumReal x | x == 0 = 0
708 instance Real Int where
709 toRational x = toInteger x % 1
711 instance Real Integer where
714 instance Integral Int where
715 quotRem = primQuotRemInt
716 toInteger = primIntToInteger
719 instance Integral Integer where
720 quotRem = primQuotRemInteger
721 --divMod = primDivModInteger
723 toInt = primIntegerToInt
725 instance Ix Int where
728 | inRange b i = i - m
729 | otherwise = error "index: Index out of range"
730 inRange (m,n) i = m <= i && i <= n
732 instance Ix Integer where
735 | inRange b i = fromInteger (i - m)
736 | otherwise = error "index: Index out of range"
737 inRange (m,n) i = m <= i && i <= n
739 instance Enum Int where
742 enumFrom = numericEnumFrom
743 enumFromTo = numericEnumFromTo
744 enumFromThen = numericEnumFromThen
745 enumFromThenTo = numericEnumFromThenTo
747 instance Enum Integer where
748 toEnum = primIntToInteger
749 fromEnum = primIntegerToInt
750 enumFrom = numericEnumFrom
751 enumFromTo = numericEnumFromTo
752 enumFromThen = numericEnumFromThen
753 enumFromThenTo = numericEnumFromThenTo
755 numericEnumFrom :: Real a => a -> [a]
756 numericEnumFromThen :: Real a => a -> a -> [a]
757 numericEnumFromTo :: Real a => a -> a -> [a]
758 numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
759 numericEnumFrom n = n : (numericEnumFrom $! (n+1))
760 numericEnumFromThen n m = iterate ((m-n)+) n
761 numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
762 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
763 where p | n' >= n = (<= m)
766 instance Read Int where
767 readsPrec p = readSigned readDec
769 instance Show Int where
771 | n == minBound = showSigned showInt p (toInteger n)
772 | otherwise = showSigned showInt p n
774 instance Read Integer where
775 readsPrec p = readSigned readDec
777 instance Show Integer where
778 showsPrec = showSigned showInt
781 -- Standard Floating types --------------------------------------------------
783 data Float -- builtin datatype of single precision floating point numbers
784 data Double -- builtin datatype of double precision floating point numbers
786 instance Eq Float where
790 instance Ord Float where
796 instance Num Float where
799 negate = primNegateFloat
803 fromInteger = primIntegerToFloat
804 fromInt = primIntToFloat
808 instance Eq Double where
812 instance Ord Double where
818 instance Num Double where
820 (-) = primMinusDouble
821 negate = primNegateDouble
822 (*) = primTimesDouble
825 fromInteger = primIntegerToDouble
826 fromInt = primIntToDouble
830 instance Real Float where
831 toRational = floatToRational
833 instance Real Double where
834 toRational = doubleToRational
836 -- Calls to these functions are optimised when passed as arguments to
838 floatToRational :: Float -> Rational
839 doubleToRational :: Double -> Rational
840 floatToRational x = realFloatToRational x
841 doubleToRational x = realFloatToRational x
843 realFloatToRational x = (m%1)*(b%1)^^n
844 where (m,n) = decodeFloat x
847 instance Fractional Float where
848 (/) = primDivideFloat
849 fromRational = rationalToRealFloat
850 fromDouble = primDoubleToFloat
853 instance Fractional Double where
854 (/) = primDivideDouble
855 fromRational = rationalToRealFloat
858 rationalToRealFloat x = x'
860 f e = if e' == e then y else f e'
861 where y = encodeFloat (round (x * (1%b)^^e)) e
862 (_,e') = decodeFloat y
863 (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
864 / fromInteger (denominator x))
867 instance Floating Float where
868 pi = 3.14159265358979323846
879 instance Floating Double where
880 pi = 3.14159265358979323846
883 sqrt = primSqrtDouble
887 asin = primAsinDouble
888 acos = primAcosDouble
889 atan = primAtanDouble
891 instance RealFrac Float where
892 properFraction = floatProperFraction
894 instance RealFrac Double where
895 properFraction = floatProperFraction
897 floatProperFraction x
898 | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
899 | otherwise = (fromInteger w, encodeFloat r n)
900 where (m,n) = decodeFloat x
902 (w,r) = quotRem m (b^(-n))
904 instance RealFloat Float where
905 floatRadix _ = toInteger primRadixFloat
906 floatDigits _ = primDigitsFloat
907 floatRange _ = (primMinExpFloat,primMaxExpFloat)
908 encodeFloat = primEncodeFloatZ
909 decodeFloat = primDecodeFloatZ
910 isNaN = primIsNaNFloat
911 isInfinite = primIsInfiniteFloat
912 isDenormalized= primIsDenormalizedFloat
913 isNegativeZero= primIsNegativeZeroFloat
914 isIEEE = const primIsIEEEFloat
916 instance RealFloat Double where
917 floatRadix _ = toInteger primRadixDouble
918 floatDigits _ = primDigitsDouble
919 floatRange _ = (primMinExpDouble,primMaxExpDouble)
920 encodeFloat = primEncodeDoubleZ
921 decodeFloat = primDecodeDoubleZ
922 isNaN = primIsNaNDouble
923 isInfinite = primIsInfiniteDouble
924 isDenormalized= primIsDenormalizedDouble
925 isNegativeZero= primIsNegativeZeroDouble
926 isIEEE = const primIsIEEEDouble
928 instance Enum Float where
929 toEnum = primIntToFloat
931 enumFrom = numericEnumFrom
932 enumFromThen = numericEnumFromThen
933 enumFromTo n m = numericEnumFromTo n (m+1/2)
934 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
936 instance Enum Double where
937 toEnum = primIntToDouble
939 enumFrom = numericEnumFrom
940 enumFromThen = numericEnumFromThen
941 enumFromTo n m = numericEnumFromTo n (m+1/2)
942 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
944 instance Read Float where
945 readsPrec p = readSigned readFloat
947 instance Show Float where
948 showsPrec p = showSigned showFloat p
950 instance Read Double where
951 readsPrec p = readSigned readFloat
953 instance Show Double where
954 showsPrec p = showSigned showFloat p
957 -- Some standard functions --------------------------------------------------
965 curry :: ((a,b) -> c) -> (a -> b -> c)
966 curry f x y = f (x,y)
968 uncurry :: (a -> b -> c) -> ((a,b) -> c)
969 uncurry f p = f (fst p) (snd p)
977 (.) :: (b -> c) -> (a -> b) -> (a -> c)
980 flip :: (a -> b -> c) -> b -> a -> c
983 ($) :: (a -> b) -> a -> b
986 until :: (a -> Bool) -> (a -> a) -> a -> a
987 until p f x = if p x then x else until p f (f x)
989 asTypeOf :: a -> a -> a
993 error msg = primRaise (ErrorCall msg)
996 undefined | False = undefined
998 -- Standard functions on rational numbers {PreludeRatio} --------------------
1000 data Integral a => Ratio a = a :% a deriving (Eq)
1001 type Rational = Ratio Integer
1003 (%) :: Integral a => a -> a -> Ratio a
1004 x % y = reduce (x * signum y) (abs y)
1006 reduce :: Integral a => a -> a -> Ratio a
1007 reduce x y | y == 0 = error "Ratio.%: zero denominator"
1008 | otherwise = (x `quot` d) :% (y `quot` d)
1011 numerator, denominator :: Integral a => Ratio a -> a
1012 numerator (x :% y) = x
1013 denominator (x :% y) = y
1015 instance Integral a => Ord (Ratio a) where
1016 compare (x:%y) (x':%y') = compare (x*y') (x'*y)
1018 instance Integral a => Num (Ratio a) where
1019 (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
1020 (x:%y) * (x':%y') = reduce (x*x') (y*y')
1021 negate (x :% y) = negate x :% y
1022 abs (x :% y) = abs x :% y
1023 signum (x :% y) = signum x :% 1
1024 fromInteger x = fromInteger x :% 1
1025 fromInt = intToRatio
1027 -- Hugs optimises code of the form fromRational (intToRatio x)
1028 intToRatio :: Integral a => Int -> Ratio a
1029 intToRatio x = fromInt x :% 1
1031 instance Integral a => Real (Ratio a) where
1032 toRational (x:%y) = toInteger x :% toInteger y
1034 instance Integral a => Fractional (Ratio a) where
1035 (x:%y) / (x':%y') = (x*y') % (y*x')
1036 recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
1037 fromRational (x:%y) = fromInteger x :% fromInteger y
1038 fromDouble = doubleToRatio
1040 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1041 doubleToRatio :: Integral a => Double -> Ratio a
1043 | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
1044 | otherwise = fromInteger m % (fromInteger b ^ (-n))
1045 where (m,n) = decodeFloat x
1048 instance Integral a => RealFrac (Ratio a) where
1049 properFraction (x:%y) = (fromIntegral q, r:%y)
1050 where (q,r) = quotRem x y
1052 instance Integral a => Enum (Ratio a) where
1055 enumFrom = numericEnumFrom
1056 enumFromThen = numericEnumFromThen
1058 instance (Read a, Integral a) => Read (Ratio a) where
1059 readsPrec p = readParen (p > 7)
1060 (\r -> [(x%y,u) | (x,s) <- reads r,
1064 instance Integral a => Show (Ratio a) where
1065 showsPrec p (x:%y) = showParen (p > 7)
1066 (shows x . showString " % " . shows y)
1068 approxRational :: RealFrac a => a -> a -> Rational
1069 approxRational x eps = simplest (x-eps) (x+eps)
1070 where simplest x y | y < x = simplest y x
1072 | x > 0 = simplest' n d n' d'
1073 | y < 0 = - simplest' (-n') d' (-n) d
1074 | otherwise = 0 :% 1
1075 where xr@(n:%d) = toRational x
1076 (n':%d') = toRational y
1077 simplest' n d n' d' -- assumes 0 < n%d < n'%d'
1079 | q /= q' = (q+1) :% 1
1080 | otherwise = (q*n''+d'') :% n''
1081 where (q,r) = quotRem n d
1082 (q',r') = quotRem n' d'
1083 (n'':%d'') = simplest' d' r' d r
1085 -- Standard list functions {PreludeList} ------------------------------------
1092 last (_:xs) = last xs
1099 init (x:xs) = x : init xs
1105 (++) :: [a] -> [a] -> [a]
1107 (x:xs) ++ ys = x : (xs ++ ys)
1109 map :: (a -> b) -> [a] -> [b]
1110 --map f xs = [ f x | x <- xs ]
1112 map f (x:xs) = f x : map f xs
1115 filter :: (a -> Bool) -> [a] -> [a]
1116 --filter p xs = [ x | x <- xs, p x ]
1118 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1121 concat :: [[a]] -> [a]
1122 --concat = foldr (++) []
1124 concat (xs:xss) = xs ++ concat xss
1126 length :: [a] -> Int
1127 --length = foldl' (\n _ -> n + 1) 0
1129 length (x:xs) = let n = length xs in primSeq n (1+n)
1131 (!!) :: [b] -> Int -> b
1133 (_:xs) !! n | n>0 = xs !! (n-1)
1134 (_:_) !! _ = error "Prelude.!!: negative index"
1135 [] !! _ = error "Prelude.!!: index too large"
1137 foldl :: (a -> b -> a) -> a -> [b] -> a
1139 foldl f z (x:xs) = foldl f (f z x) xs
1141 foldl' :: (a -> b -> a) -> a -> [b] -> a
1143 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1145 foldl1 :: (a -> a -> a) -> [a] -> a
1146 foldl1 f (x:xs) = foldl f x xs
1148 scanl :: (a -> b -> a) -> a -> [b] -> [a]
1149 scanl f q xs = q : (case xs of
1151 x:xs -> scanl f (f q x) xs)
1153 scanl1 :: (a -> a -> a) -> [a] -> [a]
1154 scanl1 f (x:xs) = scanl f x xs
1156 foldr :: (a -> b -> b) -> b -> [a] -> b
1158 foldr f z (x:xs) = f x (foldr f z xs)
1160 foldr1 :: (a -> a -> a) -> [a] -> a
1162 foldr1 f (x:xs) = f x (foldr1 f xs)
1164 scanr :: (a -> b -> b) -> b -> [a] -> [b]
1165 scanr f q0 [] = [q0]
1166 scanr f q0 (x:xs) = f x q : qs
1167 where qs@(q:_) = scanr f q0 xs
1169 scanr1 :: (a -> a -> a) -> [a] -> [a]
1171 scanr1 f (x:xs) = f x q : qs
1172 where qs@(q:_) = scanr1 f xs
1174 iterate :: (a -> a) -> a -> [a]
1175 iterate f x = x : iterate f (f x)
1178 repeat x = xs where xs = x:xs
1180 replicate :: Int -> a -> [a]
1181 replicate n x = take n (repeat x)
1184 cycle [] = error "Prelude.cycle: empty list"
1185 cycle xs = xs' where xs'=xs++xs'
1187 take :: Int -> [a] -> [a]
1190 take n (x:xs) | n>0 = x : take (n-1) xs
1191 take _ _ = error "Prelude.take: negative argument"
1193 drop :: Int -> [a] -> [a]
1196 drop n (_:xs) | n>0 = drop (n-1) xs
1197 drop _ _ = error "Prelude.drop: negative argument"
1199 splitAt :: Int -> [a] -> ([a], [a])
1200 splitAt 0 xs = ([],xs)
1201 splitAt _ [] = ([],[])
1202 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1203 splitAt _ _ = error "Prelude.splitAt: negative argument"
1205 takeWhile :: (a -> Bool) -> [a] -> [a]
1208 | p x = x : takeWhile p xs
1211 dropWhile :: (a -> Bool) -> [a] -> [a]
1213 dropWhile p xs@(x:xs')
1214 | p x = dropWhile p xs'
1217 span, break :: (a -> Bool) -> [a] -> ([a],[a])
1221 | otherwise = ([],xs)
1222 where (ys,zs) = span p xs'
1223 break p = span (not . p)
1225 lines :: String -> [String]
1227 lines s = let (l,s') = break ('\n'==) s
1228 in l : case s' of [] -> []
1229 (_:s'') -> lines s''
1231 words :: String -> [String]
1232 words s = case dropWhile isSpace s of
1235 where (w,s'') = break isSpace s'
1237 unlines :: [String] -> String
1238 unlines = concatMap (\l -> l ++ "\n")
1240 unwords :: [String] -> String
1242 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1244 reverse :: [a] -> [a]
1245 --reverse = foldl (flip (:)) []
1246 reverse xs = ri [] xs
1247 where ri acc [] = acc
1248 ri acc (x:xs) = ri (x:acc) xs
1250 and, or :: [Bool] -> Bool
1251 --and = foldr (&&) True
1252 --or = foldr (||) False
1254 and (x:xs) = if x then and xs else x
1256 or (x:xs) = if x then x else or xs
1258 any, all :: (a -> Bool) -> [a] -> Bool
1259 --any p = or . map p
1260 --all p = and . map p
1262 any p (x:xs) = if p x then True else any p xs
1264 all p (x:xs) = if p x then all p xs else False
1266 elem, notElem :: Eq a => a -> [a] -> Bool
1268 --notElem = all . (/=)
1270 elem x (y:ys) = if x==y then True else elem x ys
1272 notElem x (y:ys) = if x==y then False else notElem x ys
1274 lookup :: Eq a => a -> [(a,b)] -> Maybe b
1275 lookup k [] = Nothing
1276 lookup k ((x,y):xys)
1278 | otherwise = lookup k xys
1280 sum, product :: Num a => [a] -> a
1282 product = foldl' (*) 1
1284 maximum, minimum :: Ord a => [a] -> a
1285 maximum = foldl1 max
1286 minimum = foldl1 min
1288 concatMap :: (a -> [b]) -> [a] -> [b]
1289 concatMap f = concat . map f
1291 zip :: [a] -> [b] -> [(a,b)]
1292 zip = zipWith (\a b -> (a,b))
1294 zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
1295 zip3 = zipWith3 (\a b c -> (a,b,c))
1297 zipWith :: (a->b->c) -> [a]->[b]->[c]
1298 zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
1301 zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1302 zipWith3 z (a:as) (b:bs) (c:cs)
1303 = z a b c : zipWith3 z as bs cs
1304 zipWith3 _ _ _ _ = []
1306 unzip :: [(a,b)] -> ([a],[b])
1307 unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1309 unzip3 :: [(a,b,c)] -> ([a],[b],[c])
1310 unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1313 -- PreludeText ----------------------------------------------------------------
1315 reads :: Read a => ReadS a
1318 shows :: Show a => a -> ShowS
1321 read :: Read a => String -> a
1322 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1324 [] -> error "Prelude.read: no parse"
1325 _ -> error "Prelude.read: ambiguous parse"
1327 showChar :: Char -> ShowS
1330 showString :: String -> ShowS
1333 showParen :: Bool -> ShowS -> ShowS
1334 showParen b p = if b then showChar '(' . p . showChar ')' else p
1336 showField :: Show a => String -> a -> ShowS
1337 showField m v = showString m . showChar '=' . shows v
1339 readParen :: Bool -> ReadS a -> ReadS a
1340 readParen b g = if b then mandatory else optional
1341 where optional r = g r ++ mandatory r
1342 mandatory r = [(x,u) | ("(",s) <- lex r,
1343 (x,t) <- optional s,
1347 readField :: Read a => String -> ReadS a
1348 readField m s0 = [ r | (t, s1) <- lex s0, t == m,
1354 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1355 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1357 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1359 lexString ('"':s) = [("\"",s)]
1360 lexString s = [(ch++str, u)
1361 | (ch,t) <- lexStrItem s,
1362 (str,u) <- lexString t ]
1364 lexStrItem ('\\':'&':s) = [("\\&",s)]
1365 lexStrItem ('\\':c:s) | isSpace c
1366 = [("",t) | '\\':t <- [dropWhile isSpace s]]
1367 lexStrItem s = lexLitChar s
1369 lex (c:s) | isSingle c = [([c],s)]
1370 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
1371 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
1372 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
1373 (fe,t) <- lexFracExp s ]
1374 | otherwise = [] -- bad character
1376 isSingle c = c `elem` ",;()[]{}_`"
1377 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1378 isIdChar c = isAlphaNum c || c `elem` "_'"
1380 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1382 lexFracExp s = [("",s)]
1384 lexExp (e:s) | e `elem` "eE"
1385 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
1386 (ds,u) <- lexDigits t] ++
1387 [(e:ds,t) | (ds,t) <- lexDigits s]
1390 lexDigits :: ReadS String
1391 lexDigits = nonnull isDigit
1393 nonnull :: (Char -> Bool) -> ReadS String
1394 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1396 lexLitChar :: ReadS String
1397 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1399 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- "
1400 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
1401 lexEsc s@(d:_) | isDigit d = lexDigits s
1402 lexEsc s@(c:_) | isUpper c
1403 = let table = ('\DEL',"DEL") : asciiTab
1404 in case [(mne,s') | (c, mne) <- table,
1405 ([],s') <- [lexmatch mne s]]
1409 lexLitChar (c:s) = [([c],s)]
1412 isOctDigit c = c >= '0' && c <= '7'
1413 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
1414 || c >= 'a' && c <= 'f'
1416 lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
1417 lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
1418 lexmatch xs ys = (xs,ys)
1420 asciiTab = zip ['\NUL'..' ']
1421 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1422 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
1423 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1424 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
1427 readLitChar :: ReadS Char
1428 readLitChar ('\\':s) = readEsc s
1430 readEsc ('a':s) = [('\a',s)]
1431 readEsc ('b':s) = [('\b',s)]
1432 readEsc ('f':s) = [('\f',s)]
1433 readEsc ('n':s) = [('\n',s)]
1434 readEsc ('r':s) = [('\r',s)]
1435 readEsc ('t':s) = [('\t',s)]
1436 readEsc ('v':s) = [('\v',s)]
1437 readEsc ('\\':s) = [('\\',s)]
1438 readEsc ('"':s) = [('"',s)]
1439 readEsc ('\'':s) = [('\'',s)]
1440 readEsc ('^':c:s) | c >= '@' && c <= '_'
1441 = [(toEnum (fromEnum c - fromEnum '@'), s)]
1442 readEsc s@(d:_) | isDigit d
1443 = [(toEnum n, t) | (n,t) <- readDec s]
1444 readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
1445 readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
1446 readEsc s@(c:_) | isUpper c
1447 = let table = ('\DEL',"DEL") : asciiTab
1448 in case [(c,s') | (c, mne) <- table,
1449 ([],s') <- [lexmatch mne s]]
1453 readLitChar (c:s) = [(c,s)]
1455 showLitChar :: Char -> ShowS
1456 showLitChar c | c > '\DEL' = showChar '\\' .
1457 protectEsc isDigit (shows (fromEnum c))
1458 showLitChar '\DEL' = showString "\\DEL"
1459 showLitChar '\\' = showString "\\\\"
1460 showLitChar c | c >= ' ' = showChar c
1461 showLitChar '\a' = showString "\\a"
1462 showLitChar '\b' = showString "\\b"
1463 showLitChar '\f' = showString "\\f"
1464 showLitChar '\n' = showString "\\n"
1465 showLitChar '\r' = showString "\\r"
1466 showLitChar '\t' = showString "\\t"
1467 showLitChar '\v' = showString "\\v"
1468 showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
1469 showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
1471 protectEsc p f = f . cont
1472 where cont s@(c:_) | p c = "\\&" ++ s
1475 -- Unsigned readers for various bases
1476 readDec, readOct, readHex :: Integral a => ReadS a
1477 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1478 readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1479 readHex = readInt 16 isHexDigit hex
1480 where hex d = fromEnum d -
1483 else fromEnum (if isUpper d then 'A' else 'a') - 10)
1485 -- readInt reads a string of digits using an arbitrary base.
1486 -- Leading minus signs must be handled elsewhere.
1488 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1489 readInt radix isDig digToInt s =
1490 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1491 | (ds,r) <- nonnull isDig s ]
1493 -- showInt is used for positive numbers only
1494 showInt :: Integral a => a -> ShowS
1497 = error "Numeric.showInt: can't show negative numbers"
1500 = let (n',d) = quotRem n 10
1501 r' = toEnum (fromEnum '0' + fromIntegral d) : r
1502 in if n' == 0 then r' else showInt n' r'
1504 = case quotRem n 10 of { (n',d) ->
1505 let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1506 in if n' == 0 then r' else showInt n' r'
1510 readSigned:: Real a => ReadS a -> ReadS a
1511 readSigned readPos = readParen False read'
1512 where read' r = read'' r ++
1513 [(-x,t) | ("-",s) <- lex r,
1515 read'' r = [(n,s) | (str,s) <- lex r,
1516 (n,"") <- readPos str]
1518 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1519 showSigned showPos p x = if x < 0 then showParen (p > 6)
1520 (showChar '-' . showPos (-x))
1523 readFloat :: RealFloat a => ReadS a
1524 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1526 where readFix r = [(read (ds++ds'), length ds', t)
1527 | (ds, s) <- lexDigits r
1528 , (ds',t) <- lexFrac s ]
1530 lexFrac ('.':s) = lexDigits s
1531 lexFrac s = [("",s)]
1533 readExp (e:s) | e `elem` "eE" = readExp' s
1536 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1537 readExp' ('+':s) = readDec s
1538 readExp' s = readDec s
1541 -- Hooks for primitives: -----------------------------------------------------
1542 -- Do not mess with these!
1544 primCompAux :: Ord a => a -> a -> Ordering -> Ordering
1545 primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1547 primPmInt :: Num a => Int -> a -> Bool
1548 primPmInt n x = fromInt n == x
1550 primPmInteger :: Num a => Integer -> a -> Bool
1551 primPmInteger n x = fromInteger n == x
1553 primPmDouble :: Fractional a => Double -> a -> Bool
1554 primPmDouble n x = fromDouble n == x
1556 -- ToDo: make the message more informative.
1558 primPmFail = error "Pattern Match Failure"
1560 -- used in desugaring Foreign functions
1561 primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1564 primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1565 primCreateAdjThunk fun typestr callconv
1566 = do sp <- makeStablePtr fun
1567 p <- copy_String_to_cstring typestr -- is never freed
1568 a <- primCreateAdjThunkARCH sp p callconv
1571 -- The following primitives are only needed if (n+k) patterns are enabled:
1572 primPmNpk :: Integral a => Int -> a -> Maybe a
1573 primPmNpk n x = if n'<=x then Just (x-n') else Nothing
1574 where n' = fromInt n
1576 primPmSub :: Integral a => Int -> a -> a
1577 primPmSub n x = x - fromInt n
1579 -- Unpack strings generated by the Hugs code generator.
1580 -- Strings can contain \0 provided they're coded right.
1582 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1584 primUnpackString :: Addr -> String
1585 primUnpackString a = unpack 0
1587 -- The following decoding is based on evalString in the old machine.c
1590 | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1591 then '\\' : unpack (i+2)
1592 else '\0' : unpack (i+2)
1593 | otherwise = c : unpack (i+1)
1595 c = primIndexCharOffAddr a i
1598 -- Monadic I/O: --------------------------------------------------------------
1600 type FilePath = String
1602 --data IOError = ...
1603 --instance Eq IOError ...
1604 --instance Show IOError ...
1606 data IOError = IOError String
1607 instance Show IOError where
1608 showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1610 ioError :: IOError -> IO a
1611 ioError (IOError s) = primRaise (IOExcept s)
1613 userError :: String -> IOError
1614 userError s = primRaise (ErrorCall s)
1616 catch :: IO a -> (IOError -> IO a) -> IO a
1618 = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
1620 e2ioe (IOExcept s) = IOError s
1621 e2ioe other = IOError (show other)
1623 putChar :: Char -> IO ()
1624 putChar c = nh_stdout >>= \h -> nh_write h c
1626 putStr :: String -> IO ()
1627 putStr s = nh_stdout >>= \h ->
1628 let loop [] = nh_flush h
1629 loop (c:cs) = nh_write h c >> loop cs
1632 putStrLn :: String -> IO ()
1633 putStrLn s = do { putStr s; putChar '\n' }
1635 print :: Show a => a -> IO ()
1636 print = putStrLn . show
1639 getChar = unsafeInterleaveIO (
1641 nh_read h >>= \ci ->
1642 return (primIntToChar ci)
1645 getLine :: IO String
1646 getLine = do c <- getChar
1647 if c=='\n' then return ""
1648 else do cs <- getLine
1651 getContents :: IO String
1652 getContents = nh_stdin >>= \h -> readfromhandle h
1654 interact :: (String -> String) -> IO ()
1655 interact f = getContents >>= (putStr . f)
1657 readFile :: FilePath -> IO String
1659 = copy_String_to_cstring fname >>= \ptr ->
1660 nh_open ptr 0 >>= \h ->
1662 nh_errno >>= \errno ->
1663 if (isNullAddr h || errno /= 0)
1664 then (ioError.IOError) ("readFile: can't open file " ++ fname)
1665 else readfromhandle h
1667 writeFile :: FilePath -> String -> IO ()
1668 writeFile fname contents
1669 = copy_String_to_cstring fname >>= \ptr ->
1670 nh_open ptr 1 >>= \h ->
1672 nh_errno >>= \errno ->
1673 if (isNullAddr h || errno /= 0)
1674 then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1675 else writetohandle fname h contents
1677 appendFile :: FilePath -> String -> IO ()
1678 appendFile fname contents
1679 = copy_String_to_cstring fname >>= \ptr ->
1680 nh_open ptr 2 >>= \h ->
1682 nh_errno >>= \errno ->
1683 if (isNullAddr h || errno /= 0)
1684 then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1685 else writetohandle fname h contents
1688 -- raises an exception instead of an error
1689 readIO :: Read a => String -> IO a
1690 readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1692 [] -> ioError (userError "PreludeIO.readIO: no parse")
1693 _ -> ioError (userError
1694 "PreludeIO.readIO: ambiguous parse")
1696 readLn :: Read a => IO a
1697 readLn = do l <- getLine
1702 -- End of Hugs standard prelude ----------------------------------------------
1708 instance Show Exception where
1709 showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1710 showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
1712 data IOResult = IOResult deriving (Show)
1714 type FILE_STAR = Addr -- FILE *
1716 foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR
1717 foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
1718 foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
1719 foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Char -> IO ()
1720 foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int
1721 foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR
1722 foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO ()
1723 foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO ()
1724 foreign import "nHandle" "nh_errno" nh_errno :: IO Int
1726 foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
1727 foreign import "nHandle" "nh_free" nh_free :: Addr -> IO ()
1728 foreign import "nHandle" "nh_store" nh_store :: Addr -> Char -> IO ()
1729 foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Char
1730 foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
1732 copy_String_to_cstring :: String -> IO Addr
1733 copy_String_to_cstring s
1734 = nh_malloc (1 + length s) >>= \ptr0 ->
1735 let loop ptr [] = nh_store ptr (chr 0) >> return ptr0
1736 loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs
1739 then error "copy_String_to_cstring: malloc failed"
1742 copy_cstring_to_String :: Addr -> IO String
1743 copy_cstring_to_String ptr
1744 = nh_load ptr >>= \ci ->
1747 else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1750 readfromhandle :: FILE_STAR -> IO String
1752 = unsafeInterleaveIO (
1753 nh_read h >>= \ci ->
1754 if ci == -1 {-EOF-} then return "" else
1755 readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1758 writetohandle :: String -> FILE_STAR -> String -> IO ()
1759 writetohandle fname h []
1761 nh_errno >>= \errno ->
1764 else error ( "writeFile/appendFile: error closing file " ++ fname)
1765 writetohandle fname h (c:cs)
1766 = nh_write h c >> writetohandle fname h cs
1768 primGetRawArgs :: IO [String]
1770 = primGetArgc >>= \argc ->
1771 sequence (map get_one_arg [0 .. argc-1])
1773 get_one_arg :: Int -> IO String
1775 = primGetArgv argno >>= \a ->
1776 copy_cstring_to_String a
1778 primGetEnv :: String -> IO String
1780 = copy_String_to_cstring v >>= \ptr ->
1781 nh_getenv ptr >>= \ptr2 ->
1786 copy_cstring_to_String ptr2 >>= \result ->
1790 ------------------------------------------------------------------------------
1791 -- ST, IO --------------------------------------------------------------------
1792 ------------------------------------------------------------------------------
1794 -- Do not change this newtype to a data, or MVars will stop
1795 -- working. In general the MVar stuff is pretty fragile: do
1796 -- not mess with it.
1797 newtype ST s a = ST (s -> (a,s))
1800 type IO a = ST RealWorld a
1803 --primRunST :: (forall s. ST s a) -> a
1804 primRunST :: ST RealWorld a -> a
1805 primRunST m = fst (unST m theWorld)
1807 theWorld :: RealWorld
1808 theWorld = error "primRunST: entered the RealWorld"
1812 instance Functor (ST s) where
1813 fmap f x = x >>= (return . f)
1815 instance Monad (ST s) where
1816 m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1817 return x = ST (\s -> (x,s))
1818 m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1821 -- used when Hugs invokes top level function
1822 primRunIO :: IO () -> ()
1824 = protect (fst (unST m realWorld))
1826 realWorld = error "primRunIO: entered the RealWorld"
1829 = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1831 trace :: String -> a -> a
1833 = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x
1835 unsafeInterleaveST :: ST s a -> ST s a
1836 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1838 unsafeInterleaveIO :: IO a -> IO a
1839 unsafeInterleaveIO = unsafeInterleaveST
1842 ------------------------------------------------------------------------------
1843 -- Word, Addr, StablePtr, Prim*Array, ThreadId, MVar -------------------------
1844 ------------------------------------------------------------------------------
1848 nullAddr = primIntToAddr 0
1849 incAddr a = primIntToAddr (1 + primAddrToInt a)
1850 isNullAddr a = 0 == primAddrToInt a
1852 instance Eq Addr where
1856 instance Ord Addr where
1864 instance Eq Word where
1868 instance Ord Word where
1876 makeStablePtr :: a -> IO (StablePtr a)
1877 makeStablePtr = primMakeStablePtr
1878 deRefStablePtr :: StablePtr a -> IO a
1879 deRefStablePtr = primDeRefStablePtr
1880 freeStablePtr :: StablePtr a -> IO ()
1881 freeStablePtr = primFreeStablePtr
1884 data PrimArray a -- immutable arrays with Int indices
1887 data Ref s a -- mutable variables
1888 data PrimMutableArray s a -- mutable arrays with Int indices
1889 data PrimMutableByteArray s
1896 newMVar :: IO (MVar a)
1897 newMVar = primNewMVar
1899 putMVar :: MVar a -> a -> IO ()
1900 putMVar = primPutMVar
1902 takeMVar :: MVar a -> IO a
1904 = ST (\world -> primTakeMVar m cont world)
1906 -- cont :: a -> RealWorld -> (a,RealWorld)
1907 -- where 'a' is as in the top-level signature
1908 cont x world = (x,world)
1910 -- the type of the handwritten BCO (threesome) primTakeMVar is
1911 -- primTakeMVar :: MVar a
1912 -- -> (a -> RealWorld -> (a,RealWorld))
1916 -- primTakeMVar behaves like this:
1918 -- primTakeMVar (MVar# m#) cont world
1919 -- = primTakeMVar_wrk m# cont world
1921 -- primTakeMVar_wrk m# cont world
1922 -- = cont (takeMVar# m#) world
1924 -- primTakeMVar_wrk has the special property that it is
1925 -- restartable by the scheduler, should the MVar be empty.
1928 -- showFloat ------------------------------------------------------------------
1930 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1931 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1932 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1933 showFloat :: (RealFloat a) => a -> ShowS
1935 showEFloat d x = showString (formatRealFloat FFExponent d x)
1936 showFFloat d x = showString (formatRealFloat FFFixed d x)
1937 showGFloat d x = showString (formatRealFloat FFGeneric d x)
1938 showFloat = showGFloat Nothing
1940 -- These are the format types. This type is not exported.
1942 data FFFormat = FFExponent | FFFixed | FFGeneric
1944 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
1945 formatRealFloat fmt decs x = s
1949 else if isInfinite x then
1950 if x < 0 then "-Infinity" else "Infinity"
1951 else if x < 0 || isNegativeZero x then
1952 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
1954 doFmt fmt (floatToDigits (toInteger base) x)
1956 let ds = map intToDigit is
1959 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
1966 [d] -> d : ".0e" ++ show (e-1)
1967 d:ds -> d : '.' : ds ++ 'e':show (e-1)
1969 let dec' = max dec 1 in
1971 [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
1973 let (ei, is') = roundTo base (dec'+1) is
1974 d:ds = map intToDigit
1975 (if ei > 0 then init is' else is')
1976 in d:'.':ds ++ "e" ++ show (e-1+ei)
1980 let f 0 s ds = mk0 s ++ "." ++ mk0 ds
1981 f n s "" = f (n-1) (s++"0") ""
1982 f n s (d:ds) = f (n-1) (s++[d]) ds
1987 let dec' = max dec 0 in
1989 let (ei, is') = roundTo base (dec' + e) is
1990 (ls, rs) = splitAt (e+ei) (map intToDigit is')
1991 in (if null ls then "0" else ls) ++
1992 (if null rs then "" else '.' : rs)
1994 let (ei, is') = roundTo base dec'
1995 (replicate (-e) 0 ++ is)
1996 d : ds = map intToDigit
1997 (if ei > 0 then is' else 0:is')
2000 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2001 roundTo base d is = case f d is of
2003 (1, is) -> (1, 1 : is)
2004 where b2 = base `div` 2
2005 f n [] = (0, replicate n 0)
2006 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2008 let (c, ds) = f (d-1) is
2010 in if i' == base then (1, 0:ds) else (0, i':ds)
2012 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2013 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2014 -- This version uses a much slower logarithm estimator. It should be improved.
2016 -- This function returns a list of digits (Ints in [0..base-1]) and an
2019 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2021 floatToDigits _ 0 = ([0], 0)
2022 floatToDigits base x =
2023 let (f0, e0) = decodeFloat x
2024 (minExp0, _) = floatRange x
2027 minExp = minExp0 - p -- the real minimum exponent
2028 -- Haskell requires that f be adjusted so denormalized numbers
2029 -- will have an impossibly low exponent. Adjust for this.
2030 (f, e) = let n = minExp - e0
2031 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2036 if f == b^(p-1) then
2037 (f*be*b*2, 2*b, be*b, b)
2041 if e > minExp && f == b^(p-1) then
2042 (f*b*2, b^(-e+1)*2, b, 1)
2044 (f*2, b^(-e)*2, 1, 1)
2047 if b == 2 && base == 10 then
2048 -- logBase 10 2 is slightly bigger than 3/10 so
2049 -- the following will err on the low side. Ignoring
2050 -- the fraction will make it err even more.
2051 -- Haskell promises that p-1 <= logBase b f < p.
2052 (p - 1 + e0) * 3 `div` 10
2054 ceiling ((log (fromInteger (f+1)) +
2055 fromInt e * log (fromInteger b)) /
2056 log (fromInteger base))
2059 if r + mUp <= expt base n * s then n else fixup (n+1)
2061 if expt base (-n) * (r + mUp) <= s then n
2065 gen ds rn sN mUpN mDnN =
2066 let (dn, rn') = (rn * base) `divMod` sN
2069 in case (rn' < mDnN', rn' + mUpN' > sN) of
2070 (True, False) -> dn : ds
2071 (False, True) -> dn+1 : ds
2072 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2073 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2076 gen [] r (s * expt base k) mUp mDn
2078 let bk = expt base (-k)
2079 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
2080 in (map toInt (reverse rds), k)
2083 -- Exponentiation with a cache for the most common numbers.
2086 expt :: Integer -> Int -> Integer
2088 if base == 2 && n >= minExpt && n <= maxExpt then
2089 expts !! (n-minExpt)
2094 expts = [2^n | n <- [minExpt .. maxExpt]]