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), 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_, sequence, 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,
105 , MVar, newEmptyMVar, newMVar, putMVar, takeMVar, readMVar, swapMVar
109 , STRef, newSTRef, readSTRef, writeSTRef
110 , IORef, newIORef, readIORef, writeIORef
112 -- This lot really shouldn't be exported, but are needed to
113 -- implement various libs.
114 ,hugsprimCompAux,PrimArray,primRunST,primNewArray,primWriteArray
115 ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv
116 ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open
117 ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar
118 ,unsafeInterleaveIO,nh_write,primCharToInt,
119 nullAddr, incAddr, isNullAddr,
120 nh_filesize, nh_iseof, nh_system, nh_exitwith, nh_getPID,
121 nh_getCPUtime, nh_getCPUprec, prelCleanupAfterRunAction,
124 primGtWord, primGeWord, primEqWord, primNeWord,
125 primLtWord, primLeWord, primMinWord, primMaxWord,
126 primPlusWord, primMinusWord, primTimesWord, primQuotWord,
127 primRemWord, primQuotRemWord, primNegateWord, primAndWord,
128 primOrWord, primXorWord, primNotWord, primShiftLWord,
129 primShiftRAWord, primShiftRLWord, primIntToWord, primWordToInt,
131 primAndInt, primOrInt, primXorInt, primNotInt,
132 primShiftLInt, primShiftRAInt, primShiftRLInt,
134 primAddrToInt, primIntToAddr,
136 primDoubleToFloat, primFloatToDouble,
140 -- Standard value bindings {Prelude} ----------------------------------------
145 infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
147 --infixr 5 : -- this fixity declaration is hard-wired into Hugs
149 infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
154 infixr 0 $, $!, `seq`
156 -- Equality and Ordered classes ---------------------------------------------
159 (==), (/=) :: a -> a -> Bool
161 -- Minimal complete definition: (==) or (/=)
165 class (Eq a) => Ord a where
166 compare :: a -> a -> Ordering
167 (<), (<=), (>=), (>) :: a -> a -> Bool
168 max, min :: a -> a -> a
170 -- Minimal complete definition: (<=) or compare
171 -- using compare can be more efficient for complex types
172 compare x y | x==y = EQ
176 x <= y = compare x y /= GT
177 x < y = compare x y == LT
178 x >= y = compare x y /= LT
179 x > y = compare x y == GT
186 class Bounded a where
187 minBound, maxBound :: a
188 -- Minimal complete definition: All
190 -- Numeric classes ----------------------------------------------------------
192 class (Eq a, Show a) => Num a where
193 (+), (-), (*) :: a -> a -> a
195 abs, signum :: a -> a
196 fromInteger :: Integer -> a
199 -- Minimal complete definition: All, except negate or (-)
201 fromInt = fromIntegral
204 class (Num a, Ord a) => Real a where
205 toRational :: a -> Rational
207 class (Real a, Enum a) => Integral a where
208 quot, rem, div, mod :: a -> a -> a
209 quotRem, divMod :: a -> a -> (a,a)
210 even, odd :: a -> Bool
211 toInteger :: a -> Integer
214 -- Minimal complete definition: quotRem and toInteger
215 n `quot` d = q where (q,r) = quotRem n d
216 n `rem` d = r where (q,r) = quotRem n d
217 n `div` d = q where (q,r) = divMod n d
218 n `mod` d = r where (q,r) = divMod n d
219 divMod n d = if signum r == - signum d then (q-1, r+d) else qr
220 where qr@(q,r) = quotRem n d
221 even n = n `rem` 2 == 0
223 toInt = toInt . toInteger
225 class (Num a) => Fractional a where
228 fromRational :: Rational -> a
230 -- Minimal complete definition: fromRational and ((/) or recip)
234 fromDouble :: Fractional a => Double -> a
235 fromDouble n = fromRational (toRational n)
237 class (Fractional a) => Floating a where
239 exp, log, sqrt :: a -> a
240 (**), logBase :: a -> a -> a
241 sin, cos, tan :: a -> a
242 asin, acos, atan :: a -> a
243 sinh, cosh, tanh :: a -> a
244 asinh, acosh, atanh :: a -> a
246 -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
247 -- asinh, acosh, atanh
248 x ** y = exp (log x * y)
249 logBase x y = log y / log x
251 tan x = sin x / cos x
252 sinh x = (exp x - exp (-x)) / 2
253 cosh x = (exp x + exp (-x)) / 2
254 tanh x = sinh x / cosh x
255 asinh x = log (x + sqrt (x*x + 1))
256 acosh x = log (x + sqrt (x*x - 1))
257 atanh x = (log (1 + x) - log (1 - x)) / 2
259 class (Real a, Fractional a) => RealFrac a where
260 properFraction :: (Integral b) => a -> (b,a)
261 truncate, round :: (Integral b) => a -> b
262 ceiling, floor :: (Integral b) => a -> b
264 -- Minimal complete definition: properFraction
265 truncate x = m where (m,_) = properFraction x
267 round x = let (n,r) = properFraction x
268 m = if r < 0 then n - 1 else n + 1
269 in case signum (abs r - 0.5) of
271 0 -> if even n then n else m
274 ceiling x = if r > 0 then n + 1 else n
275 where (n,r) = properFraction x
277 floor x = if r < 0 then n - 1 else n
278 where (n,r) = properFraction x
280 class (RealFrac a, Floating a) => RealFloat a where
281 floatRadix :: a -> Integer
282 floatDigits :: a -> Int
283 floatRange :: a -> (Int,Int)
284 decodeFloat :: a -> (Integer,Int)
285 encodeFloat :: Integer -> Int -> a
287 significand :: a -> a
288 scaleFloat :: Int -> a -> a
289 isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
293 -- Minimal complete definition: All, except exponent, signficand,
295 exponent x = if m==0 then 0 else n + floatDigits x
296 where (m,n) = decodeFloat x
297 significand x = encodeFloat m (- floatDigits x)
298 where (m,_) = decodeFloat x
299 scaleFloat k x = encodeFloat m (n+k)
300 where (m,n) = decodeFloat x
304 | x<0 && y>0 = pi + atan (y/x)
306 (x<0 && isNegativeZero y) ||
307 (isNegativeZero x && isNegativeZero y)
309 | y==0 && (x<0 || isNegativeZero x)
310 = pi -- must be after the previous test on zero y
311 | x==0 && y==0 = y -- must be after the other double zero tests
312 | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
314 -- Numeric functions --------------------------------------------------------
316 subtract :: Num a => a -> a -> a
319 gcd :: Integral a => a -> a -> a
320 gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
321 gcd x y = gcd' (abs x) (abs y)
323 gcd' x y = gcd' y (x `rem` y)
325 lcm :: (Integral a) => a -> a -> a
328 lcm x y = abs ((x `quot` gcd x y) * y)
330 (^) :: (Num a, Integral b) => a -> b -> a
332 x ^ n | n > 0 = f x (n-1) x
334 f x n y = g x n where
335 g x n | even n = g (x*x) (n`quot`2)
336 | otherwise = f x (n-1) (x*y)
337 _ ^ _ = error "Prelude.^: negative exponent"
339 (^^) :: (Fractional a, Integral b) => a -> b -> a
340 x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
342 fromIntegral :: (Integral a, Num b) => a -> b
343 fromIntegral = fromInteger . toInteger
345 realToFrac :: (Real a, Fractional b) => a -> b
346 realToFrac = fromRational . toRational
348 -- Index and Enumeration classes --------------------------------------------
350 class (Ord a) => Ix a where
351 range :: (a,a) -> [a]
352 index :: (a,a) -> a -> Int
353 inRange :: (a,a) -> a -> Bool
354 rangeSize :: (a,a) -> Int
358 | otherwise = index r u + 1
364 enumFrom :: a -> [a] -- [n..]
365 enumFromThen :: a -> a -> [a] -- [n,m..]
366 enumFromTo :: a -> a -> [a] -- [n..m]
367 enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
369 -- Minimal complete definition: toEnum, fromEnum
370 succ = toEnum . (1+) . fromEnum
371 pred = toEnum . subtract 1 . fromEnum
372 enumFrom x = map toEnum [ fromEnum x .. ]
373 enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
374 enumFromThen x y = map toEnum [ fromEnum x, fromEnum y .. ]
375 enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
377 -- Read and Show classes ------------------------------------------------------
379 type ReadS a = String -> [(a,String)]
380 type ShowS = String -> String
383 readsPrec :: Int -> ReadS a
384 readList :: ReadS [a]
386 -- Minimal complete definition: readsPrec
387 readList = readParen False (\r -> [pr | ("[",s) <- lex r,
389 where readl s = [([],t) | ("]",t) <- lex s] ++
390 [(x:xs,u) | (x,t) <- reads s,
392 readl' s = [([],t) | ("]",t) <- lex s] ++
393 [(x:xs,v) | (",",t) <- lex s,
399 showsPrec :: Int -> a -> ShowS
400 showList :: [a] -> ShowS
402 -- Minimal complete definition: show or showsPrec
403 show x = showsPrec 0 x ""
404 showsPrec _ x s = show x ++ s
405 showList [] = showString "[]"
406 showList (x:xs) = showChar '[' . shows x . showl xs
407 where showl [] = showChar ']'
408 showl (x:xs) = showChar ',' . shows x . showl xs
410 -- Monad classes ------------------------------------------------------------
412 class Functor f where
413 fmap :: (a -> b) -> (f a -> f b)
417 (>>=) :: m a -> (a -> m b) -> m b
418 (>>) :: m a -> m b -> m b
419 fail :: String -> m a
421 -- Minimal complete definition: (>>=), return
422 p >> q = p >>= \ _ -> q
425 sequence :: Monad m => [m a] -> m [a]
426 sequence [] = return []
427 sequence (c:cs) = do x <- c
431 sequence_ :: Monad m => [m a] -> m ()
432 sequence_ = foldr (>>) (return ())
434 mapM :: Monad m => (a -> m b) -> [a] -> m [b]
435 mapM f = sequence . map f
437 mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
438 mapM_ f = sequence_ . map f
440 (=<<) :: Monad m => (a -> m b) -> m a -> m b
443 -- Evaluation and strictness ------------------------------------------------
446 seq x y = primSeq x y
448 ($!) :: (a -> b) -> a -> b
449 f $! x = x `primSeq` f x
451 -- Trivial type -------------------------------------------------------------
453 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
458 instance Ord () where
464 inRange ((),()) () = True
466 instance Enum () where
470 enumFromThen () () = [()]
472 instance Read () where
473 readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
476 instance Show () where
477 showsPrec p () = showString "()"
479 instance Bounded () where
483 -- Boolean type -------------------------------------------------------------
485 data Bool = False | True
486 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
488 (&&), (||) :: Bool -> Bool -> Bool
501 -- Character type -----------------------------------------------------------
503 data Char -- builtin datatype of ISO Latin characters
504 type String = [Char] -- strings are lists of characters
506 instance Eq Char where (==) = primEqChar
507 instance Ord Char where (<=) = primLeChar
509 instance Enum Char where
510 toEnum = primIntToChar
511 fromEnum = primCharToInt
512 enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
513 enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
514 where lastChar = if d < c then minBound else maxBound
516 instance Ix Char where
517 range (c,c') = [c..c']
519 | inRange b ci = fromEnum ci - fromEnum c
520 | otherwise = error "Ix.index: Index out of range."
521 inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
522 where i = fromEnum ci
524 instance Read Char where
525 readsPrec p = readParen False
526 (\r -> [(c,t) | ('\'':s,t) <- lex r,
527 (c,"\'") <- readLitChar s ])
528 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
530 where readl ('"':s) = [("",s)]
531 readl ('\\':'&':s) = readl s
532 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
534 instance Show Char where
535 showsPrec p '\'' = showString "'\\''"
536 showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
538 showList cs = showChar '"' . showl cs
539 where showl "" = showChar '"'
540 showl ('"':cs) = showString "\\\"" . showl cs
541 showl (c:cs) = showLitChar c . showl cs
543 instance Bounded Char where
547 isAscii, isControl, isPrint, isSpace :: Char -> Bool
548 isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
550 isAscii c = fromEnum c < 128
551 isControl c = c < ' ' || c == '\DEL'
552 isPrint c = c >= ' ' && c <= '~'
553 isSpace c = c == ' ' || c == '\t' || c == '\n' ||
554 c == '\r' || c == '\f' || c == '\v'
555 isUpper c = c >= 'A' && c <= 'Z'
556 isLower c = c >= 'a' && c <= 'z'
557 isAlpha c = isUpper c || isLower c
558 isDigit c = c >= '0' && c <= '9'
559 isAlphaNum c = isAlpha c || isDigit c
561 -- Digit conversion operations
562 digitToInt :: Char -> Int
564 | isDigit c = fromEnum c - fromEnum '0'
565 | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
566 | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
567 | otherwise = error "Char.digitToInt: not a digit"
569 intToDigit :: Int -> Char
571 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
572 | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
573 | otherwise = error "Char.intToDigit: not a digit"
575 toUpper, toLower :: Char -> Char
576 toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
579 toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
588 -- Maybe type ---------------------------------------------------------------
590 data Maybe a = Nothing | Just a
591 deriving (Eq, Ord, Read, Show)
593 maybe :: b -> (a -> b) -> Maybe a -> b
594 maybe n f Nothing = n
595 maybe n f (Just x) = f x
597 instance Functor Maybe where
598 fmap f Nothing = Nothing
599 fmap f (Just x) = Just (f x)
601 instance Monad Maybe where
603 Nothing >>= k = Nothing
607 -- Either type --------------------------------------------------------------
609 data Either a b = Left a | Right b
610 deriving (Eq, Ord, Read, Show)
612 either :: (a -> c) -> (b -> c) -> Either a b -> c
613 either l r (Left x) = l x
614 either l r (Right y) = r y
616 -- Ordering type ------------------------------------------------------------
618 data Ordering = LT | EQ | GT
619 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
621 -- Lists --------------------------------------------------------------------
623 --data [a] = [] | a : [a] deriving (Eq, Ord)
625 instance Eq a => Eq [a] where
627 (x:xs) == (y:ys) = x==y && xs==ys
630 instance Ord a => Ord [a] where
631 compare [] (_:_) = LT
633 compare (_:_) [] = GT
634 compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys)
636 instance Functor [] where
639 instance Monad [ ] where
640 (x:xs) >>= f = f x ++ (xs >>= f)
645 instance Read a => Read [a] where
646 readsPrec p = readList
648 instance Show a => Show [a] where
649 showsPrec p = showList
651 -- Tuples -------------------------------------------------------------------
653 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
656 -- Standard Integral types --------------------------------------------------
658 data Int -- builtin datatype of fixed size integers
659 data Integer -- builtin datatype of arbitrary size integers
661 instance Eq Integer where
662 (==) x y = primCompareInteger x y == 0
664 instance Ord Integer where
665 compare x y = case primCompareInteger x y of
670 instance Eq Int where
674 instance Ord Int where
680 instance Num Int where
683 negate = primNegateInt
687 fromInteger = primIntegerToInt
690 instance Bounded Int where
691 minBound = primMinInt
692 maxBound = primMaxInt
694 instance Num Integer where
695 (+) = primPlusInteger
696 (-) = primMinusInteger
697 negate = primNegateInteger
698 (*) = primTimesInteger
702 fromInt = primIntToInteger
704 absReal x | x >= 0 = x
707 signumReal x | x == 0 = 0
711 instance Real Int where
712 toRational x = toInteger x % 1
714 instance Real Integer where
717 instance Integral Int where
718 quotRem = primQuotRemInt
719 toInteger = primIntToInteger
722 instance Integral Integer where
723 quotRem = primQuotRemInteger
724 --divMod = primDivModInteger
726 toInt = primIntegerToInt
728 instance Ix Int where
731 | inRange b i = i - m
732 | otherwise = error "index: Index out of range"
733 inRange (m,n) i = m <= i && i <= n
735 instance Ix Integer where
738 | inRange b i = fromInteger (i - m)
739 | otherwise = error "index: Index out of range"
740 inRange (m,n) i = m <= i && i <= n
742 instance Enum Int where
745 enumFrom = numericEnumFrom
746 enumFromTo = numericEnumFromTo
747 enumFromThen = numericEnumFromThen
748 enumFromThenTo = numericEnumFromThenTo
750 instance Enum Integer where
751 toEnum = primIntToInteger
752 fromEnum = primIntegerToInt
753 enumFrom = numericEnumFrom
754 enumFromTo = numericEnumFromTo
755 enumFromThen = numericEnumFromThen
756 enumFromThenTo = numericEnumFromThenTo
758 numericEnumFrom :: Real a => a -> [a]
759 numericEnumFromThen :: Real a => a -> a -> [a]
760 numericEnumFromTo :: Real a => a -> a -> [a]
761 numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
762 numericEnumFrom n = n : (numericEnumFrom $! (n+1))
763 numericEnumFromThen n m = iterate ((m-n)+) n
764 numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
765 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
766 where p | n' >= n = (<= m)
769 instance Read Int where
770 readsPrec p = readSigned readDec
772 instance Show Int where
774 | n == minBound = showSigned showInt p (toInteger n)
775 | otherwise = showSigned showInt p n
777 instance Read Integer where
778 readsPrec p = readSigned readDec
780 instance Show Integer where
781 showsPrec = showSigned showInt
784 -- Standard Floating types --------------------------------------------------
786 data Float -- builtin datatype of single precision floating point numbers
787 data Double -- builtin datatype of double precision floating point numbers
789 instance Eq Float where
793 instance Ord Float where
799 instance Num Float where
802 negate = primNegateFloat
806 fromInteger = primIntegerToFloat
807 fromInt = primIntToFloat
811 instance Eq Double where
815 instance Ord Double where
821 instance Num Double where
823 (-) = primMinusDouble
824 negate = primNegateDouble
825 (*) = primTimesDouble
828 fromInteger = primIntegerToDouble
829 fromInt = primIntToDouble
833 instance Real Float where
834 toRational = floatToRational
836 instance Real Double where
837 toRational = doubleToRational
839 -- Calls to these functions are optimised when passed as arguments to
841 floatToRational :: Float -> Rational
842 doubleToRational :: Double -> Rational
843 floatToRational x = realFloatToRational x
844 doubleToRational x = realFloatToRational x
846 realFloatToRational x = (m%1)*(b%1)^^n
847 where (m,n) = decodeFloat x
850 instance Fractional Float where
851 (/) = primDivideFloat
852 fromRational = rationalToRealFloat
854 instance Fractional Double where
855 (/) = primDivideDouble
856 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
1039 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1040 doubleToRatio :: Integral a => Double -> Ratio a
1042 | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
1043 | otherwise = fromInteger m % (fromInteger b ^ (-n))
1044 where (m,n) = decodeFloat x
1047 instance Integral a => RealFrac (Ratio a) where
1048 properFraction (x:%y) = (fromIntegral q, r:%y)
1049 where (q,r) = quotRem x y
1051 instance Integral a => Enum (Ratio a) where
1054 enumFrom = numericEnumFrom
1055 enumFromThen = numericEnumFromThen
1057 instance (Read a, Integral a) => Read (Ratio a) where
1058 readsPrec p = readParen (p > 7)
1059 (\r -> [(x%y,u) | (x,s) <- reads r,
1063 instance Integral a => Show (Ratio a) where
1064 showsPrec p (x:%y) = showParen (p > 7)
1065 (shows x . showString " % " . shows y)
1067 approxRational :: RealFrac a => a -> a -> Rational
1068 approxRational x eps = simplest (x-eps) (x+eps)
1069 where simplest x y | y < x = simplest y x
1071 | x > 0 = simplest' n d n' d'
1072 | y < 0 = - simplest' (-n') d' (-n) d
1073 | otherwise = 0 :% 1
1074 where xr@(n:%d) = toRational x
1075 (n':%d') = toRational y
1076 simplest' n d n' d' -- assumes 0 < n%d < n'%d'
1078 | q /= q' = (q+1) :% 1
1079 | otherwise = (q*n''+d'') :% n''
1080 where (q,r) = quotRem n d
1081 (q',r') = quotRem n' d'
1082 (n'':%d'') = simplest' d' r' d r
1084 -- Standard list functions {PreludeList} ------------------------------------
1091 last (_:xs) = last xs
1098 init (x:xs) = x : init xs
1104 (++) :: [a] -> [a] -> [a]
1106 (x:xs) ++ ys = x : (xs ++ ys)
1108 map :: (a -> b) -> [a] -> [b]
1109 --map f xs = [ f x | x <- xs ]
1111 map f (x:xs) = f x : map f xs
1114 filter :: (a -> Bool) -> [a] -> [a]
1115 --filter p xs = [ x | x <- xs, p x ]
1117 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1120 concat :: [[a]] -> [a]
1121 --concat = foldr (++) []
1123 concat (xs:xss) = xs ++ concat xss
1125 length :: [a] -> Int
1126 --length = foldl' (\n _ -> n + 1) 0
1128 length (x:xs) = let n = length xs in primSeq n (1+n)
1130 (!!) :: [b] -> Int -> b
1132 (_:xs) !! n | n>0 = xs !! (n-1)
1133 (_:_) !! _ = error "Prelude.!!: negative index"
1134 [] !! _ = error "Prelude.!!: index too large"
1136 foldl :: (a -> b -> a) -> a -> [b] -> a
1138 foldl f z (x:xs) = foldl f (f z x) xs
1140 foldl' :: (a -> b -> a) -> a -> [b] -> a
1142 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1144 foldl1 :: (a -> a -> a) -> [a] -> a
1145 foldl1 f (x:xs) = foldl f x xs
1147 scanl :: (a -> b -> a) -> a -> [b] -> [a]
1148 scanl f q xs = q : (case xs of
1150 x:xs -> scanl f (f q x) xs)
1152 scanl1 :: (a -> a -> a) -> [a] -> [a]
1153 scanl1 f (x:xs) = scanl f x xs
1155 foldr :: (a -> b -> b) -> b -> [a] -> b
1157 foldr f z (x:xs) = f x (foldr f z xs)
1159 foldr1 :: (a -> a -> a) -> [a] -> a
1161 foldr1 f (x:xs) = f x (foldr1 f xs)
1163 scanr :: (a -> b -> b) -> b -> [a] -> [b]
1164 scanr f q0 [] = [q0]
1165 scanr f q0 (x:xs) = f x q : qs
1166 where qs@(q:_) = scanr f q0 xs
1168 scanr1 :: (a -> a -> a) -> [a] -> [a]
1170 scanr1 f (x:xs) = f x q : qs
1171 where qs@(q:_) = scanr1 f xs
1173 iterate :: (a -> a) -> a -> [a]
1174 iterate f x = x : iterate f (f x)
1177 repeat x = xs where xs = x:xs
1179 replicate :: Int -> a -> [a]
1180 replicate n x = take n (repeat x)
1183 cycle [] = error "Prelude.cycle: empty list"
1184 cycle xs = xs' where xs'=xs++xs'
1186 take :: Int -> [a] -> [a]
1189 take n (x:xs) | n>0 = x : take (n-1) xs
1190 take _ _ = error "Prelude.take: negative argument"
1192 drop :: Int -> [a] -> [a]
1195 drop n (_:xs) | n>0 = drop (n-1) xs
1196 drop _ _ = error "Prelude.drop: negative argument"
1198 splitAt :: Int -> [a] -> ([a], [a])
1199 splitAt 0 xs = ([],xs)
1200 splitAt _ [] = ([],[])
1201 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1202 splitAt _ _ = error "Prelude.splitAt: negative argument"
1204 takeWhile :: (a -> Bool) -> [a] -> [a]
1207 | p x = x : takeWhile p xs
1210 dropWhile :: (a -> Bool) -> [a] -> [a]
1212 dropWhile p xs@(x:xs')
1213 | p x = dropWhile p xs'
1216 span, break :: (a -> Bool) -> [a] -> ([a],[a])
1220 | otherwise = ([],xs)
1221 where (ys,zs) = span p xs'
1222 break p = span (not . p)
1224 lines :: String -> [String]
1226 lines s = let (l,s') = break ('\n'==) s
1227 in l : case s' of [] -> []
1228 (_:s'') -> lines s''
1230 words :: String -> [String]
1231 words s = case dropWhile isSpace s of
1234 where (w,s'') = break isSpace s'
1236 unlines :: [String] -> String
1237 unlines = concatMap (\l -> l ++ "\n")
1239 unwords :: [String] -> String
1241 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1243 reverse :: [a] -> [a]
1244 --reverse = foldl (flip (:)) []
1245 reverse xs = ri [] xs
1246 where ri acc [] = acc
1247 ri acc (x:xs) = ri (x:acc) xs
1249 and, or :: [Bool] -> Bool
1250 --and = foldr (&&) True
1251 --or = foldr (||) False
1253 and (x:xs) = if x then and xs else x
1255 or (x:xs) = if x then x else or xs
1257 any, all :: (a -> Bool) -> [a] -> Bool
1258 --any p = or . map p
1259 --all p = and . map p
1261 any p (x:xs) = if p x then True else any p xs
1263 all p (x:xs) = if p x then all p xs else False
1265 elem, notElem :: Eq a => a -> [a] -> Bool
1267 --notElem = all . (/=)
1269 elem x (y:ys) = if x==y then True else elem x ys
1271 notElem x (y:ys) = if x==y then False else notElem x ys
1273 lookup :: Eq a => a -> [(a,b)] -> Maybe b
1274 lookup k [] = Nothing
1275 lookup k ((x,y):xys)
1277 | otherwise = lookup k xys
1279 sum, product :: Num a => [a] -> a
1281 product = foldl' (*) 1
1283 maximum, minimum :: Ord a => [a] -> a
1284 maximum = foldl1 max
1285 minimum = foldl1 min
1287 concatMap :: (a -> [b]) -> [a] -> [b]
1288 concatMap f = concat . map f
1290 zip :: [a] -> [b] -> [(a,b)]
1291 zip = zipWith (\a b -> (a,b))
1293 zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
1294 zip3 = zipWith3 (\a b c -> (a,b,c))
1296 zipWith :: (a->b->c) -> [a]->[b]->[c]
1297 zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
1300 zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1301 zipWith3 z (a:as) (b:bs) (c:cs)
1302 = z a b c : zipWith3 z as bs cs
1303 zipWith3 _ _ _ _ = []
1305 unzip :: [(a,b)] -> ([a],[b])
1306 unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1308 unzip3 :: [(a,b,c)] -> ([a],[b],[c])
1309 unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1312 -- PreludeText ----------------------------------------------------------------
1314 reads :: Read a => ReadS a
1317 shows :: Show a => a -> ShowS
1320 read :: Read a => String -> a
1321 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1323 [] -> error "Prelude.read: no parse"
1324 _ -> error "Prelude.read: ambiguous parse"
1326 showChar :: Char -> ShowS
1329 showString :: String -> ShowS
1332 showParen :: Bool -> ShowS -> ShowS
1333 showParen b p = if b then showChar '(' . p . showChar ')' else p
1335 hugsprimShowField :: Show a => String -> a -> ShowS
1336 hugsprimShowField m v = showString m . showChar '=' . shows v
1338 readParen :: Bool -> ReadS a -> ReadS a
1339 readParen b g = if b then mandatory else optional
1340 where optional r = g r ++ mandatory r
1341 mandatory r = [(x,u) | ("(",s) <- lex r,
1342 (x,t) <- optional s,
1346 hugsprimReadField :: Read a => String -> ReadS a
1347 hugsprimReadField m s0 = [ r | (t, s1) <- lex s0, t == m,
1353 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1354 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1356 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1358 lexString ('"':s) = [("\"",s)]
1359 lexString s = [(ch++str, u)
1360 | (ch,t) <- lexStrItem s,
1361 (str,u) <- lexString t ]
1363 lexStrItem ('\\':'&':s) = [("\\&",s)]
1364 lexStrItem ('\\':c:s) | isSpace c
1365 = [("",t) | '\\':t <- [dropWhile isSpace s]]
1366 lexStrItem s = lexLitChar s
1368 lex (c:s) | isSingle c = [([c],s)]
1369 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
1370 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
1371 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
1372 (fe,t) <- lexFracExp s ]
1373 | otherwise = [] -- bad character
1375 isSingle c = c `elem` ",;()[]{}_`"
1376 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1377 isIdChar c = isAlphaNum c || c `elem` "_'"
1379 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1381 lexFracExp s = [("",s)]
1383 lexExp (e:s) | e `elem` "eE"
1384 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
1385 (ds,u) <- lexDigits t] ++
1386 [(e:ds,t) | (ds,t) <- lexDigits s]
1389 lexDigits :: ReadS String
1390 lexDigits = nonnull isDigit
1392 nonnull :: (Char -> Bool) -> ReadS String
1393 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1395 lexLitChar :: ReadS String
1396 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1398 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- "
1399 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
1400 lexEsc s@(d:_) | isDigit d = lexDigits s
1401 lexEsc s@(c:_) | isUpper c
1402 = let table = ('\DEL',"DEL") : asciiTab
1403 in case [(mne,s') | (c, mne) <- table,
1404 ([],s') <- [lexmatch mne s]]
1408 lexLitChar (c:s) = [([c],s)]
1411 isOctDigit c = c >= '0' && c <= '7'
1412 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
1413 || c >= 'a' && c <= 'f'
1415 lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
1416 lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
1417 lexmatch xs ys = (xs,ys)
1419 asciiTab = zip ['\NUL'..' ']
1420 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1421 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
1422 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1423 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
1426 readLitChar :: ReadS Char
1427 readLitChar ('\\':s) = readEsc s
1429 readEsc ('a':s) = [('\a',s)]
1430 readEsc ('b':s) = [('\b',s)]
1431 readEsc ('f':s) = [('\f',s)]
1432 readEsc ('n':s) = [('\n',s)]
1433 readEsc ('r':s) = [('\r',s)]
1434 readEsc ('t':s) = [('\t',s)]
1435 readEsc ('v':s) = [('\v',s)]
1436 readEsc ('\\':s) = [('\\',s)]
1437 readEsc ('"':s) = [('"',s)]
1438 readEsc ('\'':s) = [('\'',s)]
1439 readEsc ('^':c:s) | c >= '@' && c <= '_'
1440 = [(toEnum (fromEnum c - fromEnum '@'), s)]
1441 readEsc s@(d:_) | isDigit d
1442 = [(toEnum n, t) | (n,t) <- readDec s]
1443 readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
1444 readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
1445 readEsc s@(c:_) | isUpper c
1446 = let table = ('\DEL',"DEL") : asciiTab
1447 in case [(c,s') | (c, mne) <- table,
1448 ([],s') <- [lexmatch mne s]]
1452 readLitChar (c:s) = [(c,s)]
1454 showLitChar :: Char -> ShowS
1455 showLitChar c | c > '\DEL' = showChar '\\' .
1456 protectEsc isDigit (shows (fromEnum c))
1457 showLitChar '\DEL' = showString "\\DEL"
1458 showLitChar '\\' = showString "\\\\"
1459 showLitChar c | c >= ' ' = showChar c
1460 showLitChar '\a' = showString "\\a"
1461 showLitChar '\b' = showString "\\b"
1462 showLitChar '\f' = showString "\\f"
1463 showLitChar '\n' = showString "\\n"
1464 showLitChar '\r' = showString "\\r"
1465 showLitChar '\t' = showString "\\t"
1466 showLitChar '\v' = showString "\\v"
1467 showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
1468 showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
1470 protectEsc p f = f . cont
1471 where cont s@(c:_) | p c = "\\&" ++ s
1474 -- Unsigned readers for various bases
1475 readDec, readOct, readHex :: Integral a => ReadS a
1476 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1477 readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1478 readHex = readInt 16 isHexDigit hex
1479 where hex d = fromEnum d -
1482 else fromEnum (if isUpper d then 'A' else 'a') - 10)
1484 -- readInt reads a string of digits using an arbitrary base.
1485 -- Leading minus signs must be handled elsewhere.
1487 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1488 readInt radix isDig digToInt s =
1489 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1490 | (ds,r) <- nonnull isDig s ]
1492 -- showInt is used for positive numbers only
1493 showInt :: Integral a => a -> ShowS
1496 = error "Numeric.showInt: can't show negative numbers"
1499 = let (n',d) = quotRem n 10
1500 r' = toEnum (fromEnum '0' + fromIntegral d) : r
1501 in if n' == 0 then r' else showInt n' r'
1503 = case quotRem n 10 of { (n',d) ->
1504 let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1505 in if n' == 0 then r' else showInt n' r'
1509 readSigned:: Real a => ReadS a -> ReadS a
1510 readSigned readPos = readParen False read'
1511 where read' r = read'' r ++
1512 [(-x,t) | ("-",s) <- lex r,
1514 read'' r = [(n,s) | (str,s) <- lex r,
1515 (n,"") <- readPos str]
1517 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1518 showSigned showPos p x = if x < 0 then showParen (p > 6)
1519 (showChar '-' . showPos (-x))
1522 readFloat :: RealFloat a => ReadS a
1523 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1525 where readFix r = [(read (ds++ds'), length ds', t)
1526 | (ds, s) <- lexDigits r
1527 , (ds',t) <- lexFrac s ]
1529 lexFrac ('.':s) = lexDigits s
1530 lexFrac s = [("",s)]
1532 readExp (e:s) | e `elem` "eE" = readExp' s
1535 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1536 readExp' ('+':s) = readDec s
1537 readExp' s = readDec s
1540 -- Hooks for primitives: -----------------------------------------------------
1541 -- Do not mess with these!
1543 hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering
1544 hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1546 hugsprimEqChar :: Char -> Char -> Bool
1547 hugsprimEqChar c1 c2 = primEqChar c1 c2
1549 hugsprimPmInt :: Num a => Int -> a -> Bool
1550 hugsprimPmInt n x = fromInt n == x
1552 hugsprimPmInteger :: Num a => Integer -> a -> Bool
1553 hugsprimPmInteger n x = fromInteger n == x
1555 hugsprimPmDouble :: Fractional a => Double -> a -> Bool
1556 hugsprimPmDouble n x = fromDouble n == x
1558 -- ToDo: make the message more informative.
1560 hugsprimPmFail = error "Pattern Match Failure"
1562 -- used in desugaring Foreign functions
1563 -- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
1564 -- bit of code of type RealWorld -> (a,RealWorld) into a proper IO value.
1565 -- What follows is the version for standalone mode. ghc/lib/std/PrelHugs.lhs
1566 -- contains a version used in combined mode. That version takes care of
1567 -- switching between the GHC and Hugs IO representations, which are different.
1568 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1571 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1572 hugsprimCreateAdjThunk fun typestr callconv
1573 = do sp <- makeStablePtr fun
1574 p <- copy_String_to_cstring typestr -- is never freed
1575 a <- primCreateAdjThunkARCH sp p callconv
1578 -- The following primitives are only needed if (n+k) patterns are enabled:
1579 hugsprimPmSub :: Integral a => Int -> a -> a
1580 hugsprimPmSub n x = x - fromInt n
1582 hugsprimPmFromInteger :: Integral a => Integer -> a
1583 hugsprimPmFromInteger = fromIntegral
1585 hugsprimPmSubtract :: Integral a => a -> a -> a
1586 hugsprimPmSubtract x y = x - y
1588 hugsprimPmLe :: Integral a => a -> a -> Bool
1589 hugsprimPmLe x y = x <= y
1591 -- Unpack strings generated by the Hugs code generator.
1592 -- Strings can contain \0 provided they're coded right.
1594 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1596 hugsprimUnpackString :: Addr -> String
1597 hugsprimUnpackString a = unpack 0
1599 -- The following decoding is based on evalString in the old machine.c
1602 | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1603 then '\\' : unpack (i+2)
1604 else '\0' : unpack (i+2)
1605 | otherwise = c : unpack (i+1)
1607 c = primIndexCharOffAddr a i
1610 -- Monadic I/O: --------------------------------------------------------------
1612 type FilePath = String
1614 --data IOError = ...
1615 --instance Eq IOError ...
1616 --instance Show IOError ...
1618 data IOError = IOError String
1619 instance Show IOError where
1620 showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1622 ioError :: IOError -> IO a
1623 ioError (IOError s) = primRaise (IOExcept s)
1625 userError :: String -> IOError
1626 userError s = primRaise (ErrorCall s)
1628 catch :: IO a -> (IOError -> IO a) -> IO a
1630 = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
1632 e2ioe (IOExcept s) = IOError s
1633 e2ioe other = IOError (show other)
1635 putChar :: Char -> IO ()
1636 putChar c = nh_stdout >>= \h -> nh_write h c
1638 putStr :: String -> IO ()
1639 putStr s = nh_stdout >>= \h ->
1640 let loop [] = nh_flush h
1641 loop (c:cs) = nh_write h c >> loop cs
1644 putStrLn :: String -> IO ()
1645 putStrLn s = do { putStr s; putChar '\n' }
1647 print :: Show a => a -> IO ()
1648 print = putStrLn . show
1651 getChar = unsafeInterleaveIO (
1653 nh_read h >>= \ci ->
1654 return (primIntToChar ci)
1657 getLine :: IO String
1658 getLine = do c <- getChar
1659 if c=='\n' then return ""
1660 else do cs <- getLine
1663 getContents :: IO String
1664 getContents = nh_stdin >>= \h -> readfromhandle h
1666 interact :: (String -> String) -> IO ()
1667 interact f = getContents >>= (putStr . f)
1669 readFile :: FilePath -> IO String
1671 = copy_String_to_cstring fname >>= \ptr ->
1672 nh_open ptr 0 >>= \h ->
1674 nh_errno >>= \errno ->
1675 if (isNullAddr h || errno /= 0)
1676 then (ioError.IOError) ("readFile: can't open file " ++ fname)
1677 else readfromhandle h
1679 writeFile :: FilePath -> String -> IO ()
1680 writeFile fname contents
1681 = copy_String_to_cstring fname >>= \ptr ->
1682 nh_open ptr 1 >>= \h ->
1684 nh_errno >>= \errno ->
1685 if (isNullAddr h || errno /= 0)
1686 then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1687 else writetohandle fname h contents
1689 appendFile :: FilePath -> String -> IO ()
1690 appendFile fname contents
1691 = copy_String_to_cstring fname >>= \ptr ->
1692 nh_open ptr 2 >>= \h ->
1694 nh_errno >>= \errno ->
1695 if (isNullAddr h || errno /= 0)
1696 then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1697 else writetohandle fname h contents
1700 -- raises an exception instead of an error
1701 readIO :: Read a => String -> IO a
1702 readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1704 [] -> ioError (userError "PreludeIO.readIO: no parse")
1705 _ -> ioError (userError
1706 "PreludeIO.readIO: ambiguous parse")
1708 readLn :: Read a => IO a
1709 readLn = do l <- getLine
1714 -- End of Hugs standard prelude ----------------------------------------------
1720 instance Show Exception where
1721 showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1722 showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
1724 data IOResult = IOResult deriving (Show)
1726 type FILE_STAR = Addr -- FILE *
1728 foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR
1729 foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
1730 foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
1731 foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Char -> IO ()
1732 foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int
1733 foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR
1734 foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO ()
1735 foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO ()
1736 foreign import "nHandle" "nh_errno" nh_errno :: IO Int
1738 foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
1739 foreign import "nHandle" "nh_free" nh_free :: Addr -> IO ()
1740 foreign import "nHandle" "nh_store" nh_store :: Addr -> Char -> IO ()
1741 foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Char
1742 foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
1743 foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int
1744 foreign import "nHandle" "nh_iseof" nh_iseof :: FILE_STAR -> IO Int
1745 foreign import "nHandle" "nh_system" nh_system :: Addr -> IO Int
1746 foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO ()
1747 foreign import "nHandle" "nh_getPID" nh_getPID :: IO Int
1749 foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double
1750 foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double
1752 copy_String_to_cstring :: String -> IO Addr
1753 copy_String_to_cstring s
1754 = nh_malloc (1 + length s) >>= \ptr0 ->
1755 let loop ptr [] = nh_store ptr (chr 0) >> return ptr0
1756 loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs
1759 then error "copy_String_to_cstring: malloc failed"
1762 copy_cstring_to_String :: Addr -> IO String
1763 copy_cstring_to_String ptr
1764 = nh_load ptr >>= \ci ->
1767 else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1770 readfromhandle :: FILE_STAR -> IO String
1772 = unsafeInterleaveIO (
1773 nh_read h >>= \ci ->
1774 if ci == -1 {-EOF-} then return "" else
1775 readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1778 writetohandle :: String -> FILE_STAR -> String -> IO ()
1779 writetohandle fname h []
1781 nh_errno >>= \errno ->
1784 else error ( "writeFile/appendFile: error closing file " ++ fname)
1785 writetohandle fname h (c:cs)
1786 = nh_write h c >> writetohandle fname h cs
1788 primGetRawArgs :: IO [String]
1790 = primGetArgc >>= \argc ->
1791 sequence (map get_one_arg [0 .. argc-1])
1793 get_one_arg :: Int -> IO String
1795 = primGetArgv argno >>= \a ->
1796 copy_cstring_to_String a
1798 primGetEnv :: String -> IO String
1800 = copy_String_to_cstring v >>= \ptr ->
1801 nh_getenv ptr >>= \ptr2 ->
1806 copy_cstring_to_String ptr2 >>= \result ->
1810 ------------------------------------------------------------------------------
1811 -- ST, IO --------------------------------------------------------------------
1812 ------------------------------------------------------------------------------
1814 newtype ST s a = ST (s -> (a,s))
1817 type IO a = ST RealWorld a
1819 --primRunST :: (forall s. ST s a) -> a
1820 primRunST :: ST RealWorld a -> a
1821 primRunST m = fst (unST m theWorld)
1823 theWorld :: RealWorld
1824 theWorld = error "primRunST: entered the RealWorld"
1828 instance Functor (ST s) where
1829 fmap f x = x >>= (return . f)
1831 instance Monad (ST s) where
1832 m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1833 return x = ST (\s -> (x,s))
1834 m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1837 -- Library IO has a global variable which accumulates Handles
1838 -- as they are opened. We keep here a second global variable
1839 -- into which a cleanup action may be specified. When evaluation
1840 -- finishes, either normally or as a result of System.exitWith,
1841 -- this cleanup action is run, closing all known-about Handles.
1842 -- Doing it like this means the Prelude does not have to know
1843 -- anything about the grotty details of the Handle implementation.
1844 prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
1845 prelCleanupAfterRunAction = primRunST (newIORef Nothing)
1847 -- used when Hugs invokes top level function
1848 hugsprimRunIO_toplevel :: IO a -> ()
1849 hugsprimRunIO_toplevel m
1850 = protect 5 (fst (unST composite_action realWorld))
1853 = do writeIORef prelCleanupAfterRunAction Nothing
1855 cleanup_handles <- readIORef prelCleanupAfterRunAction
1856 case cleanup_handles of
1857 Nothing -> return ()
1860 realWorld = error "primRunIO: entered the RealWorld"
1861 protect :: Int -> () -> ()
1865 = primCatch (protect (n-1) comp)
1866 (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1868 trace, trace_quiet :: String -> a -> a
1870 = trace_quiet ("trace: " ++ s) x
1872 = (primRunST (putStr (s ++ "\n"))) `seq` x
1874 unsafeInterleaveST :: ST s a -> ST s a
1875 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1877 unsafeInterleaveIO :: IO a -> IO a
1878 unsafeInterleaveIO = unsafeInterleaveST
1881 ------------------------------------------------------------------------------
1882 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
1883 ------------------------------------------------------------------------------
1887 nullAddr = primIntToAddr 0
1888 incAddr a = primIntToAddr (1 + primAddrToInt a)
1889 isNullAddr a = 0 == primAddrToInt a
1891 instance Eq Addr where
1895 instance Ord Addr where
1903 instance Eq Word where
1907 instance Ord Word where
1915 makeStablePtr :: a -> IO (StablePtr a)
1916 makeStablePtr = primMakeStablePtr
1917 deRefStablePtr :: StablePtr a -> IO a
1918 deRefStablePtr = primDeRefStablePtr
1919 freeStablePtr :: StablePtr a -> IO ()
1920 freeStablePtr = primFreeStablePtr
1923 data PrimArray a -- immutable arrays with Int indices
1926 data STRef s a -- mutable variables
1927 data PrimMutableArray s a -- mutable arrays with Int indices
1928 data PrimMutableByteArray s
1930 newSTRef :: a -> ST s (STRef s a)
1931 newSTRef = primNewRef
1932 readSTRef :: STRef s a -> ST s a
1933 readSTRef = primReadRef
1934 writeSTRef :: STRef s a -> a -> ST s ()
1935 writeSTRef = primWriteRef
1937 type IORef a = STRef RealWorld a
1938 newIORef :: a -> IO (IORef a)
1939 newIORef = primNewRef
1940 readIORef :: IORef a -> IO a
1941 readIORef = primReadRef
1942 writeIORef :: IORef a -> a -> IO ()
1943 writeIORef = primWriteRef
1946 ------------------------------------------------------------------------------
1947 -- ThreadId, MVar, concurrency stuff -----------------------------------------
1948 ------------------------------------------------------------------------------
1952 newEmptyMVar :: IO (MVar a)
1953 newEmptyMVar = primNewEmptyMVar
1955 putMVar :: MVar a -> a -> IO ()
1956 putMVar = primPutMVar
1958 takeMVar :: MVar a -> IO a
1960 = ST (\world -> primTakeMVar m cont world)
1962 -- cont :: a -> RealWorld -> (a,RealWorld)
1963 -- where 'a' is as in the top-level signature
1964 cont x world = (x,world)
1966 -- the type of the handwritten BCO (threesome) primTakeMVar is
1967 -- primTakeMVar :: MVar a
1968 -- -> (a -> RealWorld -> (a,RealWorld))
1972 -- primTakeMVar behaves like this:
1974 -- primTakeMVar (MVar# m#) cont world
1975 -- = primTakeMVar_wrk m# cont world
1977 -- primTakeMVar_wrk m# cont world
1978 -- = cont (takeMVar# m#) world
1980 -- primTakeMVar_wrk has the special property that it is
1981 -- restartable by the scheduler, should the MVar be empty.
1983 newMVar :: a -> IO (MVar a)
1985 newEmptyMVar >>= \ mvar ->
1986 putMVar mvar value >>
1989 readMVar :: MVar a -> IO a
1991 takeMVar mvar >>= \ value ->
1992 putMVar mvar value >>
1995 swapMVar :: MVar a -> a -> IO a
1997 takeMVar mvar >>= \ old ->
2001 instance Eq (MVar a) where
2002 m1 == m2 = primSameMVar m1 m2
2007 instance Eq ThreadId where
2008 tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
2010 instance Ord ThreadId where
2012 = let r = primCmpThreadIds tid1 tid2
2013 in if r < 0 then LT else if r > 0 then GT else EQ
2016 forkIO :: IO a -> IO ThreadId
2017 -- Simple version; doesn't catch exceptions in computation
2018 -- forkIO computation
2019 -- = primForkIO (primRunST computation)
2024 (unST computation realWorld `primSeq` ())
2025 (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
2028 realWorld = error "primForkIO: entered the RealWorld"
2031 -- showFloat ------------------------------------------------------------------
2033 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2034 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2035 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2036 showFloat :: (RealFloat a) => a -> ShowS
2038 showEFloat d x = showString (formatRealFloat FFExponent d x)
2039 showFFloat d x = showString (formatRealFloat FFFixed d x)
2040 showGFloat d x = showString (formatRealFloat FFGeneric d x)
2041 showFloat = showGFloat Nothing
2043 -- These are the format types. This type is not exported.
2045 data FFFormat = FFExponent | FFFixed | FFGeneric
2047 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2048 formatRealFloat fmt decs x = s
2052 else if isInfinite x then
2053 if x < 0 then "-Infinity" else "Infinity"
2054 else if x < 0 || isNegativeZero x then
2055 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2057 doFmt fmt (floatToDigits (toInteger base) x)
2059 let ds = map intToDigit is
2062 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2069 [d] -> d : ".0e" ++ show (e-1)
2070 d:ds -> d : '.' : ds ++ 'e':show (e-1)
2072 let dec' = max dec 1 in
2074 [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2076 let (ei, is') = roundTo base (dec'+1) is
2077 d:ds = map intToDigit
2078 (if ei > 0 then init is' else is')
2079 in d:'.':ds ++ "e" ++ show (e-1+ei)
2083 let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2084 f n s "" = f (n-1) (s++"0") ""
2085 f n s (d:ds) = f (n-1) (s++[d]) ds
2090 let dec' = max dec 0 in
2092 let (ei, is') = roundTo base (dec' + e) is
2093 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2094 in (if null ls then "0" else ls) ++
2095 (if null rs then "" else '.' : rs)
2097 let (ei, is') = roundTo base dec'
2098 (replicate (-e) 0 ++ is)
2099 d : ds = map intToDigit
2100 (if ei > 0 then is' else 0:is')
2103 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2104 roundTo base d is = case f d is of
2106 (1, is) -> (1, 1 : is)
2107 where b2 = base `div` 2
2108 f n [] = (0, replicate n 0)
2109 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2111 let (c, ds) = f (d-1) is
2113 in if i' == base then (1, 0:ds) else (0, i':ds)
2115 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2116 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2117 -- This version uses a much slower logarithm estimator. It should be improved.
2119 -- This function returns a list of digits (Ints in [0..base-1]) and an
2122 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2124 floatToDigits _ 0 = ([0], 0)
2125 floatToDigits base x =
2126 let (f0, e0) = decodeFloat x
2127 (minExp0, _) = floatRange x
2130 minExp = minExp0 - p -- the real minimum exponent
2131 -- Haskell requires that f be adjusted so denormalized numbers
2132 -- will have an impossibly low exponent. Adjust for this.
2133 (f, e) = let n = minExp - e0
2134 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2139 if f == b^(p-1) then
2140 (f*be*b*2, 2*b, be*b, b)
2144 if e > minExp && f == b^(p-1) then
2145 (f*b*2, b^(-e+1)*2, b, 1)
2147 (f*2, b^(-e)*2, 1, 1)
2150 if b == 2 && base == 10 then
2151 -- logBase 10 2 is slightly bigger than 3/10 so
2152 -- the following will err on the low side. Ignoring
2153 -- the fraction will make it err even more.
2154 -- Haskell promises that p-1 <= logBase b f < p.
2155 (p - 1 + e0) * 3 `div` 10
2157 ceiling ((log (fromInteger (f+1)) +
2158 fromInt e * log (fromInteger b)) /
2159 log (fromInteger base))
2162 if r + mUp <= expt base n * s then n else fixup (n+1)
2164 if expt base (-n) * (r + mUp) <= s then n
2168 gen ds rn sN mUpN mDnN =
2169 let (dn, rn') = (rn * base) `divMod` sN
2172 in case (rn' < mDnN', rn' + mUpN' > sN) of
2173 (True, False) -> dn : ds
2174 (False, True) -> dn+1 : ds
2175 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2176 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2179 gen [] r (s * expt base k) mUp mDn
2181 let bk = expt base (-k)
2182 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
2183 in (map toInt (reverse rds), k)
2186 -- Exponentiation with a cache for the most common numbers.
2189 expt :: Integer -> Int -> Integer
2191 if base == 2 && n >= minExpt && n <= maxExpt then
2192 expts !! (n-minExpt)
2197 expts = [2^n | n <- [minExpt .. maxExpt]]