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: STG Hugs _______________________________________________
9 This is the Hugs 98 Standard Prelude, based very closely on the Standard
10 Prelude for Haskell 98.
12 WARNING: This file is an integral part of the Hugs source code. Changes to
13 the definitions in this file without corresponding modifications in other
14 parts of the program may cause the interpreter to fail unexpectedly. Under
15 normal circumstances, you should not attempt to modify this file in any way!
17 -----------------------------------------------------------------------------
18 Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell
19 Group 1994-99, and is distributed as Open Source software under the
20 Artistic License; see the file "Artistic" that is included in the
21 distribution for details.
22 ----------------------------------------------------------------------------}
25 -- module PreludeList,
26 map, (++), concat, filter,
27 head, last, tail, init, null, length, (!!),
28 foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
29 iterate, repeat, replicate, cycle,
30 take, drop, splitAt, takeWhile, dropWhile, span, break,
31 lines, words, unlines, unwords, reverse, and, or,
32 any, all, elem, notElem, lookup,
33 sum, product, maximum, minimum, concatMap,
34 zip, zip3, zipWith, zipWith3, unzip, unzip3,
35 -- module PreludeText,
37 Read(readsPrec, readList),
38 Show(show, showsPrec, showList),
39 reads, shows, read, lex,
40 showChar, showString, readParen, showParen,
42 FilePath, IOError, ioError, userError, catch,
43 putChar, putStr, putStrLn, print,
44 getChar, getLine, getContents, interact,
45 readFile, writeFile, appendFile, readIO, readLn,
47 Ix(range, index, inRange, rangeSize),
49 isAscii, isControl, isPrint, isSpace, isUpper, isLower,
50 isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
51 digitToInt, intToDigit,
54 readLitChar, showLitChar, lexLitChar,
58 readDec, readOct, readHex, readSigned,
61 Ratio, Rational, (%), numerator, denominator, approxRational,
62 -- Non-standard exports
63 IO, IOResult(..), Addr, StablePtr,
64 makeStablePtr, freeStablePtr, deRefStablePtr,
70 Char, String, Int, Integer, Float, Double, IO,
71 -- List type: []((:), [])
73 -- Tuple types: (,), (,,), etc.
76 Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
78 Ord(compare, (<), (<=), (>=), (>), max, min),
79 Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
80 enumFromTo, enumFromThenTo),
81 Bounded(minBound, maxBound),
82 -- Num((+), (-), (*), negate, abs, signum, fromInteger),
83 Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
85 -- Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
86 Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
87 Fractional((/), recip, fromRational), fromDouble,
88 Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
89 asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
90 RealFrac(properFraction, truncate, round, ceiling, floor),
91 RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
92 encodeFloat, exponent, significand, scaleFloat, isNaN,
93 isInfinite, isDenormalized, isIEEE, isNegativeZero),
94 Monad((>>=), (>>), return, fail),
96 mapM, mapM_, sequence, sequence_, (=<<),
98 (&&), (||), not, otherwise,
99 subtract, even, odd, gcd, lcm, (^), (^^),
100 fromIntegral, realToFrac, atan2,
101 fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
102 asTypeOf, error, undefined,
107 -- Standard value bindings {Prelude} ----------------------------------------
112 infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
114 --infixr 5 : -- this fixity declaration is hard-wired into Hugs
116 infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
121 infixr 0 $, $!, `seq`
123 -- Equality and Ordered classes ---------------------------------------------
126 (==), (/=) :: a -> a -> Bool
128 -- Minimal complete definition: (==) or (/=)
132 class (Eq a) => Ord a where
133 compare :: a -> a -> Ordering
134 (<), (<=), (>=), (>) :: a -> a -> Bool
135 max, min :: a -> a -> a
137 -- Minimal complete definition: (<=) or compare
138 -- using compare can be more efficient for complex types
139 compare x y | x==y = EQ
143 x <= y = compare x y /= GT
144 x < y = compare x y == LT
145 x >= y = compare x y /= LT
146 x > y = compare x y == GT
153 class Bounded a where
154 minBound, maxBound :: a
155 -- Minimal complete definition: All
157 -- Numeric classes ----------------------------------------------------------
159 class (Eq a, Show a) => Num a where
160 (+), (-), (*) :: a -> a -> a
162 abs, signum :: a -> a
163 fromInteger :: Integer -> a
166 -- Minimal complete definition: All, except negate or (-)
168 fromInt = fromIntegral
171 class (Num a, Ord a) => Real a where
172 toRational :: a -> Rational
174 class (Real a, Enum a) => Integral a where
175 quot, rem, div, mod :: a -> a -> a
176 quotRem, divMod :: a -> a -> (a,a)
177 even, odd :: a -> Bool
178 toInteger :: a -> Integer
181 -- Minimal complete definition: quotRem and toInteger
182 n `quot` d = q where (q,r) = quotRem n d
183 n `rem` d = r where (q,r) = quotRem n d
184 n `div` d = q where (q,r) = divMod n d
185 n `mod` d = r where (q,r) = divMod n d
186 divMod n d = if signum r == - signum d then (q-1, r+d) else qr
187 where qr@(q,r) = quotRem n d
188 even n = n `rem` 2 == 0
190 toInt = toInt . toInteger
192 class (Num a) => Fractional a where
195 fromRational :: Rational -> a
197 -- Minimal complete definition: fromRational and ((/) or recip)
201 fromDouble :: Fractional a => Double -> a
202 fromDouble n = fromRational (toRational n)
204 class (Fractional a) => Floating a where
206 exp, log, sqrt :: a -> a
207 (**), logBase :: a -> a -> a
208 sin, cos, tan :: a -> a
209 asin, acos, atan :: a -> a
210 sinh, cosh, tanh :: a -> a
211 asinh, acosh, atanh :: a -> a
213 -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
214 -- asinh, acosh, atanh
215 x ** y = exp (log x * y)
216 logBase x y = log y / log x
218 tan x = sin x / cos x
219 sinh x = (exp x - exp (-x)) / 2
220 cosh x = (exp x + exp (-x)) / 2
221 tanh x = sinh x / cosh x
222 asinh x = log (x + sqrt (x*x + 1))
223 acosh x = log (x + sqrt (x*x - 1))
224 atanh x = (log (1 + x) - log (1 - x)) / 2
226 class (Real a, Fractional a) => RealFrac a where
227 properFraction :: (Integral b) => a -> (b,a)
228 truncate, round :: (Integral b) => a -> b
229 ceiling, floor :: (Integral b) => a -> b
231 -- Minimal complete definition: properFraction
232 truncate x = m where (m,_) = properFraction x
234 round x = let (n,r) = properFraction x
235 m = if r < 0 then n - 1 else n + 1
236 in case signum (abs r - 0.5) of
238 0 -> if even n then n else m
241 ceiling x = if r > 0 then n + 1 else n
242 where (n,r) = properFraction x
244 floor x = if r < 0 then n - 1 else n
245 where (n,r) = properFraction x
247 class (RealFrac a, Floating a) => RealFloat a where
248 floatRadix :: a -> Integer
249 floatDigits :: a -> Int
250 floatRange :: a -> (Int,Int)
251 decodeFloat :: a -> (Integer,Int)
252 encodeFloat :: Integer -> Int -> a
254 significand :: a -> a
255 scaleFloat :: Int -> a -> a
256 isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
260 -- Minimal complete definition: All, except exponent, signficand,
262 exponent x = if m==0 then 0 else n + floatDigits x
263 where (m,n) = decodeFloat x
264 significand x = encodeFloat m (- floatDigits x)
265 where (m,_) = decodeFloat x
266 scaleFloat k x = encodeFloat m (n+k)
267 where (m,n) = decodeFloat x
271 | x<0 && y>0 = pi + atan (y/x)
273 (x<0 && isNegativeZero y) ||
274 (isNegativeZero x && isNegativeZero y)
276 | y==0 && (x<0 || isNegativeZero x)
277 = pi -- must be after the previous test on zero y
278 | x==0 && y==0 = y -- must be after the other double zero tests
279 | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
281 -- Numeric functions --------------------------------------------------------
283 subtract :: Num a => a -> a -> a
286 gcd :: Integral a => a -> a -> a
287 gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
288 gcd x y = gcd' (abs x) (abs y)
290 gcd' x y = gcd' y (x `rem` y)
292 lcm :: (Integral a) => a -> a -> a
295 lcm x y = abs ((x `quot` gcd x y) * y)
297 (^) :: (Num a, Integral b) => a -> b -> a
299 x ^ n | n > 0 = f x (n-1) x
301 f x n y = g x n where
302 g x n | even n = g (x*x) (n`quot`2)
303 | otherwise = f x (n-1) (x*y)
304 _ ^ _ = error "Prelude.^: negative exponent"
306 (^^) :: (Fractional a, Integral b) => a -> b -> a
307 x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
309 fromIntegral :: (Integral a, Num b) => a -> b
310 fromIntegral = fromInteger . toInteger
312 realToFrac :: (Real a, Fractional b) => a -> b
313 realToFrac = fromRational . toRational
315 -- Index and Enumeration classes --------------------------------------------
317 class (Ord a) => Ix a where
318 range :: (a,a) -> [a]
319 index :: (a,a) -> a -> Int
320 inRange :: (a,a) -> a -> Bool
321 rangeSize :: (a,a) -> Int
325 | otherwise = index r u + 1
331 enumFrom :: a -> [a] -- [n..]
332 enumFromThen :: a -> a -> [a] -- [n,m..]
333 enumFromTo :: a -> a -> [a] -- [n..m]
334 enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
336 -- Minimal complete definition: toEnum, fromEnum
337 succ = toEnum . (1+) . fromEnum
338 pred = toEnum . subtract 1 . fromEnum
339 enumFrom x = map toEnum [ fromEnum x .. ]
340 enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
341 enumFromThen x y = map toEnum [ fromEnum x, fromEnum y .. ]
342 enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
344 -- Read and Show classes ------------------------------------------------------
346 type ReadS a = String -> [(a,String)]
347 type ShowS = String -> String
350 readsPrec :: Int -> ReadS a
351 readList :: ReadS [a]
353 -- Minimal complete definition: readsPrec
354 readList = readParen False (\r -> [pr | ("[",s) <- lex r,
356 where readl s = [([],t) | ("]",t) <- lex s] ++
357 [(x:xs,u) | (x,t) <- reads s,
359 readl' s = [([],t) | ("]",t) <- lex s] ++
360 [(x:xs,v) | (",",t) <- lex s,
366 showsPrec :: Int -> a -> ShowS
367 showList :: [a] -> ShowS
369 -- Minimal complete definition: show or showsPrec
370 show x = showsPrec 0 x ""
371 showsPrec _ x s = show x ++ s
372 showList [] = showString "[]"
373 showList (x:xs) = showChar '[' . shows x . showl xs
374 where showl [] = showChar ']'
375 showl (x:xs) = showChar ',' . shows x . showl xs
377 -- Monad classes ------------------------------------------------------------
379 class Functor f where
380 fmap :: (a -> b) -> (f a -> f b)
384 (>>=) :: m a -> (a -> m b) -> m b
385 (>>) :: m a -> m b -> m b
386 fail :: String -> m a
388 -- Minimal complete definition: (>>=), return
389 p >> q = p >>= \ _ -> q
392 sequence :: Monad m => [m a] -> m [a]
393 sequence [] = return []
394 sequence (c:cs) = do x <- c
398 sequence_ :: Monad m => [m a] -> m ()
399 sequence_ = foldr (>>) (return ())
401 mapM :: Monad m => (a -> m b) -> [a] -> m [b]
402 mapM f = sequence . map f
404 mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
405 mapM_ f = sequence_ . map f
407 (=<<) :: Monad m => (a -> m b) -> m a -> m b
410 -- Evaluation and strictness ------------------------------------------------
413 seq x y = primSeq x y
415 ($!) :: (a -> b) -> a -> b
416 f $! x = x `primSeq` f x
418 -- Trivial type -------------------------------------------------------------
420 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
425 instance Ord () where
431 inRange ((),()) () = True
433 instance Enum () where
437 enumFromThen () () = [()]
439 instance Read () where
440 readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
443 instance Show () where
444 showsPrec p () = showString "()"
446 instance Bounded () where
450 -- Boolean type -------------------------------------------------------------
452 data Bool = False | True
453 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
455 (&&), (||) :: Bool -> Bool -> Bool
468 -- Character type -----------------------------------------------------------
470 data Char -- builtin datatype of ISO Latin characters
471 type String = [Char] -- strings are lists of characters
473 instance Eq Char where (==) = primEqChar
474 instance Ord Char where (<=) = primLeChar
476 instance Enum Char where
477 toEnum = primIntToChar
478 fromEnum = primCharToInt
479 enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
480 enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
481 where lastChar = if d < c then minBound else maxBound
483 instance Ix Char where
484 range (c,c') = [c..c']
486 | inRange b ci = fromEnum ci - fromEnum c
487 | otherwise = error "Ix.index: Index out of range."
488 inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
489 where i = fromEnum ci
491 instance Read Char where
492 readsPrec p = readParen False
493 (\r -> [(c,t) | ('\'':s,t) <- lex r,
494 (c,"\'") <- readLitChar s ])
495 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
497 where readl ('"':s) = [("",s)]
498 readl ('\\':'&':s) = readl s
499 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
501 instance Show Char where
502 showsPrec p '\'' = showString "'\\''"
503 showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
505 showList cs = showChar '"' . showl cs
506 where showl "" = showChar '"'
507 showl ('"':cs) = showString "\\\"" . showl cs
508 showl (c:cs) = showLitChar c . showl cs
510 instance Bounded Char where
514 isAscii, isControl, isPrint, isSpace :: Char -> Bool
515 isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
517 isAscii c = fromEnum c < 128
518 isControl c = c < ' ' || c == '\DEL'
519 isPrint c = c >= ' ' && c <= '~'
520 isSpace c = c == ' ' || c == '\t' || c == '\n' ||
521 c == '\r' || c == '\f' || c == '\v'
522 isUpper c = c >= 'A' && c <= 'Z'
523 isLower c = c >= 'a' && c <= 'z'
524 isAlpha c = isUpper c || isLower c
525 isDigit c = c >= '0' && c <= '9'
526 isAlphaNum c = isAlpha c || isDigit c
528 -- Digit conversion operations
529 digitToInt :: Char -> Int
531 | isDigit c = fromEnum c - fromEnum '0'
532 | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
533 | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
534 | otherwise = error "Char.digitToInt: not a digit"
536 intToDigit :: Int -> Char
538 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
539 | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
540 | otherwise = error "Char.intToDigit: not a digit"
542 toUpper, toLower :: Char -> Char
543 toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
546 toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
555 -- Maybe type ---------------------------------------------------------------
557 data Maybe a = Nothing | Just a
558 deriving (Eq, Ord, Read, Show)
560 maybe :: b -> (a -> b) -> Maybe a -> b
561 maybe n f Nothing = n
562 maybe n f (Just x) = f x
564 instance Functor Maybe where
565 fmap f Nothing = Nothing
566 fmap f (Just x) = Just (f x)
568 instance Monad Maybe where
570 Nothing >>= k = Nothing
574 -- Either type --------------------------------------------------------------
576 data Either a b = Left a | Right b
577 deriving (Eq, Ord, Read, Show)
579 either :: (a -> c) -> (b -> c) -> Either a b -> c
580 either l r (Left x) = l x
581 either l r (Right y) = r y
583 -- Ordering type ------------------------------------------------------------
585 data Ordering = LT | EQ | GT
586 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
588 -- Lists --------------------------------------------------------------------
590 --data [a] = [] | a : [a] deriving (Eq, Ord)
592 instance Eq a => Eq [a] where
594 (x:xs) == (y:ys) = x==y && xs==ys
597 instance Ord a => Ord [a] where
598 compare [] (_:_) = LT
600 compare (_:_) [] = GT
601 compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys)
603 instance Functor [] where
606 instance Monad [ ] where
607 (x:xs) >>= f = f x ++ (xs >>= f)
612 instance Read a => Read [a] where
613 readsPrec p = readList
615 instance Show a => Show [a] where
616 showsPrec p = showList
618 -- Tuples -------------------------------------------------------------------
620 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
623 -- Standard Integral types --------------------------------------------------
625 data Int -- builtin datatype of fixed size integers
626 data Integer -- builtin datatype of arbitrary size integers
628 instance Eq Integer where
629 (==) x y = primCompareInteger x y == 0
631 instance Ord Integer where
632 compare x y = case primCompareInteger x y of
637 instance Eq Int where
641 instance Ord Int where
647 instance Num Int where
650 negate = primNegateInt
654 fromInteger = primIntegerToInt
657 instance Bounded Int where
658 minBound = primMinInt
659 maxBound = primMaxInt
661 instance Num Integer where
662 (+) = primPlusInteger
663 (-) = primMinusInteger
664 negate = primNegateInteger
665 (*) = primTimesInteger
669 fromInt = primIntToInteger
671 absReal x | x >= 0 = x
674 signumReal x | x == 0 = 0
678 instance Real Int where
679 toRational x = toInteger x % 1
681 instance Real Integer where
684 instance Integral Int where
685 quotRem = primQuotRemInt
686 toInteger = primIntToInteger
689 instance Integral Integer where
690 quotRem = primQuotRemInteger
691 --divMod = primDivModInteger
693 toInt = primIntegerToInt
695 instance Ix Int where
698 | inRange b i = i - m
699 | otherwise = error "index: Index out of range"
700 inRange (m,n) i = m <= i && i <= n
702 instance Ix Integer where
705 | inRange b i = fromInteger (i - m)
706 | otherwise = error "index: Index out of range"
707 inRange (m,n) i = m <= i && i <= n
709 instance Enum Int where
712 enumFrom = numericEnumFrom
713 enumFromTo = numericEnumFromTo
714 enumFromThen = numericEnumFromThen
715 enumFromThenTo = numericEnumFromThenTo
717 instance Enum Integer where
718 toEnum = primIntToInteger
719 fromEnum = primIntegerToInt
720 enumFrom = numericEnumFrom
721 enumFromTo = numericEnumFromTo
722 enumFromThen = numericEnumFromThen
723 enumFromThenTo = numericEnumFromThenTo
725 numericEnumFrom :: Real a => a -> [a]
726 numericEnumFromThen :: Real a => a -> a -> [a]
727 numericEnumFromTo :: Real a => a -> a -> [a]
728 numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
729 numericEnumFrom n = n : (numericEnumFrom $! (n+1))
730 numericEnumFromThen n m = iterate ((m-n)+) n
731 numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
732 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
733 where p | n' >= n = (<= m)
736 instance Read Int where
737 readsPrec p = readSigned readDec
739 instance Show Int where
741 | n == minBound = showSigned showInt p (toInteger n)
742 | otherwise = showSigned showInt p n
744 instance Read Integer where
745 readsPrec p = readSigned readDec
747 instance Show Integer where
748 showsPrec = showSigned showInt
751 -- Standard Floating types --------------------------------------------------
753 data Float -- builtin datatype of single precision floating point numbers
754 data Double -- builtin datatype of double precision floating point numbers
756 instance Eq Float where
760 instance Ord Float where
766 instance Num Float where
769 negate = primNegateFloat
773 fromInteger = primIntegerToFloat
774 fromInt = primIntToFloat
778 instance Eq Double where
782 instance Ord Double where
788 instance Num Double where
790 (-) = primMinusDouble
791 negate = primNegateDouble
792 (*) = primTimesDouble
795 fromInteger = primIntegerToDouble
796 fromInt = primIntToDouble
800 instance Real Float where
801 toRational = floatToRational
803 instance Real Double where
804 toRational = doubleToRational
806 -- Calls to these functions are optimised when passed as arguments to
808 floatToRational :: Float -> Rational
809 doubleToRational :: Double -> Rational
810 floatToRational x = realFloatToRational x
811 doubleToRational x = realFloatToRational x
813 realFloatToRational x = (m%1)*(b%1)^^n
814 where (m,n) = decodeFloat x
817 instance Fractional Float where
818 (/) = primDivideFloat
819 fromRational = rationalToRealFloat
821 instance Fractional Double where
822 (/) = primDivideDouble
823 fromRational = rationalToRealFloat
825 rationalToRealFloat x = x'
827 f e = if e' == e then y else f e'
828 where y = encodeFloat (round (x * (1%b)^^e)) e
829 (_,e') = decodeFloat y
830 (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
831 / fromInteger (denominator x))
834 instance Floating Float where
835 pi = 3.14159265358979323846
846 instance Floating Double where
847 pi = 3.14159265358979323846
850 sqrt = primSqrtDouble
854 asin = primAsinDouble
855 acos = primAcosDouble
856 atan = primAtanDouble
858 instance RealFrac Float where
859 properFraction = floatProperFraction
861 instance RealFrac Double where
862 properFraction = floatProperFraction
864 floatProperFraction x
865 | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
866 | otherwise = (fromInteger w, encodeFloat r n)
867 where (m,n) = decodeFloat x
869 (w,r) = quotRem m (b^(-n))
871 instance RealFloat Float where
872 floatRadix _ = toInteger primRadixFloat
873 floatDigits _ = primDigitsFloat
874 floatRange _ = (primMinExpFloat,primMaxExpFloat)
875 encodeFloat = primEncodeFloatZ
876 decodeFloat = primDecodeFloatZ
877 isNaN = primIsNaNFloat
878 isInfinite = primIsInfiniteFloat
879 isDenormalized= primIsDenormalizedFloat
880 isNegativeZero= primIsNegativeZeroFloat
881 isIEEE = const primIsIEEEFloat
883 instance RealFloat Double where
884 floatRadix _ = toInteger primRadixDouble
885 floatDigits _ = primDigitsDouble
886 floatRange _ = (primMinExpDouble,primMaxExpDouble)
887 encodeFloat = primEncodeDoubleZ
888 decodeFloat = primDecodeDoubleZ
889 isNaN = primIsNaNDouble
890 isInfinite = primIsInfiniteDouble
891 isDenormalized= primIsDenormalizedDouble
892 isNegativeZero= primIsNegativeZeroDouble
893 isIEEE = const primIsIEEEDouble
895 instance Enum Float where
896 toEnum = primIntToFloat
898 enumFrom = numericEnumFrom
899 enumFromThen = numericEnumFromThen
900 enumFromTo n m = numericEnumFromTo n (m+1/2)
901 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
903 instance Enum Double where
904 toEnum = primIntToDouble
906 enumFrom = numericEnumFrom
907 enumFromThen = numericEnumFromThen
908 enumFromTo n m = numericEnumFromTo n (m+1/2)
909 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
911 instance Read Float where
912 readsPrec p = readSigned readFloat
914 instance Show Float where
915 showsPrec p = showSigned showFloat p
917 instance Read Double where
918 readsPrec p = readSigned readFloat
920 instance Show Double where
921 showsPrec p = showSigned showFloat p
924 -- Some standard functions --------------------------------------------------
932 curry :: ((a,b) -> c) -> (a -> b -> c)
933 curry f x y = f (x,y)
935 uncurry :: (a -> b -> c) -> ((a,b) -> c)
936 uncurry f p = f (fst p) (snd p)
944 (.) :: (b -> c) -> (a -> b) -> (a -> c)
947 flip :: (a -> b -> c) -> b -> a -> c
950 ($) :: (a -> b) -> a -> b
953 until :: (a -> Bool) -> (a -> a) -> a -> a
954 until p f x = if p x then x else until p f (f x)
956 asTypeOf :: a -> a -> a
960 error msg = primRaise (ErrorCall msg)
963 undefined | False = undefined
965 -- Standard functions on rational numbers {PreludeRatio} --------------------
967 data Integral a => Ratio a = a :% a deriving (Eq)
968 type Rational = Ratio Integer
970 (%) :: Integral a => a -> a -> Ratio a
971 x % y = reduce (x * signum y) (abs y)
973 reduce :: Integral a => a -> a -> Ratio a
974 reduce x y | y == 0 = error "Ratio.%: zero denominator"
975 | otherwise = (x `quot` d) :% (y `quot` d)
978 numerator, denominator :: Integral a => Ratio a -> a
979 numerator (x :% y) = x
980 denominator (x :% y) = y
982 instance Integral a => Ord (Ratio a) where
983 compare (x:%y) (x':%y') = compare (x*y') (x'*y)
985 instance Integral a => Num (Ratio a) where
986 (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
987 (x:%y) * (x':%y') = reduce (x*x') (y*y')
988 negate (x :% y) = negate x :% y
989 abs (x :% y) = abs x :% y
990 signum (x :% y) = signum x :% 1
991 fromInteger x = fromInteger x :% 1
994 -- Hugs optimises code of the form fromRational (intToRatio x)
995 intToRatio :: Integral a => Int -> Ratio a
996 intToRatio x = fromInt x :% 1
998 instance Integral a => Real (Ratio a) where
999 toRational (x:%y) = toInteger x :% toInteger y
1001 instance Integral a => Fractional (Ratio a) where
1002 (x:%y) / (x':%y') = (x*y') % (y*x')
1003 recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
1004 fromRational (x:%y) = fromInteger x :% fromInteger y
1006 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1007 doubleToRatio :: Integral a => Double -> Ratio a
1009 | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
1010 | otherwise = fromInteger m % (fromInteger b ^ (-n))
1011 where (m,n) = decodeFloat x
1014 instance Integral a => RealFrac (Ratio a) where
1015 properFraction (x:%y) = (fromIntegral q, r:%y)
1016 where (q,r) = quotRem x y
1018 instance Integral a => Enum (Ratio a) where
1021 enumFrom = numericEnumFrom
1022 enumFromThen = numericEnumFromThen
1024 instance (Read a, Integral a) => Read (Ratio a) where
1025 readsPrec p = readParen (p > 7)
1026 (\r -> [(x%y,u) | (x,s) <- reads r,
1030 instance Integral a => Show (Ratio a) where
1031 showsPrec p (x:%y) = showParen (p > 7)
1032 (shows x . showString " % " . shows y)
1034 approxRational :: RealFrac a => a -> a -> Rational
1035 approxRational x eps = simplest (x-eps) (x+eps)
1036 where simplest x y | y < x = simplest y x
1038 | x > 0 = simplest' n d n' d'
1039 | y < 0 = - simplest' (-n') d' (-n) d
1040 | otherwise = 0 :% 1
1041 where xr@(n:%d) = toRational x
1042 (n':%d') = toRational y
1043 simplest' n d n' d' -- assumes 0 < n%d < n'%d'
1045 | q /= q' = (q+1) :% 1
1046 | otherwise = (q*n''+d'') :% n''
1047 where (q,r) = quotRem n d
1048 (q',r') = quotRem n' d'
1049 (n'':%d'') = simplest' d' r' d r
1051 -- Standard list functions {PreludeList} ------------------------------------
1058 last (_:xs) = last xs
1065 init (x:xs) = x : init xs
1071 (++) :: [a] -> [a] -> [a]
1073 (x:xs) ++ ys = x : (xs ++ ys)
1075 map :: (a -> b) -> [a] -> [b]
1076 --map f xs = [ f x | x <- xs ]
1078 map f (x:xs) = f x : map f xs
1081 filter :: (a -> Bool) -> [a] -> [a]
1082 --filter p xs = [ x | x <- xs, p x ]
1084 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1087 concat :: [[a]] -> [a]
1088 --concat = foldr (++) []
1090 concat (xs:xss) = xs ++ concat xss
1092 length :: [a] -> Int
1093 --length = foldl' (\n _ -> n + 1) 0
1095 length (x:xs) = let n = length xs in primSeq n (1+n)
1097 (!!) :: [b] -> Int -> b
1099 (_:xs) !! n | n>0 = xs !! (n-1)
1100 (_:_) !! _ = error "Prelude.!!: negative index"
1101 [] !! _ = error "Prelude.!!: index too large"
1103 foldl :: (a -> b -> a) -> a -> [b] -> a
1105 foldl f z (x:xs) = foldl f (f z x) xs
1107 foldl' :: (a -> b -> a) -> a -> [b] -> a
1109 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1111 foldl1 :: (a -> a -> a) -> [a] -> a
1112 foldl1 f (x:xs) = foldl f x xs
1114 scanl :: (a -> b -> a) -> a -> [b] -> [a]
1115 scanl f q xs = q : (case xs of
1117 x:xs -> scanl f (f q x) xs)
1119 scanl1 :: (a -> a -> a) -> [a] -> [a]
1120 scanl1 f (x:xs) = scanl f x xs
1122 foldr :: (a -> b -> b) -> b -> [a] -> b
1124 foldr f z (x:xs) = f x (foldr f z xs)
1126 foldr1 :: (a -> a -> a) -> [a] -> a
1128 foldr1 f (x:xs) = f x (foldr1 f xs)
1130 scanr :: (a -> b -> b) -> b -> [a] -> [b]
1131 scanr f q0 [] = [q0]
1132 scanr f q0 (x:xs) = f x q : qs
1133 where qs@(q:_) = scanr f q0 xs
1135 scanr1 :: (a -> a -> a) -> [a] -> [a]
1137 scanr1 f (x:xs) = f x q : qs
1138 where qs@(q:_) = scanr1 f xs
1140 iterate :: (a -> a) -> a -> [a]
1141 iterate f x = x : iterate f (f x)
1144 repeat x = xs where xs = x:xs
1146 replicate :: Int -> a -> [a]
1147 replicate n x = take n (repeat x)
1150 cycle [] = error "Prelude.cycle: empty list"
1151 cycle xs = xs' where xs'=xs++xs'
1153 take :: Int -> [a] -> [a]
1156 take n (x:xs) | n>0 = x : take (n-1) xs
1157 take _ _ = error "Prelude.take: negative argument"
1159 drop :: Int -> [a] -> [a]
1162 drop n (_:xs) | n>0 = drop (n-1) xs
1163 drop _ _ = error "Prelude.drop: negative argument"
1165 splitAt :: Int -> [a] -> ([a], [a])
1166 splitAt 0 xs = ([],xs)
1167 splitAt _ [] = ([],[])
1168 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1169 splitAt _ _ = error "Prelude.splitAt: negative argument"
1171 takeWhile :: (a -> Bool) -> [a] -> [a]
1174 | p x = x : takeWhile p xs
1177 dropWhile :: (a -> Bool) -> [a] -> [a]
1179 dropWhile p xs@(x:xs')
1180 | p x = dropWhile p xs'
1183 span, break :: (a -> Bool) -> [a] -> ([a],[a])
1187 | otherwise = ([],xs)
1188 where (ys,zs) = span p xs'
1189 break p = span (not . p)
1191 lines :: String -> [String]
1193 lines s = let (l,s') = break ('\n'==) s
1194 in l : case s' of [] -> []
1195 (_:s'') -> lines s''
1197 words :: String -> [String]
1198 words s = case dropWhile isSpace s of
1201 where (w,s'') = break isSpace s'
1203 unlines :: [String] -> String
1204 unlines = concatMap (\l -> l ++ "\n")
1206 unwords :: [String] -> String
1208 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1210 reverse :: [a] -> [a]
1211 --reverse = foldl (flip (:)) []
1212 reverse xs = ri [] xs
1213 where ri acc [] = acc
1214 ri acc (x:xs) = ri (x:acc) xs
1216 and, or :: [Bool] -> Bool
1217 --and = foldr (&&) True
1218 --or = foldr (||) False
1220 and (x:xs) = if x then and xs else x
1222 or (x:xs) = if x then x else or xs
1224 any, all :: (a -> Bool) -> [a] -> Bool
1225 --any p = or . map p
1226 --all p = and . map p
1228 any p (x:xs) = if p x then True else any p xs
1230 all p (x:xs) = if p x then all p xs else False
1232 elem, notElem :: Eq a => a -> [a] -> Bool
1234 --notElem = all . (/=)
1236 elem x (y:ys) = if x==y then True else elem x ys
1238 notElem x (y:ys) = if x==y then False else notElem x ys
1240 lookup :: Eq a => a -> [(a,b)] -> Maybe b
1241 lookup k [] = Nothing
1242 lookup k ((x,y):xys)
1244 | otherwise = lookup k xys
1246 sum, product :: Num a => [a] -> a
1248 product = foldl' (*) 1
1250 maximum, minimum :: Ord a => [a] -> a
1251 maximum = foldl1 max
1252 minimum = foldl1 min
1254 concatMap :: (a -> [b]) -> [a] -> [b]
1255 concatMap f = concat . map f
1257 zip :: [a] -> [b] -> [(a,b)]
1258 zip = zipWith (\a b -> (a,b))
1260 zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
1261 zip3 = zipWith3 (\a b c -> (a,b,c))
1263 zipWith :: (a->b->c) -> [a]->[b]->[c]
1264 zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
1267 zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1268 zipWith3 z (a:as) (b:bs) (c:cs)
1269 = z a b c : zipWith3 z as bs cs
1270 zipWith3 _ _ _ _ = []
1272 unzip :: [(a,b)] -> ([a],[b])
1273 unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1275 unzip3 :: [(a,b,c)] -> ([a],[b],[c])
1276 unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1279 -- PreludeText ----------------------------------------------------------------
1281 reads :: Read a => ReadS a
1284 shows :: Show a => a -> ShowS
1287 read :: Read a => String -> a
1288 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1290 [] -> error "Prelude.read: no parse"
1291 _ -> error "Prelude.read: ambiguous parse"
1293 showChar :: Char -> ShowS
1296 showString :: String -> ShowS
1299 showParen :: Bool -> ShowS -> ShowS
1300 showParen b p = if b then showChar '(' . p . showChar ')' else p
1302 hugsprimShowField :: Show a => String -> a -> ShowS
1303 hugsprimShowField m v = showString m . showChar '=' . shows v
1305 readParen :: Bool -> ReadS a -> ReadS a
1306 readParen b g = if b then mandatory else optional
1307 where optional r = g r ++ mandatory r
1308 mandatory r = [(x,u) | ("(",s) <- lex r,
1309 (x,t) <- optional s,
1313 hugsprimReadField :: Read a => String -> ReadS a
1314 hugsprimReadField m s0 = [ r | (t, s1) <- lex s0, t == m,
1320 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1321 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1323 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1325 lexString ('"':s) = [("\"",s)]
1326 lexString s = [(ch++str, u)
1327 | (ch,t) <- lexStrItem s,
1328 (str,u) <- lexString t ]
1330 lexStrItem ('\\':'&':s) = [("\\&",s)]
1331 lexStrItem ('\\':c:s) | isSpace c
1332 = [("",t) | '\\':t <- [dropWhile isSpace s]]
1333 lexStrItem s = lexLitChar s
1335 lex (c:s) | isSingle c = [([c],s)]
1336 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
1337 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
1338 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
1339 (fe,t) <- lexFracExp s ]
1340 | otherwise = [] -- bad character
1342 isSingle c = c `elem` ",;()[]{}_`"
1343 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1344 isIdChar c = isAlphaNum c || c `elem` "_'"
1346 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1348 lexFracExp s = [("",s)]
1350 lexExp (e:s) | e `elem` "eE"
1351 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
1352 (ds,u) <- lexDigits t] ++
1353 [(e:ds,t) | (ds,t) <- lexDigits s]
1356 lexDigits :: ReadS String
1357 lexDigits = nonnull isDigit
1359 nonnull :: (Char -> Bool) -> ReadS String
1360 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1362 lexLitChar :: ReadS String
1363 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1365 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- "
1366 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
1367 lexEsc s@(d:_) | isDigit d = lexDigits s
1368 lexEsc s@(c:_) | isUpper c
1369 = let table = ('\DEL',"DEL") : asciiTab
1370 in case [(mne,s') | (c, mne) <- table,
1371 ([],s') <- [lexmatch mne s]]
1375 lexLitChar (c:s) = [([c],s)]
1378 isOctDigit c = c >= '0' && c <= '7'
1379 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
1380 || c >= 'a' && c <= 'f'
1382 lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
1383 lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
1384 lexmatch xs ys = (xs,ys)
1386 asciiTab = zip ['\NUL'..' ']
1387 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1388 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
1389 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1390 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
1393 readLitChar :: ReadS Char
1394 readLitChar ('\\':s) = readEsc s
1396 readEsc ('a':s) = [('\a',s)]
1397 readEsc ('b':s) = [('\b',s)]
1398 readEsc ('f':s) = [('\f',s)]
1399 readEsc ('n':s) = [('\n',s)]
1400 readEsc ('r':s) = [('\r',s)]
1401 readEsc ('t':s) = [('\t',s)]
1402 readEsc ('v':s) = [('\v',s)]
1403 readEsc ('\\':s) = [('\\',s)]
1404 readEsc ('"':s) = [('"',s)]
1405 readEsc ('\'':s) = [('\'',s)]
1406 readEsc ('^':c:s) | c >= '@' && c <= '_'
1407 = [(toEnum (fromEnum c - fromEnum '@'), s)]
1408 readEsc s@(d:_) | isDigit d
1409 = [(toEnum n, t) | (n,t) <- readDec s]
1410 readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
1411 readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
1412 readEsc s@(c:_) | isUpper c
1413 = let table = ('\DEL',"DEL") : asciiTab
1414 in case [(c,s') | (c, mne) <- table,
1415 ([],s') <- [lexmatch mne s]]
1419 readLitChar (c:s) = [(c,s)]
1421 showLitChar :: Char -> ShowS
1422 showLitChar c | c > '\DEL' = showChar '\\' .
1423 protectEsc isDigit (shows (fromEnum c))
1424 showLitChar '\DEL' = showString "\\DEL"
1425 showLitChar '\\' = showString "\\\\"
1426 showLitChar c | c >= ' ' = showChar c
1427 showLitChar '\a' = showString "\\a"
1428 showLitChar '\b' = showString "\\b"
1429 showLitChar '\f' = showString "\\f"
1430 showLitChar '\n' = showString "\\n"
1431 showLitChar '\r' = showString "\\r"
1432 showLitChar '\t' = showString "\\t"
1433 showLitChar '\v' = showString "\\v"
1434 showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
1435 showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
1437 protectEsc p f = f . cont
1438 where cont s@(c:_) | p c = "\\&" ++ s
1441 -- Unsigned readers for various bases
1442 readDec, readOct, readHex :: Integral a => ReadS a
1443 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1444 readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1445 readHex = readInt 16 isHexDigit hex
1446 where hex d = fromEnum d -
1449 else fromEnum (if isUpper d then 'A' else 'a') - 10)
1451 -- readInt reads a string of digits using an arbitrary base.
1452 -- Leading minus signs must be handled elsewhere.
1454 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1455 readInt radix isDig digToInt s =
1456 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1457 | (ds,r) <- nonnull isDig s ]
1459 -- showInt is used for positive numbers only
1460 showInt :: Integral a => a -> ShowS
1463 = error "Numeric.showInt: can't show negative numbers"
1466 = let (n',d) = quotRem n 10
1467 r' = toEnum (fromEnum '0' + fromIntegral d) : r
1468 in if n' == 0 then r' else showInt n' r'
1470 = case quotRem n 10 of { (n',d) ->
1471 let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1472 in if n' == 0 then r' else showInt n' r'
1476 readSigned:: Real a => ReadS a -> ReadS a
1477 readSigned readPos = readParen False read'
1478 where read' r = read'' r ++
1479 [(-x,t) | ("-",s) <- lex r,
1481 read'' r = [(n,s) | (str,s) <- lex r,
1482 (n,"") <- readPos str]
1484 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1485 showSigned showPos p x = if x < 0 then showParen (p > 6)
1486 (showChar '-' . showPos (-x))
1489 readFloat :: RealFloat a => ReadS a
1490 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1492 where readFix r = [(read (ds++ds'), length ds', t)
1493 | (ds, s) <- lexDigits r
1494 , (ds',t) <- lexFrac s ]
1496 lexFrac ('.':s) = lexDigits s
1497 lexFrac s = [("",s)]
1499 readExp (e:s) | e `elem` "eE" = readExp' s
1502 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1503 readExp' ('+':s) = readDec s
1504 readExp' s = readDec s
1507 -- Hooks for primitives: -----------------------------------------------------
1508 -- Do not mess with these!
1510 hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering
1511 hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1513 hugsprimEqChar :: Char -> Char -> Bool
1514 hugsprimEqChar c1 c2 = primEqChar c1 c2
1516 hugsprimPmInt :: Num a => Int -> a -> Bool
1517 hugsprimPmInt n x = fromInt n == x
1519 hugsprimPmInteger :: Num a => Integer -> a -> Bool
1520 hugsprimPmInteger n x = fromInteger n == x
1522 hugsprimPmDouble :: Fractional a => Double -> a -> Bool
1523 hugsprimPmDouble n x = fromDouble n == x
1525 -- ToDo: make the message more informative.
1527 hugsprimPmFail = error "Pattern Match Failure"
1529 -- used in desugaring Foreign functions
1530 -- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
1531 -- bit of code of type RealWorld -> (a,RealWorld) into a proper IO value.
1532 -- What follows is the version for standalone mode. ghc/lib/std/PrelHugs.lhs
1533 -- contains a version used in combined mode. That version takes care of
1534 -- switching between the GHC and Hugs IO representations, which are different.
1535 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1538 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1539 hugsprimCreateAdjThunk fun typestr callconv
1540 = do sp <- makeStablePtr fun
1541 p <- copy_String_to_cstring typestr -- is never freed
1542 a <- primCreateAdjThunkARCH sp p callconv
1545 -- The following primitives are only needed if (n+k) patterns are enabled:
1546 hugsprimPmSub :: Integral a => Int -> a -> a
1547 hugsprimPmSub n x = x - fromInt n
1549 hugsprimPmFromInteger :: Integral a => Integer -> a
1550 hugsprimPmFromInteger = fromIntegral
1552 hugsprimPmSubtract :: Integral a => a -> a -> a
1553 hugsprimPmSubtract x y = x - y
1555 hugsprimPmLe :: Integral a => a -> a -> Bool
1556 hugsprimPmLe x y = x <= y
1558 -- Unpack strings generated by the Hugs code generator.
1559 -- Strings can contain \0 provided they're coded right.
1561 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1563 hugsprimUnpackString :: Addr -> String
1564 hugsprimUnpackString a = unpack 0
1566 -- The following decoding is based on evalString in the old machine.c
1569 | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1570 then '\\' : unpack (i+2)
1571 else '\0' : unpack (i+2)
1572 | otherwise = c : unpack (i+1)
1574 c = primIndexCharOffAddr a i
1577 -- Monadic I/O: --------------------------------------------------------------
1579 type FilePath = String
1581 --data IOError = ...
1582 --instance Eq IOError ...
1583 --instance Show IOError ...
1585 data IOError = IOError String
1586 instance Show IOError where
1587 showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1589 ioError :: IOError -> IO a
1590 ioError (IOError s) = primRaise (IOExcept s)
1592 userError :: String -> IOError
1593 userError s = primRaise (ErrorCall s)
1595 catch :: IO a -> (IOError -> IO a) -> IO a
1597 = IO (\s -> unIO m s `primCatch` \ err -> unIO (k (e2ioe err)) s)
1599 e2ioe (IOExcept s) = IOError s
1600 e2ioe other = IOError (show other)
1602 putChar :: Char -> IO ()
1603 putChar c = nh_stdout >>= \h -> nh_write h c
1605 putStr :: String -> IO ()
1606 putStr s = nh_stdout >>= \h ->
1607 let loop [] = nh_flush h
1608 loop (c:cs) = nh_write h c >> loop cs
1611 putStrLn :: String -> IO ()
1612 putStrLn s = do { putStr s; putChar '\n' }
1614 print :: Show a => a -> IO ()
1615 print = putStrLn . show
1618 getChar = nh_stdin >>= \h ->
1619 nh_read h >>= \ci ->
1620 return (primIntToChar ci)
1622 getLine :: IO String
1623 getLine = do c <- getChar
1624 if c=='\n' then return ""
1625 else do cs <- getLine
1628 getContents :: IO String
1629 getContents = nh_stdin >>= \h -> readfromhandle h
1631 interact :: (String -> String) -> IO ()
1632 interact f = getContents >>= (putStr . f)
1634 readFile :: FilePath -> IO String
1636 = copy_String_to_cstring fname >>= \ptr ->
1637 nh_open ptr 0 >>= \h ->
1639 nh_errno >>= \errno ->
1640 if (isNullAddr h || errno /= 0)
1641 then (ioError.IOError) ("readFile: can't open file " ++ fname)
1642 else readfromhandle h
1644 writeFile :: FilePath -> String -> IO ()
1645 writeFile fname contents
1646 = copy_String_to_cstring fname >>= \ptr ->
1647 nh_open ptr 1 >>= \h ->
1649 nh_errno >>= \errno ->
1650 if (isNullAddr h || errno /= 0)
1651 then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1652 else writetohandle fname h contents
1654 appendFile :: FilePath -> String -> IO ()
1655 appendFile fname contents
1656 = copy_String_to_cstring fname >>= \ptr ->
1657 nh_open ptr 2 >>= \h ->
1659 nh_errno >>= \errno ->
1660 if (isNullAddr h || errno /= 0)
1661 then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1662 else writetohandle fname h contents
1665 -- raises an exception instead of an error
1666 readIO :: Read a => String -> IO a
1667 readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1669 [] -> ioError (userError "PreludeIO.readIO: no parse")
1670 _ -> ioError (userError
1671 "PreludeIO.readIO: ambiguous parse")
1673 readLn :: Read a => IO a
1674 readLn = do l <- getLine
1679 -- End of Hugs standard prelude ----------------------------------------------
1685 instance Show Exception where
1686 showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1687 showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
1689 data IOResult = IOResult deriving (Show)
1691 type FILE_STAR = Addr -- FILE *
1693 foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR
1694 foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
1695 foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
1696 foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Char -> IO ()
1697 foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int
1698 foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR
1699 foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO ()
1700 foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO ()
1701 foreign import "nHandle" "nh_errno" nh_errno :: IO Int
1703 foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
1704 foreign import "nHandle" "nh_free" nh_free :: Addr -> IO ()
1705 foreign import "nHandle" "nh_store" nh_store :: Addr -> Char -> IO ()
1706 foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Char
1707 foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
1708 foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int
1709 foreign import "nHandle" "nh_iseof" nh_iseof :: FILE_STAR -> IO Int
1710 foreign import "nHandle" "nh_system" nh_system :: Addr -> IO Int
1711 foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO ()
1712 foreign import "nHandle" "nh_getPID" nh_getPID :: IO Int
1714 foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double
1715 foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double
1717 copy_String_to_cstring :: String -> IO Addr
1718 copy_String_to_cstring s
1719 = nh_malloc (1 + length s) >>= \ptr0 ->
1720 let loop ptr [] = nh_store ptr (chr 0) >> return ptr0
1721 loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs
1724 then error "copy_String_to_cstring: malloc failed"
1727 copy_cstring_to_String :: Addr -> IO String
1728 copy_cstring_to_String ptr
1729 = nh_load ptr >>= \ci ->
1732 else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1735 readfromhandle :: FILE_STAR -> IO String
1737 = unsafeInterleaveIO (
1738 nh_read h >>= \ci ->
1739 if ci == -1 {-EOF-} then return "" else
1740 readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1743 writetohandle :: String -> FILE_STAR -> String -> IO ()
1744 writetohandle fname h []
1746 nh_errno >>= \errno ->
1749 else error ( "writeFile/appendFile: error closing file " ++ fname)
1750 writetohandle fname h (c:cs)
1751 = nh_write h c >> writetohandle fname h cs
1753 primGetRawArgs :: IO [String]
1755 = primGetArgc >>= \argc ->
1756 sequence (map get_one_arg [0 .. argc-1])
1758 get_one_arg :: Int -> IO String
1760 = primGetArgv argno >>= \a ->
1761 copy_cstring_to_String a
1763 primGetEnv :: String -> IO String
1765 = copy_String_to_cstring v >>= \ptr ->
1766 nh_getenv ptr >>= \ptr2 ->
1769 then ioError (IOError "getEnv failed")
1771 copy_cstring_to_String ptr2 >>= \result ->
1775 ------------------------------------------------------------------------------
1776 -- ST ------------------------------------------------------------------------
1777 ------------------------------------------------------------------------------
1779 newtype ST s a = ST (s -> (a,s))
1783 runST :: (__forall s . ST s a) -> a
1784 runST m = fst (unST m alpha)
1786 alpha = error "runST: entered the RealWorld"
1788 fixST :: (a -> ST s a) -> ST s a
1789 fixST m = ST (\ s ->
1791 (r,s) = unST (m r) s
1795 instance Functor (ST s) where
1796 fmap f x = x >>= (return . f)
1798 instance Monad (ST s) where
1799 m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1800 return x = ST (\s -> (x,s))
1801 m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1803 unsafeInterleaveST :: ST s a -> ST s a
1804 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1806 ------------------------------------------------------------------------------
1807 -- IO ------------------------------------------------------------------------
1808 ------------------------------------------------------------------------------
1810 newtype IO a = IO (RealWorld -> (a,RealWorld))
1813 stToIO :: ST RealWorld a -> IO a
1814 stToIO (ST fn) = IO fn
1816 ioToST :: IO a -> ST RealWorld a
1817 ioToST (IO fn) = ST fn
1819 unsafePerformIO :: IO a -> a
1820 unsafePerformIO m = fst (unIO m theWorld)
1822 theWorld :: RealWorld
1823 theWorld = error "unsafePerformIO: entered the RealWorld"
1825 instance Functor IO where
1826 fmap f x = x >>= (return . f)
1828 instance Monad IO where
1829 m >> k = IO (\s -> case unIO m s of { (a,s') -> unIO k s' })
1830 return x = IO (\s -> (x,s))
1831 m >>= k = IO (\s -> case unIO m s of { (a,s') -> unIO (k a) s' })
1833 -- Library IO has a global variable which accumulates Handles
1834 -- as they are opened. We keep here a second global variable
1835 -- into which a cleanup action may be specified. When evaluation
1836 -- finishes, either normally or as a result of System.exitWith,
1837 -- this cleanup action is run, closing all known-about Handles.
1838 -- Doing it like this means the Prelude does not have to know
1839 -- anything about the grotty details of the Handle implementation.
1840 prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
1841 prelCleanupAfterRunAction = unsafePerformIO (newIORef Nothing)
1843 -- used when Hugs invokes top level function
1844 hugsprimRunIO_toplevel :: IO a -> ()
1845 hugsprimRunIO_toplevel m
1846 = protect 5 (fst (unIO composite_action realWorld))
1849 = do writeIORef prelCleanupAfterRunAction Nothing
1851 cleanup_handles <- readIORef prelCleanupAfterRunAction
1852 case cleanup_handles of
1853 Nothing -> return ()
1856 realWorld = error "primRunIO: entered the RealWorld"
1857 protect :: Int -> () -> ()
1861 = primCatch (protect (n-1) comp)
1862 (\e -> fst (unIO (putStr (show e ++ "\n")) realWorld))
1864 unsafeInterleaveIO :: IO a -> IO a
1865 unsafeInterleaveIO m = IO (\ s -> (fst (unIO m s), s))
1867 ------------------------------------------------------------------------------
1868 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
1869 ------------------------------------------------------------------------------
1873 nullAddr = primIntToAddr 0
1874 incAddr a = primIntToAddr (1 + primAddrToInt a)
1875 isNullAddr a = 0 == primAddrToInt a
1877 instance Eq Addr where
1881 instance Ord Addr where
1889 instance Eq Word where
1893 instance Ord Word where
1901 makeStablePtr :: a -> IO (StablePtr a)
1902 makeStablePtr = primMakeStablePtr
1903 deRefStablePtr :: StablePtr a -> IO a
1904 deRefStablePtr = primDeRefStablePtr
1905 freeStablePtr :: StablePtr a -> IO ()
1906 freeStablePtr = primFreeStablePtr
1909 data PrimArray a -- immutable arrays with Int indices
1912 data STRef s a -- mutable variables
1913 data PrimMutableArray s a -- mutable arrays with Int indices
1914 data PrimMutableByteArray s
1916 newSTRef :: a -> ST s (STRef s a)
1917 newSTRef = primNewRef
1918 readSTRef :: STRef s a -> ST s a
1919 readSTRef = primReadRef
1920 writeSTRef :: STRef s a -> a -> ST s ()
1921 writeSTRef = primWriteRef
1923 newtype IORef a = IORef (STRef RealWorld a)
1924 newIORef :: a -> IO (IORef a)
1925 newIORef a = stToIO (primNewRef a >>= \ ref ->return (IORef ref))
1926 readIORef :: IORef a -> IO a
1927 readIORef (IORef ref) = stToIO (primReadRef ref)
1928 writeIORef :: IORef a -> a -> IO ()
1929 writeIORef (IORef ref) a = stToIO (primWriteRef ref a)
1932 ------------------------------------------------------------------------------
1933 -- ThreadId, MVar, concurrency stuff -----------------------------------------
1934 ------------------------------------------------------------------------------
1938 newEmptyMVar :: IO (MVar a)
1939 newEmptyMVar = primNewEmptyMVar
1941 putMVar :: MVar a -> a -> IO ()
1942 putMVar = primPutMVar
1944 takeMVar :: MVar a -> IO a
1946 = IO (\world -> primTakeMVar m cont world)
1948 -- cont :: a -> RealWorld -> (a,RealWorld)
1949 -- where 'a' is as in the top-level signature
1950 cont x world = (x,world)
1952 -- the type of the handwritten BCO (threesome) primTakeMVar is
1953 -- primTakeMVar :: MVar a
1954 -- -> (a -> RealWorld -> (a,RealWorld))
1958 -- primTakeMVar behaves like this:
1960 -- primTakeMVar (MVar# m#) cont world
1961 -- = primTakeMVar_wrk m# cont world
1963 -- primTakeMVar_wrk m# cont world
1964 -- = cont (takeMVar# m#) world
1966 -- primTakeMVar_wrk has the special property that it is
1967 -- restartable by the scheduler, should the MVar be empty.
1969 newMVar :: a -> IO (MVar a)
1971 newEmptyMVar >>= \ mvar ->
1972 putMVar mvar value >>
1975 readMVar :: MVar a -> IO a
1977 takeMVar mvar >>= \ value ->
1978 putMVar mvar value >>
1981 swapMVar :: MVar a -> a -> IO a
1983 takeMVar mvar >>= \ old ->
1987 instance Eq (MVar a) where
1988 m1 == m2 = primSameMVar m1 m2
1993 instance Eq ThreadId where
1994 tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
1996 instance Ord ThreadId where
1998 = let r = primCmpThreadIds tid1 tid2
1999 in if r < 0 then LT else if r > 0 then GT else EQ
2002 forkIO :: IO a -> IO ThreadId
2003 -- Simple version; doesn't catch exceptions in computation
2004 -- forkIO computation
2005 -- = primForkIO (unsafePerformIO computation)
2010 (unIO computation realWorld `primSeq` ())
2011 (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
2014 realWorld = error "primForkIO: entered the RealWorld"
2017 = (unsafePerformIO (putStr (s ++ "\n"))) `seq` x
2019 -- showFloat ------------------------------------------------------------------
2021 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2022 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2023 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2024 showFloat :: (RealFloat a) => a -> ShowS
2026 showEFloat d x = showString (formatRealFloat FFExponent d x)
2027 showFFloat d x = showString (formatRealFloat FFFixed d x)
2028 showGFloat d x = showString (formatRealFloat FFGeneric d x)
2029 showFloat = showGFloat Nothing
2031 -- These are the format types. This type is not exported.
2033 data FFFormat = FFExponent | FFFixed | FFGeneric
2035 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2036 formatRealFloat fmt decs x = s
2040 else if isInfinite x then
2041 if x < 0 then "-Infinity" else "Infinity"
2042 else if x < 0 || isNegativeZero x then
2043 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2045 doFmt fmt (floatToDigits (toInteger base) x)
2047 let ds = map intToDigit is
2050 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2057 [d] -> d : ".0e" ++ show (e-1)
2058 d:ds -> d : '.' : ds ++ 'e':show (e-1)
2060 let dec' = max dec 1 in
2062 [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2064 let (ei, is') = roundTo base (dec'+1) is
2065 d:ds = map intToDigit
2066 (if ei > 0 then init is' else is')
2067 in d:'.':ds ++ "e" ++ show (e-1+ei)
2071 let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2072 f n s "" = f (n-1) (s++"0") ""
2073 f n s (d:ds) = f (n-1) (s++[d]) ds
2078 let dec' = max dec 0 in
2080 let (ei, is') = roundTo base (dec' + e) is
2081 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2082 in (if null ls then "0" else ls) ++
2083 (if null rs then "" else '.' : rs)
2085 let (ei, is') = roundTo base dec'
2086 (replicate (-e) 0 ++ is)
2087 d : ds = map intToDigit
2088 (if ei > 0 then is' else 0:is')
2091 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2092 roundTo base d is = case f d is of
2094 (1, is) -> (1, 1 : is)
2095 where b2 = base `div` 2
2096 f n [] = (0, replicate n 0)
2097 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2099 let (c, ds) = f (d-1) is
2101 in if i' == base then (1, 0:ds) else (0, i':ds)
2103 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2104 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2105 -- This version uses a much slower logarithm estimator. It should be improved.
2107 -- This function returns a list of digits (Ints in [0..base-1]) and an
2110 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2112 floatToDigits _ 0 = ([0], 0)
2113 floatToDigits base x =
2114 let (f0, e0) = decodeFloat x
2115 (minExp0, _) = floatRange x
2118 minExp = minExp0 - p -- the real minimum exponent
2119 -- Haskell requires that f be adjusted so denormalized numbers
2120 -- will have an impossibly low exponent. Adjust for this.
2121 (f, e) = let n = minExp - e0
2122 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2127 if f == b^(p-1) then
2128 (f*be*b*2, 2*b, be*b, b)
2132 if e > minExp && f == b^(p-1) then
2133 (f*b*2, b^(-e+1)*2, b, 1)
2135 (f*2, b^(-e)*2, 1, 1)
2138 if b == 2 && base == 10 then
2139 -- logBase 10 2 is slightly bigger than 3/10 so
2140 -- the following will err on the low side. Ignoring
2141 -- the fraction will make it err even more.
2142 -- Haskell promises that p-1 <= logBase b f < p.
2143 (p - 1 + e0) * 3 `div` 10
2145 ceiling ((log (fromInteger (f+1)) +
2146 fromInt e * log (fromInteger b)) /
2147 log (fromInteger base))
2150 if r + mUp <= expt base n * s then n else fixup (n+1)
2152 if expt base (-n) * (r + mUp) <= s then n
2156 gen ds rn sN mUpN mDnN =
2157 let (dn, rn') = (rn * base) `divMod` sN
2160 in case (rn' < mDnN', rn' + mUpN' > sN) of
2161 (True, False) -> dn : ds
2162 (False, True) -> dn+1 : ds
2163 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2164 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2167 gen [] r (s * expt base k) mUp mDn
2169 let bk = expt base (-k)
2170 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
2171 in (map toInt (reverse rds), k)
2174 -- Exponentiation with a cache for the most common numbers.
2177 expt :: Integer -> Int -> Integer
2179 if base == 2 && n >= minExpt && n <= maxExpt then
2180 expts !! (n-minExpt)
2185 expts = [2^n | n <- [minExpt .. maxExpt]]