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
120 -- Standard value bindings {Prelude} ----------------------------------------
125 infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
127 --infixr 5 : -- this fixity declaration is hard-wired into Hugs
129 infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
134 infixr 0 $, $!, `seq`
136 -- Equality and Ordered classes ---------------------------------------------
139 (==), (/=) :: a -> a -> Bool
141 -- Minimal complete definition: (==) or (/=)
145 class (Eq a) => Ord a where
146 compare :: a -> a -> Ordering
147 (<), (<=), (>=), (>) :: a -> a -> Bool
148 max, min :: a -> a -> a
150 -- Minimal complete definition: (<=) or compare
151 -- using compare can be more efficient for complex types
152 compare x y | x==y = EQ
156 x <= y = compare x y /= GT
157 x < y = compare x y == LT
158 x >= y = compare x y /= LT
159 x > y = compare x y == GT
166 class Bounded a where
167 minBound, maxBound :: a
168 -- Minimal complete definition: All
170 -- Numeric classes ----------------------------------------------------------
172 class (Eq a, Show a) => Num a where
173 (+), (-), (*) :: a -> a -> a
175 abs, signum :: a -> a
176 fromInteger :: Integer -> a
179 -- Minimal complete definition: All, except negate or (-)
181 fromInt = fromIntegral
184 class (Num a, Ord a) => Real a where
185 toRational :: a -> Rational
187 class (Real a, Enum a) => Integral a where
188 quot, rem, div, mod :: a -> a -> a
189 quotRem, divMod :: a -> a -> (a,a)
190 even, odd :: a -> Bool
191 toInteger :: a -> Integer
194 -- Minimal complete definition: quotRem and toInteger
195 n `quot` d = q where (q,r) = quotRem n d
196 n `rem` d = r where (q,r) = quotRem n d
197 n `div` d = q where (q,r) = divMod n d
198 n `mod` d = r where (q,r) = divMod n d
199 divMod n d = if signum r == - signum d then (q-1, r+d) else qr
200 where qr@(q,r) = quotRem n d
201 even n = n `rem` 2 == 0
203 toInt = toInt . toInteger
205 class (Num a) => Fractional a where
208 fromRational :: Rational -> a
209 fromDouble :: Double -> a
211 -- Minimal complete definition: fromRational and ((/) or recip)
213 fromDouble = fromRational . toRational
217 class (Fractional a) => Floating a where
219 exp, log, sqrt :: a -> a
220 (**), logBase :: a -> a -> a
221 sin, cos, tan :: a -> a
222 asin, acos, atan :: a -> a
223 sinh, cosh, tanh :: a -> a
224 asinh, acosh, atanh :: a -> a
226 -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
227 -- asinh, acosh, atanh
228 x ** y = exp (log x * y)
229 logBase x y = log y / log x
231 tan x = sin x / cos x
232 sinh x = (exp x - exp (-x)) / 2
233 cosh x = (exp x + exp (-x)) / 2
234 tanh x = sinh x / cosh x
235 asinh x = log (x + sqrt (x*x + 1))
236 acosh x = log (x + sqrt (x*x - 1))
237 atanh x = (log (1 + x) - log (1 - x)) / 2
239 class (Real a, Fractional a) => RealFrac a where
240 properFraction :: (Integral b) => a -> (b,a)
241 truncate, round :: (Integral b) => a -> b
242 ceiling, floor :: (Integral b) => a -> b
244 -- Minimal complete definition: properFraction
245 truncate x = m where (m,_) = properFraction x
247 round x = let (n,r) = properFraction x
248 m = if r < 0 then n - 1 else n + 1
249 in case signum (abs r - 0.5) of
251 0 -> if even n then n else m
254 ceiling x = if r > 0 then n + 1 else n
255 where (n,r) = properFraction x
257 floor x = if r < 0 then n - 1 else n
258 where (n,r) = properFraction x
260 class (RealFrac a, Floating a) => RealFloat a where
261 floatRadix :: a -> Integer
262 floatDigits :: a -> Int
263 floatRange :: a -> (Int,Int)
264 decodeFloat :: a -> (Integer,Int)
265 encodeFloat :: Integer -> Int -> a
267 significand :: a -> a
268 scaleFloat :: Int -> a -> a
269 isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
273 -- Minimal complete definition: All, except exponent, signficand,
275 exponent x = if m==0 then 0 else n + floatDigits x
276 where (m,n) = decodeFloat x
277 significand x = encodeFloat m (- floatDigits x)
278 where (m,_) = decodeFloat x
279 scaleFloat k x = encodeFloat m (n+k)
280 where (m,n) = decodeFloat x
284 | x<0 && y>0 = pi + atan (y/x)
286 (x<0 && isNegativeZero y) ||
287 (isNegativeZero x && isNegativeZero y)
289 | y==0 && (x<0 || isNegativeZero x)
290 = pi -- must be after the previous test on zero y
291 | x==0 && y==0 = y -- must be after the other double zero tests
292 | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
294 -- Numeric functions --------------------------------------------------------
296 subtract :: Num a => a -> a -> a
299 gcd :: Integral a => a -> a -> a
300 gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
301 gcd x y = gcd' (abs x) (abs y)
303 gcd' x y = gcd' y (x `rem` y)
305 lcm :: (Integral a) => a -> a -> a
308 lcm x y = abs ((x `quot` gcd x y) * y)
310 (^) :: (Num a, Integral b) => a -> b -> a
312 x ^ n | n > 0 = f x (n-1) x
314 f x n y = g x n where
315 g x n | even n = g (x*x) (n`quot`2)
316 | otherwise = f x (n-1) (x*y)
317 _ ^ _ = error "Prelude.^: negative exponent"
319 (^^) :: (Fractional a, Integral b) => a -> b -> a
320 x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
322 fromIntegral :: (Integral a, Num b) => a -> b
323 fromIntegral = fromInteger . toInteger
325 realToFrac :: (Real a, Fractional b) => a -> b
326 realToFrac = fromRational . toRational
328 -- Index and Enumeration classes --------------------------------------------
330 class (Ord a) => Ix a where
331 range :: (a,a) -> [a]
332 index :: (a,a) -> a -> Int
333 inRange :: (a,a) -> a -> Bool
334 rangeSize :: (a,a) -> Int
338 | otherwise = index r u + 1
344 enumFrom :: a -> [a] -- [n..]
345 enumFromThen :: a -> a -> [a] -- [n,m..]
346 enumFromTo :: a -> a -> [a] -- [n..m]
347 enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
349 -- Minimal complete definition: toEnum, fromEnum
350 succ = toEnum . (1+) . fromEnum
351 pred = toEnum . subtract 1 . fromEnum
352 enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
353 enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
355 -- Read and Show classes ------------------------------------------------------
357 type ReadS a = String -> [(a,String)]
358 type ShowS = String -> String
361 readsPrec :: Int -> ReadS a
362 readList :: ReadS [a]
364 -- Minimal complete definition: readsPrec
365 readList = readParen False (\r -> [pr | ("[",s) <- lex r,
367 where readl s = [([],t) | ("]",t) <- lex s] ++
368 [(x:xs,u) | (x,t) <- reads s,
370 readl' s = [([],t) | ("]",t) <- lex s] ++
371 [(x:xs,v) | (",",t) <- lex s,
377 showsPrec :: Int -> a -> ShowS
378 showList :: [a] -> ShowS
380 -- Minimal complete definition: show or showsPrec
381 show x = showsPrec 0 x ""
382 showsPrec _ x s = show x ++ s
383 showList [] = showString "[]"
384 showList (x:xs) = showChar '[' . shows x . showl xs
385 where showl [] = showChar ']'
386 showl (x:xs) = showChar ',' . shows x . showl xs
388 -- Monad classes ------------------------------------------------------------
390 class Functor f where
391 fmap :: (a -> b) -> (f a -> f b)
395 (>>=) :: m a -> (a -> m b) -> m b
396 (>>) :: m a -> m b -> m b
397 fail :: String -> m a
399 -- Minimal complete definition: (>>=), return
400 p >> q = p >>= \ _ -> q
403 accumulate :: Monad m => [m a] -> m [a]
404 accumulate [] = return []
405 accumulate (c:cs) = do x <- c
409 sequence :: Monad m => [m a] -> m ()
410 sequence = foldr (>>) (return ())
412 mapM :: Monad m => (a -> m b) -> [a] -> m [b]
413 mapM f = accumulate . map f
415 mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
416 mapM_ f = sequence . map f
418 (=<<) :: Monad m => (a -> m b) -> m a -> m b
421 -- Evaluation and strictness ------------------------------------------------
424 seq x y = primSeq x y
426 ($!) :: (a -> b) -> a -> b
427 f $! x = x `primSeq` f x
429 -- Trivial type -------------------------------------------------------------
431 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
436 instance Ord () where
442 inRange ((),()) () = True
444 instance Enum () where
448 enumFromThen () () = [()]
450 instance Read () where
451 readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
454 instance Show () where
455 showsPrec p () = showString "()"
457 instance Bounded () where
461 -- Boolean type -------------------------------------------------------------
463 data Bool = False | True
464 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
466 (&&), (||) :: Bool -> Bool -> Bool
479 -- Character type -----------------------------------------------------------
481 data Char -- builtin datatype of ISO Latin characters
482 type String = [Char] -- strings are lists of characters
484 instance Eq Char where (==) = primEqChar
485 instance Ord Char where (<=) = primLeChar
487 instance Enum Char where
488 toEnum = primIntToChar
489 fromEnum = primCharToInt
490 enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
491 enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
492 where lastChar = if d < c then minBound else maxBound
494 instance Ix Char where
495 range (c,c') = [c..c']
497 | inRange b ci = fromEnum ci - fromEnum c
498 | otherwise = error "Ix.index: Index out of range."
499 inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
500 where i = fromEnum ci
502 instance Read Char where
503 readsPrec p = readParen False
504 (\r -> [(c,t) | ('\'':s,t) <- lex r,
505 (c,"\'") <- readLitChar s ])
506 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
508 where readl ('"':s) = [("",s)]
509 readl ('\\':'&':s) = readl s
510 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
512 instance Show Char where
513 showsPrec p '\'' = showString "'\\''"
514 showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
516 showList cs = showChar '"' . showl cs
517 where showl "" = showChar '"'
518 showl ('"':cs) = showString "\\\"" . showl cs
519 showl (c:cs) = showLitChar c . showl cs
521 instance Bounded Char where
525 isAscii, isControl, isPrint, isSpace :: Char -> Bool
526 isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
528 isAscii c = fromEnum c < 128
529 isControl c = c < ' ' || c == '\DEL'
530 isPrint c = c >= ' ' && c <= '~'
531 isSpace c = c == ' ' || c == '\t' || c == '\n' ||
532 c == '\r' || c == '\f' || c == '\v'
533 isUpper c = c >= 'A' && c <= 'Z'
534 isLower c = c >= 'a' && c <= 'z'
535 isAlpha c = isUpper c || isLower c
536 isDigit c = c >= '0' && c <= '9'
537 isAlphaNum c = isAlpha c || isDigit c
539 -- Digit conversion operations
540 digitToInt :: Char -> Int
542 | isDigit c = fromEnum c - fromEnum '0'
543 | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
544 | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
545 | otherwise = error "Char.digitToInt: not a digit"
547 intToDigit :: Int -> Char
549 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
550 | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
551 | otherwise = error "Char.intToDigit: not a digit"
553 toUpper, toLower :: Char -> Char
554 toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
557 toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
566 -- Maybe type ---------------------------------------------------------------
568 data Maybe a = Nothing | Just a
569 deriving (Eq, Ord, Read, Show)
571 maybe :: b -> (a -> b) -> Maybe a -> b
572 maybe n f Nothing = n
573 maybe n f (Just x) = f x
575 instance Functor Maybe where
576 fmap f Nothing = Nothing
577 fmap f (Just x) = Just (f x)
579 instance Monad Maybe where
581 Nothing >>= k = Nothing
585 -- Either type --------------------------------------------------------------
587 data Either a b = Left a | Right b
588 deriving (Eq, Ord, Read, Show)
590 either :: (a -> c) -> (b -> c) -> Either a b -> c
591 either l r (Left x) = l x
592 either l r (Right y) = r y
594 -- Ordering type ------------------------------------------------------------
596 data Ordering = LT | EQ | GT
597 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
599 -- Lists --------------------------------------------------------------------
601 --data [a] = [] | a : [a] deriving (Eq, Ord)
603 instance Eq a => Eq [a] where
605 (x:xs) == (y:ys) = x==y && xs==ys
608 instance Ord a => Ord [a] where
609 compare [] (_:_) = LT
611 compare (_:_) [] = GT
612 compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
614 instance Functor [] where
617 instance Monad [ ] where
618 (x:xs) >>= f = f x ++ (xs >>= f)
623 instance Read a => Read [a] where
624 readsPrec p = readList
626 instance Show a => Show [a] where
627 showsPrec p = showList
629 -- Tuples -------------------------------------------------------------------
631 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
634 -- Functions ----------------------------------------------------------------
636 instance Show (a -> b) where
637 showsPrec p f = showString "<<function>>"
639 instance Functor ((->) a) where
642 -- Standard Integral types --------------------------------------------------
644 data Int -- builtin datatype of fixed size integers
645 data Integer -- builtin datatype of arbitrary size integers
647 instance Eq Integer where
648 (==) x y = primCompareInteger x y == 0
650 instance Ord Integer where
651 compare x y = case primCompareInteger x y of
656 instance Eq Int where
660 instance Ord Int where
666 instance Num Int where
669 negate = primNegateInt
673 fromInteger = primIntegerToInt
676 instance Bounded Int where
677 minBound = primMinInt
678 maxBound = primMaxInt
680 instance Num Integer where
681 (+) = primPlusInteger
682 (-) = primMinusInteger
683 negate = primNegateInteger
684 (*) = primTimesInteger
688 fromInt = primIntToInteger
690 absReal x | x >= 0 = x
693 signumReal x | x == 0 = 0
697 instance Real Int where
698 toRational x = toInteger x % 1
700 instance Real Integer where
703 instance Integral Int where
704 quotRem = primQuotRemInt
705 toInteger = primIntToInteger
708 instance Integral Integer where
709 quotRem = primQuotRemInteger
710 --divMod = primDivModInteger
712 toInt = primIntegerToInt
714 instance Ix Int where
717 | inRange b i = i - m
718 | otherwise = error "index: Index out of range"
719 inRange (m,n) i = m <= i && i <= n
721 instance Ix Integer where
724 | inRange b i = fromInteger (i - m)
725 | otherwise = error "index: Index out of range"
726 inRange (m,n) i = m <= i && i <= n
728 instance Enum Int where
731 enumFrom = numericEnumFrom
732 enumFromTo = numericEnumFromTo
733 enumFromThen = numericEnumFromThen
734 enumFromThenTo = numericEnumFromThenTo
736 instance Enum Integer where
737 toEnum = primIntToInteger
738 fromEnum = primIntegerToInt
739 enumFrom = numericEnumFrom
740 enumFromTo = numericEnumFromTo
741 enumFromThen = numericEnumFromThen
742 enumFromThenTo = numericEnumFromThenTo
744 numericEnumFrom :: Real a => a -> [a]
745 numericEnumFromThen :: Real a => a -> a -> [a]
746 numericEnumFromTo :: Real a => a -> a -> [a]
747 numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
748 numericEnumFrom n = n : (numericEnumFrom $! (n+1))
749 numericEnumFromThen n m = iterate ((m-n)+) n
750 numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
751 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
752 where p | n' >= n = (<= m)
755 instance Read Int where
756 readsPrec p = readSigned readDec
758 instance Show Int where
760 | n == minBound = showSigned showInt p (toInteger n)
761 | otherwise = showSigned showInt p n
763 instance Read Integer where
764 readsPrec p = readSigned readDec
766 instance Show Integer where
767 showsPrec = showSigned showInt
770 -- Standard Floating types --------------------------------------------------
772 data Float -- builtin datatype of single precision floating point numbers
773 data Double -- builtin datatype of double precision floating point numbers
775 instance Eq Float where
779 instance Ord Float where
785 instance Num Float where
788 negate = primNegateFloat
792 fromInteger = primIntegerToFloat
793 fromInt = primIntToFloat
797 instance Eq Double where
801 instance Ord Double where
807 instance Num Double where
809 (-) = primMinusDouble
810 negate = primNegateDouble
811 (*) = primTimesDouble
814 fromInteger = primIntegerToDouble
815 fromInt = primIntToDouble
819 instance Real Float where
820 toRational = floatToRational
822 instance Real Double where
823 toRational = doubleToRational
825 -- Calls to these functions are optimised when passed as arguments to
827 floatToRational :: Float -> Rational
828 doubleToRational :: Double -> Rational
829 floatToRational x = realFloatToRational x
830 doubleToRational x = realFloatToRational x
832 realFloatToRational x = (m%1)*(b%1)^^n
833 where (m,n) = decodeFloat x
836 instance Fractional Float where
837 (/) = primDivideFloat
838 fromRational = rationalToRealFloat
839 fromDouble = primDoubleToFloat
842 instance Fractional Double where
843 (/) = primDivideDouble
844 fromRational = rationalToRealFloat
847 rationalToRealFloat x = x'
849 f e = if e' == e then y else f e'
850 where y = encodeFloat (round (x * (1%b)^^e)) e
851 (_,e') = decodeFloat y
852 (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
853 / fromInteger (denominator x))
856 instance Floating Float where
857 pi = 3.14159265358979323846
868 instance Floating Double where
869 pi = 3.14159265358979323846
872 sqrt = primSqrtDouble
876 asin = primAsinDouble
877 acos = primAcosDouble
878 atan = primAtanDouble
880 instance RealFrac Float where
881 properFraction = floatProperFraction
883 instance RealFrac Double where
884 properFraction = floatProperFraction
886 floatProperFraction x
887 | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
888 | otherwise = (fromInteger w, encodeFloat r n)
889 where (m,n) = decodeFloat x
891 (w,r) = quotRem m (b^(-n))
893 instance RealFloat Float where
894 floatRadix _ = toInteger primRadixFloat
895 floatDigits _ = primDigitsFloat
896 floatRange _ = (primMinExpFloat,primMaxExpFloat)
897 encodeFloat = primEncodeFloatZ
898 decodeFloat = primDecodeFloatZ
899 isNaN = primIsNaNFloat
900 isInfinite = primIsInfiniteFloat
901 isDenormalized= primIsDenormalizedFloat
902 isNegativeZero= primIsNegativeZeroFloat
903 isIEEE = const primIsIEEEFloat
905 instance RealFloat Double where
906 floatRadix _ = toInteger primRadixDouble
907 floatDigits _ = primDigitsDouble
908 floatRange _ = (primMinExpDouble,primMaxExpDouble)
909 encodeFloat = primEncodeDoubleZ
910 decodeFloat = primDecodeDoubleZ
911 isNaN = primIsNaNDouble
912 isInfinite = primIsInfiniteDouble
913 isDenormalized= primIsDenormalizedDouble
914 isNegativeZero= primIsNegativeZeroDouble
915 isIEEE = const primIsIEEEDouble
917 instance Enum Float where
918 toEnum = primIntToFloat
920 enumFrom = numericEnumFrom
921 enumFromThen = numericEnumFromThen
922 enumFromTo n m = numericEnumFromTo n (m+1/2)
923 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
925 instance Enum Double where
926 toEnum = primIntToDouble
928 enumFrom = numericEnumFrom
929 enumFromThen = numericEnumFromThen
930 enumFromTo n m = numericEnumFromTo n (m+1/2)
931 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
933 instance Read Float where
934 readsPrec p = readSigned readFloat
936 instance Show Float where
937 showsPrec p = showSigned showFloat p
939 instance Read Double where
940 readsPrec p = readSigned readFloat
942 instance Show Double where
943 showsPrec p = showSigned showFloat p
946 -- Some standard functions --------------------------------------------------
954 curry :: ((a,b) -> c) -> (a -> b -> c)
955 curry f x y = f (x,y)
957 uncurry :: (a -> b -> c) -> ((a,b) -> c)
958 uncurry f p = f (fst p) (snd p)
966 (.) :: (b -> c) -> (a -> b) -> (a -> c)
969 flip :: (a -> b -> c) -> b -> a -> c
972 ($) :: (a -> b) -> a -> b
975 until :: (a -> Bool) -> (a -> a) -> a -> a
976 until p f x = if p x then x else until p f (f x)
978 asTypeOf :: a -> a -> a
982 error msg = primRaise (ErrorCall msg)
985 undefined | False = undefined
987 -- Standard functions on rational numbers {PreludeRatio} --------------------
989 data Integral a => Ratio a = a :% a deriving (Eq)
990 type Rational = Ratio Integer
992 (%) :: Integral a => a -> a -> Ratio a
993 x % y = reduce (x * signum y) (abs y)
995 reduce :: Integral a => a -> a -> Ratio a
996 reduce x y | y == 0 = error "Ratio.%: zero denominator"
997 | otherwise = (x `quot` d) :% (y `quot` d)
1000 numerator, denominator :: Integral a => Ratio a -> a
1001 numerator (x :% y) = x
1002 denominator (x :% y) = y
1004 instance Integral a => Ord (Ratio a) where
1005 compare (x:%y) (x':%y') = compare (x*y') (x'*y)
1007 instance Integral a => Num (Ratio a) where
1008 (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
1009 (x:%y) * (x':%y') = reduce (x*x') (y*y')
1010 negate (x :% y) = negate x :% y
1011 abs (x :% y) = abs x :% y
1012 signum (x :% y) = signum x :% 1
1013 fromInteger x = fromInteger x :% 1
1014 fromInt = intToRatio
1016 -- Hugs optimises code of the form fromRational (intToRatio x)
1017 intToRatio :: Integral a => Int -> Ratio a
1018 intToRatio x = fromInt x :% 1
1020 instance Integral a => Real (Ratio a) where
1021 toRational (x:%y) = toInteger x :% toInteger y
1023 instance Integral a => Fractional (Ratio a) where
1024 (x:%y) / (x':%y') = (x*y') % (y*x')
1025 recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
1026 fromRational (x:%y) = fromInteger x :% fromInteger y
1027 fromDouble = doubleToRatio
1029 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1030 doubleToRatio :: Integral a => Double -> Ratio a
1032 | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
1033 | otherwise = fromInteger m % (fromInteger b ^ (-n))
1034 where (m,n) = decodeFloat x
1037 instance Integral a => RealFrac (Ratio a) where
1038 properFraction (x:%y) = (fromIntegral q, r:%y)
1039 where (q,r) = quotRem x y
1041 instance Integral a => Enum (Ratio a) where
1044 enumFrom = numericEnumFrom
1045 enumFromThen = numericEnumFromThen
1047 instance (Read a, Integral a) => Read (Ratio a) where
1048 readsPrec p = readParen (p > 7)
1049 (\r -> [(x%y,u) | (x,s) <- reads r,
1053 instance Integral a => Show (Ratio a) where
1054 showsPrec p (x:%y) = showParen (p > 7)
1055 (shows x . showString " % " . shows y)
1057 approxRational :: RealFrac a => a -> a -> Rational
1058 approxRational x eps = simplest (x-eps) (x+eps)
1059 where simplest x y | y < x = simplest y x
1061 | x > 0 = simplest' n d n' d'
1062 | y < 0 = - simplest' (-n') d' (-n) d
1063 | otherwise = 0 :% 1
1064 where xr@(n:%d) = toRational x
1065 (n':%d') = toRational y
1066 simplest' n d n' d' -- assumes 0 < n%d < n'%d'
1068 | q /= q' = (q+1) :% 1
1069 | otherwise = (q*n''+d'') :% n''
1070 where (q,r) = quotRem n d
1071 (q',r') = quotRem n' d'
1072 (n'':%d'') = simplest' d' r' d r
1074 -- Standard list functions {PreludeList} ------------------------------------
1081 last (_:xs) = last xs
1088 init (x:xs) = x : init xs
1094 (++) :: [a] -> [a] -> [a]
1096 (x:xs) ++ ys = x : (xs ++ ys)
1098 map :: (a -> b) -> [a] -> [b]
1099 --map f xs = [ f x | x <- xs ]
1101 map f (x:xs) = f x : map f xs
1104 filter :: (a -> Bool) -> [a] -> [a]
1105 --filter p xs = [ x | x <- xs, p x ]
1107 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1110 concat :: [[a]] -> [a]
1111 --concat = foldr (++) []
1113 concat (xs:xss) = xs ++ concat xss
1115 length :: [a] -> Int
1116 --length = foldl' (\n _ -> n + 1) 0
1118 length (x:xs) = let n = length xs in primSeq n (1+n)
1120 (!!) :: [b] -> Int -> b
1122 (_:xs) !! n | n>0 = xs !! (n-1)
1123 (_:_) !! _ = error "Prelude.!!: negative index"
1124 [] !! _ = error "Prelude.!!: index too large"
1126 foldl :: (a -> b -> a) -> a -> [b] -> a
1128 foldl f z (x:xs) = foldl f (f z x) xs
1130 foldl' :: (a -> b -> a) -> a -> [b] -> a
1132 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1134 foldl1 :: (a -> a -> a) -> [a] -> a
1135 foldl1 f (x:xs) = foldl f x xs
1137 scanl :: (a -> b -> a) -> a -> [b] -> [a]
1138 scanl f q xs = q : (case xs of
1140 x:xs -> scanl f (f q x) xs)
1142 scanl1 :: (a -> a -> a) -> [a] -> [a]
1143 scanl1 f (x:xs) = scanl f x xs
1145 foldr :: (a -> b -> b) -> b -> [a] -> b
1147 foldr f z (x:xs) = f x (foldr f z xs)
1149 foldr1 :: (a -> a -> a) -> [a] -> a
1151 foldr1 f (x:xs) = f x (foldr1 f xs)
1153 scanr :: (a -> b -> b) -> b -> [a] -> [b]
1154 scanr f q0 [] = [q0]
1155 scanr f q0 (x:xs) = f x q : qs
1156 where qs@(q:_) = scanr f q0 xs
1158 scanr1 :: (a -> a -> a) -> [a] -> [a]
1160 scanr1 f (x:xs) = f x q : qs
1161 where qs@(q:_) = scanr1 f xs
1163 iterate :: (a -> a) -> a -> [a]
1164 iterate f x = x : iterate f (f x)
1167 repeat x = xs where xs = x:xs
1169 replicate :: Int -> a -> [a]
1170 replicate n x = take n (repeat x)
1173 cycle [] = error "Prelude.cycle: empty list"
1174 cycle xs = xs' where xs'=xs++xs'
1176 take :: Int -> [a] -> [a]
1179 take n (x:xs) | n>0 = x : take (n-1) xs
1180 take _ _ = error "Prelude.take: negative argument"
1182 drop :: Int -> [a] -> [a]
1185 drop n (_:xs) | n>0 = drop (n-1) xs
1186 drop _ _ = error "Prelude.drop: negative argument"
1188 splitAt :: Int -> [a] -> ([a], [a])
1189 splitAt 0 xs = ([],xs)
1190 splitAt _ [] = ([],[])
1191 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1192 splitAt _ _ = error "Prelude.splitAt: negative argument"
1194 takeWhile :: (a -> Bool) -> [a] -> [a]
1197 | p x = x : takeWhile p xs
1200 dropWhile :: (a -> Bool) -> [a] -> [a]
1202 dropWhile p xs@(x:xs')
1203 | p x = dropWhile p xs'
1206 span, break :: (a -> Bool) -> [a] -> ([a],[a])
1210 | otherwise = ([],xs)
1211 where (ys,zs) = span p xs'
1212 break p = span (not . p)
1214 lines :: String -> [String]
1216 lines s = let (l,s') = break ('\n'==) s
1217 in l : case s' of [] -> []
1218 (_:s'') -> lines s''
1220 words :: String -> [String]
1221 words s = case dropWhile isSpace s of
1224 where (w,s'') = break isSpace s'
1226 unlines :: [String] -> String
1227 unlines = concatMap (\l -> l ++ "\n")
1229 unwords :: [String] -> String
1231 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1233 reverse :: [a] -> [a]
1234 --reverse = foldl (flip (:)) []
1235 reverse xs = ri [] xs
1236 where ri acc [] = acc
1237 ri acc (x:xs) = ri (x:acc) xs
1239 and, or :: [Bool] -> Bool
1240 --and = foldr (&&) True
1241 --or = foldr (||) False
1243 and (x:xs) = if x then and xs else x
1245 or (x:xs) = if x then x else or xs
1247 any, all :: (a -> Bool) -> [a] -> Bool
1248 --any p = or . map p
1249 --all p = and . map p
1251 any p (x:xs) = if p x then True else any p xs
1253 all p (x:xs) = if p x then all p xs else False
1255 elem, notElem :: Eq a => a -> [a] -> Bool
1257 --notElem = all . (/=)
1259 elem x (y:ys) = if x==y then True else elem x ys
1261 notElem x (y:ys) = if x==y then False else notElem x ys
1263 lookup :: Eq a => a -> [(a,b)] -> Maybe b
1264 lookup k [] = Nothing
1265 lookup k ((x,y):xys)
1267 | otherwise = lookup k xys
1269 sum, product :: Num a => [a] -> a
1271 product = foldl' (*) 1
1273 maximum, minimum :: Ord a => [a] -> a
1274 maximum = foldl1 max
1275 minimum = foldl1 min
1277 concatMap :: (a -> [b]) -> [a] -> [b]
1278 concatMap f = concat . map f
1280 zip :: [a] -> [b] -> [(a,b)]
1281 zip = zipWith (\a b -> (a,b))
1283 zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
1284 zip3 = zipWith3 (\a b c -> (a,b,c))
1286 zipWith :: (a->b->c) -> [a]->[b]->[c]
1287 zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
1290 zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1291 zipWith3 z (a:as) (b:bs) (c:cs)
1292 = z a b c : zipWith3 z as bs cs
1293 zipWith3 _ _ _ _ = []
1295 unzip :: [(a,b)] -> ([a],[b])
1296 unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1298 unzip3 :: [(a,b,c)] -> ([a],[b],[c])
1299 unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1302 -- PreludeText ----------------------------------------------------------------
1304 reads :: Read a => ReadS a
1307 shows :: Show a => a -> ShowS
1310 read :: Read a => String -> a
1311 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1313 [] -> error "Prelude.read: no parse"
1314 _ -> error "Prelude.read: ambiguous parse"
1316 showChar :: Char -> ShowS
1319 showString :: String -> ShowS
1322 showParen :: Bool -> ShowS -> ShowS
1323 showParen b p = if b then showChar '(' . p . showChar ')' else p
1325 showField :: Show a => String -> a -> ShowS
1326 showField m v = showString m . showChar '=' . shows v
1328 readParen :: Bool -> ReadS a -> ReadS a
1329 readParen b g = if b then mandatory else optional
1330 where optional r = g r ++ mandatory r
1331 mandatory r = [(x,u) | ("(",s) <- lex r,
1332 (x,t) <- optional s,
1336 readField :: Read a => String -> ReadS a
1337 readField m s0 = [ r | (t, s1) <- lex s0, t == m,
1343 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1344 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1346 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1348 lexString ('"':s) = [("\"",s)]
1349 lexString s = [(ch++str, u)
1350 | (ch,t) <- lexStrItem s,
1351 (str,u) <- lexString t ]
1353 lexStrItem ('\\':'&':s) = [("\\&",s)]
1354 lexStrItem ('\\':c:s) | isSpace c
1355 = [("",t) | '\\':t <- [dropWhile isSpace s]]
1356 lexStrItem s = lexLitChar s
1358 lex (c:s) | isSingle c = [([c],s)]
1359 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
1360 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
1361 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
1362 (fe,t) <- lexFracExp s ]
1363 | otherwise = [] -- bad character
1365 isSingle c = c `elem` ",;()[]{}_`"
1366 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1367 isIdChar c = isAlphaNum c || c `elem` "_'"
1369 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1371 lexFracExp s = [("",s)]
1373 lexExp (e:s) | e `elem` "eE"
1374 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
1375 (ds,u) <- lexDigits t] ++
1376 [(e:ds,t) | (ds,t) <- lexDigits s]
1379 lexDigits :: ReadS String
1380 lexDigits = nonnull isDigit
1382 nonnull :: (Char -> Bool) -> ReadS String
1383 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1385 lexLitChar :: ReadS String
1386 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1388 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- "
1389 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
1390 lexEsc s@(d:_) | isDigit d = lexDigits s
1391 lexEsc s@(c:_) | isUpper c
1392 = let table = ('\DEL',"DEL") : asciiTab
1393 in case [(mne,s') | (c, mne) <- table,
1394 ([],s') <- [lexmatch mne s]]
1398 lexLitChar (c:s) = [([c],s)]
1401 isOctDigit c = c >= '0' && c <= '7'
1402 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
1403 || c >= 'a' && c <= 'f'
1405 lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
1406 lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
1407 lexmatch xs ys = (xs,ys)
1409 asciiTab = zip ['\NUL'..' ']
1410 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1411 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
1412 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1413 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
1416 readLitChar :: ReadS Char
1417 readLitChar ('\\':s) = readEsc s
1419 readEsc ('a':s) = [('\a',s)]
1420 readEsc ('b':s) = [('\b',s)]
1421 readEsc ('f':s) = [('\f',s)]
1422 readEsc ('n':s) = [('\n',s)]
1423 readEsc ('r':s) = [('\r',s)]
1424 readEsc ('t':s) = [('\t',s)]
1425 readEsc ('v':s) = [('\v',s)]
1426 readEsc ('\\':s) = [('\\',s)]
1427 readEsc ('"':s) = [('"',s)]
1428 readEsc ('\'':s) = [('\'',s)]
1429 readEsc ('^':c:s) | c >= '@' && c <= '_'
1430 = [(toEnum (fromEnum c - fromEnum '@'), s)]
1431 readEsc s@(d:_) | isDigit d
1432 = [(toEnum n, t) | (n,t) <- readDec s]
1433 readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
1434 readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
1435 readEsc s@(c:_) | isUpper c
1436 = let table = ('\DEL',"DEL") : asciiTab
1437 in case [(c,s') | (c, mne) <- table,
1438 ([],s') <- [lexmatch mne s]]
1442 readLitChar (c:s) = [(c,s)]
1444 showLitChar :: Char -> ShowS
1445 showLitChar c | c > '\DEL' = showChar '\\' .
1446 protectEsc isDigit (shows (fromEnum c))
1447 showLitChar '\DEL' = showString "\\DEL"
1448 showLitChar '\\' = showString "\\\\"
1449 showLitChar c | c >= ' ' = showChar c
1450 showLitChar '\a' = showString "\\a"
1451 showLitChar '\b' = showString "\\b"
1452 showLitChar '\f' = showString "\\f"
1453 showLitChar '\n' = showString "\\n"
1454 showLitChar '\r' = showString "\\r"
1455 showLitChar '\t' = showString "\\t"
1456 showLitChar '\v' = showString "\\v"
1457 showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
1458 showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
1460 protectEsc p f = f . cont
1461 where cont s@(c:_) | p c = "\\&" ++ s
1464 -- Unsigned readers for various bases
1465 readDec, readOct, readHex :: Integral a => ReadS a
1466 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1467 readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1468 readHex = readInt 16 isHexDigit hex
1469 where hex d = fromEnum d -
1472 else fromEnum (if isUpper d then 'A' else 'a') - 10)
1474 -- readInt reads a string of digits using an arbitrary base.
1475 -- Leading minus signs must be handled elsewhere.
1477 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1478 readInt radix isDig digToInt s =
1479 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1480 | (ds,r) <- nonnull isDig s ]
1482 -- showInt is used for positive numbers only
1483 showInt :: Integral a => a -> ShowS
1486 = error "Numeric.showInt: can't show negative numbers"
1489 = let (n',d) = quotRem n 10
1490 r' = toEnum (fromEnum '0' + fromIntegral d) : r
1491 in if n' == 0 then r' else showInt n' r'
1493 = case quotRem n 10 of { (n',d) ->
1494 let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1495 in if n' == 0 then r' else showInt n' r'
1499 readSigned:: Real a => ReadS a -> ReadS a
1500 readSigned readPos = readParen False read'
1501 where read' r = read'' r ++
1502 [(-x,t) | ("-",s) <- lex r,
1504 read'' r = [(n,s) | (str,s) <- lex r,
1505 (n,"") <- readPos str]
1507 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1508 showSigned showPos p x = if x < 0 then showParen (p > 6)
1509 (showChar '-' . showPos (-x))
1512 readFloat :: RealFloat a => ReadS a
1513 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1515 where readFix r = [(read (ds++ds'), length ds', t)
1516 | (ds, s) <- lexDigits r
1517 , (ds',t) <- lexFrac s ]
1519 lexFrac ('.':s) = lexDigits s
1520 lexFrac s = [("",s)]
1522 readExp (e:s) | e `elem` "eE" = readExp' s
1525 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1526 readExp' ('+':s) = readDec s
1527 readExp' s = readDec s
1530 -- Hooks for primitives: -----------------------------------------------------
1531 -- Do not mess with these!
1533 primCompAux :: Ord a => a -> a -> Ordering -> Ordering
1534 primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1536 primPmInt :: Num a => Int -> a -> Bool
1537 primPmInt n x = fromInt n == x
1539 primPmInteger :: Num a => Integer -> a -> Bool
1540 primPmInteger n x = fromInteger n == x
1542 primPmFlt :: Fractional a => Double -> a -> Bool
1543 primPmFlt n x = fromDouble n == x
1545 -- ToDo: make the message more informative.
1547 primPmFail = error "Pattern Match Failure"
1549 -- used in desugaring Foreign functions
1550 primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1553 primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1554 primCreateAdjThunk fun typestr callconv
1555 = do sp <- makeStablePtr fun
1556 p <- copy_String_to_cstring typestr -- is never freed
1557 a <- primCreateAdjThunkARCH sp p callconv
1560 -- The following primitives are only needed if (n+k) patterns are enabled:
1561 primPmNpk :: Integral a => Int -> a -> Maybe a
1562 primPmNpk n x = if n'<=x then Just (x-n') else Nothing
1563 where n' = fromInt n
1565 primPmSub :: Integral a => Int -> a -> a
1566 primPmSub n x = x - fromInt n
1568 -- Unpack strings generated by the Hugs code generator.
1569 -- Strings can contain \0 provided they're coded right.
1571 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1573 primUnpackString :: Addr -> String
1574 primUnpackString a = unpack 0
1576 -- The following decoding is based on evalString in the old machine.c
1579 | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1580 then '\\' : unpack (i+2)
1581 else '\0' : unpack (i+2)
1582 | otherwise = c : unpack (i+1)
1584 c = primIndexCharOffAddr a i
1587 -- Monadic I/O: --------------------------------------------------------------
1589 type FilePath = String
1591 --data IOError = ...
1592 --instance Eq IOError ...
1593 --instance Show IOError ...
1595 data IOError = IOError String
1596 instance Show IOError where
1597 showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1599 ioError :: IOError -> IO a
1600 ioError (IOError s) = primRaise (IOExcept s)
1602 userError :: String -> IOError
1603 userError s = primRaise (ErrorCall s)
1605 catch :: IO a -> (IOError -> IO a) -> IO a
1607 = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
1609 e2ioe (IOExcept s) = IOError s
1610 e2ioe other = IOError (show other)
1612 putChar :: Char -> IO ()
1613 putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c)
1615 putStr :: String -> IO ()
1616 putStr s = --mapM_ putChar s -- correct, but slow
1618 let loop [] = return ()
1619 loop (c:cs) = nh_write h (primCharToInt c) >> loop cs
1622 putStrLn :: String -> IO ()
1623 putStrLn s = do { putStr s; putChar '\n' }
1625 print :: Show a => a -> IO ()
1626 print = putStrLn . show
1629 getChar = unsafeInterleaveIO (
1631 nh_read h >>= \ci ->
1632 return (primIntToChar ci)
1635 getLine :: IO String
1636 getLine = do c <- getChar
1637 if c=='\n' then return ""
1638 else do cs <- getLine
1641 getContents :: IO String
1642 getContents = nh_stdin >>= \h -> readfromhandle h
1644 interact :: (String -> String) -> IO ()
1645 interact f = getContents >>= (putStr . f)
1647 readFile :: FilePath -> IO String
1649 = copy_String_to_cstring fname >>= \ptr ->
1650 nh_open ptr 0 >>= \h ->
1652 nh_errno >>= \errno ->
1653 if (h == 0 || errno /= 0)
1654 then (ioError.IOError) ("readFile: can't open file " ++ fname)
1655 else readfromhandle h
1657 writeFile :: FilePath -> String -> IO ()
1658 writeFile fname contents
1659 = copy_String_to_cstring fname >>= \ptr ->
1660 nh_open ptr 1 >>= \h ->
1662 nh_errno >>= \errno ->
1663 if (h == 0 || errno /= 0)
1664 then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1665 else writetohandle fname h contents
1667 appendFile :: FilePath -> String -> IO ()
1668 appendFile fname contents
1669 = copy_String_to_cstring fname >>= \ptr ->
1670 nh_open ptr 2 >>= \h ->
1672 nh_errno >>= \errno ->
1673 if (h == 0 || errno /= 0)
1674 then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1675 else writetohandle fname h contents
1678 -- raises an exception instead of an error
1679 readIO :: Read a => String -> IO a
1680 readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1682 [] -> ioError (userError "PreludeIO.readIO: no parse")
1683 _ -> ioError (userError
1684 "PreludeIO.readIO: ambiguous parse")
1686 readLn :: Read a => IO a
1687 readLn = do l <- getLine
1692 -- End of Hugs standard prelude ----------------------------------------------
1698 instance Show Exception where
1699 showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1700 showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
1702 data IOResult = IOResult deriving (Show)
1704 type FILE_STAR = Int -- FILE *
1706 foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR
1707 foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
1708 foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
1709 foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Int -> IO ()
1710 foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int
1711 foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR
1712 foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO ()
1713 foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO ()
1714 foreign import "nHandle" "nh_errno" nh_errno :: IO Int
1716 foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
1717 foreign import "nHandle" "nh_free" nh_free :: Addr -> IO ()
1718 foreign import "nHandle" "nh_store" nh_store :: Addr -> Int -> IO ()
1719 foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Int
1721 foreign import "nHandle" "nh_argc" nh_argc :: IO Int
1722 foreign import "nHandle" "nh_argvb" nh_argvb :: Int -> Int -> IO Int
1723 foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
1725 copy_String_to_cstring :: String -> IO Addr
1726 copy_String_to_cstring s
1727 = nh_malloc (1 + length s) >>= \ptr0 ->
1728 let loop ptr [] = nh_store ptr 0 >> return ptr0
1729 loop ptr (c:cs) = nh_store ptr (primCharToInt c) >> loop (incAddr ptr) cs
1732 then error "copy_String_to_cstring: malloc failed"
1735 copy_cstring_to_String :: Addr -> IO String
1736 copy_cstring_to_String ptr
1737 = nh_load ptr >>= \ci ->
1740 else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1741 return ((primIntToChar ci) : cs)
1743 readfromhandle :: FILE_STAR -> IO String
1745 = unsafeInterleaveIO (
1746 nh_read h >>= \ci ->
1747 if ci == -1 {-EOF-} then return "" else
1748 readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1751 writetohandle :: String -> FILE_STAR -> String -> IO ()
1752 writetohandle fname h []
1754 nh_errno >>= \errno ->
1757 else error ( "writeFile/appendFile: error closing file " ++ fname)
1758 writetohandle fname h (c:cs)
1759 = nh_write h (primCharToInt c) >>
1760 writetohandle fname h cs
1762 primGetRawArgs :: IO [String]
1764 = nh_argc >>= \argc ->
1765 accumulate (map (get_one_arg 0) [0 .. argc-1])
1767 get_one_arg :: Int -> Int -> IO String
1768 get_one_arg offset argno
1769 = nh_argvb argno offset >>= \cb ->
1772 else get_one_arg (offset+1) argno >>= \s ->
1773 return ((primIntToChar cb):s)
1775 primGetEnv :: String -> IO String
1777 = copy_String_to_cstring v >>= \ptr ->
1778 nh_getenv ptr >>= \ptr2 ->
1783 copy_cstring_to_String ptr2 >>= \result ->
1787 ------------------------------------------------------------------------------
1788 -- ST, IO --------------------------------------------------------------------
1789 ------------------------------------------------------------------------------
1791 newtype ST s a = ST (s -> (a,s))
1794 type IO a = ST RealWorld a
1797 --primRunST :: (forall s. ST s a) -> a
1798 primRunST :: ST RealWorld a -> a
1799 primRunST m = fst (unST m theWorld)
1801 theWorld :: RealWorld
1802 theWorld = error "primRunST: entered the RealWorld"
1806 instance Functor (ST s) where
1807 fmap f x = x >>= (return . f)
1809 instance Monad (ST s) where
1810 m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1811 return x = ST (\s -> (x,s))
1812 m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1815 -- used when Hugs invokes top level function
1816 primRunIO :: IO () -> ()
1818 = protect (fst (unST m realWorld))
1820 realWorld = error "primRunIO: entered the RealWorld"
1823 = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1825 trace :: String -> a -> a
1827 = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x
1829 unsafeInterleaveST :: ST s a -> ST s a
1830 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1832 unsafeInterleaveIO :: IO a -> IO a
1833 unsafeInterleaveIO = unsafeInterleaveST
1836 ------------------------------------------------------------------------------
1837 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
1838 ------------------------------------------------------------------------------
1842 nullAddr = primIntToAddr 0
1843 incAddr a = primIntToAddr (1 + primAddrToInt a)
1844 isNullAddr a = 0 == primAddrToInt a
1846 instance Eq Addr where
1850 instance Ord Addr where
1859 instance Eq Word where
1863 instance Ord Word where
1872 makeStablePtr :: a -> IO (StablePtr a)
1873 makeStablePtr = primMakeStablePtr
1874 deRefStablePtr :: StablePtr a -> IO a
1875 deRefStablePtr = primDeRefStablePtr
1876 freeStablePtr :: StablePtr a -> IO ()
1877 freeStablePtr = primFreeStablePtr
1880 data PrimArray a -- immutable arrays with Int indices
1883 data Ref s a -- mutable variables
1884 data PrimMutableArray s a -- mutable arrays with Int indices
1885 data PrimMutableByteArray s
1889 -- showFloat ------------------------------------------------------------------
1891 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1892 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1893 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1894 showFloat :: (RealFloat a) => a -> ShowS
1896 showEFloat d x = showString (formatRealFloat FFExponent d x)
1897 showFFloat d x = showString (formatRealFloat FFFixed d x)
1898 showGFloat d x = showString (formatRealFloat FFGeneric d x)
1899 showFloat = showGFloat Nothing
1901 -- These are the format types. This type is not exported.
1903 data FFFormat = FFExponent | FFFixed | FFGeneric
1905 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
1906 formatRealFloat fmt decs x = s
1910 else if isInfinite x then
1911 if x < 0 then "-Infinity" else "Infinity"
1912 else if x < 0 || isNegativeZero x then
1913 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
1915 doFmt fmt (floatToDigits (toInteger base) x)
1917 let ds = map intToDigit is
1920 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
1927 [d] -> d : ".0e" ++ show (e-1)
1928 d:ds -> d : '.' : ds ++ 'e':show (e-1)
1930 let dec' = max dec 1 in
1932 [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
1934 let (ei, is') = roundTo base (dec'+1) is
1935 d:ds = map intToDigit
1936 (if ei > 0 then init is' else is')
1937 in d:'.':ds ++ "e" ++ show (e-1+ei)
1941 let f 0 s ds = mk0 s ++ "." ++ mk0 ds
1942 f n s "" = f (n-1) (s++"0") ""
1943 f n s (d:ds) = f (n-1) (s++[d]) ds
1948 let dec' = max dec 0 in
1950 let (ei, is') = roundTo base (dec' + e) is
1951 (ls, rs) = splitAt (e+ei) (map intToDigit is')
1952 in (if null ls then "0" else ls) ++
1953 (if null rs then "" else '.' : rs)
1955 let (ei, is') = roundTo base dec'
1956 (replicate (-e) 0 ++ is)
1957 d : ds = map intToDigit
1958 (if ei > 0 then is' else 0:is')
1961 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
1962 roundTo base d is = case f d is of
1964 (1, is) -> (1, 1 : is)
1965 where b2 = base `div` 2
1966 f n [] = (0, replicate n 0)
1967 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
1969 let (c, ds) = f (d-1) is
1971 in if i' == base then (1, 0:ds) else (0, i':ds)
1973 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
1974 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
1975 -- This version uses a much slower logarithm estimator. It should be improved.
1977 -- This function returns a list of digits (Ints in [0..base-1]) and an
1980 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
1982 floatToDigits _ 0 = ([0], 0)
1983 floatToDigits base x =
1984 let (f0, e0) = decodeFloat x
1985 (minExp0, _) = floatRange x
1988 minExp = minExp0 - p -- the real minimum exponent
1989 -- Haskell requires that f be adjusted so denormalized numbers
1990 -- will have an impossibly low exponent. Adjust for this.
1991 (f, e) = let n = minExp - e0
1992 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
1997 if f == b^(p-1) then
1998 (f*be*b*2, 2*b, be*b, b)
2002 if e > minExp && f == b^(p-1) then
2003 (f*b*2, b^(-e+1)*2, b, 1)
2005 (f*2, b^(-e)*2, 1, 1)
2008 if b == 2 && base == 10 then
2009 -- logBase 10 2 is slightly bigger than 3/10 so
2010 -- the following will err on the low side. Ignoring
2011 -- the fraction will make it err even more.
2012 -- Haskell promises that p-1 <= logBase b f < p.
2013 (p - 1 + e0) * 3 `div` 10
2015 ceiling ((log (fromInteger (f+1)) +
2016 fromInt e * log (fromInteger b)) /
2017 log (fromInteger base))
2020 if r + mUp <= expt base n * s then n else fixup (n+1)
2022 if expt base (-n) * (r + mUp) <= s then n
2026 gen ds rn sN mUpN mDnN =
2027 let (dn, rn') = (rn * base) `divMod` sN
2030 in case (rn' < mDnN', rn' + mUpN' > sN) of
2031 (True, False) -> dn : ds
2032 (False, True) -> dn+1 : ds
2033 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2034 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2037 gen [] r (s * expt base k) mUp mDn
2039 let bk = expt base (-k)
2040 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
2041 in (map toInt (reverse rds), k)
2044 -- Exponentiation with a cache for the most common numbers.
2047 expt :: Integer -> Int -> Integer
2049 if base == 2 && n >= minExpt && n <= maxExpt then
2050 expts !! (n-minExpt)
2055 expts = [2^n | n <- [minExpt .. maxExpt]]