1 {----------------------------------------------------------------------------
2 __ __ __ __ ____ ___ _______________________________________________
3 || || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system
4 ||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999
5 ||---|| ___|| World Wide Web: http://haskell.org/hugs
6 || || Report bugs to: hugs-bugs@haskell.org
7 || || Version: January 1999 _______________________________________________
9 This is the Hugs 98 Standard Prelude, based very closely on the Standard
10 Prelude for Haskell 98.
12 WARNING: This file is an integral part of the Hugs source code. Changes to
13 the definitions in this file without corresponding modifications in other
14 parts of the program may cause the interpreter to fail unexpectedly. Under
15 normal circumstances, you should not attempt to modify this file in any way!
17 -----------------------------------------------------------------------------
18 Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell
19 Group 1994-99, and is distributed as Open Source software under the
20 Artistic License; see the file "Artistic" that is included in the
21 distribution for details.
22 ----------------------------------------------------------------------------}
25 -- module PreludeList,
26 map, (++), concat, filter,
27 head, last, tail, init, null, length, (!!),
28 foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
29 iterate, repeat, replicate, cycle,
30 take, drop, splitAt, takeWhile, dropWhile, span, break,
31 lines, words, unlines, unwords, reverse, and, or,
32 any, all, elem, notElem, lookup,
33 sum, product, maximum, minimum, concatMap,
34 zip, zip3, zipWith, zipWith3, unzip, unzip3,
35 -- module PreludeText,
37 Read(readsPrec, readList),
38 Show(show, showsPrec, showList),
39 reads, shows, read, lex,
40 showChar, showString, readParen, showParen,
42 FilePath, IOError, ioError, userError, catch,
43 putChar, putStr, putStrLn, print,
44 getChar, getLine, getContents, interact,
45 readFile, writeFile, appendFile, readIO, readLn,
47 Ix(range, index, inRange, rangeSize),
49 isAscii, isControl, isPrint, isSpace, isUpper, isLower,
50 isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
51 digitToInt, intToDigit,
54 readLitChar, showLitChar, lexLitChar,
58 readDec, readOct, readHex, readSigned,
61 Ratio, Rational, (%), numerator, denominator, approxRational,
62 -- Non-standard exports
63 IO(..), IOResult(..), Addr, StablePtr,
64 makeStablePtr, freeStablePtr, deRefStablePtr,
70 Char, String, Int, Integer, Float, Double, IO,
71 -- List type: []((:), [])
73 -- Tuple types: (,), (,,), etc.
76 Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
78 Ord(compare, (<), (<=), (>=), (>), max, min),
79 Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
80 enumFromTo, enumFromThenTo),
81 Bounded(minBound, maxBound),
82 -- Num((+), (-), (*), negate, abs, signum, fromInteger),
83 Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
85 -- Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
86 Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
87 -- Fractional((/), recip, fromRational),
88 Fractional((/), recip, fromRational, fromDouble),
89 Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
90 asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
91 RealFrac(properFraction, truncate, round, ceiling, floor),
92 RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
93 encodeFloat, exponent, significand, scaleFloat, isNaN,
94 isInfinite, isDenormalized, isIEEE, isNegativeZero),
95 Monad((>>=), (>>), return, fail),
97 mapM, mapM_, accumulate, sequence, (=<<),
99 (&&), (||), not, otherwise,
100 subtract, even, odd, gcd, lcm, (^), (^^),
101 fromIntegral, realToFrac, atan2,
102 fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
103 asTypeOf, error, undefined,
107 -- Arrrggghhh!!! Help! Help! Help!
108 -- What?! Prelude.hs doesn't even _define_ most of these things!
109 ,primCompAux,PrimArray,primRunST,primNewArray,primWriteArray
110 ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv
111 ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open
112 ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar
113 ,unsafeInterleaveIO,nh_write,primCharToInt
122 -- Standard value bindings {Prelude} ----------------------------------------
127 infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
129 --infixr 5 : -- this fixity declaration is hard-wired into Hugs
131 infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
136 infixr 0 $, $!, `seq`
138 -- Equality and Ordered classes ---------------------------------------------
141 (==), (/=) :: a -> a -> Bool
143 -- Minimal complete definition: (==) or (/=)
147 class (Eq a) => Ord a where
148 compare :: a -> a -> Ordering
149 (<), (<=), (>=), (>) :: a -> a -> Bool
150 max, min :: a -> a -> a
152 -- Minimal complete definition: (<=) or compare
153 -- using compare can be more efficient for complex types
154 compare x y | x==y = EQ
158 x <= y = compare x y /= GT
159 x < y = compare x y == LT
160 x >= y = compare x y /= LT
161 x > y = compare x y == GT
168 class Bounded a where
169 minBound, maxBound :: a
170 -- Minimal complete definition: All
172 -- Numeric classes ----------------------------------------------------------
174 class (Eq a, Show a) => Num a where
175 (+), (-), (*) :: a -> a -> a
177 abs, signum :: a -> a
178 fromInteger :: Integer -> a
181 -- Minimal complete definition: All, except negate or (-)
183 fromInt = fromIntegral
186 class (Num a, Ord a) => Real a where
187 toRational :: a -> Rational
189 class (Real a, Enum a) => Integral a where
190 quot, rem, div, mod :: a -> a -> a
191 quotRem, divMod :: a -> a -> (a,a)
192 even, odd :: a -> Bool
193 toInteger :: a -> Integer
196 -- Minimal complete definition: quotRem and toInteger
197 n `quot` d = q where (q,r) = quotRem n d
198 n `rem` d = r where (q,r) = quotRem n d
199 n `div` d = q where (q,r) = divMod n d
200 n `mod` d = r where (q,r) = divMod n d
201 divMod n d = if signum r == - signum d then (q-1, r+d) else qr
202 where qr@(q,r) = quotRem n d
203 even n = n `rem` 2 == 0
205 toInt = toInt . toInteger
207 class (Num a) => Fractional a where
210 fromRational :: Rational -> a
211 fromDouble :: Double -> a
213 -- Minimal complete definition: fromRational and ((/) or recip)
215 fromDouble = fromRational . toRational
219 class (Fractional a) => Floating a where
221 exp, log, sqrt :: a -> a
222 (**), logBase :: a -> a -> a
223 sin, cos, tan :: a -> a
224 asin, acos, atan :: a -> a
225 sinh, cosh, tanh :: a -> a
226 asinh, acosh, atanh :: a -> a
228 -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
229 -- asinh, acosh, atanh
230 x ** y = exp (log x * y)
231 logBase x y = log y / log x
233 tan x = sin x / cos x
234 sinh x = (exp x - exp (-x)) / 2
235 cosh x = (exp x + exp (-x)) / 2
236 tanh x = sinh x / cosh x
237 asinh x = log (x + sqrt (x*x + 1))
238 acosh x = log (x + sqrt (x*x - 1))
239 atanh x = (log (1 + x) - log (1 - x)) / 2
241 class (Real a, Fractional a) => RealFrac a where
242 properFraction :: (Integral b) => a -> (b,a)
243 truncate, round :: (Integral b) => a -> b
244 ceiling, floor :: (Integral b) => a -> b
246 -- Minimal complete definition: properFraction
247 truncate x = m where (m,_) = properFraction x
249 round x = let (n,r) = properFraction x
250 m = if r < 0 then n - 1 else n + 1
251 in case signum (abs r - 0.5) of
253 0 -> if even n then n else m
256 ceiling x = if r > 0 then n + 1 else n
257 where (n,r) = properFraction x
259 floor x = if r < 0 then n - 1 else n
260 where (n,r) = properFraction x
262 class (RealFrac a, Floating a) => RealFloat a where
263 floatRadix :: a -> Integer
264 floatDigits :: a -> Int
265 floatRange :: a -> (Int,Int)
266 decodeFloat :: a -> (Integer,Int)
267 encodeFloat :: Integer -> Int -> a
269 significand :: a -> a
270 scaleFloat :: Int -> a -> a
271 isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
275 -- Minimal complete definition: All, except exponent, signficand,
277 exponent x = if m==0 then 0 else n + floatDigits x
278 where (m,n) = decodeFloat x
279 significand x = encodeFloat m (- floatDigits x)
280 where (m,_) = decodeFloat x
281 scaleFloat k x = encodeFloat m (n+k)
282 where (m,n) = decodeFloat x
286 | x<0 && y>0 = pi + atan (y/x)
288 (x<0 && isNegativeZero y) ||
289 (isNegativeZero x && isNegativeZero y)
291 | y==0 && (x<0 || isNegativeZero x)
292 = pi -- must be after the previous test on zero y
293 | x==0 && y==0 = y -- must be after the other double zero tests
294 | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
296 -- Numeric functions --------------------------------------------------------
298 subtract :: Num a => a -> a -> a
301 gcd :: Integral a => a -> a -> a
302 gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
303 gcd x y = gcd' (abs x) (abs y)
305 gcd' x y = gcd' y (x `rem` y)
307 lcm :: (Integral a) => a -> a -> a
310 lcm x y = abs ((x `quot` gcd x y) * y)
312 (^) :: (Num a, Integral b) => a -> b -> a
314 x ^ n | n > 0 = f x (n-1) x
316 f x n y = g x n where
317 g x n | even n = g (x*x) (n`quot`2)
318 | otherwise = f x (n-1) (x*y)
319 _ ^ _ = error "Prelude.^: negative exponent"
321 (^^) :: (Fractional a, Integral b) => a -> b -> a
322 x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
324 fromIntegral :: (Integral a, Num b) => a -> b
325 fromIntegral = fromInteger . toInteger
327 realToFrac :: (Real a, Fractional b) => a -> b
328 realToFrac = fromRational . toRational
330 -- Index and Enumeration classes --------------------------------------------
332 class (Ord a) => Ix a where
333 range :: (a,a) -> [a]
334 index :: (a,a) -> a -> Int
335 inRange :: (a,a) -> a -> Bool
336 rangeSize :: (a,a) -> Int
340 | otherwise = index r u + 1
346 enumFrom :: a -> [a] -- [n..]
347 enumFromThen :: a -> a -> [a] -- [n,m..]
348 enumFromTo :: a -> a -> [a] -- [n..m]
349 enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
351 -- Minimal complete definition: toEnum, fromEnum
352 succ = toEnum . (1+) . fromEnum
353 pred = toEnum . subtract 1 . fromEnum
354 enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
355 enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
357 -- Read and Show classes ------------------------------------------------------
359 type ReadS a = String -> [(a,String)]
360 type ShowS = String -> String
363 readsPrec :: Int -> ReadS a
364 readList :: ReadS [a]
366 -- Minimal complete definition: readsPrec
367 readList = readParen False (\r -> [pr | ("[",s) <- lex r,
369 where readl s = [([],t) | ("]",t) <- lex s] ++
370 [(x:xs,u) | (x,t) <- reads s,
372 readl' s = [([],t) | ("]",t) <- lex s] ++
373 [(x:xs,v) | (",",t) <- lex s,
379 showsPrec :: Int -> a -> ShowS
380 showList :: [a] -> ShowS
382 -- Minimal complete definition: show or showsPrec
383 show x = showsPrec 0 x ""
384 showsPrec _ x s = show x ++ s
385 showList [] = showString "[]"
386 showList (x:xs) = showChar '[' . shows x . showl xs
387 where showl [] = showChar ']'
388 showl (x:xs) = showChar ',' . shows x . showl xs
390 -- Monad classes ------------------------------------------------------------
392 class Functor f where
393 fmap :: (a -> b) -> (f a -> f b)
397 (>>=) :: m a -> (a -> m b) -> m b
398 (>>) :: m a -> m b -> m b
399 fail :: String -> m a
401 -- Minimal complete definition: (>>=), return
402 p >> q = p >>= \ _ -> q
405 accumulate :: Monad m => [m a] -> m [a]
406 accumulate [] = return []
407 accumulate (c:cs) = do x <- c
411 sequence :: Monad m => [m a] -> m ()
412 sequence = foldr (>>) (return ())
414 mapM :: Monad m => (a -> m b) -> [a] -> m [b]
415 mapM f = accumulate . map f
417 mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
418 mapM_ f = sequence . map f
420 (=<<) :: Monad m => (a -> m b) -> m a -> m b
423 -- Evaluation and strictness ------------------------------------------------
426 seq x y = primSeq x y
428 ($!) :: (a -> b) -> a -> b
429 f $! x = x `primSeq` f x
431 -- Trivial type -------------------------------------------------------------
433 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
438 instance Ord () where
444 inRange ((),()) () = True
446 instance Enum () where
450 enumFromThen () () = [()]
452 instance Read () where
453 readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
456 instance Show () where
457 showsPrec p () = showString "()"
459 instance Bounded () where
463 -- Boolean type -------------------------------------------------------------
465 data Bool = False | True
466 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
468 (&&), (||) :: Bool -> Bool -> Bool
481 -- Character type -----------------------------------------------------------
483 data Char -- builtin datatype of ISO Latin characters
484 type String = [Char] -- strings are lists of characters
486 instance Eq Char where (==) = primEqChar
487 instance Ord Char where (<=) = primLeChar
489 instance Enum Char where
490 toEnum = primIntToChar
491 fromEnum = primCharToInt
492 enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
493 enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
494 where lastChar = if d < c then minBound else maxBound
496 instance Ix Char where
497 range (c,c') = [c..c']
499 | inRange b ci = fromEnum ci - fromEnum c
500 | otherwise = error "Ix.index: Index out of range."
501 inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
502 where i = fromEnum ci
504 instance Read Char where
505 readsPrec p = readParen False
506 (\r -> [(c,t) | ('\'':s,t) <- lex r,
507 (c,"\'") <- readLitChar s ])
508 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
510 where readl ('"':s) = [("",s)]
511 readl ('\\':'&':s) = readl s
512 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
514 instance Show Char where
515 showsPrec p '\'' = showString "'\\''"
516 showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
518 showList cs = showChar '"' . showl cs
519 where showl "" = showChar '"'
520 showl ('"':cs) = showString "\\\"" . showl cs
521 showl (c:cs) = showLitChar c . showl cs
523 instance Bounded Char where
527 isAscii, isControl, isPrint, isSpace :: Char -> Bool
528 isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
530 isAscii c = fromEnum c < 128
531 isControl c = c < ' ' || c == '\DEL'
532 isPrint c = c >= ' ' && c <= '~'
533 isSpace c = c == ' ' || c == '\t' || c == '\n' ||
534 c == '\r' || c == '\f' || c == '\v'
535 isUpper c = c >= 'A' && c <= 'Z'
536 isLower c = c >= 'a' && c <= 'z'
537 isAlpha c = isUpper c || isLower c
538 isDigit c = c >= '0' && c <= '9'
539 isAlphaNum c = isAlpha c || isDigit c
541 -- Digit conversion operations
542 digitToInt :: Char -> Int
544 | isDigit c = fromEnum c - fromEnum '0'
545 | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
546 | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
547 | otherwise = error "Char.digitToInt: not a digit"
549 intToDigit :: Int -> Char
551 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
552 | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
553 | otherwise = error "Char.intToDigit: not a digit"
555 toUpper, toLower :: Char -> Char
556 toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
559 toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
568 -- Maybe type ---------------------------------------------------------------
570 data Maybe a = Nothing | Just a
571 deriving (Eq, Ord, Read, Show)
573 maybe :: b -> (a -> b) -> Maybe a -> b
574 maybe n f Nothing = n
575 maybe n f (Just x) = f x
577 instance Functor Maybe where
578 fmap f Nothing = Nothing
579 fmap f (Just x) = Just (f x)
581 instance Monad Maybe where
583 Nothing >>= k = Nothing
587 -- Either type --------------------------------------------------------------
589 data Either a b = Left a | Right b
590 deriving (Eq, Ord, Read, Show)
592 either :: (a -> c) -> (b -> c) -> Either a b -> c
593 either l r (Left x) = l x
594 either l r (Right y) = r y
596 -- Ordering type ------------------------------------------------------------
598 data Ordering = LT | EQ | GT
599 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
601 -- Lists --------------------------------------------------------------------
603 --data [a] = [] | a : [a] deriving (Eq, Ord)
605 instance Eq a => Eq [a] where
607 (x:xs) == (y:ys) = x==y && xs==ys
610 instance Ord a => Ord [a] where
611 compare [] (_:_) = LT
613 compare (_:_) [] = GT
614 compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
616 instance Functor [] where
619 instance Monad [ ] where
620 (x:xs) >>= f = f x ++ (xs >>= f)
625 instance Read a => Read [a] where
626 readsPrec p = readList
628 instance Show a => Show [a] where
629 showsPrec p = showList
631 -- Tuples -------------------------------------------------------------------
633 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
636 -- Functions ----------------------------------------------------------------
638 instance Show (a -> b) where
639 showsPrec p f = showString "<<function>>"
641 instance Functor ((->) a) where
644 -- Standard Integral types --------------------------------------------------
646 data Int -- builtin datatype of fixed size integers
647 data Integer -- builtin datatype of arbitrary size integers
649 instance Eq Integer where
650 (==) x y = primCompareInteger x y == 0
652 instance Ord Integer where
653 compare x y = case primCompareInteger x y of
658 instance Eq Int where
662 instance Ord Int where
668 instance Num Int where
671 negate = primNegateInt
675 fromInteger = primIntegerToInt
678 instance Bounded Int where
679 minBound = primMinInt
680 maxBound = primMaxInt
682 instance Num Integer where
683 (+) = primPlusInteger
684 (-) = primMinusInteger
685 negate = primNegateInteger
686 (*) = primTimesInteger
690 fromInt = primIntToInteger
692 absReal x | x >= 0 = x
695 signumReal x | x == 0 = 0
699 instance Real Int where
700 toRational x = toInteger x % 1
702 instance Real Integer where
705 instance Integral Int where
706 quotRem = primQuotRemInt
707 toInteger = primIntToInteger
710 instance Integral Integer where
711 quotRem = primQuotRemInteger
712 --divMod = primDivModInteger
714 toInt = primIntegerToInt
716 instance Ix Int where
719 | inRange b i = i - m
720 | otherwise = error "index: Index out of range"
721 inRange (m,n) i = m <= i && i <= n
723 instance Ix Integer where
726 | inRange b i = fromInteger (i - m)
727 | otherwise = error "index: Index out of range"
728 inRange (m,n) i = m <= i && i <= n
730 instance Enum Int where
733 enumFrom = numericEnumFrom
734 enumFromTo = numericEnumFromTo
735 enumFromThen = numericEnumFromThen
736 enumFromThenTo = numericEnumFromThenTo
738 instance Enum Integer where
739 toEnum = primIntToInteger
740 fromEnum = primIntegerToInt
741 enumFrom = numericEnumFrom
742 enumFromTo = numericEnumFromTo
743 enumFromThen = numericEnumFromThen
744 enumFromThenTo = numericEnumFromThenTo
746 numericEnumFrom :: Real a => a -> [a]
747 numericEnumFromThen :: Real a => a -> a -> [a]
748 numericEnumFromTo :: Real a => a -> a -> [a]
749 numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
750 numericEnumFrom n = n : (numericEnumFrom $! (n+1))
751 numericEnumFromThen n m = iterate ((m-n)+) n
752 numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
753 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
754 where p | n' >= n = (<= m)
757 instance Read Int where
758 readsPrec p = readSigned readDec
760 instance Show Int where
762 | n == minBound = showSigned showInt p (toInteger n)
763 | otherwise = showSigned showInt p n
765 instance Read Integer where
766 readsPrec p = readSigned readDec
768 instance Show Integer where
769 showsPrec = showSigned showInt
772 -- Standard Floating types --------------------------------------------------
774 data Float -- builtin datatype of single precision floating point numbers
775 data Double -- builtin datatype of double precision floating point numbers
777 instance Eq Float where
781 instance Ord Float where
787 instance Num Float where
790 negate = primNegateFloat
794 fromInteger = primIntegerToFloat
795 fromInt = primIntToFloat
799 instance Eq Double where
803 instance Ord Double where
809 instance Num Double where
811 (-) = primMinusDouble
812 negate = primNegateDouble
813 (*) = primTimesDouble
816 fromInteger = primIntegerToDouble
817 fromInt = primIntToDouble
821 instance Real Float where
822 toRational = floatToRational
824 instance Real Double where
825 toRational = doubleToRational
827 -- Calls to these functions are optimised when passed as arguments to
829 floatToRational :: Float -> Rational
830 doubleToRational :: Double -> Rational
831 floatToRational x = realFloatToRational x
832 doubleToRational x = realFloatToRational x
834 realFloatToRational x = (m%1)*(b%1)^^n
835 where (m,n) = decodeFloat x
838 instance Fractional Float where
839 (/) = primDivideFloat
840 fromRational = rationalToRealFloat
841 fromDouble = primDoubleToFloat
844 instance Fractional Double where
845 (/) = primDivideDouble
846 fromRational = rationalToRealFloat
849 rationalToRealFloat x = x'
851 f e = if e' == e then y else f e'
852 where y = encodeFloat (round (x * (1%b)^^e)) e
853 (_,e') = decodeFloat y
854 (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
855 / fromInteger (denominator x))
858 instance Floating Float where
859 pi = 3.14159265358979323846
870 instance Floating Double where
871 pi = 3.14159265358979323846
874 sqrt = primSqrtDouble
878 asin = primAsinDouble
879 acos = primAcosDouble
880 atan = primAtanDouble
882 instance RealFrac Float where
883 properFraction = floatProperFraction
885 instance RealFrac Double where
886 properFraction = floatProperFraction
888 floatProperFraction x
889 | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
890 | otherwise = (fromInteger w, encodeFloat r n)
891 where (m,n) = decodeFloat x
893 (w,r) = quotRem m (b^(-n))
895 instance RealFloat Float where
896 floatRadix _ = toInteger primRadixFloat
897 floatDigits _ = primDigitsFloat
898 floatRange _ = (primMinExpFloat,primMaxExpFloat)
899 encodeFloat = primEncodeFloatZ
900 decodeFloat = primDecodeFloatZ
901 isNaN = primIsNaNFloat
902 isInfinite = primIsInfiniteFloat
903 isDenormalized= primIsDenormalizedFloat
904 isNegativeZero= primIsNegativeZeroFloat
905 isIEEE = const primIsIEEEFloat
907 instance RealFloat Double where
908 floatRadix _ = toInteger primRadixDouble
909 floatDigits _ = primDigitsDouble
910 floatRange _ = (primMinExpDouble,primMaxExpDouble)
911 encodeFloat = primEncodeDoubleZ
912 decodeFloat = primDecodeDoubleZ
913 isNaN = primIsNaNDouble
914 isInfinite = primIsInfiniteDouble
915 isDenormalized= primIsDenormalizedDouble
916 isNegativeZero= primIsNegativeZeroDouble
917 isIEEE = const primIsIEEEDouble
919 instance Enum Float where
920 toEnum = primIntToFloat
922 enumFrom = numericEnumFrom
923 enumFromThen = numericEnumFromThen
924 enumFromTo n m = numericEnumFromTo n (m+1/2)
925 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
927 instance Enum Double where
928 toEnum = primIntToDouble
930 enumFrom = numericEnumFrom
931 enumFromThen = numericEnumFromThen
932 enumFromTo n m = numericEnumFromTo n (m+1/2)
933 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
935 instance Read Float where
936 readsPrec p = readSigned readFloat
938 instance Show Float where
939 showsPrec p = showSigned showFloat p
941 instance Read Double where
942 readsPrec p = readSigned readFloat
944 instance Show Double where
945 showsPrec p = showSigned showFloat p
948 -- Some standard functions --------------------------------------------------
956 curry :: ((a,b) -> c) -> (a -> b -> c)
957 curry f x y = f (x,y)
959 uncurry :: (a -> b -> c) -> ((a,b) -> c)
960 uncurry f p = f (fst p) (snd p)
968 (.) :: (b -> c) -> (a -> b) -> (a -> c)
971 flip :: (a -> b -> c) -> b -> a -> c
974 ($) :: (a -> b) -> a -> b
977 until :: (a -> Bool) -> (a -> a) -> a -> a
978 until p f x = if p x then x else until p f (f x)
980 asTypeOf :: a -> a -> a
984 error msg = primRaise (ErrorCall msg)
987 undefined | False = undefined
989 -- Standard functions on rational numbers {PreludeRatio} --------------------
991 data Integral a => Ratio a = a :% a deriving (Eq)
992 type Rational = Ratio Integer
994 (%) :: Integral a => a -> a -> Ratio a
995 x % y = reduce (x * signum y) (abs y)
997 reduce :: Integral a => a -> a -> Ratio a
998 reduce x y | y == 0 = error "Ratio.%: zero denominator"
999 | otherwise = (x `quot` d) :% (y `quot` d)
1002 numerator, denominator :: Integral a => Ratio a -> a
1003 numerator (x :% y) = x
1004 denominator (x :% y) = y
1006 instance Integral a => Ord (Ratio a) where
1007 compare (x:%y) (x':%y') = compare (x*y') (x'*y)
1009 instance Integral a => Num (Ratio a) where
1010 (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
1011 (x:%y) * (x':%y') = reduce (x*x') (y*y')
1012 negate (x :% y) = negate x :% y
1013 abs (x :% y) = abs x :% y
1014 signum (x :% y) = signum x :% 1
1015 fromInteger x = fromInteger x :% 1
1016 fromInt = intToRatio
1018 -- Hugs optimises code of the form fromRational (intToRatio x)
1019 intToRatio :: Integral a => Int -> Ratio a
1020 intToRatio x = fromInt x :% 1
1022 instance Integral a => Real (Ratio a) where
1023 toRational (x:%y) = toInteger x :% toInteger y
1025 instance Integral a => Fractional (Ratio a) where
1026 (x:%y) / (x':%y') = (x*y') % (y*x')
1027 recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
1028 fromRational (x:%y) = fromInteger x :% fromInteger y
1029 fromDouble = doubleToRatio
1031 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1032 doubleToRatio :: Integral a => Double -> Ratio a
1034 | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
1035 | otherwise = fromInteger m % (fromInteger b ^ (-n))
1036 where (m,n) = decodeFloat x
1039 instance Integral a => RealFrac (Ratio a) where
1040 properFraction (x:%y) = (fromIntegral q, r:%y)
1041 where (q,r) = quotRem x y
1043 instance Integral a => Enum (Ratio a) where
1046 enumFrom = numericEnumFrom
1047 enumFromThen = numericEnumFromThen
1049 instance (Read a, Integral a) => Read (Ratio a) where
1050 readsPrec p = readParen (p > 7)
1051 (\r -> [(x%y,u) | (x,s) <- reads r,
1055 instance Integral a => Show (Ratio a) where
1056 showsPrec p (x:%y) = showParen (p > 7)
1057 (shows x . showString " % " . shows y)
1059 approxRational :: RealFrac a => a -> a -> Rational
1060 approxRational x eps = simplest (x-eps) (x+eps)
1061 where simplest x y | y < x = simplest y x
1063 | x > 0 = simplest' n d n' d'
1064 | y < 0 = - simplest' (-n') d' (-n) d
1065 | otherwise = 0 :% 1
1066 where xr@(n:%d) = toRational x
1067 (n':%d') = toRational y
1068 simplest' n d n' d' -- assumes 0 < n%d < n'%d'
1070 | q /= q' = (q+1) :% 1
1071 | otherwise = (q*n''+d'') :% n''
1072 where (q,r) = quotRem n d
1073 (q',r') = quotRem n' d'
1074 (n'':%d'') = simplest' d' r' d r
1076 -- Standard list functions {PreludeList} ------------------------------------
1083 last (_:xs) = last xs
1090 init (x:xs) = x : init xs
1096 (++) :: [a] -> [a] -> [a]
1098 (x:xs) ++ ys = x : (xs ++ ys)
1100 map :: (a -> b) -> [a] -> [b]
1101 --map f xs = [ f x | x <- xs ]
1103 map f (x:xs) = f x : map f xs
1106 filter :: (a -> Bool) -> [a] -> [a]
1107 --filter p xs = [ x | x <- xs, p x ]
1109 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1112 concat :: [[a]] -> [a]
1113 --concat = foldr (++) []
1115 concat (xs:xss) = xs ++ concat xss
1117 length :: [a] -> Int
1118 --length = foldl' (\n _ -> n + 1) 0
1120 length (x:xs) = let n = length xs in primSeq n (1+n)
1122 (!!) :: [b] -> Int -> b
1124 (_:xs) !! n | n>0 = xs !! (n-1)
1125 (_:_) !! _ = error "Prelude.!!: negative index"
1126 [] !! _ = error "Prelude.!!: index too large"
1128 foldl :: (a -> b -> a) -> a -> [b] -> a
1130 foldl f z (x:xs) = foldl f (f z x) xs
1132 foldl' :: (a -> b -> a) -> a -> [b] -> a
1134 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1136 foldl1 :: (a -> a -> a) -> [a] -> a
1137 foldl1 f (x:xs) = foldl f x xs
1139 scanl :: (a -> b -> a) -> a -> [b] -> [a]
1140 scanl f q xs = q : (case xs of
1142 x:xs -> scanl f (f q x) xs)
1144 scanl1 :: (a -> a -> a) -> [a] -> [a]
1145 scanl1 f (x:xs) = scanl f x xs
1147 foldr :: (a -> b -> b) -> b -> [a] -> b
1149 foldr f z (x:xs) = f x (foldr f z xs)
1151 foldr1 :: (a -> a -> a) -> [a] -> a
1153 foldr1 f (x:xs) = f x (foldr1 f xs)
1155 scanr :: (a -> b -> b) -> b -> [a] -> [b]
1156 scanr f q0 [] = [q0]
1157 scanr f q0 (x:xs) = f x q : qs
1158 where qs@(q:_) = scanr f q0 xs
1160 scanr1 :: (a -> a -> a) -> [a] -> [a]
1162 scanr1 f (x:xs) = f x q : qs
1163 where qs@(q:_) = scanr1 f xs
1165 iterate :: (a -> a) -> a -> [a]
1166 iterate f x = x : iterate f (f x)
1169 repeat x = xs where xs = x:xs
1171 replicate :: Int -> a -> [a]
1172 replicate n x = take n (repeat x)
1175 cycle [] = error "Prelude.cycle: empty list"
1176 cycle xs = xs' where xs'=xs++xs'
1178 take :: Int -> [a] -> [a]
1181 take n (x:xs) | n>0 = x : take (n-1) xs
1182 take _ _ = error "Prelude.take: negative argument"
1184 drop :: Int -> [a] -> [a]
1187 drop n (_:xs) | n>0 = drop (n-1) xs
1188 drop _ _ = error "Prelude.drop: negative argument"
1190 splitAt :: Int -> [a] -> ([a], [a])
1191 splitAt 0 xs = ([],xs)
1192 splitAt _ [] = ([],[])
1193 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1194 splitAt _ _ = error "Prelude.splitAt: negative argument"
1196 takeWhile :: (a -> Bool) -> [a] -> [a]
1199 | p x = x : takeWhile p xs
1202 dropWhile :: (a -> Bool) -> [a] -> [a]
1204 dropWhile p xs@(x:xs')
1205 | p x = dropWhile p xs'
1208 span, break :: (a -> Bool) -> [a] -> ([a],[a])
1212 | otherwise = ([],xs)
1213 where (ys,zs) = span p xs'
1214 break p = span (not . p)
1216 lines :: String -> [String]
1218 lines s = let (l,s') = break ('\n'==) s
1219 in l : case s' of [] -> []
1220 (_:s'') -> lines s''
1222 words :: String -> [String]
1223 words s = case dropWhile isSpace s of
1226 where (w,s'') = break isSpace s'
1228 unlines :: [String] -> String
1229 unlines = concatMap (\l -> l ++ "\n")
1231 unwords :: [String] -> String
1233 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1235 reverse :: [a] -> [a]
1236 --reverse = foldl (flip (:)) []
1237 reverse xs = ri [] xs
1238 where ri acc [] = acc
1239 ri acc (x:xs) = ri (x:acc) xs
1241 and, or :: [Bool] -> Bool
1242 --and = foldr (&&) True
1243 --or = foldr (||) False
1245 and (x:xs) = if x then and xs else x
1247 or (x:xs) = if x then x else or xs
1249 any, all :: (a -> Bool) -> [a] -> Bool
1250 --any p = or . map p
1251 --all p = and . map p
1253 any p (x:xs) = if p x then True else any p xs
1255 all p (x:xs) = if p x then all p xs else False
1257 elem, notElem :: Eq a => a -> [a] -> Bool
1259 --notElem = all . (/=)
1261 elem x (y:ys) = if x==y then True else elem x ys
1263 notElem x (y:ys) = if x==y then False else notElem x ys
1265 lookup :: Eq a => a -> [(a,b)] -> Maybe b
1266 lookup k [] = Nothing
1267 lookup k ((x,y):xys)
1269 | otherwise = lookup k xys
1271 sum, product :: Num a => [a] -> a
1273 product = foldl' (*) 1
1275 maximum, minimum :: Ord a => [a] -> a
1276 maximum = foldl1 max
1277 minimum = foldl1 min
1279 concatMap :: (a -> [b]) -> [a] -> [b]
1280 concatMap f = concat . map f
1282 zip :: [a] -> [b] -> [(a,b)]
1283 zip = zipWith (\a b -> (a,b))
1285 zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
1286 zip3 = zipWith3 (\a b c -> (a,b,c))
1288 zipWith :: (a->b->c) -> [a]->[b]->[c]
1289 zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
1292 zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1293 zipWith3 z (a:as) (b:bs) (c:cs)
1294 = z a b c : zipWith3 z as bs cs
1295 zipWith3 _ _ _ _ = []
1297 unzip :: [(a,b)] -> ([a],[b])
1298 unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1300 unzip3 :: [(a,b,c)] -> ([a],[b],[c])
1301 unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1304 -- PreludeText ----------------------------------------------------------------
1306 reads :: Read a => ReadS a
1309 shows :: Show a => a -> ShowS
1312 read :: Read a => String -> a
1313 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1315 [] -> error "Prelude.read: no parse"
1316 _ -> error "Prelude.read: ambiguous parse"
1318 showChar :: Char -> ShowS
1321 showString :: String -> ShowS
1324 showParen :: Bool -> ShowS -> ShowS
1325 showParen b p = if b then showChar '(' . p . showChar ')' else p
1327 showField :: Show a => String -> a -> ShowS
1328 showField m v = showString m . showChar '=' . shows v
1330 readParen :: Bool -> ReadS a -> ReadS a
1331 readParen b g = if b then mandatory else optional
1332 where optional r = g r ++ mandatory r
1333 mandatory r = [(x,u) | ("(",s) <- lex r,
1334 (x,t) <- optional s,
1338 readField :: Read a => String -> ReadS a
1339 readField m s0 = [ r | (t, s1) <- lex s0, t == m,
1345 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1346 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1348 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1350 lexString ('"':s) = [("\"",s)]
1351 lexString s = [(ch++str, u)
1352 | (ch,t) <- lexStrItem s,
1353 (str,u) <- lexString t ]
1355 lexStrItem ('\\':'&':s) = [("\\&",s)]
1356 lexStrItem ('\\':c:s) | isSpace c
1357 = [("",t) | '\\':t <- [dropWhile isSpace s]]
1358 lexStrItem s = lexLitChar s
1360 lex (c:s) | isSingle c = [([c],s)]
1361 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
1362 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
1363 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
1364 (fe,t) <- lexFracExp s ]
1365 | otherwise = [] -- bad character
1367 isSingle c = c `elem` ",;()[]{}_`"
1368 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1369 isIdChar c = isAlphaNum c || c `elem` "_'"
1371 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1373 lexFracExp s = [("",s)]
1375 lexExp (e:s) | e `elem` "eE"
1376 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
1377 (ds,u) <- lexDigits t] ++
1378 [(e:ds,t) | (ds,t) <- lexDigits s]
1381 lexDigits :: ReadS String
1382 lexDigits = nonnull isDigit
1384 nonnull :: (Char -> Bool) -> ReadS String
1385 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1387 lexLitChar :: ReadS String
1388 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1390 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- "
1391 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
1392 lexEsc s@(d:_) | isDigit d = lexDigits s
1393 lexEsc s@(c:_) | isUpper c
1394 = let table = ('\DEL',"DEL") : asciiTab
1395 in case [(mne,s') | (c, mne) <- table,
1396 ([],s') <- [lexmatch mne s]]
1400 lexLitChar (c:s) = [([c],s)]
1403 isOctDigit c = c >= '0' && c <= '7'
1404 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
1405 || c >= 'a' && c <= 'f'
1407 lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
1408 lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
1409 lexmatch xs ys = (xs,ys)
1411 asciiTab = zip ['\NUL'..' ']
1412 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1413 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
1414 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1415 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
1418 readLitChar :: ReadS Char
1419 readLitChar ('\\':s) = readEsc s
1421 readEsc ('a':s) = [('\a',s)]
1422 readEsc ('b':s) = [('\b',s)]
1423 readEsc ('f':s) = [('\f',s)]
1424 readEsc ('n':s) = [('\n',s)]
1425 readEsc ('r':s) = [('\r',s)]
1426 readEsc ('t':s) = [('\t',s)]
1427 readEsc ('v':s) = [('\v',s)]
1428 readEsc ('\\':s) = [('\\',s)]
1429 readEsc ('"':s) = [('"',s)]
1430 readEsc ('\'':s) = [('\'',s)]
1431 readEsc ('^':c:s) | c >= '@' && c <= '_'
1432 = [(toEnum (fromEnum c - fromEnum '@'), s)]
1433 readEsc s@(d:_) | isDigit d
1434 = [(toEnum n, t) | (n,t) <- readDec s]
1435 readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
1436 readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
1437 readEsc s@(c:_) | isUpper c
1438 = let table = ('\DEL',"DEL") : asciiTab
1439 in case [(c,s') | (c, mne) <- table,
1440 ([],s') <- [lexmatch mne s]]
1444 readLitChar (c:s) = [(c,s)]
1446 showLitChar :: Char -> ShowS
1447 showLitChar c | c > '\DEL' = showChar '\\' .
1448 protectEsc isDigit (shows (fromEnum c))
1449 showLitChar '\DEL' = showString "\\DEL"
1450 showLitChar '\\' = showString "\\\\"
1451 showLitChar c | c >= ' ' = showChar c
1452 showLitChar '\a' = showString "\\a"
1453 showLitChar '\b' = showString "\\b"
1454 showLitChar '\f' = showString "\\f"
1455 showLitChar '\n' = showString "\\n"
1456 showLitChar '\r' = showString "\\r"
1457 showLitChar '\t' = showString "\\t"
1458 showLitChar '\v' = showString "\\v"
1459 showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
1460 showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
1462 protectEsc p f = f . cont
1463 where cont s@(c:_) | p c = "\\&" ++ s
1466 -- Unsigned readers for various bases
1467 readDec, readOct, readHex :: Integral a => ReadS a
1468 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1469 readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1470 readHex = readInt 16 isHexDigit hex
1471 where hex d = fromEnum d -
1474 else fromEnum (if isUpper d then 'A' else 'a') - 10)
1476 -- readInt reads a string of digits using an arbitrary base.
1477 -- Leading minus signs must be handled elsewhere.
1479 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1480 readInt radix isDig digToInt s =
1481 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1482 | (ds,r) <- nonnull isDig s ]
1484 -- showInt is used for positive numbers only
1485 showInt :: Integral a => a -> ShowS
1488 = error "Numeric.showInt: can't show negative numbers"
1491 = let (n',d) = quotRem n 10
1492 r' = toEnum (fromEnum '0' + fromIntegral d) : r
1493 in if n' == 0 then r' else showInt n' r'
1495 = case quotRem n 10 of { (n',d) ->
1496 let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1497 in if n' == 0 then r' else showInt n' r'
1501 readSigned:: Real a => ReadS a -> ReadS a
1502 readSigned readPos = readParen False read'
1503 where read' r = read'' r ++
1504 [(-x,t) | ("-",s) <- lex r,
1506 read'' r = [(n,s) | (str,s) <- lex r,
1507 (n,"") <- readPos str]
1509 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1510 showSigned showPos p x = if x < 0 then showParen (p > 6)
1511 (showChar '-' . showPos (-x))
1514 readFloat :: RealFloat a => ReadS a
1515 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1517 where readFix r = [(read (ds++ds'), length ds', t)
1518 | (ds, s) <- lexDigits r
1519 , (ds',t) <- lexFrac s ]
1521 lexFrac ('.':s) = lexDigits s
1522 lexFrac s = [("",s)]
1524 readExp (e:s) | e `elem` "eE" = readExp' s
1527 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1528 readExp' ('+':s) = readDec s
1529 readExp' s = readDec s
1532 -- Hooks for primitives: -----------------------------------------------------
1533 -- Do not mess with these!
1535 primCompAux :: Ord a => a -> a -> Ordering -> Ordering
1536 primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1538 primPmInt :: Num a => Int -> a -> Bool
1539 primPmInt n x = fromInt n == x
1541 primPmInteger :: Num a => Integer -> a -> Bool
1542 primPmInteger n x = fromInteger n == x
1544 primPmFlt :: Fractional a => Double -> a -> Bool
1545 primPmFlt n x = fromDouble n == x
1547 -- ToDo: make the message more informative.
1549 primPmFail = error "Pattern Match Failure"
1551 -- used in desugaring Foreign functions
1552 primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1555 primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1556 primCreateAdjThunk fun typestr callconv
1557 = do sp <- makeStablePtr fun
1558 p <- copy_String_to_cstring typestr -- is never freed
1559 a <- primCreateAdjThunkARCH sp p callconv
1562 -- The following primitives are only needed if (n+k) patterns are enabled:
1563 primPmNpk :: Integral a => Int -> a -> Maybe a
1564 primPmNpk n x = if n'<=x then Just (x-n') else Nothing
1565 where n' = fromInt n
1567 primPmSub :: Integral a => Int -> a -> a
1568 primPmSub n x = x - fromInt n
1570 -- Unpack strings generated by the Hugs code generator.
1571 -- Strings can contain \0 provided they're coded right.
1573 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1575 primUnpackString :: Addr -> String
1576 primUnpackString a = unpack 0
1578 -- The following decoding is based on evalString in the old machine.c
1581 | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1582 then '\\' : unpack (i+2)
1583 else '\0' : unpack (i+2)
1584 | otherwise = c : unpack (i+1)
1586 c = primIndexCharOffAddr a i
1589 -- Monadic I/O: --------------------------------------------------------------
1591 type FilePath = String
1593 --data IOError = ...
1594 --instance Eq IOError ...
1595 --instance Show IOError ...
1597 data IOError = IOError String
1598 instance Show IOError where
1599 showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1601 ioError :: IOError -> IO a
1602 ioError (IOError s) = primRaise (IOExcept s)
1604 userError :: String -> IOError
1605 userError s = primRaise (ErrorCall s)
1607 catch :: IO a -> (IOError -> IO a) -> IO a
1609 = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
1611 e2ioe (IOExcept s) = IOError s
1612 e2ioe other = IOError (show other)
1614 putChar :: Char -> IO ()
1615 putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c)
1617 putStr :: String -> IO ()
1618 putStr s = --mapM_ putChar s -- correct, but slow
1620 let loop [] = return ()
1621 loop (c:cs) = nh_write h (primCharToInt c) >> loop cs
1624 putStrLn :: String -> IO ()
1625 putStrLn s = do { putStr s; putChar '\n' }
1627 print :: Show a => a -> IO ()
1628 print = putStrLn . show
1631 getChar = unsafeInterleaveIO (
1633 nh_read h >>= \ci ->
1634 return (primIntToChar ci)
1637 getLine :: IO String
1638 getLine = do c <- getChar
1639 if c=='\n' then return ""
1640 else do cs <- getLine
1643 getContents :: IO String
1644 getContents = nh_stdin >>= \h -> readfromhandle h
1646 interact :: (String -> String) -> IO ()
1647 interact f = getContents >>= (putStr . f)
1649 readFile :: FilePath -> IO String
1651 = copy_String_to_cstring fname >>= \ptr ->
1652 nh_open ptr 0 >>= \h ->
1654 nh_errno >>= \errno ->
1655 if (h == 0 || errno /= 0)
1656 then (ioError.IOError) ("readFile: can't open file " ++ fname)
1657 else readfromhandle h
1659 writeFile :: FilePath -> String -> IO ()
1660 writeFile fname contents
1661 = copy_String_to_cstring fname >>= \ptr ->
1662 nh_open ptr 1 >>= \h ->
1664 nh_errno >>= \errno ->
1665 if (h == 0 || errno /= 0)
1666 then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1667 else writetohandle fname h contents
1669 appendFile :: FilePath -> String -> IO ()
1670 appendFile fname contents
1671 = copy_String_to_cstring fname >>= \ptr ->
1672 nh_open ptr 2 >>= \h ->
1674 nh_errno >>= \errno ->
1675 if (h == 0 || errno /= 0)
1676 then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1677 else writetohandle fname h contents
1680 -- raises an exception instead of an error
1681 readIO :: Read a => String -> IO a
1682 readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1684 [] -> ioError (userError "PreludeIO.readIO: no parse")
1685 _ -> ioError (userError
1686 "PreludeIO.readIO: ambiguous parse")
1688 readLn :: Read a => IO a
1689 readLn = do l <- getLine
1694 -- End of Hugs standard prelude ----------------------------------------------
1700 instance Show Exception where
1701 showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1702 showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
1704 data IOResult = IOResult deriving (Show)
1706 type FILE_STAR = Int -- FILE *
1708 foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR
1709 foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
1710 foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
1711 foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Int -> IO ()
1712 foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int
1713 foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR
1714 foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO ()
1715 foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO ()
1716 foreign import "nHandle" "nh_errno" nh_errno :: IO Int
1718 foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
1719 foreign import "nHandle" "nh_free" nh_free :: Addr -> IO ()
1720 foreign import "nHandle" "nh_store" nh_store :: Addr -> Int -> IO ()
1721 foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Int
1723 --foreign import "nHandle" "nh_argc" nh_argc :: IO Int
1724 --foreign import "nHandle" "nh_argvb" nh_argvb :: Int -> Int -> IO Int
1725 foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
1727 copy_String_to_cstring :: String -> IO Addr
1728 copy_String_to_cstring s
1729 = nh_malloc (1 + length s) >>= \ptr0 ->
1730 let loop ptr [] = nh_store ptr 0 >> return ptr0
1731 loop ptr (c:cs) = nh_store ptr (primCharToInt c) >> loop (incAddr ptr) cs
1734 then error "copy_String_to_cstring: malloc failed"
1737 copy_cstring_to_String :: Addr -> IO String
1738 copy_cstring_to_String ptr
1739 = nh_load ptr >>= \ci ->
1742 else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1743 return ((primIntToChar ci) : cs)
1745 readfromhandle :: FILE_STAR -> IO String
1747 = unsafeInterleaveIO (
1748 nh_read h >>= \ci ->
1749 if ci == -1 {-EOF-} then return "" else
1750 readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1753 writetohandle :: String -> FILE_STAR -> String -> IO ()
1754 writetohandle fname h []
1756 nh_errno >>= \errno ->
1759 else error ( "writeFile/appendFile: error closing file " ++ fname)
1760 writetohandle fname h (c:cs)
1761 = nh_write h (primCharToInt c) >>
1762 writetohandle fname h cs
1764 primGetRawArgs :: IO [String]
1766 = primGetArgc >>= \argc ->
1767 accumulate (map get_one_arg [0 .. argc-1])
1769 get_one_arg :: Int -> IO String
1771 = primGetArgv argno >>= \a ->
1772 copy_cstring_to_String a
1774 primGetEnv :: String -> IO String
1776 = copy_String_to_cstring v >>= \ptr ->
1777 nh_getenv ptr >>= \ptr2 ->
1782 copy_cstring_to_String ptr2 >>= \result ->
1786 ------------------------------------------------------------------------------
1787 -- ST, IO --------------------------------------------------------------------
1788 ------------------------------------------------------------------------------
1790 newtype ST s a = ST (s -> (a,s))
1793 type IO a = ST RealWorld a
1796 --primRunST :: (forall s. ST s a) -> a
1797 primRunST :: ST RealWorld a -> a
1798 primRunST m = fst (unST m theWorld)
1800 theWorld :: RealWorld
1801 theWorld = error "primRunST: entered the RealWorld"
1805 instance Functor (ST s) where
1806 fmap f x = x >>= (return . f)
1808 instance Monad (ST s) where
1809 m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1810 return x = ST (\s -> (x,s))
1811 m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1814 -- used when Hugs invokes top level function
1815 primRunIO :: IO () -> ()
1817 = protect (fst (unST m realWorld))
1819 realWorld = error "primRunIO: entered the RealWorld"
1822 = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1824 trace :: String -> a -> a
1826 = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x
1828 unsafeInterleaveST :: ST s a -> ST s a
1829 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1831 unsafeInterleaveIO :: IO a -> IO a
1832 unsafeInterleaveIO = unsafeInterleaveST
1835 ------------------------------------------------------------------------------
1836 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
1837 ------------------------------------------------------------------------------
1841 nullAddr = primIntToAddr 0
1842 incAddr a = primIntToAddr (1 + primAddrToInt a)
1843 isNullAddr a = 0 == primAddrToInt a
1845 instance Eq Addr where
1849 instance Ord Addr where
1858 instance Eq Word where
1862 instance Ord Word where
1871 makeStablePtr :: a -> IO (StablePtr a)
1872 makeStablePtr = primMakeStablePtr
1873 deRefStablePtr :: StablePtr a -> IO a
1874 deRefStablePtr = primDeRefStablePtr
1875 freeStablePtr :: StablePtr a -> IO ()
1876 freeStablePtr = primFreeStablePtr
1879 data PrimArray a -- immutable arrays with Int indices
1882 data Ref s a -- mutable variables
1883 data PrimMutableArray s a -- mutable arrays with Int indices
1884 data PrimMutableByteArray s
1888 -- showFloat ------------------------------------------------------------------
1890 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1891 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1892 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1893 showFloat :: (RealFloat a) => a -> ShowS
1895 showEFloat d x = showString (formatRealFloat FFExponent d x)
1896 showFFloat d x = showString (formatRealFloat FFFixed d x)
1897 showGFloat d x = showString (formatRealFloat FFGeneric d x)
1898 showFloat = showGFloat Nothing
1900 -- These are the format types. This type is not exported.
1902 data FFFormat = FFExponent | FFFixed | FFGeneric
1904 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
1905 formatRealFloat fmt decs x = s
1909 else if isInfinite x then
1910 if x < 0 then "-Infinity" else "Infinity"
1911 else if x < 0 || isNegativeZero x then
1912 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
1914 doFmt fmt (floatToDigits (toInteger base) x)
1916 let ds = map intToDigit is
1919 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
1926 [d] -> d : ".0e" ++ show (e-1)
1927 d:ds -> d : '.' : ds ++ 'e':show (e-1)
1929 let dec' = max dec 1 in
1931 [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
1933 let (ei, is') = roundTo base (dec'+1) is
1934 d:ds = map intToDigit
1935 (if ei > 0 then init is' else is')
1936 in d:'.':ds ++ "e" ++ show (e-1+ei)
1940 let f 0 s ds = mk0 s ++ "." ++ mk0 ds
1941 f n s "" = f (n-1) (s++"0") ""
1942 f n s (d:ds) = f (n-1) (s++[d]) ds
1947 let dec' = max dec 0 in
1949 let (ei, is') = roundTo base (dec' + e) is
1950 (ls, rs) = splitAt (e+ei) (map intToDigit is')
1951 in (if null ls then "0" else ls) ++
1952 (if null rs then "" else '.' : rs)
1954 let (ei, is') = roundTo base dec'
1955 (replicate (-e) 0 ++ is)
1956 d : ds = map intToDigit
1957 (if ei > 0 then is' else 0:is')
1960 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
1961 roundTo base d is = case f d is of
1963 (1, is) -> (1, 1 : is)
1964 where b2 = base `div` 2
1965 f n [] = (0, replicate n 0)
1966 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
1968 let (c, ds) = f (d-1) is
1970 in if i' == base then (1, 0:ds) else (0, i':ds)
1972 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
1973 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
1974 -- This version uses a much slower logarithm estimator. It should be improved.
1976 -- This function returns a list of digits (Ints in [0..base-1]) and an
1979 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
1981 floatToDigits _ 0 = ([0], 0)
1982 floatToDigits base x =
1983 let (f0, e0) = decodeFloat x
1984 (minExp0, _) = floatRange x
1987 minExp = minExp0 - p -- the real minimum exponent
1988 -- Haskell requires that f be adjusted so denormalized numbers
1989 -- will have an impossibly low exponent. Adjust for this.
1990 (f, e) = let n = minExp - e0
1991 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
1996 if f == b^(p-1) then
1997 (f*be*b*2, 2*b, be*b, b)
2001 if e > minExp && f == b^(p-1) then
2002 (f*b*2, b^(-e+1)*2, b, 1)
2004 (f*2, b^(-e)*2, 1, 1)
2007 if b == 2 && base == 10 then
2008 -- logBase 10 2 is slightly bigger than 3/10 so
2009 -- the following will err on the low side. Ignoring
2010 -- the fraction will make it err even more.
2011 -- Haskell promises that p-1 <= logBase b f < p.
2012 (p - 1 + e0) * 3 `div` 10
2014 ceiling ((log (fromInteger (f+1)) +
2015 fromInt e * log (fromInteger b)) /
2016 log (fromInteger base))
2019 if r + mUp <= expt base n * s then n else fixup (n+1)
2021 if expt base (-n) * (r + mUp) <= s then n
2025 gen ds rn sN mUpN mDnN =
2026 let (dn, rn') = (rn * base) `divMod` sN
2029 in case (rn' < mDnN', rn' + mUpN' > sN) of
2030 (True, False) -> dn : ds
2031 (False, True) -> dn+1 : ds
2032 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2033 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2036 gen [] r (s * expt base k) mUp mDn
2038 let bk = expt base (-k)
2039 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
2040 in (map toInt (reverse rds), k)
2043 -- Exponentiation with a cache for the most common numbers.
2046 expt :: Integer -> Int -> Integer
2048 if base == 2 && n >= minExpt && n <= maxExpt then
2049 expts !! (n-minExpt)
2054 expts = [2^n | n <- [minExpt .. maxExpt]]