1 {----------------------------------------------------------------------------
2 __ __ __ __ ____ ___ _______________________________________________
3 || || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system
4 ||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999
5 ||---|| ___|| World Wide Web: http://haskell.org/hugs
6 || || Report bugs to: hugs-bugs@haskell.org
7 || || Version: January 1999 _______________________________________________
9 This is the Hugs 98 Standard Prelude, based very closely on the Standard
10 Prelude for Haskell 98.
12 WARNING: This file is an integral part of the Hugs source code. Changes to
13 the definitions in this file without corresponding modifications in other
14 parts of the program may cause the interpreter to fail unexpectedly. Under
15 normal circumstances, you should not attempt to modify this file in any way!
17 -----------------------------------------------------------------------------
18 Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell
19 Group 1994-99, and is distributed as Open Source software under the
20 Artistic License; see the file "Artistic" that is included in the
21 distribution for details.
22 ----------------------------------------------------------------------------}
25 -- module PreludeList,
26 map, (++), concat, filter,
27 head, last, tail, init, null, length, (!!),
28 foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
29 iterate, repeat, replicate, cycle,
30 take, drop, splitAt, takeWhile, dropWhile, span, break,
31 lines, words, unlines, unwords, reverse, and, or,
32 any, all, elem, notElem, lookup,
33 sum, product, maximum, minimum, concatMap,
34 zip, zip3, zipWith, zipWith3, unzip, unzip3,
35 -- module PreludeText,
37 Read(readsPrec, readList),
38 Show(show, showsPrec, showList),
39 reads, shows, read, lex,
40 showChar, showString, readParen, showParen,
42 FilePath, IOError, ioError, userError, catch,
43 putChar, putStr, putStrLn, print,
44 getChar, getLine, getContents, interact,
45 readFile, writeFile, appendFile, readIO, readLn,
47 Ix(range, index, inRange, rangeSize),
49 isAscii, isControl, isPrint, isSpace, isUpper, isLower,
50 isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
51 digitToInt, intToDigit,
54 readLitChar, showLitChar, lexLitChar,
58 readDec, readOct, readHex, readSigned,
61 Ratio, Rational, (%), numerator, denominator, approxRational,
62 -- Non-standard exports
63 IO(..), IOResult(..), Addr,
69 Char, String, Int, Integer, Float, Double, IO,
70 -- List type: []((:), [])
72 -- Tuple types: (,), (,,), etc.
75 Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
77 Ord(compare, (<), (<=), (>=), (>), max, min),
78 Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
79 enumFromTo, enumFromThenTo),
80 Bounded(minBound, maxBound),
81 -- Num((+), (-), (*), negate, abs, signum, fromInteger),
82 Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
84 -- Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
85 Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
86 -- Fractional((/), recip, fromRational),
87 Fractional((/), recip, fromRational, fromDouble),
88 Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
89 asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
90 RealFrac(properFraction, truncate, round, ceiling, floor),
91 RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
92 encodeFloat, exponent, significand, scaleFloat, isNaN,
93 isInfinite, isDenormalized, isIEEE, isNegativeZero),
94 Monad((>>=), (>>), return, fail),
96 mapM, mapM_, accumulate, sequence, (=<<),
98 (&&), (||), not, otherwise,
99 subtract, even, odd, gcd, lcm, (^), (^^),
100 fromIntegral, realToFrac, atan2,
101 fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
102 asTypeOf, error, undefined,
106 -- Arrrggghhh!!! Help! Help! Help!
107 -- What?! Prelude.hs doesn't even _define_ most of these things!
108 ,primCompAux,PrimArray,primRunST,primNewArray,primWriteArray
109 ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv
110 ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open
111 ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar
112 ,unsafeInterleaveIO,nh_write,primCharToInt
114 -- ToDo: rm -- these are only for debugging
115 ,primPlusInt,primEqChar,primRunIO
118 -- Standard value bindings {Prelude} ----------------------------------------
123 infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
125 --infixr 5 : -- this fixity declaration is hard-wired into Hugs
127 infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
132 infixr 0 $, $!, `seq`
134 -- Equality and Ordered classes ---------------------------------------------
137 (==), (/=) :: a -> a -> Bool
139 -- Minimal complete definition: (==) or (/=)
143 class (Eq a) => Ord a where
144 compare :: a -> a -> Ordering
145 (<), (<=), (>=), (>) :: a -> a -> Bool
146 max, min :: a -> a -> a
148 -- Minimal complete definition: (<=) or compare
149 -- using compare can be more efficient for complex types
150 compare x y | x==y = EQ
154 x <= y = compare x y /= GT
155 x < y = compare x y == LT
156 x >= y = compare x y /= LT
157 x > y = compare x y == GT
164 class Bounded a where
165 minBound, maxBound :: a
166 -- Minimal complete definition: All
168 -- Numeric classes ----------------------------------------------------------
170 class (Eq a, Show a) => Num a where
171 (+), (-), (*) :: a -> a -> a
173 abs, signum :: a -> a
174 fromInteger :: Integer -> a
177 -- Minimal complete definition: All, except negate or (-)
179 fromInt = fromIntegral
182 class (Num a, Ord a) => Real a where
183 toRational :: a -> Rational
185 class (Real a, Enum a) => Integral a where
186 quot, rem, div, mod :: a -> a -> a
187 quotRem, divMod :: a -> a -> (a,a)
188 even, odd :: a -> Bool
189 toInteger :: a -> Integer
192 -- Minimal complete definition: quotRem and toInteger
193 n `quot` d = q where (q,r) = quotRem n d
194 n `rem` d = r where (q,r) = quotRem n d
195 n `div` d = q where (q,r) = divMod n d
196 n `mod` d = r where (q,r) = divMod n d
197 divMod n d = if signum r == - signum d then (q-1, r+d) else qr
198 where qr@(q,r) = quotRem n d
199 even n = n `rem` 2 == 0
201 toInt = toInt . toInteger
203 class (Num a) => Fractional a where
206 fromRational :: Rational -> a
207 fromDouble :: Double -> a
209 -- Minimal complete definition: fromRational and ((/) or recip)
211 fromDouble = fromRational . toRational
215 class (Fractional a) => Floating a where
217 exp, log, sqrt :: a -> a
218 (**), logBase :: a -> a -> a
219 sin, cos, tan :: a -> a
220 asin, acos, atan :: a -> a
221 sinh, cosh, tanh :: a -> a
222 asinh, acosh, atanh :: a -> a
224 -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
225 -- asinh, acosh, atanh
226 x ** y = exp (log x * y)
227 logBase x y = log y / log x
229 tan x = sin x / cos x
230 sinh x = (exp x - exp (-x)) / 2
231 cosh x = (exp x + exp (-x)) / 2
232 tanh x = sinh x / cosh x
233 asinh x = log (x + sqrt (x*x + 1))
234 acosh x = log (x + sqrt (x*x - 1))
235 atanh x = (log (1 + x) - log (1 - x)) / 2
237 class (Real a, Fractional a) => RealFrac a where
238 properFraction :: (Integral b) => a -> (b,a)
239 truncate, round :: (Integral b) => a -> b
240 ceiling, floor :: (Integral b) => a -> b
242 -- Minimal complete definition: properFraction
243 truncate x = m where (m,_) = properFraction x
245 round x = let (n,r) = properFraction x
246 m = if r < 0 then n - 1 else n + 1
247 in case signum (abs r - 0.5) of
249 0 -> if even n then n else m
252 ceiling x = if r > 0 then n + 1 else n
253 where (n,r) = properFraction x
255 floor x = if r < 0 then n - 1 else n
256 where (n,r) = properFraction x
258 class (RealFrac a, Floating a) => RealFloat a where
259 floatRadix :: a -> Integer
260 floatDigits :: a -> Int
261 floatRange :: a -> (Int,Int)
262 decodeFloat :: a -> (Integer,Int)
263 encodeFloat :: Integer -> Int -> a
265 significand :: a -> a
266 scaleFloat :: Int -> a -> a
267 isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
271 -- Minimal complete definition: All, except exponent, signficand,
273 exponent x = if m==0 then 0 else n + floatDigits x
274 where (m,n) = decodeFloat x
275 significand x = encodeFloat m (- floatDigits x)
276 where (m,_) = decodeFloat x
277 scaleFloat k x = encodeFloat m (n+k)
278 where (m,n) = decodeFloat x
282 | x<0 && y>0 = pi + atan (y/x)
284 (x<0 && isNegativeZero y) ||
285 (isNegativeZero x && isNegativeZero y)
287 | y==0 && (x<0 || isNegativeZero x)
288 = pi -- must be after the previous test on zero y
289 | x==0 && y==0 = y -- must be after the other double zero tests
290 | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
292 -- Numeric functions --------------------------------------------------------
294 subtract :: Num a => a -> a -> a
297 gcd :: Integral a => a -> a -> a
298 gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
299 gcd x y = gcd' (abs x) (abs y)
301 gcd' x y = gcd' y (x `rem` y)
303 lcm :: (Integral a) => a -> a -> a
306 lcm x y = abs ((x `quot` gcd x y) * y)
308 (^) :: (Num a, Integral b) => a -> b -> a
310 x ^ n | n > 0 = f x (n-1) x
312 f x n y = g x n where
313 g x n | even n = g (x*x) (n`quot`2)
314 | otherwise = f x (n-1) (x*y)
315 _ ^ _ = error "Prelude.^: negative exponent"
317 (^^) :: (Fractional a, Integral b) => a -> b -> a
318 x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
320 fromIntegral :: (Integral a, Num b) => a -> b
321 fromIntegral = fromInteger . toInteger
323 realToFrac :: (Real a, Fractional b) => a -> b
324 realToFrac = fromRational . toRational
326 -- Index and Enumeration classes --------------------------------------------
328 class (Ord a) => Ix a where
329 range :: (a,a) -> [a]
330 index :: (a,a) -> a -> Int
331 inRange :: (a,a) -> a -> Bool
332 rangeSize :: (a,a) -> Int
336 | otherwise = index r u + 1
342 enumFrom :: a -> [a] -- [n..]
343 enumFromThen :: a -> a -> [a] -- [n,m..]
344 enumFromTo :: a -> a -> [a] -- [n..m]
345 enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
347 -- Minimal complete definition: toEnum, fromEnum
348 succ = toEnum . (1+) . fromEnum
349 pred = toEnum . subtract 1 . fromEnum
350 enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
351 enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
353 -- Read and Show classes ------------------------------------------------------
355 type ReadS a = String -> [(a,String)]
356 type ShowS = String -> String
359 readsPrec :: Int -> ReadS a
360 readList :: ReadS [a]
362 -- Minimal complete definition: readsPrec
363 readList = readParen False (\r -> [pr | ("[",s) <- lex r,
365 where readl s = [([],t) | ("]",t) <- lex s] ++
366 [(x:xs,u) | (x,t) <- reads s,
368 readl' s = [([],t) | ("]",t) <- lex s] ++
369 [(x:xs,v) | (",",t) <- lex s,
375 showsPrec :: Int -> a -> ShowS
376 showList :: [a] -> ShowS
378 -- Minimal complete definition: show or showsPrec
379 show x = showsPrec 0 x ""
380 showsPrec _ x s = show x ++ s
381 showList [] = showString "[]"
382 showList (x:xs) = showChar '[' . shows x . showl xs
383 where showl [] = showChar ']'
384 showl (x:xs) = showChar ',' . shows x . showl xs
386 -- Monad classes ------------------------------------------------------------
388 class Functor f where
389 fmap :: (a -> b) -> (f a -> f b)
393 (>>=) :: m a -> (a -> m b) -> m b
394 (>>) :: m a -> m b -> m b
395 fail :: String -> m a
397 -- Minimal complete definition: (>>=), return
398 p >> q = p >>= \ _ -> q
401 accumulate :: Monad m => [m a] -> m [a]
402 accumulate [] = return []
403 accumulate (c:cs) = do x <- c
407 sequence :: Monad m => [m a] -> m ()
408 sequence = foldr (>>) (return ())
410 mapM :: Monad m => (a -> m b) -> [a] -> m [b]
411 mapM f = accumulate . map f
413 mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
414 mapM_ f = sequence . map f
416 (=<<) :: Monad m => (a -> m b) -> m a -> m b
419 -- Evaluation and strictness ------------------------------------------------
422 seq x y = --case primForce x of () -> y
425 ($!) :: (a -> b) -> a -> b
428 -- Trivial type -------------------------------------------------------------
430 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
435 instance Ord () where
441 inRange ((),()) () = True
443 instance Enum () where
447 enumFromThen () () = [()]
449 instance Read () where
450 readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
453 instance Show () where
454 showsPrec p () = showString "()"
456 instance Bounded () where
460 -- Boolean type -------------------------------------------------------------
462 data Bool = False | True
463 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
465 (&&), (||) :: Bool -> Bool -> Bool
478 -- Character type -----------------------------------------------------------
480 data Char -- builtin datatype of ISO Latin characters
481 type String = [Char] -- strings are lists of characters
483 instance Eq Char where (==) = primEqChar
484 instance Ord Char where (<=) = primLeChar
486 instance Enum Char where
487 toEnum = primIntToChar
488 fromEnum = primCharToInt
489 enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
490 enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
491 where lastChar = if d < c then minBound else maxBound
493 instance Ix Char where
494 range (c,c') = [c..c']
496 | inRange b ci = fromEnum ci - fromEnum c
497 | otherwise = error "Ix.index: Index out of range."
498 inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
499 where i = fromEnum ci
501 instance Read Char where
502 readsPrec p = readParen False
503 (\r -> [(c,t) | ('\'':s,t) <- lex r,
504 (c,"\'") <- readLitChar s ])
505 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
507 where readl ('"':s) = [("",s)]
508 readl ('\\':'&':s) = readl s
509 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
511 instance Show Char where
512 showsPrec p '\'' = showString "'\\''"
513 showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
515 showList cs = showChar '"' . showl cs
516 where showl "" = showChar '"'
517 showl ('"':cs) = showString "\\\"" . showl cs
518 showl (c:cs) = showLitChar c . showl cs
520 instance Bounded Char where
524 isAscii, isControl, isPrint, isSpace :: Char -> Bool
525 isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
527 isAscii c = fromEnum c < 128
528 isControl c = c < ' ' || c == '\DEL'
529 isPrint c = c >= ' ' && c <= '~'
530 isSpace c = c == ' ' || c == '\t' || c == '\n' ||
531 c == '\r' || c == '\f' || c == '\v'
532 isUpper c = c >= 'A' && c <= 'Z'
533 isLower c = c >= 'a' && c <= 'z'
534 isAlpha c = isUpper c || isLower c
535 isDigit c = c >= '0' && c <= '9'
536 isAlphaNum c = isAlpha c || isDigit c
538 -- Digit conversion operations
539 digitToInt :: Char -> Int
541 | isDigit c = fromEnum c - fromEnum '0'
542 | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
543 | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
544 | otherwise = error "Char.digitToInt: not a digit"
546 intToDigit :: Int -> Char
548 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
549 | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
550 | otherwise = error "Char.intToDigit: not a digit"
552 toUpper, toLower :: Char -> Char
553 toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
556 toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
565 -- Maybe type ---------------------------------------------------------------
567 data Maybe a = Nothing | Just a
568 deriving (Eq, Ord, Read, Show)
570 maybe :: b -> (a -> b) -> Maybe a -> b
571 maybe n f Nothing = n
572 maybe n f (Just x) = f x
574 instance Functor Maybe where
575 fmap f Nothing = Nothing
576 fmap f (Just x) = Just (f x)
578 instance Monad Maybe where
580 Nothing >>= k = Nothing
584 -- Either type --------------------------------------------------------------
586 data Either a b = Left a | Right b
587 deriving (Eq, Ord, Read, Show)
589 either :: (a -> c) -> (b -> c) -> Either a b -> c
590 either l r (Left x) = l x
591 either l r (Right y) = r y
593 -- Ordering type ------------------------------------------------------------
595 data Ordering = LT | EQ | GT
596 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
598 -- Lists --------------------------------------------------------------------
600 --data [a] = [] | a : [a] deriving (Eq, Ord)
602 instance Eq a => Eq [a] where
604 (x:xs) == (y:ys) = x==y && xs==ys
607 instance Ord a => Ord [a] where
608 compare [] (_:_) = LT
610 compare (_:_) [] = GT
611 compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
613 instance Functor [] where
616 instance Monad [ ] where
617 (x:xs) >>= f = f x ++ (xs >>= f)
622 instance Read a => Read [a] where
623 readsPrec p = readList
625 instance Show a => Show [a] where
626 showsPrec p = showList
628 -- Tuples -------------------------------------------------------------------
630 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
633 -- Functions ----------------------------------------------------------------
635 instance Show (a -> b) where
636 showsPrec p f = showString "<<function>>"
638 instance Functor ((->) a) where
641 -- Standard Integral types --------------------------------------------------
643 data Int -- builtin datatype of fixed size integers
644 data Integer -- builtin datatype of arbitrary size integers
646 instance Eq Integer where
647 (==) x y = primCompareInteger x y == 0
649 instance Ord Integer where
650 compare x y = case primCompareInteger x y of
655 instance Eq Int where
659 instance Ord Int where
665 instance Num Int where
668 negate = primNegateInt
672 fromInteger = primIntegerToInt
675 instance Bounded Int where
676 minBound = primMinInt
677 maxBound = primMaxInt
679 instance Num Integer where
680 (+) = primPlusInteger
681 (-) = primMinusInteger
682 negate = primNegateInteger
683 (*) = primTimesInteger
687 fromInt = primIntToInteger
689 absReal x | x >= 0 = x
692 signumReal x | x == 0 = 0
696 instance Real Int where
697 toRational x = toInteger x % 1
699 instance Real Integer where
702 instance Integral Int where
703 quotRem = primQuotRemInt
704 toInteger = primIntToInteger
707 instance Integral Integer where
708 quotRem = primQuotRemInteger
709 --divMod = primDivModInteger
711 toInt = primIntegerToInt
713 instance Ix Int where
716 | inRange b i = i - m
717 | otherwise = error "index: Index out of range"
718 inRange (m,n) i = m <= i && i <= n
720 instance Ix Integer where
723 | inRange b i = fromInteger (i - m)
724 | otherwise = error "index: Index out of range"
725 inRange (m,n) i = m <= i && i <= n
727 instance Enum Int where
730 enumFrom = numericEnumFrom
731 enumFromTo = numericEnumFromTo
732 enumFromThen = numericEnumFromThen
733 enumFromThenTo = numericEnumFromThenTo
735 instance Enum Integer where
736 toEnum = primIntToInteger
737 fromEnum = primIntegerToInt
738 enumFrom = numericEnumFrom
739 enumFromTo = numericEnumFromTo
740 enumFromThen = numericEnumFromThen
741 enumFromThenTo = numericEnumFromThenTo
743 numericEnumFrom :: Real a => a -> [a]
744 numericEnumFromThen :: Real a => a -> a -> [a]
745 numericEnumFromTo :: Real a => a -> a -> [a]
746 numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
747 numericEnumFrom n = n : (numericEnumFrom $! (n+1))
748 numericEnumFromThen n m = iterate ((m-n)+) n
749 numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
750 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
751 where p | n' >= n = (<= m)
754 instance Read Int where
755 readsPrec p = readSigned readDec
757 instance Show Int where
759 | n == minBound = showSigned showInt p (toInteger n)
760 | otherwise = showSigned showInt p n
762 instance Read Integer where
763 readsPrec p = readSigned readDec
765 instance Show Integer where
766 showsPrec = showSigned showInt
769 -- Standard Floating types --------------------------------------------------
771 data Float -- builtin datatype of single precision floating point numbers
772 data Double -- builtin datatype of double precision floating point numbers
774 instance Eq Float where
778 instance Ord Float where
784 instance Num Float where
787 negate = primNegateFloat
791 fromInteger = primIntegerToFloat
792 fromInt = primIntToFloat
796 instance Eq Double where
800 instance Ord Double where
806 instance Num Double where
808 (-) = primMinusDouble
809 negate = primNegateDouble
810 (*) = primTimesDouble
813 fromInteger = primIntegerToDouble
814 fromInt = primIntToDouble
818 instance Real Float where
819 toRational = floatToRational
821 instance Real Double where
822 toRational = doubleToRational
824 -- Calls to these functions are optimised when passed as arguments to
826 floatToRational :: Float -> Rational
827 doubleToRational :: Double -> Rational
828 floatToRational x = realFloatToRational x
829 doubleToRational x = realFloatToRational x
831 realFloatToRational x = (m%1)*(b%1)^^n
832 where (m,n) = decodeFloat x
835 instance Fractional Float where
836 (/) = primDivideFloat
837 fromRational = rationalToRealFloat
838 fromDouble = primDoubleToFloat
841 instance Fractional Double where
842 (/) = primDivideDouble
843 fromRational = rationalToRealFloat
846 rationalToRealFloat x = x'
848 f e = if e' == e then y else f e'
849 where y = encodeFloat (round (x * (1%b)^^e)) e
850 (_,e') = decodeFloat y
851 (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
852 / fromInteger (denominator x))
855 instance Floating Float where
856 pi = 3.14159265358979323846
867 instance Floating Double where
868 pi = 3.14159265358979323846
871 sqrt = primSqrtDouble
875 asin = primAsinDouble
876 acos = primAcosDouble
877 atan = primAtanDouble
879 instance RealFrac Float where
880 properFraction = floatProperFraction
882 instance RealFrac Double where
883 properFraction = floatProperFraction
885 floatProperFraction x
886 | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
887 | otherwise = (fromInteger w, encodeFloat r n)
888 where (m,n) = decodeFloat x
890 (w,r) = quotRem m (b^(-n))
892 instance RealFloat Float where
893 floatRadix _ = toInteger primRadixFloat
894 floatDigits _ = primDigitsFloat
895 floatRange _ = (primMinExpFloat,primMaxExpFloat)
896 encodeFloat = primEncodeFloatZ
897 decodeFloat = primDecodeFloatZ
898 isNaN = primIsNaNFloat
899 isInfinite = primIsInfiniteFloat
900 isDenormalized= primIsDenormalizedFloat
901 isNegativeZero= primIsNegativeZeroFloat
902 isIEEE = const primIsIEEEFloat
904 instance RealFloat Double where
905 floatRadix _ = toInteger primRadixDouble
906 floatDigits _ = primDigitsDouble
907 floatRange _ = (primMinExpDouble,primMaxExpDouble)
908 encodeFloat = primEncodeDoubleZ
909 decodeFloat = primDecodeDoubleZ
910 isNaN = primIsNaNDouble
911 isInfinite = primIsInfiniteDouble
912 isDenormalized= primIsDenormalizedDouble
913 isNegativeZero= primIsNegativeZeroDouble
914 isIEEE = const primIsIEEEDouble
916 instance Enum Float where
917 toEnum = primIntToFloat
919 enumFrom = numericEnumFrom
920 enumFromThen = numericEnumFromThen
921 enumFromTo n m = numericEnumFromTo n (m+1/2)
922 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
924 instance Enum Double where
925 toEnum = primIntToDouble
927 enumFrom = numericEnumFrom
928 enumFromThen = numericEnumFromThen
929 enumFromTo n m = numericEnumFromTo n (m+1/2)
930 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
932 instance Read Float where
933 readsPrec p = readSigned readFloat
935 instance Show Float where
936 showsPrec p = showSigned showFloat p
938 instance Read Double where
939 readsPrec p = readSigned readFloat
941 instance Show Double where
942 showsPrec p = showSigned showFloat p
945 -- Some standard functions --------------------------------------------------
953 curry :: ((a,b) -> c) -> (a -> b -> c)
954 curry f x y = f (x,y)
956 uncurry :: (a -> b -> c) -> ((a,b) -> c)
957 uncurry f p = f (fst p) (snd p)
965 (.) :: (b -> c) -> (a -> b) -> (a -> c)
968 flip :: (a -> b -> c) -> b -> a -> c
971 ($) :: (a -> b) -> a -> b
974 until :: (a -> Bool) -> (a -> a) -> a -> a
975 until p f x = if p x then x else until p f (f x)
977 asTypeOf :: a -> a -> a
981 error msg = primRaise (ErrorCall msg)
984 undefined | False = undefined
986 -- Standard functions on rational numbers {PreludeRatio} --------------------
988 data Integral a => Ratio a = a :% a deriving (Eq)
989 type Rational = Ratio Integer
991 (%) :: Integral a => a -> a -> Ratio a
992 x % y = reduce (x * signum y) (abs y)
994 reduce :: Integral a => a -> a -> Ratio a
995 reduce x y | y == 0 = error "Ratio.%: zero denominator"
996 | otherwise = (x `quot` d) :% (y `quot` d)
999 numerator, denominator :: Integral a => Ratio a -> a
1000 numerator (x :% y) = x
1001 denominator (x :% y) = y
1003 instance Integral a => Ord (Ratio a) where
1004 compare (x:%y) (x':%y') = compare (x*y') (x'*y)
1006 instance Integral a => Num (Ratio a) where
1007 (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
1008 (x:%y) * (x':%y') = reduce (x*x') (y*y')
1009 negate (x :% y) = negate x :% y
1010 abs (x :% y) = abs x :% y
1011 signum (x :% y) = signum x :% 1
1012 fromInteger x = fromInteger x :% 1
1013 fromInt = intToRatio
1015 -- Hugs optimises code of the form fromRational (intToRatio x)
1016 intToRatio :: Integral a => Int -> Ratio a
1017 intToRatio x = fromInt x :% 1
1019 instance Integral a => Real (Ratio a) where
1020 toRational (x:%y) = toInteger x :% toInteger y
1022 instance Integral a => Fractional (Ratio a) where
1023 (x:%y) / (x':%y') = (x*y') % (y*x')
1024 recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
1025 fromRational (x:%y) = fromInteger x :% fromInteger y
1026 fromDouble = doubleToRatio
1028 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1029 doubleToRatio :: Integral a => Double -> Ratio a
1031 | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
1032 | otherwise = fromInteger m % (fromInteger b ^ (-n))
1033 where (m,n) = decodeFloat x
1036 instance Integral a => RealFrac (Ratio a) where
1037 properFraction (x:%y) = (fromIntegral q, r:%y)
1038 where (q,r) = quotRem x y
1040 instance Integral a => Enum (Ratio a) where
1043 enumFrom = numericEnumFrom
1044 enumFromThen = numericEnumFromThen
1046 instance (Read a, Integral a) => Read (Ratio a) where
1047 readsPrec p = readParen (p > 7)
1048 (\r -> [(x%y,u) | (x,s) <- reads r,
1052 instance Integral a => Show (Ratio a) where
1053 showsPrec p (x:%y) = showParen (p > 7)
1054 (shows x . showString " % " . shows y)
1056 approxRational :: RealFrac a => a -> a -> Rational
1057 approxRational x eps = simplest (x-eps) (x+eps)
1058 where simplest x y | y < x = simplest y x
1060 | x > 0 = simplest' n d n' d'
1061 | y < 0 = - simplest' (-n') d' (-n) d
1062 | otherwise = 0 :% 1
1063 where xr@(n:%d) = toRational x
1064 (n':%d') = toRational y
1065 simplest' n d n' d' -- assumes 0 < n%d < n'%d'
1067 | q /= q' = (q+1) :% 1
1068 | otherwise = (q*n''+d'') :% n''
1069 where (q,r) = quotRem n d
1070 (q',r') = quotRem n' d'
1071 (n'':%d'') = simplest' d' r' d r
1073 -- Standard list functions {PreludeList} ------------------------------------
1080 last (_:xs) = last xs
1087 init (x:xs) = x : init xs
1093 (++) :: [a] -> [a] -> [a]
1095 (x:xs) ++ ys = x : (xs ++ ys)
1097 map :: (a -> b) -> [a] -> [b]
1098 map f xs = [ f x | x <- xs ]
1100 filter :: (a -> Bool) -> [a] -> [a]
1101 filter p xs = [ x | x <- xs, p x ]
1103 concat :: [[a]] -> [a]
1104 concat = foldr (++) []
1106 length :: [a] -> Int
1107 length = foldl' (\n _ -> n + 1) 0
1109 (!!) :: [b] -> Int -> b
1111 (_:xs) !! n | n>0 = xs !! (n-1)
1112 (_:_) !! _ = error "Prelude.!!: negative index"
1113 [] !! _ = error "Prelude.!!: index too large"
1115 foldl :: (a -> b -> a) -> a -> [b] -> a
1117 foldl f z (x:xs) = foldl f (f z x) xs
1119 foldl' :: (a -> b -> a) -> a -> [b] -> a
1121 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1123 foldl1 :: (a -> a -> a) -> [a] -> a
1124 foldl1 f (x:xs) = foldl f x xs
1126 scanl :: (a -> b -> a) -> a -> [b] -> [a]
1127 scanl f q xs = q : (case xs of
1129 x:xs -> scanl f (f q x) xs)
1131 scanl1 :: (a -> a -> a) -> [a] -> [a]
1132 scanl1 f (x:xs) = scanl f x xs
1134 foldr :: (a -> b -> b) -> b -> [a] -> b
1136 foldr f z (x:xs) = f x (foldr f z xs)
1138 foldr1 :: (a -> a -> a) -> [a] -> a
1140 foldr1 f (x:xs) = f x (foldr1 f xs)
1142 scanr :: (a -> b -> b) -> b -> [a] -> [b]
1143 scanr f q0 [] = [q0]
1144 scanr f q0 (x:xs) = f x q : qs
1145 where qs@(q:_) = scanr f q0 xs
1147 scanr1 :: (a -> a -> a) -> [a] -> [a]
1149 scanr1 f (x:xs) = f x q : qs
1150 where qs@(q:_) = scanr1 f xs
1152 iterate :: (a -> a) -> a -> [a]
1153 iterate f x = x : iterate f (f x)
1156 repeat x = xs where xs = x:xs
1158 replicate :: Int -> a -> [a]
1159 replicate n x = take n (repeat x)
1162 cycle [] = error "Prelude.cycle: empty list"
1163 cycle xs = xs' where xs'=xs++xs'
1165 take :: Int -> [a] -> [a]
1168 take n (x:xs) | n>0 = x : take (n-1) xs
1169 take _ _ = error "Prelude.take: negative argument"
1171 drop :: Int -> [a] -> [a]
1174 drop n (_:xs) | n>0 = drop (n-1) xs
1175 drop _ _ = error "Prelude.drop: negative argument"
1177 splitAt :: Int -> [a] -> ([a], [a])
1178 splitAt 0 xs = ([],xs)
1179 splitAt _ [] = ([],[])
1180 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1181 splitAt _ _ = error "Prelude.splitAt: negative argument"
1183 takeWhile :: (a -> Bool) -> [a] -> [a]
1186 | p x = x : takeWhile p xs
1189 dropWhile :: (a -> Bool) -> [a] -> [a]
1191 dropWhile p xs@(x:xs')
1192 | p x = dropWhile p xs'
1195 span, break :: (a -> Bool) -> [a] -> ([a],[a])
1199 | otherwise = ([],xs)
1200 where (ys,zs) = span p xs'
1201 break p = span (not . p)
1203 lines :: String -> [String]
1205 lines s = let (l,s') = break ('\n'==) s
1206 in l : case s' of [] -> []
1207 (_:s'') -> lines s''
1209 words :: String -> [String]
1210 words s = case dropWhile isSpace s of
1213 where (w,s'') = break isSpace s'
1215 unlines :: [String] -> String
1216 unlines = concatMap (\l -> l ++ "\n")
1218 unwords :: [String] -> String
1220 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1222 reverse :: [a] -> [a]
1223 reverse = foldl (flip (:)) []
1225 and, or :: [Bool] -> Bool
1226 and = foldr (&&) True
1227 or = foldr (||) False
1229 any, all :: (a -> Bool) -> [a] -> Bool
1233 elem, notElem :: Eq a => a -> [a] -> Bool
1235 notElem = all . (/=)
1237 lookup :: Eq a => a -> [(a,b)] -> Maybe b
1238 lookup k [] = Nothing
1239 lookup k ((x,y):xys)
1241 | otherwise = lookup k xys
1243 sum, product :: Num a => [a] -> a
1245 product = foldl' (*) 1
1247 maximum, minimum :: Ord a => [a] -> a
1248 maximum = foldl1 max
1249 minimum = foldl1 min
1251 concatMap :: (a -> [b]) -> [a] -> [b]
1252 concatMap f = concat . map f
1254 zip :: [a] -> [b] -> [(a,b)]
1255 zip = zipWith (\a b -> (a,b))
1257 zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
1258 zip3 = zipWith3 (\a b c -> (a,b,c))
1260 zipWith :: (a->b->c) -> [a]->[b]->[c]
1261 zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
1264 zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1265 zipWith3 z (a:as) (b:bs) (c:cs)
1266 = z a b c : zipWith3 z as bs cs
1267 zipWith3 _ _ _ _ = []
1269 unzip :: [(a,b)] -> ([a],[b])
1270 unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1272 unzip3 :: [(a,b,c)] -> ([a],[b],[c])
1273 unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1276 -- PreludeText ----------------------------------------------------------------
1278 reads :: Read a => ReadS a
1281 shows :: Show a => a -> ShowS
1284 read :: Read a => String -> a
1285 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1287 [] -> error "Prelude.read: no parse"
1288 _ -> error "Prelude.read: ambiguous parse"
1290 showChar :: Char -> ShowS
1293 showString :: String -> ShowS
1296 showParen :: Bool -> ShowS -> ShowS
1297 showParen b p = if b then showChar '(' . p . showChar ')' else p
1299 showField :: Show a => String -> a -> ShowS
1300 showField m v = showString m . showChar '=' . shows v
1302 readParen :: Bool -> ReadS a -> ReadS a
1303 readParen b g = if b then mandatory else optional
1304 where optional r = g r ++ mandatory r
1305 mandatory r = [(x,u) | ("(",s) <- lex r,
1306 (x,t) <- optional s,
1310 readField :: Read a => String -> ReadS a
1311 readField m s0 = [ r | (t, s1) <- lex s0, t == m,
1317 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1318 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1320 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1322 lexString ('"':s) = [("\"",s)]
1323 lexString s = [(ch++str, u)
1324 | (ch,t) <- lexStrItem s,
1325 (str,u) <- lexString t ]
1327 lexStrItem ('\\':'&':s) = [("\\&",s)]
1328 lexStrItem ('\\':c:s) | isSpace c
1329 = [("",t) | '\\':t <- [dropWhile isSpace s]]
1330 lexStrItem s = lexLitChar s
1332 lex (c:s) | isSingle c = [([c],s)]
1333 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
1334 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
1335 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
1336 (fe,t) <- lexFracExp s ]
1337 | otherwise = [] -- bad character
1339 isSingle c = c `elem` ",;()[]{}_`"
1340 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1341 isIdChar c = isAlphaNum c || c `elem` "_'"
1343 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1345 lexFracExp s = [("",s)]
1347 lexExp (e:s) | e `elem` "eE"
1348 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
1349 (ds,u) <- lexDigits t] ++
1350 [(e:ds,t) | (ds,t) <- lexDigits s]
1353 lexDigits :: ReadS String
1354 lexDigits = nonnull isDigit
1356 nonnull :: (Char -> Bool) -> ReadS String
1357 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1359 lexLitChar :: ReadS String
1360 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1362 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
1363 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
1364 lexEsc s@(d:_) | isDigit d = lexDigits s
1365 lexEsc s@(c:_) | isUpper c
1366 = let table = ('\DEL',"DEL") : asciiTab
1367 in case [(mne,s') | (c, mne) <- table,
1368 ([],s') <- [lexmatch mne s]]
1372 lexLitChar (c:s) = [([c],s)]
1375 isOctDigit c = c >= '0' && c <= '7'
1376 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
1377 || c >= 'a' && c <= 'f'
1379 lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
1380 lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
1381 lexmatch xs ys = (xs,ys)
1383 asciiTab = zip ['\NUL'..' ']
1384 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1385 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
1386 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1387 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
1390 readLitChar :: ReadS Char
1391 readLitChar ('\\':s) = readEsc s
1393 readEsc ('a':s) = [('\a',s)]
1394 readEsc ('b':s) = [('\b',s)]
1395 readEsc ('f':s) = [('\f',s)]
1396 readEsc ('n':s) = [('\n',s)]
1397 readEsc ('r':s) = [('\r',s)]
1398 readEsc ('t':s) = [('\t',s)]
1399 readEsc ('v':s) = [('\v',s)]
1400 readEsc ('\\':s) = [('\\',s)]
1401 readEsc ('"':s) = [('"',s)]
1402 readEsc ('\'':s) = [('\'',s)]
1403 readEsc ('^':c:s) | c >= '@' && c <= '_'
1404 = [(toEnum (fromEnum c - fromEnum '@'), s)]
1405 readEsc s@(d:_) | isDigit d
1406 = [(toEnum n, t) | (n,t) <- readDec s]
1407 readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
1408 readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
1409 readEsc s@(c:_) | isUpper c
1410 = let table = ('\DEL',"DEL") : asciiTab
1411 in case [(c,s') | (c, mne) <- table,
1412 ([],s') <- [lexmatch mne s]]
1416 readLitChar (c:s) = [(c,s)]
1418 showLitChar :: Char -> ShowS
1419 showLitChar c | c > '\DEL' = showChar '\\' .
1420 protectEsc isDigit (shows (fromEnum c))
1421 showLitChar '\DEL' = showString "\\DEL"
1422 showLitChar '\\' = showString "\\\\"
1423 showLitChar c | c >= ' ' = showChar c
1424 showLitChar '\a' = showString "\\a"
1425 showLitChar '\b' = showString "\\b"
1426 showLitChar '\f' = showString "\\f"
1427 showLitChar '\n' = showString "\\n"
1428 showLitChar '\r' = showString "\\r"
1429 showLitChar '\t' = showString "\\t"
1430 showLitChar '\v' = showString "\\v"
1431 showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
1432 showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
1434 protectEsc p f = f . cont
1435 where cont s@(c:_) | p c = "\\&" ++ s
1438 -- Unsigned readers for various bases
1439 readDec, readOct, readHex :: Integral a => ReadS a
1440 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1441 readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1442 readHex = readInt 16 isHexDigit hex
1443 where hex d = fromEnum d -
1446 else fromEnum (if isUpper d then 'A' else 'a') - 10)
1448 -- readInt reads a string of digits using an arbitrary base.
1449 -- Leading minus signs must be handled elsewhere.
1451 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1452 readInt radix isDig digToInt s =
1453 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1454 | (ds,r) <- nonnull isDig s ]
1456 -- showInt is used for positive numbers only
1457 showInt :: Integral a => a -> ShowS
1460 = error "Numeric.showInt: can't show negative numbers"
1463 = let (n',d) = quotRem n 10
1464 r' = toEnum (fromEnum '0' + fromIntegral d) : r
1465 in if n' == 0 then r' else showInt n' r'
1467 = case quotRem n 10 of { (n',d) ->
1468 let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1469 in if n' == 0 then r' else showInt n' r'
1473 readSigned:: Real a => ReadS a -> ReadS a
1474 readSigned readPos = readParen False read'
1475 where read' r = read'' r ++
1476 [(-x,t) | ("-",s) <- lex r,
1478 read'' r = [(n,s) | (str,s) <- lex r,
1479 (n,"") <- readPos str]
1481 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1482 showSigned showPos p x = if x < 0 then showParen (p > 6)
1483 (showChar '-' . showPos (-x))
1486 readFloat :: RealFloat a => ReadS a
1487 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1489 where readFix r = [(read (ds++ds'), length ds', t)
1490 | (ds, s) <- lexDigits r
1491 , (ds',t) <- lexFrac s ]
1493 lexFrac ('.':s) = lexDigits s
1494 lexFrac s = [("",s)]
1496 readExp (e:s) | e `elem` "eE" = readExp' s
1499 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1500 readExp' ('+':s) = readDec s
1501 readExp' s = readDec s
1504 -- Hooks for primitives: -----------------------------------------------------
1505 -- Do not mess with these!
1507 primCompAux :: Ord a => a -> a -> Ordering -> Ordering
1508 primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1510 primPmInt :: Num a => Int -> a -> Bool
1511 primPmInt n x = fromInt n == x
1513 primPmInteger :: Num a => Integer -> a -> Bool
1514 primPmInteger n x = fromInteger n == x
1516 primPmFlt :: Fractional a => Double -> a -> Bool
1517 primPmFlt n x = fromDouble n == x
1519 -- ToDo: make the message more informative.
1521 primPmFail = error "Pattern Match Failure"
1523 -- used in desugaring Foreign functions
1524 primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1527 -- The following primitives are only needed if (n+k) patterns are enabled:
1528 primPmNpk :: Integral a => Int -> a -> Maybe a
1529 primPmNpk n x = if n'<=x then Just (x-n') else Nothing
1530 where n' = fromInt n
1532 primPmSub :: Integral a => Int -> a -> a
1533 primPmSub n x = x - fromInt n
1535 -- Unpack strings generated by the Hugs code generator.
1536 -- Strings can contain \0 provided they're coded right.
1538 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1540 primUnpackString :: Addr -> String
1541 primUnpackString a = unpack 0
1543 -- The following decoding is based on evalString in the old machine.c
1546 | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1547 then '\\' : unpack (i+2)
1548 else '\0' : unpack (i+2)
1549 | otherwise = c : unpack (i+1)
1551 c = primIndexCharOffAddr a i
1554 -- Monadic I/O: --------------------------------------------------------------
1556 type FilePath = String
1558 --data IOError = ...
1559 --instance Eq IOError ...
1560 --instance Show IOError ...
1562 data IOError = IOError String
1563 instance Show IOError where
1564 showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1566 ioError :: IOError -> IO a
1567 ioError (IOError s) = primRaise (IOExcept s)
1569 userError :: String -> IOError
1570 userError s = primRaise (ErrorCall s)
1572 catch :: IO a -> (IOError -> IO a) -> IO a
1574 = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
1576 e2ioe (IOExcept s) = IOError s
1577 e2ioe other = IOError (show other)
1579 putChar :: Char -> IO ()
1580 putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c)
1582 putStr :: String -> IO ()
1583 putStr s = --mapM_ putChar s -- correct, but slow
1585 let loop [] = return ()
1586 loop (c:cs) = nh_write h (primCharToInt c) >> loop cs
1589 putStrLn :: String -> IO ()
1590 putStrLn s = do { putStr s; putChar '\n' }
1592 print :: Show a => a -> IO ()
1593 print = putStrLn . show
1596 getChar = unsafeInterleaveIO (
1598 nh_read h >>= \ci ->
1599 return (primIntToChar ci)
1602 getLine :: IO String
1603 getLine = do c <- getChar
1604 if c=='\n' then return ""
1605 else do cs <- getLine
1608 getContents :: IO String
1609 getContents = nh_stdin >>= \h -> readfromhandle h
1611 interact :: (String -> String) -> IO ()
1612 interact f = getContents >>= (putStr . f)
1614 readFile :: FilePath -> IO String
1616 = copy_String_to_cstring fname >>= \ptr ->
1617 nh_open ptr 0 >>= \h ->
1619 nh_errno >>= \errno ->
1620 if (h == 0 || errno /= 0)
1621 then (ioError.IOError) ("readFile: can't open file " ++ fname)
1622 else readfromhandle h
1624 writeFile :: FilePath -> String -> IO ()
1625 writeFile fname contents
1626 = copy_String_to_cstring fname >>= \ptr ->
1627 nh_open ptr 1 >>= \h ->
1629 nh_errno >>= \errno ->
1630 if (h == 0 || errno /= 0)
1631 then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1632 else writetohandle fname h contents
1635 appendFile :: FilePath -> String -> IO ()
1636 appendFile fname contents
1637 = copy_String_to_cstring fname >>= \ptr ->
1638 nh_open ptr 2 >>= \h ->
1640 nh_errno >>= \errno ->
1641 if (h == 0 || errno /= 0)
1642 then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1643 else writetohandle fname h contents
1646 -- raises an exception instead of an error
1647 readIO :: Read a => String -> IO a
1648 readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1650 [] -> ioError (userError "PreludeIO.readIO: no parse")
1651 _ -> ioError (userError
1652 "PreludeIO.readIO: ambiguous parse")
1654 readLn :: Read a => IO a
1655 readLn = do l <- getLine
1660 -- End of Hugs standard prelude ----------------------------------------------
1666 instance Show Exception where
1667 showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1668 showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
1670 data IOResult = IOResult deriving (Show)
1672 type FILE_STAR = Int -- FILE *
1673 type Ptr = Int -- char *
1675 foreign import stdcall "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR
1676 foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR
1677 foreign import stdcall "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR
1678 foreign import stdcall "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO ()
1679 foreign import stdcall "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int
1680 foreign import stdcall "nHandle.so" "nh_open" nh_open :: Int -> Int -> IO FILE_STAR
1681 foreign import stdcall "nHandle.so" "nh_flush" nh_flush :: FILE_STAR -> IO ()
1682 foreign import stdcall "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO ()
1683 foreign import stdcall "nHandle.so" "nh_errno" nh_errno :: IO Int
1685 foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Ptr
1686 foreign import stdcall "nHandle.so" "nh_free" nh_free :: Ptr -> IO ()
1687 foreign import stdcall "nHandle.so" "nh_store" nh_store :: Ptr -> Int -> IO ()
1688 foreign import stdcall "nHandle.so" "nh_load" nh_load :: Ptr -> IO Int
1690 foreign import stdcall "nHandle.so" "nh_argc" nh_argc :: IO Int
1691 foreign import stdcall "nHandle.so" "nh_argvb" nh_argvb :: Int -> Int -> IO Int
1692 foreign import stdcall "nHandle.so" "nh_getenv" nh_getenv :: Ptr -> IO Ptr
1694 copy_String_to_cstring :: String -> IO Ptr
1695 copy_String_to_cstring s
1696 = nh_malloc (1 + length s) >>= \ptr0 ->
1697 let loop ptr [] = nh_store ptr 0 >> return ptr0
1698 loop ptr (c:cs) = --trace ("Out `" ++ [c] ++ "'") (
1699 nh_store ptr (primCharToInt c) >> loop (ptr+1) cs
1704 copy_cstring_to_String :: Ptr -> IO String
1705 copy_cstring_to_String ptr
1706 = nh_load ptr >>= \ci ->
1709 else copy_cstring_to_String (ptr+1) >>= \cs ->
1710 --trace ("In " ++ show ci) (
1711 return ((primIntToChar ci) : cs)
1714 readfromhandle :: FILE_STAR -> IO String
1716 = unsafeInterleaveIO (
1717 nh_read h >>= \ci ->
1718 if ci == -1 {-EOF-} then return "" else
1719 readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1722 writetohandle :: String -> FILE_STAR -> String -> IO ()
1723 writetohandle fname h []
1725 nh_errno >>= \errno ->
1728 else error ( "writeFile/appendFile: error closing file " ++ fname)
1729 writetohandle fname h (c:cs)
1730 = nh_write h (primCharToInt c) >>
1731 writetohandle fname h cs
1733 primGetRawArgs :: IO [String]
1735 = nh_argc >>= \argc ->
1736 accumulate (map (get_one_arg 0) [0 .. argc-1])
1738 get_one_arg :: Int -> Int -> IO String
1739 get_one_arg offset argno
1740 = nh_argvb argno offset >>= \cb ->
1743 else get_one_arg (offset+1) argno >>= \s ->
1744 return ((primIntToChar cb):s)
1746 primGetEnv :: String -> IO String
1748 = copy_String_to_cstring v >>= \ptr ->
1749 nh_getenv ptr >>= \ptr2 ->
1754 copy_cstring_to_String ptr2 >>= \result ->
1758 ------------------------------------------------------------------------------
1759 -- ST, IO --------------------------------------------------------------------
1760 ------------------------------------------------------------------------------
1762 newtype ST s a = ST (s -> (a,s))
1765 type IO a = ST RealWorld a
1768 --primRunST :: (forall s. ST s a) -> a
1769 primRunST :: ST RealWorld a -> a
1770 primRunST m = fst (unST m theWorld)
1772 theWorld :: RealWorld
1773 theWorld = error "primRunST: entered the RealWorld"
1777 instance Functor (ST s) where
1778 fmap f x = x >>= (return . f)
1780 instance Monad (ST s) where
1781 m >> k = m >>= \ _ -> k
1782 return x = ST $ \ s -> (x,s)
1783 m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' }
1786 -- used when Hugs invokes top level function
1787 primRunIO :: IO () -> ()
1789 = protect (fst (unST m realWorld))
1791 realWorld = error "panic: Hugs entered the real world"
1794 = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1796 trace :: String -> a -> a
1798 = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x
1800 unsafeInterleaveST :: ST s a -> ST s a
1801 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1803 unsafeInterleaveIO :: IO a -> IO a
1804 unsafeInterleaveIO = unsafeInterleaveST
1807 ------------------------------------------------------------------------------
1808 -- Word, Addr, ForeignObj, Prim*Array ----------------------------------------
1809 ------------------------------------------------------------------------------
1813 nullAddr = primIntToAddr 0
1815 instance Eq Addr where
1819 instance Ord Addr where
1828 instance Eq Word where
1832 instance Ord Word where
1840 --makeForeignObj :: Addr -> IO ForeignObj
1841 --makeForeignObj = primMakeForeignObj
1844 data PrimArray a -- immutable arrays with Int indices
1847 data Ref s a -- mutable variables
1848 data PrimMutableArray s a -- mutable arrays with Int indices
1849 data PrimMutableByteArray s
1853 ------------------------------------------------------------------------------
1854 -- hooks to call libHS_cbits -------------------------------------------------
1855 ------------------------------------------------------------------------------
1857 type FILE_OBJ = ForeignObj -- as passed into functions
1858 type CString = PrimByteArray
1861 type OpenFlags = Int
1862 type IOFileAddr = Addr -- as returned from functions
1864 type OpenStdFlags = Int
1865 type Readable = Int -- really Bool
1866 type Exclusive = Int -- really Bool
1867 type RC = Int -- standard return code
1868 type Bytes = PrimMutableByteArray RealWorld
1869 type Flush = Int -- really Bool
1871 foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
1872 freeStdFileObject :: ForeignObj -> IO ()
1874 foreign import stdcall "libHS_cbits.so" "freeFileObject"
1875 freeFileObject :: ForeignObj -> IO ()
1877 foreign import stdcall "libHS_cbits.so" "setBuf"
1878 prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO ()
1880 foreign import stdcall "libHS_cbits.so" "getBufSize"
1881 prim_getBufSize :: FILE_OBJ -> IO Int
1883 foreign import stdcall "libHS_cbits.so" "inputReady"
1884 prim_inputReady :: FILE_OBJ -> Int -> IO RC
1886 foreign import stdcall "libHS_cbits.so" "fileGetc"
1887 prim_fileGetc :: FILE_OBJ -> IO Int
1889 foreign import stdcall "libHS_cbits.so" "fileLookAhead"
1890 prim_fileLookAhead :: FILE_OBJ -> IO Int
1892 foreign import stdcall "libHS_cbits.so" "readBlock"
1893 prim_readBlock :: FILE_OBJ -> IO Int
1895 foreign import stdcall "libHS_cbits.so" "readLine"
1896 prim_readLine :: FILE_OBJ -> IO Int
1898 foreign import stdcall "libHS_cbits.so" "readChar"
1899 prim_readChar :: FILE_OBJ -> IO Int
1901 foreign import stdcall "libHS_cbits.so" "writeFileObject"
1902 prim_writeFileObject :: FILE_OBJ -> Int -> IO RC
1904 foreign import stdcall "libHS_cbits.so" "filePutc"
1905 prim_filePutc :: FILE_OBJ -> Char -> IO RC
1907 foreign import stdcall "libHS_cbits.so" "getBufStart"
1908 prim_getBufStart :: FILE_OBJ -> Int -> IO Addr
1910 foreign import stdcall "libHS_cbits.so" "getWriteableBuf"
1911 prim_getWriteableBuf :: FILE_OBJ -> IO Addr
1913 foreign import stdcall "libHS_cbits.so" "getBufWPtr"
1914 prim_getBufWPtr :: FILE_OBJ -> IO Int
1916 foreign import stdcall "libHS_cbits.so" "setBufWPtr"
1917 prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
1919 foreign import stdcall "libHS_cbits.so" "closeFile"
1920 prim_closeFile :: FILE_OBJ -> Flush -> IO RC
1922 foreign import stdcall "libHS_cbits.so" "fileEOF"
1923 prim_fileEOF :: FILE_OBJ -> IO RC
1925 foreign import stdcall "libHS_cbits.so" "setBuffering"
1926 prim_setBuffering :: FILE_OBJ -> Int -> IO RC
1928 foreign import stdcall "libHS_cbits.so" "flushFile"
1929 prim_flushFile :: FILE_OBJ -> IO RC
1931 foreign import stdcall "libHS_cbits.so" "getBufferMode"
1932 prim_getBufferMode :: FILE_OBJ -> IO RC
1934 foreign import stdcall "libHS_cbits.so" "seekFileP"
1935 prim_seekFileP :: FILE_OBJ -> IO RC
1937 foreign import stdcall "libHS_cbits.so" "setTerminalEcho"
1938 prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
1940 foreign import stdcall "libHS_cbits.so" "getTerminalEcho"
1941 prim_getTerminalEcho :: FILE_OBJ -> IO RC
1943 foreign import stdcall "libHS_cbits.so" "isTerminalDevice"
1944 prim_isTerminalDevice :: FILE_OBJ -> IO RC
1946 foreign import stdcall "libHS_cbits.so" "setConnectedTo"
1947 prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
1949 foreign import stdcall "libHS_cbits.so" "ungetChar"
1950 prim_ungetChar :: FILE_OBJ -> Char -> IO RC
1952 foreign import stdcall "libHS_cbits.so" "readChunk"
1953 prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC
1955 foreign import stdcall "libHS_cbits.so" "writeBuf"
1956 prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC
1958 foreign import stdcall "libHS_cbits.so" "getFileFd"
1959 prim_getFileFd :: FILE_OBJ -> IO FD
1961 foreign import stdcall "libHS_cbits.so" "fileSize_int64"
1962 prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC
1964 foreign import stdcall "libHS_cbits.so" "getFilePosn"
1965 prim_getFilePosn :: FILE_OBJ -> IO Int
1967 foreign import stdcall "libHS_cbits.so" "setFilePosn"
1968 prim_setFilePosn :: FILE_OBJ -> Int -> IO Int
1970 foreign import stdcall "libHS_cbits.so" "getConnFileFd"
1971 prim_getConnFileFd :: FILE_OBJ -> IO FD
1973 foreign import stdcall "libHS_cbits.so" "allocMemory__"
1974 prim_allocMemory__ :: Int -> IO Addr
1976 foreign import stdcall "libHS_cbits.so" "getLock"
1977 prim_getLock :: FD -> Exclusive -> IO RC
1979 foreign import stdcall "libHS_cbits.so" "openStdFile"
1980 prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
1982 foreign import stdcall "libHS_cbits.so" "openFile"
1983 prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
1985 foreign import stdcall "libHS_cbits.so" "freeFileObject"
1986 prim_freeFileObject :: FILE_OBJ -> IO ()
1988 foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
1989 prim_freeStdFileObject :: FILE_OBJ -> IO ()
1991 foreign import stdcall "libHS_cbits.so" "const_BUFSIZ"
1994 foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__"
1995 prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1997 foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__"
1998 prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
2000 foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__"
2001 prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
2003 foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__"
2004 prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
2006 foreign import stdcall "libHS_cbits.so" "getErrStr__"
2007 prim_getErrStr__ :: IO Addr
2009 foreign import stdcall "libHS_cbits.so" "getErrNo__"
2010 prim_getErrNo__ :: IO Int
2012 foreign import stdcall "libHS_cbits.so" "getErrType__"
2013 prim_getErrType__ :: IO Int
2015 --foreign import stdcall "libHS_cbits.so" "seekFile_int64"
2016 -- prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
2019 -- showFloat ------------------------------------------------------------------
2021 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2022 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2023 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2024 showFloat :: (RealFloat a) => a -> ShowS
2026 showEFloat d x = showString (formatRealFloat FFExponent d x)
2027 showFFloat d x = showString (formatRealFloat FFFixed d x)
2028 showGFloat d x = showString (formatRealFloat FFGeneric d x)
2029 showFloat = showGFloat Nothing
2031 -- These are the format types. This type is not exported.
2033 data FFFormat = FFExponent | FFFixed | FFGeneric
2035 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2036 formatRealFloat fmt decs x = s
2040 else if isInfinite x then
2041 if x < 0 then "-Infinity" else "Infinity"
2042 else if x < 0 || isNegativeZero x then
2043 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2045 doFmt fmt (floatToDigits (toInteger base) x)
2047 let ds = map intToDigit is
2050 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2057 [d] -> d : ".0e" ++ show (e-1)
2058 d:ds -> d : '.' : ds ++ 'e':show (e-1)
2060 let dec' = max dec 1 in
2062 [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2064 let (ei, is') = roundTo base (dec'+1) is
2065 d:ds = map intToDigit
2066 (if ei > 0 then init is' else is')
2067 in d:'.':ds ++ "e" ++ show (e-1+ei)
2071 let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2072 f n s "" = f (n-1) (s++"0") ""
2073 f n s (d:ds) = f (n-1) (s++[d]) ds
2078 let dec' = max dec 0 in
2080 let (ei, is') = roundTo base (dec' + e) is
2081 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2082 in (if null ls then "0" else ls) ++
2083 (if null rs then "" else '.' : rs)
2085 let (ei, is') = roundTo base dec'
2086 (replicate (-e) 0 ++ is)
2087 d : ds = map intToDigit
2088 (if ei > 0 then is' else 0:is')
2091 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2092 roundTo base d is = case f d is of
2094 (1, is) -> (1, 1 : is)
2095 where b2 = base `div` 2
2096 f n [] = (0, replicate n 0)
2097 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2099 let (c, ds) = f (d-1) is
2101 in if i' == base then (1, 0:ds) else (0, i':ds)
2103 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2104 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2105 -- This version uses a much slower logarithm estimator. It should be improved.
2107 -- This function returns a list of digits (Ints in [0..base-1]) and an
2110 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2112 floatToDigits _ 0 = ([0], 0)
2113 floatToDigits base x =
2114 let (f0, e0) = decodeFloat x
2115 (minExp0, _) = floatRange x
2118 minExp = minExp0 - p -- the real minimum exponent
2119 -- Haskell requires that f be adjusted so denormalized numbers
2120 -- will have an impossibly low exponent. Adjust for this.
2121 (f, e) = let n = minExp - e0
2122 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2127 if f == b^(p-1) then
2128 (f*be*b*2, 2*b, be*b, b)
2132 if e > minExp && f == b^(p-1) then
2133 (f*b*2, b^(-e+1)*2, b, 1)
2135 (f*2, b^(-e)*2, 1, 1)
2138 if b == 2 && base == 10 then
2139 -- logBase 10 2 is slightly bigger than 3/10 so
2140 -- the following will err on the low side. Ignoring
2141 -- the fraction will make it err even more.
2142 -- Haskell promises that p-1 <= logBase b f < p.
2143 (p - 1 + e0) * 3 `div` 10
2145 ceiling ((log (fromInteger (f+1)) +
2146 fromInt e * log (fromInteger b)) /
2147 log (fromInteger base))
2150 if r + mUp <= expt base n * s then n else fixup (n+1)
2152 if expt base (-n) * (r + mUp) <= s then n
2156 gen ds rn sN mUpN mDnN =
2157 let (dn, rn') = (rn * base) `divMod` sN
2160 in case (rn' < mDnN', rn' + mUpN' > sN) of
2161 (True, False) -> dn : ds
2162 (False, True) -> dn+1 : ds
2163 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2164 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2167 gen [] r (s * expt base k) mUp mDn
2169 let bk = expt base (-k)
2170 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
2171 in (map toInt (reverse rds), k)
2174 -- Exponentiation with(out) a cache for the most common numbers.
2175 expt :: Integer -> Int -> Integer
2176 expt base n = base^n
2180 -- Exponentiation with a cache for the most common numbers.
2183 expt :: Integer -> Int -> Integer
2185 if base == 2 && n >= minExpt && n <= maxExpt then
2186 expts !! (n-minExpt)
2191 expts = [2^n | n <- [minExpt .. maxExpt]]