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
111 , STRef, newSTRef, readSTRef, writeSTRef
112 , IORef, newIORef, readIORef, writeIORef
113 , PrimMutableArray, PrimMutableByteArray
116 -- This lot really shouldn't be exported, but are needed to
117 -- implement various libs.
118 , runST , fixST, unsafeInterleaveST
121 , primReallyUnsafePtrEquality
122 ,hugsprimCompAux,PrimArray,primRunST,primNewArray,primWriteArray
123 ,primReadArray, primIndexArray, primSizeMutableArray
125 ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv
126 ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open
127 ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar
128 ,unsafeInterleaveIO,nh_write,primCharToInt,
129 nullAddr, incAddr, isNullAddr,
130 nh_filesize, nh_iseof, nh_system, nh_exitwith, nh_getPID,
131 nh_getCPUtime, nh_getCPUprec, prelCleanupAfterRunAction,
134 primGtWord, primGeWord, primEqWord, primNeWord,
135 primLtWord, primLeWord, primMinWord, primMaxWord,
136 primPlusWord, primMinusWord, primTimesWord, primQuotWord,
137 primRemWord, primQuotRemWord, primNegateWord, primAndWord,
138 primOrWord, primXorWord, primNotWord, primShiftLWord,
139 primShiftRAWord, primShiftRLWord, primIntToWord, primWordToInt,
141 primAndInt, primOrInt, primXorInt, primNotInt,
142 primShiftLInt, primShiftRAInt, primShiftRLInt,
144 primAddrToInt, primIntToAddr,
146 primDoubleToFloat, primFloatToDouble,
150 -- Standard value bindings {Prelude} ----------------------------------------
155 infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
157 --infixr 5 : -- this fixity declaration is hard-wired into Hugs
159 infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
164 infixr 0 $, $!, `seq`
166 -- Equality and Ordered classes ---------------------------------------------
169 (==), (/=) :: a -> a -> Bool
171 -- Minimal complete definition: (==) or (/=)
175 class (Eq a) => Ord a where
176 compare :: a -> a -> Ordering
177 (<), (<=), (>=), (>) :: a -> a -> Bool
178 max, min :: a -> a -> a
180 -- Minimal complete definition: (<=) or compare
181 -- using compare can be more efficient for complex types
182 compare x y | x==y = EQ
186 x <= y = compare x y /= GT
187 x < y = compare x y == LT
188 x >= y = compare x y /= LT
189 x > y = compare x y == GT
196 class Bounded a where
197 minBound, maxBound :: a
198 -- Minimal complete definition: All
200 -- Numeric classes ----------------------------------------------------------
202 class (Eq a, Show a) => Num a where
203 (+), (-), (*) :: a -> a -> a
205 abs, signum :: a -> a
206 fromInteger :: Integer -> a
209 -- Minimal complete definition: All, except negate or (-)
211 fromInt = fromIntegral
214 class (Num a, Ord a) => Real a where
215 toRational :: a -> Rational
217 class (Real a, Enum a) => Integral a where
218 quot, rem, div, mod :: a -> a -> a
219 quotRem, divMod :: a -> a -> (a,a)
220 even, odd :: a -> Bool
221 toInteger :: a -> Integer
224 -- Minimal complete definition: quotRem and toInteger
225 n `quot` d = q where (q,r) = quotRem n d
226 n `rem` d = r where (q,r) = quotRem n d
227 n `div` d = q where (q,r) = divMod n d
228 n `mod` d = r where (q,r) = divMod n d
229 divMod n d = if signum r == - signum d then (q-1, r+d) else qr
230 where qr@(q,r) = quotRem n d
231 even n = n `rem` 2 == 0
233 toInt = toInt . toInteger
235 class (Num a) => Fractional a where
238 fromRational :: Rational -> a
240 -- Minimal complete definition: fromRational and ((/) or recip)
244 fromDouble :: Fractional a => Double -> a
245 fromDouble n = fromRational (toRational n)
247 class (Fractional a) => Floating a where
249 exp, log, sqrt :: a -> a
250 (**), logBase :: a -> a -> a
251 sin, cos, tan :: a -> a
252 asin, acos, atan :: a -> a
253 sinh, cosh, tanh :: a -> a
254 asinh, acosh, atanh :: a -> a
256 -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
257 -- asinh, acosh, atanh
258 x ** y = exp (log x * y)
259 logBase x y = log y / log x
261 tan x = sin x / cos x
262 sinh x = (exp x - exp (-x)) / 2
263 cosh x = (exp x + exp (-x)) / 2
264 tanh x = sinh x / cosh x
265 asinh x = log (x + sqrt (x*x + 1))
266 acosh x = log (x + sqrt (x*x - 1))
267 atanh x = (log (1 + x) - log (1 - x)) / 2
269 class (Real a, Fractional a) => RealFrac a where
270 properFraction :: (Integral b) => a -> (b,a)
271 truncate, round :: (Integral b) => a -> b
272 ceiling, floor :: (Integral b) => a -> b
274 -- Minimal complete definition: properFraction
275 truncate x = m where (m,_) = properFraction x
277 round x = let (n,r) = properFraction x
278 m = if r < 0 then n - 1 else n + 1
279 in case signum (abs r - 0.5) of
281 0 -> if even n then n else m
284 ceiling x = if r > 0 then n + 1 else n
285 where (n,r) = properFraction x
287 floor x = if r < 0 then n - 1 else n
288 where (n,r) = properFraction x
290 class (RealFrac a, Floating a) => RealFloat a where
291 floatRadix :: a -> Integer
292 floatDigits :: a -> Int
293 floatRange :: a -> (Int,Int)
294 decodeFloat :: a -> (Integer,Int)
295 encodeFloat :: Integer -> Int -> a
297 significand :: a -> a
298 scaleFloat :: Int -> a -> a
299 isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
303 -- Minimal complete definition: All, except exponent, signficand,
305 exponent x = if m==0 then 0 else n + floatDigits x
306 where (m,n) = decodeFloat x
307 significand x = encodeFloat m (- floatDigits x)
308 where (m,_) = decodeFloat x
309 scaleFloat k x = encodeFloat m (n+k)
310 where (m,n) = decodeFloat x
314 | x<0 && y>0 = pi + atan (y/x)
316 (x<0 && isNegativeZero y) ||
317 (isNegativeZero x && isNegativeZero y)
319 | y==0 && (x<0 || isNegativeZero x)
320 = pi -- must be after the previous test on zero y
321 | x==0 && y==0 = y -- must be after the other double zero tests
322 | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
324 -- Numeric functions --------------------------------------------------------
326 subtract :: Num a => a -> a -> a
329 gcd :: Integral a => a -> a -> a
330 gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
331 gcd x y = gcd' (abs x) (abs y)
333 gcd' x y = gcd' y (x `rem` y)
335 lcm :: (Integral a) => a -> a -> a
338 lcm x y = abs ((x `quot` gcd x y) * y)
340 (^) :: (Num a, Integral b) => a -> b -> a
342 x ^ n | n > 0 = f x (n-1) x
344 f x n y = g x n where
345 g x n | even n = g (x*x) (n`quot`2)
346 | otherwise = f x (n-1) (x*y)
347 _ ^ _ = error "Prelude.^: negative exponent"
349 (^^) :: (Fractional a, Integral b) => a -> b -> a
350 x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
352 fromIntegral :: (Integral a, Num b) => a -> b
353 fromIntegral = fromInteger . toInteger
355 realToFrac :: (Real a, Fractional b) => a -> b
356 realToFrac = fromRational . toRational
358 -- Index and Enumeration classes --------------------------------------------
360 class (Ord a) => Ix a where
361 range :: (a,a) -> [a]
362 index :: (a,a) -> a -> Int
363 inRange :: (a,a) -> a -> Bool
364 rangeSize :: (a,a) -> Int
368 | otherwise = index r u + 1
374 enumFrom :: a -> [a] -- [n..]
375 enumFromThen :: a -> a -> [a] -- [n,m..]
376 enumFromTo :: a -> a -> [a] -- [n..m]
377 enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
379 -- Minimal complete definition: toEnum, fromEnum
380 succ = toEnum . (1+) . fromEnum
381 pred = toEnum . subtract 1 . fromEnum
382 enumFrom x = map toEnum [ fromEnum x .. ]
383 enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
384 enumFromThen x y = map toEnum [ fromEnum x, fromEnum y .. ]
385 enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
387 -- Read and Show classes ------------------------------------------------------
389 type ReadS a = String -> [(a,String)]
390 type ShowS = String -> String
393 readsPrec :: Int -> ReadS a
394 readList :: ReadS [a]
396 -- Minimal complete definition: readsPrec
397 readList = readParen False (\r -> [pr | ("[",s) <- lex r,
399 where readl s = [([],t) | ("]",t) <- lex s] ++
400 [(x:xs,u) | (x,t) <- reads s,
402 readl' s = [([],t) | ("]",t) <- lex s] ++
403 [(x:xs,v) | (",",t) <- lex s,
409 showsPrec :: Int -> a -> ShowS
410 showList :: [a] -> ShowS
412 -- Minimal complete definition: show or showsPrec
413 show x = showsPrec 0 x ""
414 showsPrec _ x s = show x ++ s
415 showList [] = showString "[]"
416 showList (x:xs) = showChar '[' . shows x . showl xs
417 where showl [] = showChar ']'
418 showl (x:xs) = showChar ',' . shows x . showl xs
420 -- Monad classes ------------------------------------------------------------
422 class Functor f where
423 fmap :: (a -> b) -> (f a -> f b)
427 (>>=) :: m a -> (a -> m b) -> m b
428 (>>) :: m a -> m b -> m b
429 fail :: String -> m a
431 -- Minimal complete definition: (>>=), return
432 p >> q = p >>= \ _ -> q
435 sequence :: Monad m => [m a] -> m [a]
436 sequence [] = return []
437 sequence (c:cs) = do x <- c
441 sequence_ :: Monad m => [m a] -> m ()
442 sequence_ = foldr (>>) (return ())
444 mapM :: Monad m => (a -> m b) -> [a] -> m [b]
445 mapM f = sequence . map f
447 mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
448 mapM_ f = sequence_ . map f
450 (=<<) :: Monad m => (a -> m b) -> m a -> m b
453 -- Evaluation and strictness ------------------------------------------------
456 seq x y = primSeq x y
458 ($!) :: (a -> b) -> a -> b
459 f $! x = x `primSeq` f x
461 -- Trivial type -------------------------------------------------------------
463 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
468 instance Ord () where
474 inRange ((),()) () = True
476 instance Enum () where
480 enumFromThen () () = [()]
482 instance Read () where
483 readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
486 instance Show () where
487 showsPrec p () = showString "()"
489 instance Bounded () where
493 -- Boolean type -------------------------------------------------------------
495 data Bool = False | True
496 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
498 (&&), (||) :: Bool -> Bool -> Bool
511 -- Character type -----------------------------------------------------------
513 data Char -- builtin datatype of ISO Latin characters
514 type String = [Char] -- strings are lists of characters
516 instance Eq Char where (==) = primEqChar
517 instance Ord Char where (<=) = primLeChar
519 instance Enum Char where
520 toEnum = primIntToChar
521 fromEnum = primCharToInt
522 enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
523 enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
524 where lastChar = if d < c then minBound else maxBound
526 instance Ix Char where
527 range (c,c') = [c..c']
529 | inRange b ci = fromEnum ci - fromEnum c
530 | otherwise = error "Ix.index: Index out of range."
531 inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
532 where i = fromEnum ci
534 instance Read Char where
535 readsPrec p = readParen False
536 (\r -> [(c,t) | ('\'':s,t) <- lex r,
537 (c,"\'") <- readLitChar s ])
538 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
540 where readl ('"':s) = [("",s)]
541 readl ('\\':'&':s) = readl s
542 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
544 instance Show Char where
545 showsPrec p '\'' = showString "'\\''"
546 showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
548 showList cs = showChar '"' . showl cs
549 where showl "" = showChar '"'
550 showl ('"':cs) = showString "\\\"" . showl cs
551 showl (c:cs) = showLitChar c . showl cs
553 instance Bounded Char where
557 isAscii, isControl, isPrint, isSpace :: Char -> Bool
558 isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
560 isAscii c = fromEnum c < 128
561 isControl c = c < ' ' || c == '\DEL'
562 isPrint c = c >= ' ' && c <= '~'
563 isSpace c = c == ' ' || c == '\t' || c == '\n' ||
564 c == '\r' || c == '\f' || c == '\v'
565 isUpper c = c >= 'A' && c <= 'Z'
566 isLower c = c >= 'a' && c <= 'z'
567 isAlpha c = isUpper c || isLower c
568 isDigit c = c >= '0' && c <= '9'
569 isAlphaNum c = isAlpha c || isDigit c
571 -- Digit conversion operations
572 digitToInt :: Char -> Int
574 | isDigit c = fromEnum c - fromEnum '0'
575 | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
576 | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
577 | otherwise = error "Char.digitToInt: not a digit"
579 intToDigit :: Int -> Char
581 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
582 | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
583 | otherwise = error "Char.intToDigit: not a digit"
585 toUpper, toLower :: Char -> Char
586 toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
589 toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
598 -- Maybe type ---------------------------------------------------------------
600 data Maybe a = Nothing | Just a
601 deriving (Eq, Ord, Read, Show)
603 maybe :: b -> (a -> b) -> Maybe a -> b
604 maybe n f Nothing = n
605 maybe n f (Just x) = f x
607 instance Functor Maybe where
608 fmap f Nothing = Nothing
609 fmap f (Just x) = Just (f x)
611 instance Monad Maybe where
613 Nothing >>= k = Nothing
617 -- Either type --------------------------------------------------------------
619 data Either a b = Left a | Right b
620 deriving (Eq, Ord, Read, Show)
622 either :: (a -> c) -> (b -> c) -> Either a b -> c
623 either l r (Left x) = l x
624 either l r (Right y) = r y
626 -- Ordering type ------------------------------------------------------------
628 data Ordering = LT | EQ | GT
629 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
631 -- Lists --------------------------------------------------------------------
633 --data [a] = [] | a : [a] deriving (Eq, Ord)
635 instance Eq a => Eq [a] where
637 (x:xs) == (y:ys) = x==y && xs==ys
640 instance Ord a => Ord [a] where
641 compare [] (_:_) = LT
643 compare (_:_) [] = GT
644 compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys)
646 instance Functor [] where
649 instance Monad [ ] where
650 (x:xs) >>= f = f x ++ (xs >>= f)
655 instance Read a => Read [a] where
656 readsPrec p = readList
658 instance Show a => Show [a] where
659 showsPrec p = showList
661 -- Tuples -------------------------------------------------------------------
663 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
666 -- Standard Integral types --------------------------------------------------
668 data Int -- builtin datatype of fixed size integers
669 data Integer -- builtin datatype of arbitrary size integers
671 instance Eq Integer where
672 (==) x y = primCompareInteger x y == 0
674 instance Ord Integer where
675 compare x y = case primCompareInteger x y of
680 instance Eq Int where
684 instance Ord Int where
690 instance Num Int where
693 negate = primNegateInt
697 fromInteger = primIntegerToInt
700 instance Bounded Int where
701 minBound = primMinInt
702 maxBound = primMaxInt
704 instance Num Integer where
705 (+) = primPlusInteger
706 (-) = primMinusInteger
707 negate = primNegateInteger
708 (*) = primTimesInteger
712 fromInt = primIntToInteger
714 absReal x | x >= 0 = x
717 signumReal x | x == 0 = 0
721 instance Real Int where
722 toRational x = toInteger x % 1
724 instance Real Integer where
727 instance Integral Int where
728 quotRem = primQuotRemInt
729 toInteger = primIntToInteger
732 instance Integral Integer where
733 quotRem = primQuotRemInteger
734 --divMod = primDivModInteger
736 toInt = primIntegerToInt
738 instance Ix Int where
741 | inRange b i = i - m
742 | otherwise = error "index: Index out of range"
743 inRange (m,n) i = m <= i && i <= n
745 instance Ix Integer where
748 | inRange b i = fromInteger (i - m)
749 | otherwise = error "index: Index out of range"
750 inRange (m,n) i = m <= i && i <= n
752 instance Enum Int where
755 enumFrom = numericEnumFrom
756 enumFromTo = numericEnumFromTo
757 enumFromThen = numericEnumFromThen
758 enumFromThenTo = numericEnumFromThenTo
760 instance Enum Integer where
761 toEnum = primIntToInteger
762 fromEnum = primIntegerToInt
763 enumFrom = numericEnumFrom
764 enumFromTo = numericEnumFromTo
765 enumFromThen = numericEnumFromThen
766 enumFromThenTo = numericEnumFromThenTo
768 numericEnumFrom :: Real a => a -> [a]
769 numericEnumFromThen :: Real a => a -> a -> [a]
770 numericEnumFromTo :: Real a => a -> a -> [a]
771 numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
772 numericEnumFrom n = n : (numericEnumFrom $! (n+1))
773 numericEnumFromThen n m = iterate ((m-n)+) n
774 numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
775 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
776 where p | n' >= n = (<= m)
779 instance Read Int where
780 readsPrec p = readSigned readDec
782 instance Show Int where
784 | n == minBound = showSigned showInt p (toInteger n)
785 | otherwise = showSigned showInt p n
787 instance Read Integer where
788 readsPrec p = readSigned readDec
790 instance Show Integer where
791 showsPrec = showSigned showInt
794 -- Standard Floating types --------------------------------------------------
796 data Float -- builtin datatype of single precision floating point numbers
797 data Double -- builtin datatype of double precision floating point numbers
799 instance Eq Float where
803 instance Ord Float where
809 instance Num Float where
812 negate = primNegateFloat
816 fromInteger = primIntegerToFloat
817 fromInt = primIntToFloat
821 instance Eq Double where
825 instance Ord Double where
831 instance Num Double where
833 (-) = primMinusDouble
834 negate = primNegateDouble
835 (*) = primTimesDouble
838 fromInteger = primIntegerToDouble
839 fromInt = primIntToDouble
843 instance Real Float where
844 toRational = floatToRational
846 instance Real Double where
847 toRational = doubleToRational
849 -- Calls to these functions are optimised when passed as arguments to
851 floatToRational :: Float -> Rational
852 doubleToRational :: Double -> Rational
853 floatToRational x = realFloatToRational x
854 doubleToRational x = realFloatToRational x
856 realFloatToRational x = (m%1)*(b%1)^^n
857 where (m,n) = decodeFloat x
860 instance Fractional Float where
861 (/) = primDivideFloat
862 fromRational = rationalToRealFloat
864 instance Fractional Double where
865 (/) = primDivideDouble
866 fromRational = rationalToRealFloat
868 rationalToRealFloat x = x'
870 f e = if e' == e then y else f e'
871 where y = encodeFloat (round (x * (1%b)^^e)) e
872 (_,e') = decodeFloat y
873 (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
874 / fromInteger (denominator x))
877 instance Floating Float where
878 pi = 3.14159265358979323846
889 instance Floating Double where
890 pi = 3.14159265358979323846
893 sqrt = primSqrtDouble
897 asin = primAsinDouble
898 acos = primAcosDouble
899 atan = primAtanDouble
901 instance RealFrac Float where
902 properFraction = floatProperFraction
904 instance RealFrac Double where
905 properFraction = floatProperFraction
907 floatProperFraction x
908 | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
909 | otherwise = (fromInteger w, encodeFloat r n)
910 where (m,n) = decodeFloat x
912 (w,r) = quotRem m (b^(-n))
914 instance RealFloat Float where
915 floatRadix _ = toInteger primRadixFloat
916 floatDigits _ = primDigitsFloat
917 floatRange _ = (primMinExpFloat,primMaxExpFloat)
918 encodeFloat = primEncodeFloatZ
919 decodeFloat = primDecodeFloatZ
920 isNaN = primIsNaNFloat
921 isInfinite = primIsInfiniteFloat
922 isDenormalized= primIsDenormalizedFloat
923 isNegativeZero= primIsNegativeZeroFloat
924 isIEEE = const primIsIEEEFloat
926 instance RealFloat Double where
927 floatRadix _ = toInteger primRadixDouble
928 floatDigits _ = primDigitsDouble
929 floatRange _ = (primMinExpDouble,primMaxExpDouble)
930 encodeFloat = primEncodeDoubleZ
931 decodeFloat = primDecodeDoubleZ
932 isNaN = primIsNaNDouble
933 isInfinite = primIsInfiniteDouble
934 isDenormalized= primIsDenormalizedDouble
935 isNegativeZero= primIsNegativeZeroDouble
936 isIEEE = const primIsIEEEDouble
938 instance Enum Float where
939 toEnum = primIntToFloat
941 enumFrom = numericEnumFrom
942 enumFromThen = numericEnumFromThen
943 enumFromTo n m = numericEnumFromTo n (m+1/2)
944 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
946 instance Enum Double where
947 toEnum = primIntToDouble
949 enumFrom = numericEnumFrom
950 enumFromThen = numericEnumFromThen
951 enumFromTo n m = numericEnumFromTo n (m+1/2)
952 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
954 instance Read Float where
955 readsPrec p = readSigned readFloat
957 instance Show Float where
958 showsPrec p = showSigned showFloat p
960 instance Read Double where
961 readsPrec p = readSigned readFloat
963 instance Show Double where
964 showsPrec p = showSigned showFloat p
967 -- Some standard functions --------------------------------------------------
975 curry :: ((a,b) -> c) -> (a -> b -> c)
976 curry f x y = f (x,y)
978 uncurry :: (a -> b -> c) -> ((a,b) -> c)
979 uncurry f p = f (fst p) (snd p)
987 (.) :: (b -> c) -> (a -> b) -> (a -> c)
990 flip :: (a -> b -> c) -> b -> a -> c
993 ($) :: (a -> b) -> a -> b
996 until :: (a -> Bool) -> (a -> a) -> a -> a
997 until p f x = if p x then x else until p f (f x)
999 asTypeOf :: a -> a -> a
1002 error :: String -> a
1003 error msg = primRaise (ErrorCall msg)
1006 undefined | False = undefined
1008 -- Standard functions on rational numbers {PreludeRatio} --------------------
1010 data Integral a => Ratio a = a :% a deriving (Eq)
1011 type Rational = Ratio Integer
1013 (%) :: Integral a => a -> a -> Ratio a
1014 x % y = reduce (x * signum y) (abs y)
1016 reduce :: Integral a => a -> a -> Ratio a
1017 reduce x y | y == 0 = error "Ratio.%: zero denominator"
1018 | otherwise = (x `quot` d) :% (y `quot` d)
1021 numerator, denominator :: Integral a => Ratio a -> a
1022 numerator (x :% y) = x
1023 denominator (x :% y) = y
1025 instance Integral a => Ord (Ratio a) where
1026 compare (x:%y) (x':%y') = compare (x*y') (x'*y)
1028 instance Integral a => Num (Ratio a) where
1029 (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
1030 (x:%y) * (x':%y') = reduce (x*x') (y*y')
1031 negate (x :% y) = negate x :% y
1032 abs (x :% y) = abs x :% y
1033 signum (x :% y) = signum x :% 1
1034 fromInteger x = fromInteger x :% 1
1035 fromInt = intToRatio
1037 -- Hugs optimises code of the form fromRational (intToRatio x)
1038 intToRatio :: Integral a => Int -> Ratio a
1039 intToRatio x = fromInt x :% 1
1041 instance Integral a => Real (Ratio a) where
1042 toRational (x:%y) = toInteger x :% toInteger y
1044 instance Integral a => Fractional (Ratio a) where
1045 (x:%y) / (x':%y') = (x*y') % (y*x')
1046 recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
1047 fromRational (x:%y) = fromInteger x :% fromInteger y
1049 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1050 doubleToRatio :: Integral a => Double -> Ratio a
1052 | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
1053 | otherwise = fromInteger m % (fromInteger b ^ (-n))
1054 where (m,n) = decodeFloat x
1057 instance Integral a => RealFrac (Ratio a) where
1058 properFraction (x:%y) = (fromIntegral q, r:%y)
1059 where (q,r) = quotRem x y
1061 instance Integral a => Enum (Ratio a) where
1064 enumFrom = numericEnumFrom
1065 enumFromThen = numericEnumFromThen
1067 instance (Read a, Integral a) => Read (Ratio a) where
1068 readsPrec p = readParen (p > 7)
1069 (\r -> [(x%y,u) | (x,s) <- reads r,
1073 instance Integral a => Show (Ratio a) where
1074 showsPrec p (x:%y) = showParen (p > 7)
1075 (shows x . showString " % " . shows y)
1077 approxRational :: RealFrac a => a -> a -> Rational
1078 approxRational x eps = simplest (x-eps) (x+eps)
1079 where simplest x y | y < x = simplest y x
1081 | x > 0 = simplest' n d n' d'
1082 | y < 0 = - simplest' (-n') d' (-n) d
1083 | otherwise = 0 :% 1
1084 where xr@(n:%d) = toRational x
1085 (n':%d') = toRational y
1086 simplest' n d n' d' -- assumes 0 < n%d < n'%d'
1088 | q /= q' = (q+1) :% 1
1089 | otherwise = (q*n''+d'') :% n''
1090 where (q,r) = quotRem n d
1091 (q',r') = quotRem n' d'
1092 (n'':%d'') = simplest' d' r' d r
1094 -- Standard list functions {PreludeList} ------------------------------------
1101 last (_:xs) = last xs
1108 init (x:xs) = x : init xs
1114 (++) :: [a] -> [a] -> [a]
1116 (x:xs) ++ ys = x : (xs ++ ys)
1118 map :: (a -> b) -> [a] -> [b]
1119 --map f xs = [ f x | x <- xs ]
1121 map f (x:xs) = f x : map f xs
1124 filter :: (a -> Bool) -> [a] -> [a]
1125 --filter p xs = [ x | x <- xs, p x ]
1127 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1130 concat :: [[a]] -> [a]
1131 --concat = foldr (++) []
1133 concat (xs:xss) = xs ++ concat xss
1135 length :: [a] -> Int
1136 --length = foldl' (\n _ -> n + 1) 0
1138 length (x:xs) = let n = length xs in primSeq n (1+n)
1140 (!!) :: [b] -> Int -> b
1142 (_:xs) !! n | n>0 = xs !! (n-1)
1143 (_:_) !! _ = error "Prelude.!!: negative index"
1144 [] !! _ = error "Prelude.!!: index too large"
1146 foldl :: (a -> b -> a) -> a -> [b] -> a
1148 foldl f z (x:xs) = foldl f (f z x) xs
1150 foldl' :: (a -> b -> a) -> a -> [b] -> a
1152 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1154 foldl1 :: (a -> a -> a) -> [a] -> a
1155 foldl1 f (x:xs) = foldl f x xs
1157 scanl :: (a -> b -> a) -> a -> [b] -> [a]
1158 scanl f q xs = q : (case xs of
1160 x:xs -> scanl f (f q x) xs)
1162 scanl1 :: (a -> a -> a) -> [a] -> [a]
1163 scanl1 f (x:xs) = scanl f x xs
1165 foldr :: (a -> b -> b) -> b -> [a] -> b
1167 foldr f z (x:xs) = f x (foldr f z xs)
1169 foldr1 :: (a -> a -> a) -> [a] -> a
1171 foldr1 f (x:xs) = f x (foldr1 f xs)
1173 scanr :: (a -> b -> b) -> b -> [a] -> [b]
1174 scanr f q0 [] = [q0]
1175 scanr f q0 (x:xs) = f x q : qs
1176 where qs@(q:_) = scanr f q0 xs
1178 scanr1 :: (a -> a -> a) -> [a] -> [a]
1180 scanr1 f (x:xs) = f x q : qs
1181 where qs@(q:_) = scanr1 f xs
1183 iterate :: (a -> a) -> a -> [a]
1184 iterate f x = x : iterate f (f x)
1187 repeat x = xs where xs = x:xs
1189 replicate :: Int -> a -> [a]
1190 replicate n x = take n (repeat x)
1193 cycle [] = error "Prelude.cycle: empty list"
1194 cycle xs = xs' where xs'=xs++xs'
1196 take :: Int -> [a] -> [a]
1199 take n (x:xs) | n>0 = x : take (n-1) xs
1200 take _ _ = error "Prelude.take: negative argument"
1202 drop :: Int -> [a] -> [a]
1205 drop n (_:xs) | n>0 = drop (n-1) xs
1206 drop _ _ = error "Prelude.drop: negative argument"
1208 splitAt :: Int -> [a] -> ([a], [a])
1209 splitAt 0 xs = ([],xs)
1210 splitAt _ [] = ([],[])
1211 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1212 splitAt _ _ = error "Prelude.splitAt: negative argument"
1214 takeWhile :: (a -> Bool) -> [a] -> [a]
1217 | p x = x : takeWhile p xs
1220 dropWhile :: (a -> Bool) -> [a] -> [a]
1222 dropWhile p xs@(x:xs')
1223 | p x = dropWhile p xs'
1226 span, break :: (a -> Bool) -> [a] -> ([a],[a])
1230 | otherwise = ([],xs)
1231 where (ys,zs) = span p xs'
1232 break p = span (not . p)
1234 lines :: String -> [String]
1236 lines s = let (l,s') = break ('\n'==) s
1237 in l : case s' of [] -> []
1238 (_:s'') -> lines s''
1240 words :: String -> [String]
1241 words s = case dropWhile isSpace s of
1244 where (w,s'') = break isSpace s'
1246 unlines :: [String] -> String
1247 unlines = concatMap (\l -> l ++ "\n")
1249 unwords :: [String] -> String
1251 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1253 reverse :: [a] -> [a]
1254 --reverse = foldl (flip (:)) []
1255 reverse xs = ri [] xs
1256 where ri acc [] = acc
1257 ri acc (x:xs) = ri (x:acc) xs
1259 and, or :: [Bool] -> Bool
1260 --and = foldr (&&) True
1261 --or = foldr (||) False
1263 and (x:xs) = if x then and xs else x
1265 or (x:xs) = if x then x else or xs
1267 any, all :: (a -> Bool) -> [a] -> Bool
1268 --any p = or . map p
1269 --all p = and . map p
1271 any p (x:xs) = if p x then True else any p xs
1273 all p (x:xs) = if p x then all p xs else False
1275 elem, notElem :: Eq a => a -> [a] -> Bool
1277 --notElem = all . (/=)
1279 elem x (y:ys) = if x==y then True else elem x ys
1281 notElem x (y:ys) = if x==y then False else notElem x ys
1283 lookup :: Eq a => a -> [(a,b)] -> Maybe b
1284 lookup k [] = Nothing
1285 lookup k ((x,y):xys)
1287 | otherwise = lookup k xys
1289 sum, product :: Num a => [a] -> a
1291 product = foldl' (*) 1
1293 maximum, minimum :: Ord a => [a] -> a
1294 maximum = foldl1 max
1295 minimum = foldl1 min
1297 concatMap :: (a -> [b]) -> [a] -> [b]
1298 concatMap f = concat . map f
1300 zip :: [a] -> [b] -> [(a,b)]
1301 zip = zipWith (\a b -> (a,b))
1303 zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
1304 zip3 = zipWith3 (\a b c -> (a,b,c))
1306 zipWith :: (a->b->c) -> [a]->[b]->[c]
1307 zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
1310 zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1311 zipWith3 z (a:as) (b:bs) (c:cs)
1312 = z a b c : zipWith3 z as bs cs
1313 zipWith3 _ _ _ _ = []
1315 unzip :: [(a,b)] -> ([a],[b])
1316 unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1318 unzip3 :: [(a,b,c)] -> ([a],[b],[c])
1319 unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1322 -- PreludeText ----------------------------------------------------------------
1324 reads :: Read a => ReadS a
1327 shows :: Show a => a -> ShowS
1330 read :: Read a => String -> a
1331 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1333 [] -> error "Prelude.read: no parse"
1334 _ -> error "Prelude.read: ambiguous parse"
1336 showChar :: Char -> ShowS
1339 showString :: String -> ShowS
1342 showParen :: Bool -> ShowS -> ShowS
1343 showParen b p = if b then showChar '(' . p . showChar ')' else p
1345 hugsprimShowField :: Show a => String -> a -> ShowS
1346 hugsprimShowField m v = showString m . showChar '=' . shows v
1348 readParen :: Bool -> ReadS a -> ReadS a
1349 readParen b g = if b then mandatory else optional
1350 where optional r = g r ++ mandatory r
1351 mandatory r = [(x,u) | ("(",s) <- lex r,
1352 (x,t) <- optional s,
1356 hugsprimReadField :: Read a => String -> ReadS a
1357 hugsprimReadField m s0 = [ r | (t, s1) <- lex s0, t == m,
1363 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1364 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1366 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1368 lexString ('"':s) = [("\"",s)]
1369 lexString s = [(ch++str, u)
1370 | (ch,t) <- lexStrItem s,
1371 (str,u) <- lexString t ]
1373 lexStrItem ('\\':'&':s) = [("\\&",s)]
1374 lexStrItem ('\\':c:s) | isSpace c
1375 = [("",t) | '\\':t <- [dropWhile isSpace s]]
1376 lexStrItem s = lexLitChar s
1378 lex (c:s) | isSingle c = [([c],s)]
1379 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
1380 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
1381 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
1382 (fe,t) <- lexFracExp s ]
1383 | otherwise = [] -- bad character
1385 isSingle c = c `elem` ",;()[]{}_`"
1386 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1387 isIdChar c = isAlphaNum c || c `elem` "_'"
1389 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1391 lexFracExp s = [("",s)]
1393 lexExp (e:s) | e `elem` "eE"
1394 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
1395 (ds,u) <- lexDigits t] ++
1396 [(e:ds,t) | (ds,t) <- lexDigits s]
1399 lexDigits :: ReadS String
1400 lexDigits = nonnull isDigit
1402 nonnull :: (Char -> Bool) -> ReadS String
1403 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1405 lexLitChar :: ReadS String
1406 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1408 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- "
1409 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
1410 lexEsc s@(d:_) | isDigit d = lexDigits s
1411 lexEsc s@(c:_) | isUpper c
1412 = let table = ('\DEL',"DEL") : asciiTab
1413 in case [(mne,s') | (c, mne) <- table,
1414 ([],s') <- [lexmatch mne s]]
1418 lexLitChar (c:s) = [([c],s)]
1421 isOctDigit c = c >= '0' && c <= '7'
1422 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
1423 || c >= 'a' && c <= 'f'
1425 lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
1426 lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
1427 lexmatch xs ys = (xs,ys)
1429 asciiTab = zip ['\NUL'..' ']
1430 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1431 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
1432 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1433 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
1436 readLitChar :: ReadS Char
1437 readLitChar ('\\':s) = readEsc s
1439 readEsc ('a':s) = [('\a',s)]
1440 readEsc ('b':s) = [('\b',s)]
1441 readEsc ('f':s) = [('\f',s)]
1442 readEsc ('n':s) = [('\n',s)]
1443 readEsc ('r':s) = [('\r',s)]
1444 readEsc ('t':s) = [('\t',s)]
1445 readEsc ('v':s) = [('\v',s)]
1446 readEsc ('\\':s) = [('\\',s)]
1447 readEsc ('"':s) = [('"',s)]
1448 readEsc ('\'':s) = [('\'',s)]
1449 readEsc ('^':c:s) | c >= '@' && c <= '_'
1450 = [(toEnum (fromEnum c - fromEnum '@'), s)]
1451 readEsc s@(d:_) | isDigit d
1452 = [(toEnum n, t) | (n,t) <- readDec s]
1453 readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
1454 readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
1455 readEsc s@(c:_) | isUpper c
1456 = let table = ('\DEL',"DEL") : asciiTab
1457 in case [(c,s') | (c, mne) <- table,
1458 ([],s') <- [lexmatch mne s]]
1462 readLitChar (c:s) = [(c,s)]
1464 showLitChar :: Char -> ShowS
1465 showLitChar c | c > '\DEL' = showChar '\\' .
1466 protectEsc isDigit (shows (fromEnum c))
1467 showLitChar '\DEL' = showString "\\DEL"
1468 showLitChar '\\' = showString "\\\\"
1469 showLitChar c | c >= ' ' = showChar c
1470 showLitChar '\a' = showString "\\a"
1471 showLitChar '\b' = showString "\\b"
1472 showLitChar '\f' = showString "\\f"
1473 showLitChar '\n' = showString "\\n"
1474 showLitChar '\r' = showString "\\r"
1475 showLitChar '\t' = showString "\\t"
1476 showLitChar '\v' = showString "\\v"
1477 showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
1478 showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
1480 protectEsc p f = f . cont
1481 where cont s@(c:_) | p c = "\\&" ++ s
1484 -- Unsigned readers for various bases
1485 readDec, readOct, readHex :: Integral a => ReadS a
1486 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1487 readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1488 readHex = readInt 16 isHexDigit hex
1489 where hex d = fromEnum d -
1492 else fromEnum (if isUpper d then 'A' else 'a') - 10)
1494 -- readInt reads a string of digits using an arbitrary base.
1495 -- Leading minus signs must be handled elsewhere.
1497 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1498 readInt radix isDig digToInt s =
1499 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1500 | (ds,r) <- nonnull isDig s ]
1502 -- showInt is used for positive numbers only
1503 showInt :: Integral a => a -> ShowS
1506 = error "Numeric.showInt: can't show negative numbers"
1509 = let (n',d) = quotRem n 10
1510 r' = toEnum (fromEnum '0' + fromIntegral d) : r
1511 in if n' == 0 then r' else showInt n' r'
1513 = case quotRem n 10 of { (n',d) ->
1514 let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1515 in if n' == 0 then r' else showInt n' r'
1519 readSigned:: Real a => ReadS a -> ReadS a
1520 readSigned readPos = readParen False read'
1521 where read' r = read'' r ++
1522 [(-x,t) | ("-",s) <- lex r,
1524 read'' r = [(n,s) | (str,s) <- lex r,
1525 (n,"") <- readPos str]
1527 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1528 showSigned showPos p x = if x < 0 then showParen (p > 6)
1529 (showChar '-' . showPos (-x))
1532 readFloat :: RealFloat a => ReadS a
1533 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1535 where readFix r = [(read (ds++ds'), length ds', t)
1536 | (ds, s) <- lexDigits r
1537 , (ds',t) <- lexFrac s ]
1539 lexFrac ('.':s) = lexDigits s
1540 lexFrac s = [("",s)]
1542 readExp (e:s) | e `elem` "eE" = readExp' s
1545 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1546 readExp' ('+':s) = readDec s
1547 readExp' s = readDec s
1550 -- Hooks for primitives: -----------------------------------------------------
1551 -- Do not mess with these!
1553 hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering
1554 hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1556 hugsprimEqChar :: Char -> Char -> Bool
1557 hugsprimEqChar c1 c2 = primEqChar c1 c2
1559 hugsprimPmInt :: Num a => Int -> a -> Bool
1560 hugsprimPmInt n x = fromInt n == x
1562 hugsprimPmInteger :: Num a => Integer -> a -> Bool
1563 hugsprimPmInteger n x = fromInteger n == x
1565 hugsprimPmDouble :: Fractional a => Double -> a -> Bool
1566 hugsprimPmDouble n x = fromDouble n == x
1568 -- ToDo: make the message more informative.
1570 hugsprimPmFail = error "Pattern Match Failure"
1572 -- used in desugaring Foreign functions
1573 -- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
1574 -- bit of code of type RealWorld -> (a,RealWorld) into a proper IO value.
1575 -- What follows is the version for standalone mode. ghc/lib/std/PrelHugs.lhs
1576 -- contains a version used in combined mode. That version takes care of
1577 -- switching between the GHC and Hugs IO representations, which are different.
1578 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1581 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1582 hugsprimCreateAdjThunk fun typestr callconv
1583 = do sp <- makeStablePtr fun
1584 p <- copy_String_to_cstring typestr -- is never freed
1585 a <- primCreateAdjThunkARCH sp p callconv
1588 -- The following primitives are only needed if (n+k) patterns are enabled:
1589 hugsprimPmSub :: Integral a => Int -> a -> a
1590 hugsprimPmSub n x = x - fromInt n
1592 hugsprimPmFromInteger :: Integral a => Integer -> a
1593 hugsprimPmFromInteger = fromIntegral
1595 hugsprimPmSubtract :: Integral a => a -> a -> a
1596 hugsprimPmSubtract x y = x - y
1598 hugsprimPmLe :: Integral a => a -> a -> Bool
1599 hugsprimPmLe x y = x <= y
1601 -- Unpack strings generated by the Hugs code generator.
1602 -- Strings can contain \0 provided they're coded right.
1604 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1606 hugsprimUnpackString :: Addr -> String
1607 hugsprimUnpackString a = unpack 0
1609 -- The following decoding is based on evalString in the old machine.c
1612 | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1613 then '\\' : unpack (i+2)
1614 else '\0' : unpack (i+2)
1615 | otherwise = c : unpack (i+1)
1617 c = primIndexCharOffAddr a i
1620 -- Monadic I/O: --------------------------------------------------------------
1622 type FilePath = String
1624 --data IOError = ...
1625 --instance Eq IOError ...
1626 --instance Show IOError ...
1628 data IOError = IOError String
1629 instance Show IOError where
1630 showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1632 ioError :: IOError -> IO a
1633 ioError (IOError s) = primRaise (IOExcept s)
1635 userError :: String -> IOError
1636 userError s = primRaise (ErrorCall s)
1638 catch :: IO a -> (IOError -> IO a) -> IO a
1640 = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
1642 e2ioe (IOExcept s) = IOError s
1643 e2ioe other = IOError (show other)
1645 putChar :: Char -> IO ()
1646 putChar c = nh_stdout >>= \h -> nh_write h c
1648 putStr :: String -> IO ()
1649 putStr s = nh_stdout >>= \h ->
1650 let loop [] = nh_flush h
1651 loop (c:cs) = nh_write h c >> loop cs
1654 putStrLn :: String -> IO ()
1655 putStrLn s = do { putStr s; putChar '\n' }
1657 print :: Show a => a -> IO ()
1658 print = putStrLn . show
1661 getChar = unsafeInterleaveIO (
1663 nh_read h >>= \ci ->
1664 return (primIntToChar ci)
1667 getLine :: IO String
1668 getLine = do c <- getChar
1669 if c=='\n' then return ""
1670 else do cs <- getLine
1673 getContents :: IO String
1674 getContents = nh_stdin >>= \h -> readfromhandle h
1676 interact :: (String -> String) -> IO ()
1677 interact f = getContents >>= (putStr . f)
1679 readFile :: FilePath -> IO String
1681 = copy_String_to_cstring fname >>= \ptr ->
1682 nh_open ptr 0 >>= \h ->
1684 nh_errno >>= \errno ->
1685 if (isNullAddr h || errno /= 0)
1686 then (ioError.IOError) ("readFile: can't open file " ++ fname)
1687 else readfromhandle h
1689 writeFile :: FilePath -> String -> IO ()
1690 writeFile fname contents
1691 = copy_String_to_cstring fname >>= \ptr ->
1692 nh_open ptr 1 >>= \h ->
1694 nh_errno >>= \errno ->
1695 if (isNullAddr h || errno /= 0)
1696 then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1697 else writetohandle fname h contents
1699 appendFile :: FilePath -> String -> IO ()
1700 appendFile fname contents
1701 = copy_String_to_cstring fname >>= \ptr ->
1702 nh_open ptr 2 >>= \h ->
1704 nh_errno >>= \errno ->
1705 if (isNullAddr h || errno /= 0)
1706 then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1707 else writetohandle fname h contents
1710 -- raises an exception instead of an error
1711 readIO :: Read a => String -> IO a
1712 readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1714 [] -> ioError (userError "PreludeIO.readIO: no parse")
1715 _ -> ioError (userError
1716 "PreludeIO.readIO: ambiguous parse")
1718 readLn :: Read a => IO a
1719 readLn = do l <- getLine
1724 -- End of Hugs standard prelude ----------------------------------------------
1730 instance Show Exception where
1731 showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1732 showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
1734 data IOResult = IOResult deriving (Show)
1736 type FILE_STAR = Addr -- FILE *
1738 foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR
1739 foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
1740 foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
1741 foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Char -> IO ()
1742 foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int
1743 foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR
1744 foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO ()
1745 foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO ()
1746 foreign import "nHandle" "nh_errno" nh_errno :: IO Int
1748 foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
1749 foreign import "nHandle" "nh_free" nh_free :: Addr -> IO ()
1750 foreign import "nHandle" "nh_store" nh_store :: Addr -> Char -> IO ()
1751 foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Char
1752 foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
1753 foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int
1754 foreign import "nHandle" "nh_iseof" nh_iseof :: FILE_STAR -> IO Int
1755 foreign import "nHandle" "nh_system" nh_system :: Addr -> IO Int
1756 foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO ()
1757 foreign import "nHandle" "nh_getPID" nh_getPID :: IO Int
1759 foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double
1760 foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double
1762 copy_String_to_cstring :: String -> IO Addr
1763 copy_String_to_cstring s
1764 = nh_malloc (1 + length s) >>= \ptr0 ->
1765 let loop ptr [] = nh_store ptr (chr 0) >> return ptr0
1766 loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs
1769 then error "copy_String_to_cstring: malloc failed"
1772 copy_cstring_to_String :: Addr -> IO String
1773 copy_cstring_to_String ptr
1774 = nh_load ptr >>= \ci ->
1777 else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1780 readfromhandle :: FILE_STAR -> IO String
1782 = unsafeInterleaveIO (
1783 nh_read h >>= \ci ->
1784 if ci == -1 {-EOF-} then return "" else
1785 readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1788 writetohandle :: String -> FILE_STAR -> String -> IO ()
1789 writetohandle fname h []
1791 nh_errno >>= \errno ->
1794 else error ( "writeFile/appendFile: error closing file " ++ fname)
1795 writetohandle fname h (c:cs)
1796 = nh_write h c >> writetohandle fname h cs
1798 primGetRawArgs :: IO [String]
1800 = primGetArgc >>= \argc ->
1801 sequence (map get_one_arg [0 .. argc-1])
1803 get_one_arg :: Int -> IO String
1805 = primGetArgv argno >>= \a ->
1806 copy_cstring_to_String a
1808 primGetEnv :: String -> IO String
1810 = copy_String_to_cstring v >>= \ptr ->
1811 nh_getenv ptr >>= \ptr2 ->
1814 then ioError (IOError "getEnv failed")
1816 copy_cstring_to_String ptr2 >>= \result ->
1820 ------------------------------------------------------------------------------
1821 -- ST, IO --------------------------------------------------------------------
1822 ------------------------------------------------------------------------------
1824 newtype ST s a = ST (s -> (a,s))
1826 primRunST :: ST RealWorld a -> a
1827 primRunST m = fst (unST m theWorld)
1829 theWorld :: RealWorld
1830 theWorld = error "primRunST: entered the RealWorld"
1832 runST :: (__forall s . ST s a) -> a
1833 runST m = fst (unST m alpha)
1835 alpha = error "primRunST: entered the RealWorld"
1837 fixST :: (a -> ST s a) -> ST s a
1838 fixST m = ST (\ s ->
1840 (r,s) = unST (m r) s
1847 -- Should IO not be abstract?
1848 -- Is "instance (IO a)" allowed, for example ?
1849 type IO a = ST RealWorld a
1851 stToIO :: ST RealWorld a -> IO a
1854 ioToST :: IO a -> ST RealWorld a
1857 unsafePerformIO :: IO a -> a
1858 unsafePerformIO m = primRunST (ioToST m)
1860 instance Functor (ST s) where
1861 fmap f x = x >>= (return . f)
1863 instance Monad (ST s) where
1864 m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1865 return x = ST (\s -> (x,s))
1866 m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1869 -- Library IO has a global variable which accumulates Handles
1870 -- as they are opened. We keep here a second global variable
1871 -- into which a cleanup action may be specified. When evaluation
1872 -- finishes, either normally or as a result of System.exitWith,
1873 -- this cleanup action is run, closing all known-about Handles.
1874 -- Doing it like this means the Prelude does not have to know
1875 -- anything about the grotty details of the Handle implementation.
1876 prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
1877 prelCleanupAfterRunAction = primRunST (newIORef Nothing)
1879 -- used when Hugs invokes top level function
1880 hugsprimRunIO_toplevel :: IO a -> ()
1881 hugsprimRunIO_toplevel m
1882 = protect 5 (fst (unST composite_action realWorld))
1885 = do writeIORef prelCleanupAfterRunAction Nothing
1887 cleanup_handles <- readIORef prelCleanupAfterRunAction
1888 case cleanup_handles of
1889 Nothing -> return ()
1892 realWorld = error "primRunIO: entered the RealWorld"
1893 protect :: Int -> () -> ()
1897 = primCatch (protect (n-1) comp)
1898 (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1900 trace, trace_quiet :: String -> a -> a
1902 = trace_quiet ("trace: " ++ s) x
1904 = (primRunST (putStr (s ++ "\n"))) `seq` x
1906 unsafeInterleaveST :: ST s a -> ST s a
1907 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1909 unsafeInterleaveIO :: IO a -> IO a
1910 unsafeInterleaveIO = unsafeInterleaveST
1913 ------------------------------------------------------------------------------
1914 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
1915 ------------------------------------------------------------------------------
1919 nullAddr = primIntToAddr 0
1920 incAddr a = primIntToAddr (1 + primAddrToInt a)
1921 isNullAddr a = 0 == primAddrToInt a
1923 instance Eq Addr where
1927 instance Ord Addr where
1935 instance Eq Word where
1939 instance Ord Word where
1947 makeStablePtr :: a -> IO (StablePtr a)
1948 makeStablePtr = primMakeStablePtr
1949 deRefStablePtr :: StablePtr a -> IO a
1950 deRefStablePtr = primDeRefStablePtr
1951 freeStablePtr :: StablePtr a -> IO ()
1952 freeStablePtr = primFreeStablePtr
1955 data PrimArray a -- immutable arrays with Int indices
1958 data STRef s a -- mutable variables
1959 data PrimMutableArray s a -- mutable arrays with Int indices
1960 data PrimMutableByteArray s
1962 newSTRef :: a -> ST s (STRef s a)
1963 newSTRef = primNewRef
1964 readSTRef :: STRef s a -> ST s a
1965 readSTRef = primReadRef
1966 writeSTRef :: STRef s a -> a -> ST s ()
1967 writeSTRef = primWriteRef
1969 type IORef a = STRef RealWorld a
1970 newIORef :: a -> IO (IORef a)
1971 newIORef = primNewRef
1972 readIORef :: IORef a -> IO a
1973 readIORef = primReadRef
1974 writeIORef :: IORef a -> a -> IO ()
1975 writeIORef = primWriteRef
1978 ------------------------------------------------------------------------------
1979 -- ThreadId, MVar, concurrency stuff -----------------------------------------
1980 ------------------------------------------------------------------------------
1984 newEmptyMVar :: IO (MVar a)
1985 newEmptyMVar = primNewEmptyMVar
1987 putMVar :: MVar a -> a -> IO ()
1988 putMVar = primPutMVar
1990 takeMVar :: MVar a -> IO a
1992 = ST (\world -> primTakeMVar m cont world)
1994 -- cont :: a -> RealWorld -> (a,RealWorld)
1995 -- where 'a' is as in the top-level signature
1996 cont x world = (x,world)
1998 -- the type of the handwritten BCO (threesome) primTakeMVar is
1999 -- primTakeMVar :: MVar a
2000 -- -> (a -> RealWorld -> (a,RealWorld))
2004 -- primTakeMVar behaves like this:
2006 -- primTakeMVar (MVar# m#) cont world
2007 -- = primTakeMVar_wrk m# cont world
2009 -- primTakeMVar_wrk m# cont world
2010 -- = cont (takeMVar# m#) world
2012 -- primTakeMVar_wrk has the special property that it is
2013 -- restartable by the scheduler, should the MVar be empty.
2015 newMVar :: a -> IO (MVar a)
2017 newEmptyMVar >>= \ mvar ->
2018 putMVar mvar value >>
2021 readMVar :: MVar a -> IO a
2023 takeMVar mvar >>= \ value ->
2024 putMVar mvar value >>
2027 swapMVar :: MVar a -> a -> IO a
2029 takeMVar mvar >>= \ old ->
2033 instance Eq (MVar a) where
2034 m1 == m2 = primSameMVar m1 m2
2039 instance Eq ThreadId where
2040 tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
2042 instance Ord ThreadId where
2044 = let r = primCmpThreadIds tid1 tid2
2045 in if r < 0 then LT else if r > 0 then GT else EQ
2048 forkIO :: IO a -> IO ThreadId
2049 -- Simple version; doesn't catch exceptions in computation
2050 -- forkIO computation
2051 -- = primForkIO (primRunST computation)
2056 (unST computation realWorld `primSeq` ())
2057 (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
2060 realWorld = error "primForkIO: entered the RealWorld"
2063 -- showFloat ------------------------------------------------------------------
2065 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2066 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2067 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2068 showFloat :: (RealFloat a) => a -> ShowS
2070 showEFloat d x = showString (formatRealFloat FFExponent d x)
2071 showFFloat d x = showString (formatRealFloat FFFixed d x)
2072 showGFloat d x = showString (formatRealFloat FFGeneric d x)
2073 showFloat = showGFloat Nothing
2075 -- These are the format types. This type is not exported.
2077 data FFFormat = FFExponent | FFFixed | FFGeneric
2079 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2080 formatRealFloat fmt decs x = s
2084 else if isInfinite x then
2085 if x < 0 then "-Infinity" else "Infinity"
2086 else if x < 0 || isNegativeZero x then
2087 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2089 doFmt fmt (floatToDigits (toInteger base) x)
2091 let ds = map intToDigit is
2094 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2101 [d] -> d : ".0e" ++ show (e-1)
2102 d:ds -> d : '.' : ds ++ 'e':show (e-1)
2104 let dec' = max dec 1 in
2106 [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2108 let (ei, is') = roundTo base (dec'+1) is
2109 d:ds = map intToDigit
2110 (if ei > 0 then init is' else is')
2111 in d:'.':ds ++ "e" ++ show (e-1+ei)
2115 let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2116 f n s "" = f (n-1) (s++"0") ""
2117 f n s (d:ds) = f (n-1) (s++[d]) ds
2122 let dec' = max dec 0 in
2124 let (ei, is') = roundTo base (dec' + e) is
2125 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2126 in (if null ls then "0" else ls) ++
2127 (if null rs then "" else '.' : rs)
2129 let (ei, is') = roundTo base dec'
2130 (replicate (-e) 0 ++ is)
2131 d : ds = map intToDigit
2132 (if ei > 0 then is' else 0:is')
2135 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2136 roundTo base d is = case f d is of
2138 (1, is) -> (1, 1 : is)
2139 where b2 = base `div` 2
2140 f n [] = (0, replicate n 0)
2141 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2143 let (c, ds) = f (d-1) is
2145 in if i' == base then (1, 0:ds) else (0, i':ds)
2147 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2148 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2149 -- This version uses a much slower logarithm estimator. It should be improved.
2151 -- This function returns a list of digits (Ints in [0..base-1]) and an
2154 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2156 floatToDigits _ 0 = ([0], 0)
2157 floatToDigits base x =
2158 let (f0, e0) = decodeFloat x
2159 (minExp0, _) = floatRange x
2162 minExp = minExp0 - p -- the real minimum exponent
2163 -- Haskell requires that f be adjusted so denormalized numbers
2164 -- will have an impossibly low exponent. Adjust for this.
2165 (f, e) = let n = minExp - e0
2166 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2171 if f == b^(p-1) then
2172 (f*be*b*2, 2*b, be*b, b)
2176 if e > minExp && f == b^(p-1) then
2177 (f*b*2, b^(-e+1)*2, b, 1)
2179 (f*2, b^(-e)*2, 1, 1)
2182 if b == 2 && base == 10 then
2183 -- logBase 10 2 is slightly bigger than 3/10 so
2184 -- the following will err on the low side. Ignoring
2185 -- the fraction will make it err even more.
2186 -- Haskell promises that p-1 <= logBase b f < p.
2187 (p - 1 + e0) * 3 `div` 10
2189 ceiling ((log (fromInteger (f+1)) +
2190 fromInt e * log (fromInteger b)) /
2191 log (fromInteger base))
2194 if r + mUp <= expt base n * s then n else fixup (n+1)
2196 if expt base (-n) * (r + mUp) <= s then n
2200 gen ds rn sN mUpN mDnN =
2201 let (dn, rn') = (rn * base) `divMod` sN
2204 in case (rn' < mDnN', rn' + mUpN' > sN) of
2205 (True, False) -> dn : ds
2206 (False, True) -> dn+1 : ds
2207 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2208 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2211 gen [] r (s * expt base k) mUp mDn
2213 let bk = expt base (-k)
2214 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
2215 in (map toInt (reverse rds), k)
2218 -- Exponentiation with a cache for the most common numbers.
2221 expt :: Integer -> Int -> Integer
2223 if base == 2 && n >= minExpt && n <= maxExpt then
2224 expts !! (n-minExpt)
2229 expts = [2^n | n <- [minExpt .. maxExpt]]