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,
108 -- Standard value bindings {Prelude} ----------------------------------------
113 infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
115 --infixr 5 : -- this fixity declaration is hard-wired into Hugs
117 infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
122 infixr 0 $, $!, `seq`
124 -- Equality and Ordered classes ---------------------------------------------
127 (==), (/=) :: a -> a -> Bool
129 -- Minimal complete definition: (==) or (/=)
133 class (Eq a) => Ord a where
134 compare :: a -> a -> Ordering
135 (<), (<=), (>=), (>) :: a -> a -> Bool
136 max, min :: a -> a -> a
138 -- Minimal complete definition: (<=) or compare
139 -- using compare can be more efficient for complex types
140 compare x y | x==y = EQ
144 x <= y = compare x y /= GT
145 x < y = compare x y == LT
146 x >= y = compare x y /= LT
147 x > y = compare x y == GT
154 class Bounded a where
155 minBound, maxBound :: a
156 -- Minimal complete definition: All
158 -- Numeric classes ----------------------------------------------------------
160 class (Eq a, Show a) => Num a where
161 (+), (-), (*) :: a -> a -> a
163 abs, signum :: a -> a
164 fromInteger :: Integer -> a
167 -- Minimal complete definition: All, except negate or (-)
169 fromInt = fromIntegral
172 class (Num a, Ord a) => Real a where
173 toRational :: a -> Rational
175 class (Real a, Enum a) => Integral a where
176 quot, rem, div, mod :: a -> a -> a
177 quotRem, divMod :: a -> a -> (a,a)
178 even, odd :: a -> Bool
179 toInteger :: a -> Integer
182 -- Minimal complete definition: quotRem and toInteger
183 n `quot` d = q where (q,r) = quotRem n d
184 n `rem` d = r where (q,r) = quotRem n d
185 n `div` d = q where (q,r) = divMod n d
186 n `mod` d = r where (q,r) = divMod n d
187 divMod n d = if signum r == - signum d then (q-1, r+d) else qr
188 where qr@(q,r) = quotRem n d
189 even n = n `rem` 2 == 0
191 toInt = toInt . toInteger
193 class (Num a) => Fractional a where
196 fromRational :: Rational -> a
197 fromDouble :: Double -> a
199 -- Minimal complete definition: fromRational and ((/) or recip)
201 fromDouble = fromRational . toRational
205 class (Fractional a) => Floating a where
207 exp, log, sqrt :: a -> a
208 (**), logBase :: a -> a -> a
209 sin, cos, tan :: a -> a
210 asin, acos, atan :: a -> a
211 sinh, cosh, tanh :: a -> a
212 asinh, acosh, atanh :: a -> a
214 -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
215 -- asinh, acosh, atanh
216 x ** y = exp (log x * y)
217 logBase x y = log y / log x
219 tan x = sin x / cos x
220 sinh x = (exp x - exp (-x)) / 2
221 cosh x = (exp x + exp (-x)) / 2
222 tanh x = sinh x / cosh x
223 asinh x = log (x + sqrt (x*x + 1))
224 acosh x = log (x + sqrt (x*x - 1))
225 atanh x = (log (1 + x) - log (1 - x)) / 2
227 class (Real a, Fractional a) => RealFrac a where
228 properFraction :: (Integral b) => a -> (b,a)
229 truncate, round :: (Integral b) => a -> b
230 ceiling, floor :: (Integral b) => a -> b
232 -- Minimal complete definition: properFraction
233 truncate x = m where (m,_) = properFraction x
235 round x = let (n,r) = properFraction x
236 m = if r < 0 then n - 1 else n + 1
237 in case signum (abs r - 0.5) of
239 0 -> if even n then n else m
242 ceiling x = if r > 0 then n + 1 else n
243 where (n,r) = properFraction x
245 floor x = if r < 0 then n - 1 else n
246 where (n,r) = properFraction x
248 class (RealFrac a, Floating a) => RealFloat a where
249 floatRadix :: a -> Integer
250 floatDigits :: a -> Int
251 floatRange :: a -> (Int,Int)
252 decodeFloat :: a -> (Integer,Int)
253 encodeFloat :: Integer -> Int -> a
255 significand :: a -> a
256 scaleFloat :: Int -> a -> a
257 isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
261 -- Minimal complete definition: All, except exponent, signficand,
263 exponent x = if m==0 then 0 else n + floatDigits x
264 where (m,n) = decodeFloat x
265 significand x = encodeFloat m (- floatDigits x)
266 where (m,_) = decodeFloat x
267 scaleFloat k x = encodeFloat m (n+k)
268 where (m,n) = decodeFloat x
272 | x<0 && y>0 = pi + atan (y/x)
274 (x<0 && isNegativeZero y) ||
275 (isNegativeZero x && isNegativeZero y)
277 | y==0 && (x<0 || isNegativeZero x)
278 = pi -- must be after the previous test on zero y
279 | x==0 && y==0 = y -- must be after the other double zero tests
280 | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
282 -- Numeric functions --------------------------------------------------------
284 subtract :: Num a => a -> a -> a
287 gcd :: Integral a => a -> a -> a
288 gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
289 gcd x y = gcd' (abs x) (abs y)
291 gcd' x y = gcd' y (x `rem` y)
293 lcm :: (Integral a) => a -> a -> a
296 lcm x y = abs ((x `quot` gcd x y) * y)
298 (^) :: (Num a, Integral b) => a -> b -> a
300 x ^ n | n > 0 = f x (n-1) x
302 f x n y = g x n where
303 g x n | even n = g (x*x) (n`quot`2)
304 | otherwise = f x (n-1) (x*y)
305 _ ^ _ = error "Prelude.^: negative exponent"
307 (^^) :: (Fractional a, Integral b) => a -> b -> a
308 x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
310 fromIntegral :: (Integral a, Num b) => a -> b
311 fromIntegral = fromInteger . toInteger
313 realToFrac :: (Real a, Fractional b) => a -> b
314 realToFrac = fromRational . toRational
316 -- Index and Enumeration classes --------------------------------------------
318 class (Ord a) => Ix a where
319 range :: (a,a) -> [a]
320 index :: (a,a) -> a -> Int
321 inRange :: (a,a) -> a -> Bool
322 rangeSize :: (a,a) -> Int
326 | otherwise = index r u + 1
332 enumFrom :: a -> [a] -- [n..]
333 enumFromThen :: a -> a -> [a] -- [n,m..]
334 enumFromTo :: a -> a -> [a] -- [n..m]
335 enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
337 -- Minimal complete definition: toEnum, fromEnum
338 succ = toEnum . (1+) . fromEnum
339 pred = toEnum . subtract 1 . fromEnum
340 enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
341 enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
343 -- Read and Show classes ------------------------------------------------------
345 type ReadS a = String -> [(a,String)]
346 type ShowS = String -> String
349 readsPrec :: Int -> ReadS a
350 readList :: ReadS [a]
352 -- Minimal complete definition: readsPrec
353 readList = readParen False (\r -> [pr | ("[",s) <- lex r,
355 where readl s = [([],t) | ("]",t) <- lex s] ++
356 [(x:xs,u) | (x,t) <- reads s,
358 readl' s = [([],t) | ("]",t) <- lex s] ++
359 [(x:xs,v) | (",",t) <- lex s,
365 showsPrec :: Int -> a -> ShowS
366 showList :: [a] -> ShowS
368 -- Minimal complete definition: show or showsPrec
369 show x = showsPrec 0 x ""
370 showsPrec _ x s = show x ++ s
371 showList [] = showString "[]"
372 showList (x:xs) = showChar '[' . shows x . showl xs
373 where showl [] = showChar ']'
374 showl (x:xs) = showChar ',' . shows x . showl xs
376 -- Monad classes ------------------------------------------------------------
378 class Functor f where
379 fmap :: (a -> b) -> (f a -> f b)
383 (>>=) :: m a -> (a -> m b) -> m b
384 (>>) :: m a -> m b -> m b
385 fail :: String -> m a
387 -- Minimal complete definition: (>>=), return
388 p >> q = p >>= \ _ -> q
391 accumulate :: Monad m => [m a] -> m [a]
392 accumulate [] = return []
393 accumulate (c:cs) = do x <- c
397 sequence :: Monad m => [m a] -> m ()
398 sequence = foldr (>>) (return ())
400 mapM :: Monad m => (a -> m b) -> [a] -> m [b]
401 mapM f = accumulate . map f
403 mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
404 mapM_ f = sequence . map f
406 (=<<) :: Monad m => (a -> m b) -> m a -> m b
409 -- Evaluation and strictness ------------------------------------------------
412 seq x y = --case primForce x of () -> y
415 ($!) :: (a -> b) -> a -> b
418 -- Trivial type -------------------------------------------------------------
420 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
425 instance Ord () where
431 inRange ((),()) () = True
433 instance Enum () where
437 enumFromThen () () = [()]
439 instance Read () where
440 readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
443 instance Show () where
444 showsPrec p () = showString "()"
446 instance Bounded () where
450 -- Boolean type -------------------------------------------------------------
452 data Bool = False | True
453 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
455 (&&), (||) :: Bool -> Bool -> Bool
468 -- Character type -----------------------------------------------------------
470 data Char -- builtin datatype of ISO Latin characters
471 type String = [Char] -- strings are lists of characters
473 instance Eq Char where (==) = primEqChar
474 instance Ord Char where (<=) = primLeChar
476 instance Enum Char where
477 toEnum = primIntToChar
478 fromEnum = primCharToInt
479 enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
480 enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
481 where lastChar = if d < c then minBound else maxBound
483 instance Ix Char where
484 range (c,c') = [c..c']
486 | inRange b ci = fromEnum ci - fromEnum c
487 | otherwise = error "Ix.index: Index out of range."
488 inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
489 where i = fromEnum ci
491 instance Read Char where
492 readsPrec p = readParen False
493 (\r -> [(c,t) | ('\'':s,t) <- lex r,
494 (c,"\'") <- readLitChar s ])
495 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
497 where readl ('"':s) = [("",s)]
498 readl ('\\':'&':s) = readl s
499 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
501 instance Show Char where
502 showsPrec p '\'' = showString "'\\''"
503 showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
505 showList cs = showChar '"' . showl cs
506 where showl "" = showChar '"'
507 showl ('"':cs) = showString "\\\"" . showl cs
508 showl (c:cs) = showLitChar c . showl cs
510 instance Bounded Char where
514 isAscii, isControl, isPrint, isSpace :: Char -> Bool
515 isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
517 isAscii c = fromEnum c < 128
518 isControl c = c < ' ' || c == '\DEL'
519 isPrint c = c >= ' ' && c <= '~'
520 isSpace c = c == ' ' || c == '\t' || c == '\n' ||
521 c == '\r' || c == '\f' || c == '\v'
522 isUpper c = c >= 'A' && c <= 'Z'
523 isLower c = c >= 'a' && c <= 'z'
524 isAlpha c = isUpper c || isLower c
525 isDigit c = c >= '0' && c <= '9'
526 isAlphaNum c = isAlpha c || isDigit c
528 -- Digit conversion operations
529 digitToInt :: Char -> Int
531 | isDigit c = fromEnum c - fromEnum '0'
532 | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
533 | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
534 | otherwise = error "Char.digitToInt: not a digit"
536 intToDigit :: Int -> Char
538 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
539 | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
540 | otherwise = error "Char.intToDigit: not a digit"
542 toUpper, toLower :: Char -> Char
543 toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
546 toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
555 -- Maybe type ---------------------------------------------------------------
557 data Maybe a = Nothing | Just a
558 deriving (Eq, Ord, Read, Show)
560 maybe :: b -> (a -> b) -> Maybe a -> b
561 maybe n f Nothing = n
562 maybe n f (Just x) = f x
564 instance Functor Maybe where
565 fmap f Nothing = Nothing
566 fmap f (Just x) = Just (f x)
568 instance Monad Maybe where
570 Nothing >>= k = Nothing
574 -- Either type --------------------------------------------------------------
576 data Either a b = Left a | Right b
577 deriving (Eq, Ord, Read, Show)
579 either :: (a -> c) -> (b -> c) -> Either a b -> c
580 either l r (Left x) = l x
581 either l r (Right y) = r y
583 -- Ordering type ------------------------------------------------------------
585 data Ordering = LT | EQ | GT
586 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
588 -- Lists --------------------------------------------------------------------
590 --data [a] = [] | a : [a] deriving (Eq, Ord)
592 instance Eq a => Eq [a] where
594 (x:xs) == (y:ys) = x==y && xs==ys
597 instance Ord a => Ord [a] where
598 compare [] (_:_) = LT
600 compare (_:_) [] = GT
601 compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
603 instance Functor [] where
606 instance Monad [ ] where
607 (x:xs) >>= f = f x ++ (xs >>= f)
612 instance Read a => Read [a] where
613 readsPrec p = readList
615 instance Show a => Show [a] where
616 showsPrec p = showList
618 -- Tuples -------------------------------------------------------------------
620 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
623 -- Functions ----------------------------------------------------------------
625 instance Show (a -> b) where
626 showsPrec p f = showString "<<function>>"
628 instance Functor ((->) a) where
631 -- Standard Integral types --------------------------------------------------
633 data Int -- builtin datatype of fixed size integers
634 data Integer -- builtin datatype of arbitrary size integers
636 instance Eq Integer where
637 (==) x y = primCompareInteger x y == 0
639 instance Ord Integer where
640 compare x y = case primCompareInteger x y of
645 instance Eq Int where
649 instance Ord Int where
655 instance Num Int where
658 negate = primNegateInt
662 fromInteger = primIntegerToInt
665 instance Bounded Int where
666 minBound = primMinInt
667 maxBound = primMaxInt
669 instance Num Integer where
670 (+) = primPlusInteger
671 (-) = primMinusInteger
672 negate = primNegateInteger
673 (*) = primTimesInteger
677 fromInt = primIntToInteger
679 absReal x | x >= 0 = x
682 signumReal x | x == 0 = 0
686 instance Real Int where
687 toRational x = toInteger x % 1
689 instance Real Integer where
692 instance Integral Int where
693 quotRem = primQuotRemInt
694 toInteger = primIntToInteger
697 instance Integral Integer where
698 quotRem = primQuotRemInteger
699 divMod = primDivModInteger
701 toInt = primIntegerToInt
703 instance Ix Int where
706 | inRange b i = i - m
707 | otherwise = error "index: Index out of range"
708 inRange (m,n) i = m <= i && i <= n
710 instance Ix Integer where
713 | inRange b i = fromInteger (i - m)
714 | otherwise = error "index: Index out of range"
715 inRange (m,n) i = m <= i && i <= n
717 instance Enum Int where
720 enumFrom = numericEnumFrom
721 enumFromTo = numericEnumFromTo
722 enumFromThen = numericEnumFromThen
723 enumFromThenTo = numericEnumFromThenTo
725 instance Enum Integer where
726 toEnum = primIntToInteger
727 fromEnum = primIntegerToInt
728 enumFrom = numericEnumFrom
729 enumFromTo = numericEnumFromTo
730 enumFromThen = numericEnumFromThen
731 enumFromThenTo = numericEnumFromThenTo
733 numericEnumFrom :: Real a => a -> [a]
734 numericEnumFromThen :: Real a => a -> a -> [a]
735 numericEnumFromTo :: Real a => a -> a -> [a]
736 numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
737 numericEnumFrom n = n : (numericEnumFrom $! (n+1))
738 numericEnumFromThen n m = iterate ((m-n)+) n
739 numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
740 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
741 where p | n' > n = (<= m)
744 instance Read Int where
745 readsPrec p = readSigned readDec
747 instance Show Int where
749 | n == minBound = showSigned showInt p (toInteger n)
750 | otherwise = showSigned showInt p n
752 instance Read Integer where
753 readsPrec p = readSigned readDec
755 instance Show Integer where
756 showsPrec = showSigned showInt
758 -- Standard Floating types --------------------------------------------------
760 data Float -- builtin datatype of single precision floating point numbers
761 data Double -- builtin datatype of double precision floating point numbers
763 instance Eq Float where
767 instance Ord Float where
773 instance Num Float where
776 negate = primNegateFloat
780 fromInteger = primIntegerToFloat
781 fromInt = primIntToFloat
785 instance Eq Double where
789 instance Ord Double where
795 instance Num Double where
797 (-) = primMinusDouble
798 negate = primNegateDouble
799 (*) = primTimesDouble
802 fromInteger = primIntegerToDouble
803 fromInt = primIntToDouble
807 instance Real Float where
808 toRational = floatToRational
810 instance Real Double where
811 toRational = doubleToRational
813 -- Calls to these functions are optimised when passed as arguments to
815 floatToRational :: Float -> Rational
816 doubleToRational :: Double -> Rational
817 floatToRational x = realFloatToRational x
818 doubleToRational x = realFloatToRational x
820 realFloatToRational x = (m%1)*(b%1)^^n
821 where (m,n) = decodeFloat x
824 instance Fractional Float where
825 (/) = primDivideFloat
826 fromRational = rationalToRealFloat
827 fromDouble = primDoubleToFloat
830 instance Fractional Double where
831 (/) = primDivideDouble
832 fromRational = rationalToRealFloat
835 rationalToRealFloat x = x'
837 f e = if e' == e then y else f e'
838 where y = encodeFloat (round (x * (1%b)^^e)) e
839 (_,e') = decodeFloat y
840 (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
841 / fromInteger (denominator x))
844 instance Floating Float where
845 pi = 3.14159265358979323846
856 instance Floating Double where
857 pi = 3.14159265358979323846
860 sqrt = primSqrtDouble
864 asin = primAsinDouble
865 acos = primAcosDouble
866 atan = primAtanDouble
868 instance RealFrac Float where
869 properFraction = floatProperFraction
871 instance RealFrac Double where
872 properFraction = floatProperFraction
874 floatProperFraction x
875 | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
876 | otherwise = (fromInteger w, encodeFloat r n)
877 where (m,n) = decodeFloat x
879 (w,r) = quotRem m (b^(-n))
881 instance RealFloat Float where
882 floatRadix _ = toInteger primRadixFloat
883 floatDigits _ = primDigitsFloat
884 floatRange _ = (primMinExpFloat,primMaxExpFloat)
885 encodeFloat = primEncodeFloatZ
886 decodeFloat = primDecodeFloatZ
887 isNaN = primIsNaNFloat
888 isInfinite = primIsInfiniteFloat
889 isDenormalized= primIsDenormalizedFloat
890 isNegativeZero= primIsNegativeZeroFloat
891 isIEEE = const primIsIEEEFloat
893 instance RealFloat Double where
894 floatRadix _ = toInteger primRadixDouble
895 floatDigits _ = primDigitsDouble
896 floatRange _ = (primMinExpDouble,primMaxExpDouble)
897 encodeFloat = primEncodeDoubleZ
898 decodeFloat = primDecodeDoubleZ
899 isNaN = primIsNaNDouble
900 isInfinite = primIsInfiniteDouble
901 isDenormalized= primIsDenormalizedDouble
902 isNegativeZero= primIsNegativeZeroDouble
903 isIEEE = const primIsIEEEDouble
905 instance Enum Float where
906 toEnum = primIntToFloat
908 enumFrom = numericEnumFrom
909 enumFromThen = numericEnumFromThen
910 enumFromTo n m = numericEnumFromTo n (m+1/2)
911 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
913 instance Enum Double where
914 toEnum = primIntToDouble
916 enumFrom = numericEnumFrom
917 enumFromThen = numericEnumFromThen
918 enumFromTo n m = numericEnumFromTo n (m+1/2)
919 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
921 instance Read Float where
922 readsPrec p = readSigned readFloat
924 instance Show Float where
925 showsPrec p = showFloat
926 --error "should call showFloat"
928 instance Read Double where
929 readsPrec p = readSigned readFloat
931 -- Note that showFloat in Numeric isn't used here
932 instance Show Double where
933 showsPrec p = showFloat
934 --error "should call showFloat"
936 -- Some standard functions --------------------------------------------------
944 curry :: ((a,b) -> c) -> (a -> b -> c)
945 curry f x y = f (x,y)
947 uncurry :: (a -> b -> c) -> ((a,b) -> c)
948 uncurry f p = f (fst p) (snd p)
956 (.) :: (b -> c) -> (a -> b) -> (a -> c)
959 flip :: (a -> b -> c) -> b -> a -> c
962 ($) :: (a -> b) -> a -> b
965 until :: (a -> Bool) -> (a -> a) -> a -> a
966 until p f x = if p x then x else until p f (f x)
968 asTypeOf :: a -> a -> a
972 error msg = primRaise (ErrorCall msg)
975 undefined | False = undefined
977 -- Standard functions on rational numbers {PreludeRatio} --------------------
979 data Integral a => Ratio a = a :% a deriving (Eq)
980 type Rational = Ratio Integer
982 (%) :: Integral a => a -> a -> Ratio a
983 x % y = reduce (x * signum y) (abs y)
985 reduce :: Integral a => a -> a -> Ratio a
986 reduce x y | y == 0 = error "Ratio.%: zero denominator"
987 | otherwise = (x `quot` d) :% (y `quot` d)
990 numerator, denominator :: Integral a => Ratio a -> a
991 numerator (x :% y) = x
992 denominator (x :% y) = y
994 instance Integral a => Ord (Ratio a) where
995 compare (x:%y) (x':%y') = compare (x*y') (x'*y)
997 instance Integral a => Num (Ratio a) where
998 (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
999 (x:%y) * (x':%y') = reduce (x*x') (y*y')
1000 negate (x :% y) = negate x :% y
1001 abs (x :% y) = abs x :% y
1002 signum (x :% y) = signum x :% 1
1003 fromInteger x = fromInteger x :% 1
1004 fromInt = intToRatio
1006 -- Hugs optimises code of the form fromRational (intToRatio x)
1007 intToRatio :: Integral a => Int -> Ratio a
1008 intToRatio x = fromInt x :% 1
1010 instance Integral a => Real (Ratio a) where
1011 toRational (x:%y) = toInteger x :% toInteger y
1013 instance Integral a => Fractional (Ratio a) where
1014 (x:%y) / (x':%y') = (x*y') % (y*x')
1015 recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
1016 fromRational (x:%y) = fromInteger x :% fromInteger y
1017 fromDouble = doubleToRatio
1019 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1020 doubleToRatio :: Integral a => Double -> Ratio a
1022 | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
1023 | otherwise = fromInteger m % (fromInteger b ^ (-n))
1024 where (m,n) = decodeFloat x
1027 instance Integral a => RealFrac (Ratio a) where
1028 properFraction (x:%y) = (fromIntegral q, r:%y)
1029 where (q,r) = quotRem x y
1031 instance Integral a => Enum (Ratio a) where
1034 enumFrom = numericEnumFrom
1035 enumFromThen = numericEnumFromThen
1037 instance (Read a, Integral a) => Read (Ratio a) where
1038 readsPrec p = readParen (p > 7)
1039 (\r -> [(x%y,u) | (x,s) <- reads r,
1043 instance Integral a => Show (Ratio a) where
1044 showsPrec p (x:%y) = showParen (p > 7)
1045 (shows x . showString " % " . shows y)
1047 approxRational :: RealFrac a => a -> a -> Rational
1048 approxRational x eps = simplest (x-eps) (x+eps)
1049 where simplest x y | y < x = simplest y x
1051 | x > 0 = simplest' n d n' d'
1052 | y < 0 = - simplest' (-n') d' (-n) d
1053 | otherwise = 0 :% 1
1054 where xr@(n:%d) = toRational x
1055 (n':%d') = toRational y
1056 simplest' n d n' d' -- assumes 0 < n%d < n'%d'
1058 | q /= q' = (q+1) :% 1
1059 | otherwise = (q*n''+d'') :% n''
1060 where (q,r) = quotRem n d
1061 (q',r') = quotRem n' d'
1062 (n'':%d'') = simplest' d' r' d r
1064 -- Standard list functions {PreludeList} ------------------------------------
1071 last (_:xs) = last xs
1078 init (x:xs) = x : init xs
1084 (++) :: [a] -> [a] -> [a]
1086 (x:xs) ++ ys = x : (xs ++ ys)
1088 map :: (a -> b) -> [a] -> [b]
1089 map f xs = [ f x | x <- xs ]
1091 filter :: (a -> Bool) -> [a] -> [a]
1092 filter p xs = [ x | x <- xs, p x ]
1094 concat :: [[a]] -> [a]
1095 concat = foldr (++) []
1097 length :: [a] -> Int
1098 length = foldl' (\n _ -> n + 1) 0
1100 (!!) :: [b] -> Int -> b
1102 (_:xs) !! n | n>0 = xs !! (n-1)
1103 (_:_) !! _ = error "Prelude.!!: negative index"
1104 [] !! _ = error "Prelude.!!: index too large"
1106 foldl :: (a -> b -> a) -> a -> [b] -> a
1108 foldl f z (x:xs) = foldl f (f z x) xs
1110 foldl' :: (a -> b -> a) -> a -> [b] -> a
1112 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1114 foldl1 :: (a -> a -> a) -> [a] -> a
1115 foldl1 f (x:xs) = foldl f x xs
1117 scanl :: (a -> b -> a) -> a -> [b] -> [a]
1118 scanl f q xs = q : (case xs of
1120 x:xs -> scanl f (f q x) xs)
1122 scanl1 :: (a -> a -> a) -> [a] -> [a]
1123 scanl1 f (x:xs) = scanl f x xs
1125 foldr :: (a -> b -> b) -> b -> [a] -> b
1127 foldr f z (x:xs) = f x (foldr f z xs)
1129 foldr1 :: (a -> a -> a) -> [a] -> a
1131 foldr1 f (x:xs) = f x (foldr1 f xs)
1133 scanr :: (a -> b -> b) -> b -> [a] -> [b]
1134 scanr f q0 [] = [q0]
1135 scanr f q0 (x:xs) = f x q : qs
1136 where qs@(q:_) = scanr f q0 xs
1138 scanr1 :: (a -> a -> a) -> [a] -> [a]
1140 scanr1 f (x:xs) = f x q : qs
1141 where qs@(q:_) = scanr1 f xs
1143 iterate :: (a -> a) -> a -> [a]
1144 iterate f x = x : iterate f (f x)
1147 repeat x = xs where xs = x:xs
1149 replicate :: Int -> a -> [a]
1150 replicate n x = take n (repeat x)
1153 cycle [] = error "Prelude.cycle: empty list"
1154 cycle xs = xs' where xs'=xs++xs'
1156 take :: Int -> [a] -> [a]
1159 take n (x:xs) | n>0 = x : take (n-1) xs
1160 take _ _ = error "Prelude.take: negative argument"
1162 drop :: Int -> [a] -> [a]
1165 drop n (_:xs) | n>0 = drop (n-1) xs
1166 drop _ _ = error "Prelude.drop: negative argument"
1168 splitAt :: Int -> [a] -> ([a], [a])
1169 splitAt 0 xs = ([],xs)
1170 splitAt _ [] = ([],[])
1171 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1172 splitAt _ _ = error "Prelude.splitAt: negative argument"
1174 takeWhile :: (a -> Bool) -> [a] -> [a]
1177 | p x = x : takeWhile p xs
1180 dropWhile :: (a -> Bool) -> [a] -> [a]
1182 dropWhile p xs@(x:xs')
1183 | p x = dropWhile p xs'
1186 span, break :: (a -> Bool) -> [a] -> ([a],[a])
1190 | otherwise = ([],xs)
1191 where (ys,zs) = span p xs'
1192 break p = span (not . p)
1194 lines :: String -> [String]
1196 lines s = let (l,s') = break ('\n'==) s
1197 in l : case s' of [] -> []
1198 (_:s'') -> lines s''
1200 words :: String -> [String]
1201 words s = case dropWhile isSpace s of
1204 where (w,s'') = break isSpace s'
1206 unlines :: [String] -> String
1207 unlines = concatMap (\l -> l ++ "\n")
1209 unwords :: [String] -> String
1211 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1213 reverse :: [a] -> [a]
1214 reverse = foldl (flip (:)) []
1216 and, or :: [Bool] -> Bool
1217 and = foldr (&&) True
1218 or = foldr (||) False
1220 any, all :: (a -> Bool) -> [a] -> Bool
1224 elem, notElem :: Eq a => a -> [a] -> Bool
1226 notElem = all . (/=)
1228 lookup :: Eq a => a -> [(a,b)] -> Maybe b
1229 lookup k [] = Nothing
1230 lookup k ((x,y):xys)
1232 | otherwise = lookup k xys
1234 sum, product :: Num a => [a] -> a
1236 product = foldl' (*) 1
1238 maximum, minimum :: Ord a => [a] -> a
1239 maximum = foldl1 max
1240 minimum = foldl1 min
1242 concatMap :: (a -> [b]) -> [a] -> [b]
1243 concatMap f = concat . map f
1245 zip :: [a] -> [b] -> [(a,b)]
1246 zip = zipWith (\a b -> (a,b))
1248 zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
1249 zip3 = zipWith3 (\a b c -> (a,b,c))
1251 zipWith :: (a->b->c) -> [a]->[b]->[c]
1252 zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
1255 zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1256 zipWith3 z (a:as) (b:bs) (c:cs)
1257 = z a b c : zipWith3 z as bs cs
1258 zipWith3 _ _ _ _ = []
1260 unzip :: [(a,b)] -> ([a],[b])
1261 unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1263 unzip3 :: [(a,b,c)] -> ([a],[b],[c])
1264 unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1267 -- PreludeText ----------------------------------------------------------------
1269 reads :: Read a => ReadS a
1272 shows :: Show a => a -> ShowS
1275 read :: Read a => String -> a
1276 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1278 [] -> error "Prelude.read: no parse"
1279 _ -> error "Prelude.read: ambiguous parse"
1281 showChar :: Char -> ShowS
1284 showString :: String -> ShowS
1287 showParen :: Bool -> ShowS -> ShowS
1288 showParen b p = if b then showChar '(' . p . showChar ')' else p
1290 showField :: Show a => String -> a -> ShowS
1291 showField m v = showString m . showChar '=' . shows v
1293 readParen :: Bool -> ReadS a -> ReadS a
1294 readParen b g = if b then mandatory else optional
1295 where optional r = g r ++ mandatory r
1296 mandatory r = [(x,u) | ("(",s) <- lex r,
1297 (x,t) <- optional s,
1301 readField :: Read a => String -> ReadS a
1302 readField m s0 = [ r | (t, s1) <- lex s0, t == m,
1308 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1309 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1311 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1313 lexString ('"':s) = [("\"",s)]
1314 lexString s = [(ch++str, u)
1315 | (ch,t) <- lexStrItem s,
1316 (str,u) <- lexString t ]
1318 lexStrItem ('\\':'&':s) = [("\\&",s)]
1319 lexStrItem ('\\':c:s) | isSpace c
1320 = [("",t) | '\\':t <- [dropWhile isSpace s]]
1321 lexStrItem s = lexLitChar s
1323 lex (c:s) | isSingle c = [([c],s)]
1324 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
1325 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
1326 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
1327 (fe,t) <- lexFracExp s ]
1328 | otherwise = [] -- bad character
1330 isSingle c = c `elem` ",;()[]{}_`"
1331 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1332 isIdChar c = isAlphaNum c || c `elem` "_'"
1334 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1336 lexFracExp s = [("",s)]
1338 lexExp (e:s) | e `elem` "eE"
1339 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
1340 (ds,u) <- lexDigits t] ++
1341 [(e:ds,t) | (ds,t) <- lexDigits s]
1344 lexDigits :: ReadS String
1345 lexDigits = nonnull isDigit
1347 nonnull :: (Char -> Bool) -> ReadS String
1348 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1350 lexLitChar :: ReadS String
1351 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1353 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
1354 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
1355 lexEsc s@(d:_) | isDigit d = lexDigits s
1356 lexEsc s@(c:_) | isUpper c
1357 = let table = ('\DEL',"DEL") : asciiTab
1358 in case [(mne,s') | (c, mne) <- table,
1359 ([],s') <- [lexmatch mne s]]
1363 lexLitChar (c:s) = [([c],s)]
1366 isOctDigit c = c >= '0' && c <= '7'
1367 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
1368 || c >= 'a' && c <= 'f'
1370 lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
1371 lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
1372 lexmatch xs ys = (xs,ys)
1374 asciiTab = zip ['\NUL'..' ']
1375 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1376 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
1377 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1378 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
1381 readLitChar :: ReadS Char
1382 readLitChar ('\\':s) = readEsc s
1384 readEsc ('a':s) = [('\a',s)]
1385 readEsc ('b':s) = [('\b',s)]
1386 readEsc ('f':s) = [('\f',s)]
1387 readEsc ('n':s) = [('\n',s)]
1388 readEsc ('r':s) = [('\r',s)]
1389 readEsc ('t':s) = [('\t',s)]
1390 readEsc ('v':s) = [('\v',s)]
1391 readEsc ('\\':s) = [('\\',s)]
1392 readEsc ('"':s) = [('"',s)]
1393 readEsc ('\'':s) = [('\'',s)]
1394 readEsc ('^':c:s) | c >= '@' && c <= '_'
1395 = [(toEnum (fromEnum c - fromEnum '@'), s)]
1396 readEsc s@(d:_) | isDigit d
1397 = [(toEnum n, t) | (n,t) <- readDec s]
1398 readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
1399 readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
1400 readEsc s@(c:_) | isUpper c
1401 = let table = ('\DEL',"DEL") : asciiTab
1402 in case [(c,s') | (c, mne) <- table,
1403 ([],s') <- [lexmatch mne s]]
1407 readLitChar (c:s) = [(c,s)]
1409 showLitChar :: Char -> ShowS
1410 showLitChar c | c > '\DEL' = showChar '\\' .
1411 protectEsc isDigit (shows (fromEnum c))
1412 showLitChar '\DEL' = showString "\\DEL"
1413 showLitChar '\\' = showString "\\\\"
1414 showLitChar c | c >= ' ' = showChar c
1415 showLitChar '\a' = showString "\\a"
1416 showLitChar '\b' = showString "\\b"
1417 showLitChar '\f' = showString "\\f"
1418 showLitChar '\n' = showString "\\n"
1419 showLitChar '\r' = showString "\\r"
1420 showLitChar '\t' = showString "\\t"
1421 showLitChar '\v' = showString "\\v"
1422 showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
1423 showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
1425 protectEsc p f = f . cont
1426 where cont s@(c:_) | p c = "\\&" ++ s
1429 -- Unsigned readers for various bases
1430 readDec, readOct, readHex :: Integral a => ReadS a
1431 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1432 readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1433 readHex = readInt 16 isHexDigit hex
1434 where hex d = fromEnum d -
1437 else fromEnum (if isUpper d then 'A' else 'a') - 10)
1439 -- readInt reads a string of digits using an arbitrary base.
1440 -- Leading minus signs must be handled elsewhere.
1442 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1443 readInt radix isDig digToInt s =
1444 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1445 | (ds,r) <- nonnull isDig s ]
1447 -- showInt is used for positive numbers only
1448 showInt :: Integral a => a -> ShowS
1449 showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers"
1451 let (n',d) = quotRem n 10
1452 r' = toEnum (fromEnum '0' + fromIntegral d) : r
1453 in if n' == 0 then r' else showInt n' r'
1455 readSigned:: Real a => ReadS a -> ReadS a
1456 readSigned readPos = readParen False read'
1457 where read' r = read'' r ++
1458 [(-x,t) | ("-",s) <- lex r,
1460 read'' r = [(n,s) | (str,s) <- lex r,
1461 (n,"") <- readPos str]
1463 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1464 showSigned showPos p x = if x < 0 then showParen (p > 6)
1465 (showChar '-' . showPos (-x))
1468 readFloat :: RealFloat a => ReadS a
1469 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1471 where readFix r = [(read (ds++ds'), length ds', t)
1472 | (ds, s) <- lexDigits r
1473 , (ds',t) <- lexFrac s ]
1475 lexFrac ('.':s) = lexDigits s
1476 lexFrac s = [("",s)]
1478 readExp (e:s) | e `elem` "eE" = readExp' s
1481 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1482 readExp' ('+':s) = readDec s
1483 readExp' s = readDec s
1486 -- Hooks for primitives: -----------------------------------------------------
1487 -- Do not mess with these!
1489 primCompAux :: Ord a => a -> a -> Ordering -> Ordering
1490 primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1492 primPmInt :: Num a => Int -> a -> Bool
1493 primPmInt n x = fromInt n == x
1495 primPmInteger :: Num a => Integer -> a -> Bool
1496 primPmInteger n x = fromInteger n == x
1498 primPmFlt :: Fractional a => Double -> a -> Bool
1499 primPmFlt n x = fromDouble n == x
1501 -- ToDo: make the message more informative.
1503 primPmFail = error "Pattern Match Failure"
1505 primPmFailBUG = error ("\nSTG-Hugs: detected a bug in translation to STG code.\n" ++
1506 "**Please** report to v-julsew@microsoft.com. Thx!\n")
1508 -- used in desugaring Foreign functions
1509 primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1512 -- The following primitives are only needed if (n+k) patterns are enabled:
1513 primPmNpk :: Integral a => Int -> a -> Maybe a
1514 primPmNpk n x = if n'<=x then Just (x-n') else Nothing
1515 where n' = fromInt n
1517 primPmSub :: Integral a => Int -> a -> a
1518 primPmSub n x = x - fromInt n
1520 -- Unpack strings generated by the Hugs code generator.
1521 -- Strings can contain \0 provided they're coded right.
1523 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1525 primUnpackString :: Addr -> String
1526 primUnpackString a = unpack 0
1528 -- The following decoding is based on evalString in the old machine.c
1531 | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1532 then '\\' : unpack (i+2)
1533 else '\0' : unpack (i+2)
1534 | otherwise = c : unpack (i+1)
1536 c = primIndexCharOffAddr a i
1539 -- Monadic I/O: --------------------------------------------------------------
1541 type FilePath = String
1543 --data IOError = ...
1544 --instance Eq IOError ...
1545 --instance Show IOError ...
1547 data IOError = IOError String
1548 instance Show IOError where
1549 showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1551 ioError :: IOError -> IO a
1552 ioError (IOError s) = primRaise (IOExcept s)
1554 userError :: String -> IOError
1555 userError s = primRaise (ErrorCall s)
1557 catch :: IO a -> (IOError -> IO a) -> IO a
1558 catch x eh = primCatch x (eh.exception2ioerror)
1560 exception2ioerror (IOExcept s) = IOError s
1561 exception2ioerror other = IOError (show other)
1563 putChar :: Char -> IO ()
1564 putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c)
1566 putStr :: String -> IO ()
1567 putStr s = --mapM_ putChar s -- correct, but slow
1569 let loop [] = return ()
1570 loop (c:cs) = nh_write h (primCharToInt c) >> loop cs
1573 putStrLn :: String -> IO ()
1574 putStrLn s = do { putStr s; putChar '\n' }
1576 print :: Show a => a -> IO ()
1577 print = putStrLn . show
1580 getChar = unsafeInterleaveIO (
1582 nh_read h >>= \ci ->
1583 return (primIntToChar ci)
1586 getLine :: IO String
1587 getLine = do c <- getChar
1588 if c=='\n' then return ""
1589 else do cs <- getLine
1592 getContents :: IO String
1593 getContents = nh_stdin >>= \h -> readfromhandle h
1595 interact :: (String -> String) -> IO ()
1596 interact f = getContents >>= (putStr . f)
1598 readFile :: FilePath -> IO String
1600 = fileopen_sendname fname >>= \ptr ->
1601 nh_open ptr 0 >>= \h ->
1603 nh_errno >>= \errno ->
1604 if (h == 0 || errno /= 0)
1605 then (ioError.IOError) ("readFile: can't open file " ++ fname)
1606 else readfromhandle h
1608 writeFile :: FilePath -> String -> IO ()
1609 writeFile fname contents
1610 = fileopen_sendname fname >>= \ptr ->
1611 nh_open ptr 1 >>= \h ->
1613 nh_errno >>= \errno ->
1614 if (h == 0 || errno /= 0)
1615 then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1616 else writetohandle fname h contents
1619 appendFile :: FilePath -> String -> IO ()
1620 appendFile fname contents
1621 = fileopen_sendname fname >>= \ptr ->
1622 nh_open ptr 2 >>= \h ->
1624 nh_errno >>= \errno ->
1625 if (h == 0 || errno /= 0)
1626 then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1627 else writetohandle fname h contents
1630 -- raises an exception instead of an error
1631 readIO :: Read a => String -> IO a
1632 readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1634 [] -> ioError (userError "PreludeIO.readIO: no parse")
1635 _ -> ioError (userError
1636 "PreludeIO.readIO: ambiguous parse")
1638 readLn :: Read a => IO a
1639 readLn = do l <- getLine
1644 -- End of Hugs standard prelude ----------------------------------------------
1650 instance Show Exception where
1651 showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1652 showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
1654 data IOResult = IOResult deriving (Show)
1656 type FILE_STAR = Int
1658 foreign import stdcall "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR
1659 foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR
1660 foreign import stdcall "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO ()
1661 foreign import stdcall "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int
1662 foreign import stdcall "nHandle.so" "nh_open" nh_open :: Int -> Int -> IO FILE_STAR
1663 foreign import stdcall "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO ()
1664 foreign import stdcall "nHandle.so" "nh_errno" nh_errno :: IO Int
1666 foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Int
1667 foreign import stdcall "nHandle.so" "nh_free" nh_free :: Int -> IO ()
1668 foreign import stdcall "nHandle.so" "nh_assign" nh_assign :: Int -> Int -> Int -> IO Int
1670 fileopen_sendname :: String -> IO Int
1671 fileopen_sendname fname
1672 = nh_malloc (1 + length fname) >>= \ptr ->
1673 let loop i [] = nh_assign ptr i 0 >> return ptr
1674 loop i (c:cs) = nh_assign ptr i (primCharToInt c) >> loop (i+1) cs
1678 readfromhandle :: FILE_STAR -> IO String
1680 = unsafeInterleaveIO (
1681 nh_read h >>= \ci ->
1682 if ci == -1 {-EOF-} then return "" else
1683 readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1686 writetohandle :: String -> FILE_STAR -> String -> IO ()
1687 writetohandle fname h []
1689 nh_errno >>= \errno ->
1692 else error ( "writeFile/appendFile: error closing file " ++ fname)
1693 writetohandle fname h (c:cs)
1694 = nh_write h (primCharToInt c) >>
1695 writetohandle fname h cs
1697 ------------------------------------------------------------------------------
1698 -- ST, IO --------------------------------------------------------------------
1699 ------------------------------------------------------------------------------
1701 newtype ST s a = ST (s -> (a,s))
1704 type IO a = ST RealWorld a
1707 --runST :: (forall s. ST s a) -> a
1708 runST :: ST RealWorld a -> a
1709 runST m = fst (unST m theWorld)
1711 theWorld :: RealWorld
1712 theWorld = error "runST: entered the RealWorld"
1716 instance Functor (ST s) where
1717 fmap f x = x >>= (return . f)
1719 instance Monad (ST s) where
1720 m >> k = m >>= \ _ -> k
1721 return x = ST $ \ s -> (x,s)
1722 m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' }
1725 -- used when Hugs invokes top level function
1726 primRunIO :: IO () -> ()
1728 = protect (fst (unST m realWorld))
1730 realWorld = error "panic: Hugs entered the real world"
1733 = primCatch comp (\e -> fst (unST (putStr (show e)) realWorld))
1735 trace :: String -> a -> a
1737 = (runST (putStr ("trace: " ++ s ++ "\n"))) `seq` x
1739 unsafeInterleaveST :: ST s a -> ST s a
1740 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1742 unsafeInterleaveIO :: IO a -> IO a
1743 unsafeInterleaveIO = unsafeInterleaveST
1746 ------------------------------------------------------------------------------
1747 -- Addr, ForeignObj, Prim*Array ----------------------------------------------
1748 ------------------------------------------------------------------------------
1752 nullAddr = primIntToAddr 0
1754 instance Eq Addr where
1758 instance Ord Addr where
1766 makeForeignObj :: Addr -> IO ForeignObj
1767 makeForeignObj = primMakeForeignObj
1770 data PrimArray a -- immutable arrays with Int indices
1773 data Ref s a -- mutable variables
1774 data PrimMutableArray s a -- mutable arrays with Int indices
1775 data PrimMutableByteArray s
1778 ------------------------------------------------------------------------------
1779 -- hooks to call libHS_cbits -------------------------------------------------
1780 ------------------------------------------------------------------------------
1782 type FILE_OBJ = ForeignObj -- as passed into functions
1783 type CString = PrimByteArray
1786 type OpenFlags = Int
1787 type IOFileAddr = Addr -- as returned from functions
1789 type OpenStdFlags = Int
1790 type Readable = Int -- really Bool
1791 type Exclusive = Int -- really Bool
1792 type RC = Int -- standard return code
1793 type Bytes = PrimMutableByteArray RealWorld
1794 type Flush = Int -- really Bool
1796 foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
1797 freeStdFileObject :: ForeignObj -> IO ()
1799 foreign import stdcall "libHS_cbits.so" "freeFileObject"
1800 freeFileObject :: ForeignObj -> IO ()
1802 foreign import stdcall "libHS_cbits.so" "setBuf"
1803 prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO ()
1805 foreign import stdcall "libHS_cbits.so" "getBufSize"
1806 prim_getBufSize :: FILE_OBJ -> IO Int
1808 foreign import stdcall "libHS_cbits.so" "inputReady"
1809 prim_inputReady :: FILE_OBJ -> Int -> IO RC
1811 foreign import stdcall "libHS_cbits.so" "fileGetc"
1812 prim_fileGetc :: FILE_OBJ -> IO Int
1814 foreign import stdcall "libHS_cbits.so" "fileLookAhead"
1815 prim_fileLookAhead :: FILE_OBJ -> IO Int
1817 foreign import stdcall "libHS_cbits.so" "readBlock"
1818 prim_readBlock :: FILE_OBJ -> IO Int
1820 foreign import stdcall "libHS_cbits.so" "readLine"
1821 prim_readLine :: FILE_OBJ -> IO Int
1823 foreign import stdcall "libHS_cbits.so" "readChar"
1824 prim_readChar :: FILE_OBJ -> IO Int
1826 foreign import stdcall "libHS_cbits.so" "writeFileObject"
1827 prim_writeFileObject :: FILE_OBJ -> Int -> IO RC
1829 foreign import stdcall "libHS_cbits.so" "filePutc"
1830 prim_filePutc :: FILE_OBJ -> Char -> IO RC
1832 foreign import stdcall "libHS_cbits.so" "getBufStart"
1833 prim_getBufStart :: FILE_OBJ -> Int -> IO Addr
1835 foreign import stdcall "libHS_cbits.so" "getWriteableBuf"
1836 prim_getWriteableBuf :: FILE_OBJ -> IO Addr
1838 foreign import stdcall "libHS_cbits.so" "getBufWPtr"
1839 prim_getBufWPtr :: FILE_OBJ -> IO Int
1841 foreign import stdcall "libHS_cbits.so" "setBufWPtr"
1842 prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
1844 foreign import stdcall "libHS_cbits.so" "closeFile"
1845 prim_closeFile :: FILE_OBJ -> Flush -> IO RC
1847 foreign import stdcall "libHS_cbits.so" "fileEOF"
1848 prim_fileEOF :: FILE_OBJ -> IO RC
1850 foreign import stdcall "libHS_cbits.so" "setBuffering"
1851 prim_setBuffering :: FILE_OBJ -> Int -> IO RC
1853 foreign import stdcall "libHS_cbits.so" "flushFile"
1854 prim_flushFile :: FILE_OBJ -> IO RC
1856 foreign import stdcall "libHS_cbits.so" "getBufferMode"
1857 prim_getBufferMode :: FILE_OBJ -> IO RC
1859 foreign import stdcall "libHS_cbits.so" "seekFileP"
1860 prim_seekFileP :: FILE_OBJ -> IO RC
1862 foreign import stdcall "libHS_cbits.so" "setTerminalEcho"
1863 prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
1865 foreign import stdcall "libHS_cbits.so" "getTerminalEcho"
1866 prim_getTerminalEcho :: FILE_OBJ -> IO RC
1868 foreign import stdcall "libHS_cbits.so" "isTerminalDevice"
1869 prim_isTerminalDevice :: FILE_OBJ -> IO RC
1871 foreign import stdcall "libHS_cbits.so" "setConnectedTo"
1872 prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
1874 foreign import stdcall "libHS_cbits.so" "ungetChar"
1875 prim_ungetChar :: FILE_OBJ -> Char -> IO RC
1877 foreign import stdcall "libHS_cbits.so" "readChunk"
1878 prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC
1880 foreign import stdcall "libHS_cbits.so" "writeBuf"
1881 prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC
1883 foreign import stdcall "libHS_cbits.so" "getFileFd"
1884 prim_getFileFd :: FILE_OBJ -> IO FD
1886 foreign import stdcall "libHS_cbits.so" "fileSize_int64"
1887 prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC
1889 foreign import stdcall "libHS_cbits.so" "getFilePosn"
1890 prim_getFilePosn :: FILE_OBJ -> IO Int
1892 foreign import stdcall "libHS_cbits.so" "setFilePosn"
1893 prim_setFilePosn :: FILE_OBJ -> Int -> IO Int
1895 foreign import stdcall "libHS_cbits.so" "getConnFileFd"
1896 prim_getConnFileFd :: FILE_OBJ -> IO FD
1898 foreign import stdcall "libHS_cbits.so" "allocMemory__"
1899 prim_allocMemory__ :: Int -> IO Addr
1901 foreign import stdcall "libHS_cbits.so" "getLock"
1902 prim_getLock :: FD -> Exclusive -> IO RC
1904 foreign import stdcall "libHS_cbits.so" "openStdFile"
1905 prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
1907 foreign import stdcall "libHS_cbits.so" "openFile"
1908 prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
1910 foreign import stdcall "libHS_cbits.so" "freeFileObject"
1911 prim_freeFileObject :: FILE_OBJ -> IO ()
1913 foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
1914 prim_freeStdFileObject :: FILE_OBJ -> IO ()
1916 foreign import stdcall "libHS_cbits.so" "const_BUFSIZ"
1919 foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__"
1920 prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1922 foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__"
1923 prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1925 foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__"
1926 prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1928 foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__"
1929 prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1931 foreign import stdcall "libHS_cbits.so" "getErrStr__"
1932 prim_getErrStr__ :: IO Addr
1934 foreign import stdcall "libHS_cbits.so" "getErrNo__"
1935 prim_getErrNo__ :: IO Int
1937 foreign import stdcall "libHS_cbits.so" "getErrType__"
1938 prim_getErrType__ :: IO Int
1940 --foreign import stdcall "libHS_cbits.so" "seekFile_int64"
1941 -- prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
1944 -- showFloat ------------------------------------------------------------------
1946 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1947 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1948 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1949 showFloat :: (RealFloat a) => a -> ShowS
1951 showEFloat d x = showString (formatRealFloat FFExponent d x)
1952 showFFloat d x = showString (formatRealFloat FFFixed d x)
1953 showGFloat d x = showString (formatRealFloat FFGeneric d x)
1954 showFloat = showGFloat Nothing
1956 -- These are the format types. This type is not exported.
1958 data FFFormat = FFExponent | FFFixed | FFGeneric
1960 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
1961 formatRealFloat fmt decs x = s
1965 else if isInfinite x then
1966 if x < 0 then "-Infinity" else "Infinity"
1967 else if x < 0 || isNegativeZero x then
1968 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
1970 doFmt fmt (floatToDigits (toInteger base) x)
1972 let ds = map intToDigit is
1975 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
1982 [d] -> d : ".0e" ++ show (e-1)
1983 d:ds -> d : '.' : ds ++ 'e':show (e-1)
1985 let dec' = max dec 1 in
1987 [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
1989 let (ei, is') = roundTo base (dec'+1) is
1990 d:ds = map intToDigit
1991 (if ei > 0 then init is' else is')
1992 in d:'.':ds ++ "e" ++ show (e-1+ei)
1996 let f 0 s ds = mk0 s ++ "." ++ mk0 ds
1997 f n s "" = f (n-1) (s++"0") ""
1998 f n s (d:ds) = f (n-1) (s++[d]) ds
2003 let dec' = max dec 0 in
2005 let (ei, is') = roundTo base (dec' + e) is
2006 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2007 in (if null ls then "0" else ls) ++
2008 (if null rs then "" else '.' : rs)
2010 let (ei, is') = roundTo base dec'
2011 (replicate (-e) 0 ++ is)
2012 d : ds = map intToDigit
2013 (if ei > 0 then is' else 0:is')
2016 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2017 roundTo base d is = case f d is of
2019 (1, is) -> (1, 1 : is)
2020 where b2 = base `div` 2
2021 f n [] = (0, replicate n 0)
2022 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2024 let (c, ds) = f (d-1) is
2026 in if i' == base then (1, 0:ds) else (0, i':ds)
2028 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2029 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2030 -- This version uses a much slower logarithm estimator. It should be improved.
2032 -- This function returns a list of digits (Ints in [0..base-1]) and an
2035 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2037 floatToDigits _ 0 = ([0], 0)
2038 floatToDigits base x =
2039 let (f0, e0) = decodeFloat x
2040 (minExp0, _) = floatRange x
2043 minExp = minExp0 - p -- the real minimum exponent
2044 -- Haskell requires that f be adjusted so denormalized numbers
2045 -- will have an impossibly low exponent. Adjust for this.
2046 (f, e) = let n = minExp - e0
2047 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2052 if f == b^(p-1) then
2053 (f*be*b*2, 2*b, be*b, b)
2057 if e > minExp && f == b^(p-1) then
2058 (f*b*2, b^(-e+1)*2, b, 1)
2060 (f*2, b^(-e)*2, 1, 1)
2068 if r + mUp <= expt base n * s then n else fixup (n+1)
2070 if expt base (-n) * (r + mUp) <= s then n
2074 gen ds rn sN mUpN mDnN =
2075 let (dn, rn') = (rn * base) `divMod` sN
2078 in case (rn' < mDnN', rn' + mUpN' > sN) of
2079 (True, False) -> dn : ds
2080 (False, True) -> dn+1 : ds
2081 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2082 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2085 gen [] r (s * expt base k) mUp mDn
2087 let bk = expt base (-k)
2088 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
2089 in (map toInt (reverse rds), k)
2091 -- Exponentiation with(out) a cache for the most common numbers.
2092 expt :: Integer -> Int -> Integer
2093 expt base n = base^n