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_, sequence, 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,
114 nullAddr, incAddr, isNullAddr,
122 -- Standard value bindings {Prelude} ----------------------------------------
127 infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
129 --infixr 5 : -- this fixity declaration is hard-wired into Hugs
131 infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
136 infixr 0 $, $!, `seq`
138 -- Equality and Ordered classes ---------------------------------------------
141 (==), (/=) :: a -> a -> Bool
143 -- Minimal complete definition: (==) or (/=)
147 class (Eq a) => Ord a where
148 compare :: a -> a -> Ordering
149 (<), (<=), (>=), (>) :: a -> a -> Bool
150 max, min :: a -> a -> a
152 -- Minimal complete definition: (<=) or compare
153 -- using compare can be more efficient for complex types
154 compare x y | x==y = EQ
158 x <= y = compare x y /= GT
159 x < y = compare x y == LT
160 x >= y = compare x y /= LT
161 x > y = compare x y == GT
168 class Bounded a where
169 minBound, maxBound :: a
170 -- Minimal complete definition: All
172 -- Numeric classes ----------------------------------------------------------
174 class (Eq a, Show a) => Num a where
175 (+), (-), (*) :: a -> a -> a
177 abs, signum :: a -> a
178 fromInteger :: Integer -> a
181 -- Minimal complete definition: All, except negate or (-)
183 fromInt = fromIntegral
186 class (Num a, Ord a) => Real a where
187 toRational :: a -> Rational
189 class (Real a, Enum a) => Integral a where
190 quot, rem, div, mod :: a -> a -> a
191 quotRem, divMod :: a -> a -> (a,a)
192 even, odd :: a -> Bool
193 toInteger :: a -> Integer
196 -- Minimal complete definition: quotRem and toInteger
197 n `quot` d = q where (q,r) = quotRem n d
198 n `rem` d = r where (q,r) = quotRem n d
199 n `div` d = q where (q,r) = divMod n d
200 n `mod` d = r where (q,r) = divMod n d
201 divMod n d = if signum r == - signum d then (q-1, r+d) else qr
202 where qr@(q,r) = quotRem n d
203 even n = n `rem` 2 == 0
205 toInt = toInt . toInteger
207 class (Num a) => Fractional a where
210 fromRational :: Rational -> a
211 fromDouble :: Double -> a
213 -- Minimal complete definition: fromRational and ((/) or recip)
215 fromDouble = fromRational . toRational
219 class (Fractional a) => Floating a where
221 exp, log, sqrt :: a -> a
222 (**), logBase :: a -> a -> a
223 sin, cos, tan :: a -> a
224 asin, acos, atan :: a -> a
225 sinh, cosh, tanh :: a -> a
226 asinh, acosh, atanh :: a -> a
228 -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
229 -- asinh, acosh, atanh
230 x ** y = exp (log x * y)
231 logBase x y = log y / log x
233 tan x = sin x / cos x
234 sinh x = (exp x - exp (-x)) / 2
235 cosh x = (exp x + exp (-x)) / 2
236 tanh x = sinh x / cosh x
237 asinh x = log (x + sqrt (x*x + 1))
238 acosh x = log (x + sqrt (x*x - 1))
239 atanh x = (log (1 + x) - log (1 - x)) / 2
241 class (Real a, Fractional a) => RealFrac a where
242 properFraction :: (Integral b) => a -> (b,a)
243 truncate, round :: (Integral b) => a -> b
244 ceiling, floor :: (Integral b) => a -> b
246 -- Minimal complete definition: properFraction
247 truncate x = m where (m,_) = properFraction x
249 round x = let (n,r) = properFraction x
250 m = if r < 0 then n - 1 else n + 1
251 in case signum (abs r - 0.5) of
253 0 -> if even n then n else m
256 ceiling x = if r > 0 then n + 1 else n
257 where (n,r) = properFraction x
259 floor x = if r < 0 then n - 1 else n
260 where (n,r) = properFraction x
262 class (RealFrac a, Floating a) => RealFloat a where
263 floatRadix :: a -> Integer
264 floatDigits :: a -> Int
265 floatRange :: a -> (Int,Int)
266 decodeFloat :: a -> (Integer,Int)
267 encodeFloat :: Integer -> Int -> a
269 significand :: a -> a
270 scaleFloat :: Int -> a -> a
271 isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
275 -- Minimal complete definition: All, except exponent, signficand,
277 exponent x = if m==0 then 0 else n + floatDigits x
278 where (m,n) = decodeFloat x
279 significand x = encodeFloat m (- floatDigits x)
280 where (m,_) = decodeFloat x
281 scaleFloat k x = encodeFloat m (n+k)
282 where (m,n) = decodeFloat x
286 | x<0 && y>0 = pi + atan (y/x)
288 (x<0 && isNegativeZero y) ||
289 (isNegativeZero x && isNegativeZero y)
291 | y==0 && (x<0 || isNegativeZero x)
292 = pi -- must be after the previous test on zero y
293 | x==0 && y==0 = y -- must be after the other double zero tests
294 | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
296 -- Numeric functions --------------------------------------------------------
298 subtract :: Num a => a -> a -> a
301 gcd :: Integral a => a -> a -> a
302 gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
303 gcd x y = gcd' (abs x) (abs y)
305 gcd' x y = gcd' y (x `rem` y)
307 lcm :: (Integral a) => a -> a -> a
310 lcm x y = abs ((x `quot` gcd x y) * y)
312 (^) :: (Num a, Integral b) => a -> b -> a
314 x ^ n | n > 0 = f x (n-1) x
316 f x n y = g x n where
317 g x n | even n = g (x*x) (n`quot`2)
318 | otherwise = f x (n-1) (x*y)
319 _ ^ _ = error "Prelude.^: negative exponent"
321 (^^) :: (Fractional a, Integral b) => a -> b -> a
322 x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
324 fromIntegral :: (Integral a, Num b) => a -> b
325 fromIntegral = fromInteger . toInteger
327 realToFrac :: (Real a, Fractional b) => a -> b
328 realToFrac = fromRational . toRational
330 -- Index and Enumeration classes --------------------------------------------
332 class (Ord a) => Ix a where
333 range :: (a,a) -> [a]
334 index :: (a,a) -> a -> Int
335 inRange :: (a,a) -> a -> Bool
336 rangeSize :: (a,a) -> Int
340 | otherwise = index r u + 1
346 enumFrom :: a -> [a] -- [n..]
347 enumFromThen :: a -> a -> [a] -- [n,m..]
348 enumFromTo :: a -> a -> [a] -- [n..m]
349 enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
351 -- Minimal complete definition: toEnum, fromEnum
352 succ = toEnum . (1+) . fromEnum
353 pred = toEnum . subtract 1 . fromEnum
354 enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
355 enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
357 -- Read and Show classes ------------------------------------------------------
359 type ReadS a = String -> [(a,String)]
360 type ShowS = String -> String
363 readsPrec :: Int -> ReadS a
364 readList :: ReadS [a]
366 -- Minimal complete definition: readsPrec
367 readList = readParen False (\r -> [pr | ("[",s) <- lex r,
369 where readl s = [([],t) | ("]",t) <- lex s] ++
370 [(x:xs,u) | (x,t) <- reads s,
372 readl' s = [([],t) | ("]",t) <- lex s] ++
373 [(x:xs,v) | (",",t) <- lex s,
379 showsPrec :: Int -> a -> ShowS
380 showList :: [a] -> ShowS
382 -- Minimal complete definition: show or showsPrec
383 show x = showsPrec 0 x ""
384 showsPrec _ x s = show x ++ s
385 showList [] = showString "[]"
386 showList (x:xs) = showChar '[' . shows x . showl xs
387 where showl [] = showChar ']'
388 showl (x:xs) = showChar ',' . shows x . showl xs
390 -- Monad classes ------------------------------------------------------------
392 class Functor f where
393 fmap :: (a -> b) -> (f a -> f b)
397 (>>=) :: m a -> (a -> m b) -> m b
398 (>>) :: m a -> m b -> m b
399 fail :: String -> m a
401 -- Minimal complete definition: (>>=), return
402 p >> q = p >>= \ _ -> q
405 sequence :: Monad m => [m a] -> m [a]
406 sequence [] = return []
407 sequence (c:cs) = do x <- c
411 sequence_ :: Monad m => [m a] -> m ()
412 sequence_ = foldr (>>) (return ())
414 mapM :: Monad m => (a -> m b) -> [a] -> m [b]
415 mapM f = sequence . map f
417 mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
418 mapM_ f = sequence_ . map f
420 (=<<) :: Monad m => (a -> m b) -> m a -> m b
423 -- Evaluation and strictness ------------------------------------------------
426 seq x y = primSeq x y
428 ($!) :: (a -> b) -> a -> b
429 f $! x = x `primSeq` f x
431 -- Trivial type -------------------------------------------------------------
433 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
438 instance Ord () where
444 inRange ((),()) () = True
446 instance Enum () where
450 enumFromThen () () = [()]
452 instance Read () where
453 readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
456 instance Show () where
457 showsPrec p () = showString "()"
459 instance Bounded () where
463 -- Boolean type -------------------------------------------------------------
465 data Bool = False | True
466 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
468 (&&), (||) :: Bool -> Bool -> Bool
481 -- Character type -----------------------------------------------------------
483 data Char -- builtin datatype of ISO Latin characters
484 type String = [Char] -- strings are lists of characters
486 instance Eq Char where (==) = primEqChar
487 instance Ord Char where (<=) = primLeChar
489 instance Enum Char where
490 toEnum = primIntToChar
491 fromEnum = primCharToInt
492 enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
493 enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
494 where lastChar = if d < c then minBound else maxBound
496 instance Ix Char where
497 range (c,c') = [c..c']
499 | inRange b ci = fromEnum ci - fromEnum c
500 | otherwise = error "Ix.index: Index out of range."
501 inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
502 where i = fromEnum ci
504 instance Read Char where
505 readsPrec p = readParen False
506 (\r -> [(c,t) | ('\'':s,t) <- lex r,
507 (c,"\'") <- readLitChar s ])
508 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
510 where readl ('"':s) = [("",s)]
511 readl ('\\':'&':s) = readl s
512 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
514 instance Show Char where
515 showsPrec p '\'' = showString "'\\''"
516 showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
518 showList cs = showChar '"' . showl cs
519 where showl "" = showChar '"'
520 showl ('"':cs) = showString "\\\"" . showl cs
521 showl (c:cs) = showLitChar c . showl cs
523 instance Bounded Char where
527 isAscii, isControl, isPrint, isSpace :: Char -> Bool
528 isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
530 isAscii c = fromEnum c < 128
531 isControl c = c < ' ' || c == '\DEL'
532 isPrint c = c >= ' ' && c <= '~'
533 isSpace c = c == ' ' || c == '\t' || c == '\n' ||
534 c == '\r' || c == '\f' || c == '\v'
535 isUpper c = c >= 'A' && c <= 'Z'
536 isLower c = c >= 'a' && c <= 'z'
537 isAlpha c = isUpper c || isLower c
538 isDigit c = c >= '0' && c <= '9'
539 isAlphaNum c = isAlpha c || isDigit c
541 -- Digit conversion operations
542 digitToInt :: Char -> Int
544 | isDigit c = fromEnum c - fromEnum '0'
545 | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
546 | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
547 | otherwise = error "Char.digitToInt: not a digit"
549 intToDigit :: Int -> Char
551 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
552 | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
553 | otherwise = error "Char.intToDigit: not a digit"
555 toUpper, toLower :: Char -> Char
556 toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
559 toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
568 -- Maybe type ---------------------------------------------------------------
570 data Maybe a = Nothing | Just a
571 deriving (Eq, Ord, Read, Show)
573 maybe :: b -> (a -> b) -> Maybe a -> b
574 maybe n f Nothing = n
575 maybe n f (Just x) = f x
577 instance Functor Maybe where
578 fmap f Nothing = Nothing
579 fmap f (Just x) = Just (f x)
581 instance Monad Maybe where
583 Nothing >>= k = Nothing
587 -- Either type --------------------------------------------------------------
589 data Either a b = Left a | Right b
590 deriving (Eq, Ord, Read, Show)
592 either :: (a -> c) -> (b -> c) -> Either a b -> c
593 either l r (Left x) = l x
594 either l r (Right y) = r y
596 -- Ordering type ------------------------------------------------------------
598 data Ordering = LT | EQ | GT
599 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
601 -- Lists --------------------------------------------------------------------
603 --data [a] = [] | a : [a] deriving (Eq, Ord)
605 instance Eq a => Eq [a] where
607 (x:xs) == (y:ys) = x==y && xs==ys
610 instance Ord a => Ord [a] where
611 compare [] (_:_) = LT
613 compare (_:_) [] = GT
614 compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
616 instance Functor [] where
619 instance Monad [ ] where
620 (x:xs) >>= f = f x ++ (xs >>= f)
625 instance Read a => Read [a] where
626 readsPrec p = readList
628 instance Show a => Show [a] where
629 showsPrec p = showList
631 -- Tuples -------------------------------------------------------------------
633 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
636 -- Standard Integral types --------------------------------------------------
638 data Int -- builtin datatype of fixed size integers
639 data Integer -- builtin datatype of arbitrary size integers
641 instance Eq Integer where
642 (==) x y = primCompareInteger x y == 0
644 instance Ord Integer where
645 compare x y = case primCompareInteger x y of
650 instance Eq Int where
654 instance Ord Int where
660 instance Num Int where
663 negate = primNegateInt
667 fromInteger = primIntegerToInt
670 instance Bounded Int where
671 minBound = primMinInt
672 maxBound = primMaxInt
674 instance Num Integer where
675 (+) = primPlusInteger
676 (-) = primMinusInteger
677 negate = primNegateInteger
678 (*) = primTimesInteger
682 fromInt = primIntToInteger
684 absReal x | x >= 0 = x
687 signumReal x | x == 0 = 0
691 instance Real Int where
692 toRational x = toInteger x % 1
694 instance Real Integer where
697 instance Integral Int where
698 quotRem = primQuotRemInt
699 toInteger = primIntToInteger
702 instance Integral Integer where
703 quotRem = primQuotRemInteger
704 --divMod = primDivModInteger
706 toInt = primIntegerToInt
708 instance Ix Int where
711 | inRange b i = i - m
712 | otherwise = error "index: Index out of range"
713 inRange (m,n) i = m <= i && i <= n
715 instance Ix Integer where
718 | inRange b i = fromInteger (i - m)
719 | otherwise = error "index: Index out of range"
720 inRange (m,n) i = m <= i && i <= n
722 instance Enum Int where
725 enumFrom = numericEnumFrom
726 enumFromTo = numericEnumFromTo
727 enumFromThen = numericEnumFromThen
728 enumFromThenTo = numericEnumFromThenTo
730 instance Enum Integer where
731 toEnum = primIntToInteger
732 fromEnum = primIntegerToInt
733 enumFrom = numericEnumFrom
734 enumFromTo = numericEnumFromTo
735 enumFromThen = numericEnumFromThen
736 enumFromThenTo = numericEnumFromThenTo
738 numericEnumFrom :: Real a => a -> [a]
739 numericEnumFromThen :: Real a => a -> a -> [a]
740 numericEnumFromTo :: Real a => a -> a -> [a]
741 numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
742 numericEnumFrom n = n : (numericEnumFrom $! (n+1))
743 numericEnumFromThen n m = iterate ((m-n)+) n
744 numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
745 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
746 where p | n' >= n = (<= m)
749 instance Read Int where
750 readsPrec p = readSigned readDec
752 instance Show Int where
754 | n == minBound = showSigned showInt p (toInteger n)
755 | otherwise = showSigned showInt p n
757 instance Read Integer where
758 readsPrec p = readSigned readDec
760 instance Show Integer where
761 showsPrec = showSigned showInt
764 -- Standard Floating types --------------------------------------------------
766 data Float -- builtin datatype of single precision floating point numbers
767 data Double -- builtin datatype of double precision floating point numbers
769 instance Eq Float where
773 instance Ord Float where
779 instance Num Float where
782 negate = primNegateFloat
786 fromInteger = primIntegerToFloat
787 fromInt = primIntToFloat
791 instance Eq Double where
795 instance Ord Double where
801 instance Num Double where
803 (-) = primMinusDouble
804 negate = primNegateDouble
805 (*) = primTimesDouble
808 fromInteger = primIntegerToDouble
809 fromInt = primIntToDouble
813 instance Real Float where
814 toRational = floatToRational
816 instance Real Double where
817 toRational = doubleToRational
819 -- Calls to these functions are optimised when passed as arguments to
821 floatToRational :: Float -> Rational
822 doubleToRational :: Double -> Rational
823 floatToRational x = realFloatToRational x
824 doubleToRational x = realFloatToRational x
826 realFloatToRational x = (m%1)*(b%1)^^n
827 where (m,n) = decodeFloat x
830 instance Fractional Float where
831 (/) = primDivideFloat
832 fromRational = rationalToRealFloat
833 fromDouble = primDoubleToFloat
836 instance Fractional Double where
837 (/) = primDivideDouble
838 fromRational = rationalToRealFloat
841 rationalToRealFloat x = x'
843 f e = if e' == e then y else f e'
844 where y = encodeFloat (round (x * (1%b)^^e)) e
845 (_,e') = decodeFloat y
846 (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
847 / fromInteger (denominator x))
850 instance Floating Float where
851 pi = 3.14159265358979323846
862 instance Floating Double where
863 pi = 3.14159265358979323846
866 sqrt = primSqrtDouble
870 asin = primAsinDouble
871 acos = primAcosDouble
872 atan = primAtanDouble
874 instance RealFrac Float where
875 properFraction = floatProperFraction
877 instance RealFrac Double where
878 properFraction = floatProperFraction
880 floatProperFraction x
881 | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
882 | otherwise = (fromInteger w, encodeFloat r n)
883 where (m,n) = decodeFloat x
885 (w,r) = quotRem m (b^(-n))
887 instance RealFloat Float where
888 floatRadix _ = toInteger primRadixFloat
889 floatDigits _ = primDigitsFloat
890 floatRange _ = (primMinExpFloat,primMaxExpFloat)
891 encodeFloat = primEncodeFloatZ
892 decodeFloat = primDecodeFloatZ
893 isNaN = primIsNaNFloat
894 isInfinite = primIsInfiniteFloat
895 isDenormalized= primIsDenormalizedFloat
896 isNegativeZero= primIsNegativeZeroFloat
897 isIEEE = const primIsIEEEFloat
899 instance RealFloat Double where
900 floatRadix _ = toInteger primRadixDouble
901 floatDigits _ = primDigitsDouble
902 floatRange _ = (primMinExpDouble,primMaxExpDouble)
903 encodeFloat = primEncodeDoubleZ
904 decodeFloat = primDecodeDoubleZ
905 isNaN = primIsNaNDouble
906 isInfinite = primIsInfiniteDouble
907 isDenormalized= primIsDenormalizedDouble
908 isNegativeZero= primIsNegativeZeroDouble
909 isIEEE = const primIsIEEEDouble
911 instance Enum Float where
912 toEnum = primIntToFloat
914 enumFrom = numericEnumFrom
915 enumFromThen = numericEnumFromThen
916 enumFromTo n m = numericEnumFromTo n (m+1/2)
917 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
919 instance Enum Double where
920 toEnum = primIntToDouble
922 enumFrom = numericEnumFrom
923 enumFromThen = numericEnumFromThen
924 enumFromTo n m = numericEnumFromTo n (m+1/2)
925 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
927 instance Read Float where
928 readsPrec p = readSigned readFloat
930 instance Show Float where
931 showsPrec p = showSigned showFloat p
933 instance Read Double where
934 readsPrec p = readSigned readFloat
936 instance Show Double where
937 showsPrec p = showSigned showFloat p
940 -- Some standard functions --------------------------------------------------
948 curry :: ((a,b) -> c) -> (a -> b -> c)
949 curry f x y = f (x,y)
951 uncurry :: (a -> b -> c) -> ((a,b) -> c)
952 uncurry f p = f (fst p) (snd p)
960 (.) :: (b -> c) -> (a -> b) -> (a -> c)
963 flip :: (a -> b -> c) -> b -> a -> c
966 ($) :: (a -> b) -> a -> b
969 until :: (a -> Bool) -> (a -> a) -> a -> a
970 until p f x = if p x then x else until p f (f x)
972 asTypeOf :: a -> a -> a
976 error msg = primRaise (ErrorCall msg)
979 undefined | False = undefined
981 -- Standard functions on rational numbers {PreludeRatio} --------------------
983 data Integral a => Ratio a = a :% a deriving (Eq)
984 type Rational = Ratio Integer
986 (%) :: Integral a => a -> a -> Ratio a
987 x % y = reduce (x * signum y) (abs y)
989 reduce :: Integral a => a -> a -> Ratio a
990 reduce x y | y == 0 = error "Ratio.%: zero denominator"
991 | otherwise = (x `quot` d) :% (y `quot` d)
994 numerator, denominator :: Integral a => Ratio a -> a
995 numerator (x :% y) = x
996 denominator (x :% y) = y
998 instance Integral a => Ord (Ratio a) where
999 compare (x:%y) (x':%y') = compare (x*y') (x'*y)
1001 instance Integral a => Num (Ratio a) where
1002 (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
1003 (x:%y) * (x':%y') = reduce (x*x') (y*y')
1004 negate (x :% y) = negate x :% y
1005 abs (x :% y) = abs x :% y
1006 signum (x :% y) = signum x :% 1
1007 fromInteger x = fromInteger x :% 1
1008 fromInt = intToRatio
1010 -- Hugs optimises code of the form fromRational (intToRatio x)
1011 intToRatio :: Integral a => Int -> Ratio a
1012 intToRatio x = fromInt x :% 1
1014 instance Integral a => Real (Ratio a) where
1015 toRational (x:%y) = toInteger x :% toInteger y
1017 instance Integral a => Fractional (Ratio a) where
1018 (x:%y) / (x':%y') = (x*y') % (y*x')
1019 recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
1020 fromRational (x:%y) = fromInteger x :% fromInteger y
1021 fromDouble = doubleToRatio
1023 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1024 doubleToRatio :: Integral a => Double -> Ratio a
1026 | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
1027 | otherwise = fromInteger m % (fromInteger b ^ (-n))
1028 where (m,n) = decodeFloat x
1031 instance Integral a => RealFrac (Ratio a) where
1032 properFraction (x:%y) = (fromIntegral q, r:%y)
1033 where (q,r) = quotRem x y
1035 instance Integral a => Enum (Ratio a) where
1038 enumFrom = numericEnumFrom
1039 enumFromThen = numericEnumFromThen
1041 instance (Read a, Integral a) => Read (Ratio a) where
1042 readsPrec p = readParen (p > 7)
1043 (\r -> [(x%y,u) | (x,s) <- reads r,
1047 instance Integral a => Show (Ratio a) where
1048 showsPrec p (x:%y) = showParen (p > 7)
1049 (shows x . showString " % " . shows y)
1051 approxRational :: RealFrac a => a -> a -> Rational
1052 approxRational x eps = simplest (x-eps) (x+eps)
1053 where simplest x y | y < x = simplest y x
1055 | x > 0 = simplest' n d n' d'
1056 | y < 0 = - simplest' (-n') d' (-n) d
1057 | otherwise = 0 :% 1
1058 where xr@(n:%d) = toRational x
1059 (n':%d') = toRational y
1060 simplest' n d n' d' -- assumes 0 < n%d < n'%d'
1062 | q /= q' = (q+1) :% 1
1063 | otherwise = (q*n''+d'') :% n''
1064 where (q,r) = quotRem n d
1065 (q',r') = quotRem n' d'
1066 (n'':%d'') = simplest' d' r' d r
1068 -- Standard list functions {PreludeList} ------------------------------------
1075 last (_:xs) = last xs
1082 init (x:xs) = x : init xs
1088 (++) :: [a] -> [a] -> [a]
1090 (x:xs) ++ ys = x : (xs ++ ys)
1092 map :: (a -> b) -> [a] -> [b]
1093 --map f xs = [ f x | x <- xs ]
1095 map f (x:xs) = f x : map f xs
1098 filter :: (a -> Bool) -> [a] -> [a]
1099 --filter p xs = [ x | x <- xs, p x ]
1101 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1104 concat :: [[a]] -> [a]
1105 --concat = foldr (++) []
1107 concat (xs:xss) = xs ++ concat xss
1109 length :: [a] -> Int
1110 --length = foldl' (\n _ -> n + 1) 0
1112 length (x:xs) = let n = length xs in primSeq n (1+n)
1114 (!!) :: [b] -> Int -> b
1116 (_:xs) !! n | n>0 = xs !! (n-1)
1117 (_:_) !! _ = error "Prelude.!!: negative index"
1118 [] !! _ = error "Prelude.!!: index too large"
1120 foldl :: (a -> b -> a) -> a -> [b] -> a
1122 foldl f z (x:xs) = foldl f (f z x) xs
1124 foldl' :: (a -> b -> a) -> a -> [b] -> a
1126 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1128 foldl1 :: (a -> a -> a) -> [a] -> a
1129 foldl1 f (x:xs) = foldl f x xs
1131 scanl :: (a -> b -> a) -> a -> [b] -> [a]
1132 scanl f q xs = q : (case xs of
1134 x:xs -> scanl f (f q x) xs)
1136 scanl1 :: (a -> a -> a) -> [a] -> [a]
1137 scanl1 f (x:xs) = scanl f x xs
1139 foldr :: (a -> b -> b) -> b -> [a] -> b
1141 foldr f z (x:xs) = f x (foldr f z xs)
1143 foldr1 :: (a -> a -> a) -> [a] -> a
1145 foldr1 f (x:xs) = f x (foldr1 f xs)
1147 scanr :: (a -> b -> b) -> b -> [a] -> [b]
1148 scanr f q0 [] = [q0]
1149 scanr f q0 (x:xs) = f x q : qs
1150 where qs@(q:_) = scanr f q0 xs
1152 scanr1 :: (a -> a -> a) -> [a] -> [a]
1154 scanr1 f (x:xs) = f x q : qs
1155 where qs@(q:_) = scanr1 f xs
1157 iterate :: (a -> a) -> a -> [a]
1158 iterate f x = x : iterate f (f x)
1161 repeat x = xs where xs = x:xs
1163 replicate :: Int -> a -> [a]
1164 replicate n x = take n (repeat x)
1167 cycle [] = error "Prelude.cycle: empty list"
1168 cycle xs = xs' where xs'=xs++xs'
1170 take :: Int -> [a] -> [a]
1173 take n (x:xs) | n>0 = x : take (n-1) xs
1174 take _ _ = error "Prelude.take: negative argument"
1176 drop :: Int -> [a] -> [a]
1179 drop n (_:xs) | n>0 = drop (n-1) xs
1180 drop _ _ = error "Prelude.drop: negative argument"
1182 splitAt :: Int -> [a] -> ([a], [a])
1183 splitAt 0 xs = ([],xs)
1184 splitAt _ [] = ([],[])
1185 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1186 splitAt _ _ = error "Prelude.splitAt: negative argument"
1188 takeWhile :: (a -> Bool) -> [a] -> [a]
1191 | p x = x : takeWhile p xs
1194 dropWhile :: (a -> Bool) -> [a] -> [a]
1196 dropWhile p xs@(x:xs')
1197 | p x = dropWhile p xs'
1200 span, break :: (a -> Bool) -> [a] -> ([a],[a])
1204 | otherwise = ([],xs)
1205 where (ys,zs) = span p xs'
1206 break p = span (not . p)
1208 lines :: String -> [String]
1210 lines s = let (l,s') = break ('\n'==) s
1211 in l : case s' of [] -> []
1212 (_:s'') -> lines s''
1214 words :: String -> [String]
1215 words s = case dropWhile isSpace s of
1218 where (w,s'') = break isSpace s'
1220 unlines :: [String] -> String
1221 unlines = concatMap (\l -> l ++ "\n")
1223 unwords :: [String] -> String
1225 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1227 reverse :: [a] -> [a]
1228 --reverse = foldl (flip (:)) []
1229 reverse xs = ri [] xs
1230 where ri acc [] = acc
1231 ri acc (x:xs) = ri (x:acc) xs
1233 and, or :: [Bool] -> Bool
1234 --and = foldr (&&) True
1235 --or = foldr (||) False
1237 and (x:xs) = if x then and xs else x
1239 or (x:xs) = if x then x else or xs
1241 any, all :: (a -> Bool) -> [a] -> Bool
1242 --any p = or . map p
1243 --all p = and . map p
1245 any p (x:xs) = if p x then True else any p xs
1247 all p (x:xs) = if p x then all p xs else False
1249 elem, notElem :: Eq a => a -> [a] -> Bool
1251 --notElem = all . (/=)
1253 elem x (y:ys) = if x==y then True else elem x ys
1255 notElem x (y:ys) = if x==y then False else notElem x ys
1257 lookup :: Eq a => a -> [(a,b)] -> Maybe b
1258 lookup k [] = Nothing
1259 lookup k ((x,y):xys)
1261 | otherwise = lookup k xys
1263 sum, product :: Num a => [a] -> a
1265 product = foldl' (*) 1
1267 maximum, minimum :: Ord a => [a] -> a
1268 maximum = foldl1 max
1269 minimum = foldl1 min
1271 concatMap :: (a -> [b]) -> [a] -> [b]
1272 concatMap f = concat . map f
1274 zip :: [a] -> [b] -> [(a,b)]
1275 zip = zipWith (\a b -> (a,b))
1277 zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
1278 zip3 = zipWith3 (\a b c -> (a,b,c))
1280 zipWith :: (a->b->c) -> [a]->[b]->[c]
1281 zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
1284 zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1285 zipWith3 z (a:as) (b:bs) (c:cs)
1286 = z a b c : zipWith3 z as bs cs
1287 zipWith3 _ _ _ _ = []
1289 unzip :: [(a,b)] -> ([a],[b])
1290 unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1292 unzip3 :: [(a,b,c)] -> ([a],[b],[c])
1293 unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1296 -- PreludeText ----------------------------------------------------------------
1298 reads :: Read a => ReadS a
1301 shows :: Show a => a -> ShowS
1304 read :: Read a => String -> a
1305 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1307 [] -> error "Prelude.read: no parse"
1308 _ -> error "Prelude.read: ambiguous parse"
1310 showChar :: Char -> ShowS
1313 showString :: String -> ShowS
1316 showParen :: Bool -> ShowS -> ShowS
1317 showParen b p = if b then showChar '(' . p . showChar ')' else p
1319 showField :: Show a => String -> a -> ShowS
1320 showField m v = showString m . showChar '=' . shows v
1322 readParen :: Bool -> ReadS a -> ReadS a
1323 readParen b g = if b then mandatory else optional
1324 where optional r = g r ++ mandatory r
1325 mandatory r = [(x,u) | ("(",s) <- lex r,
1326 (x,t) <- optional s,
1330 readField :: Read a => String -> ReadS a
1331 readField m s0 = [ r | (t, s1) <- lex s0, t == m,
1337 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1338 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1340 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1342 lexString ('"':s) = [("\"",s)]
1343 lexString s = [(ch++str, u)
1344 | (ch,t) <- lexStrItem s,
1345 (str,u) <- lexString t ]
1347 lexStrItem ('\\':'&':s) = [("\\&",s)]
1348 lexStrItem ('\\':c:s) | isSpace c
1349 = [("",t) | '\\':t <- [dropWhile isSpace s]]
1350 lexStrItem s = lexLitChar s
1352 lex (c:s) | isSingle c = [([c],s)]
1353 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
1354 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
1355 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
1356 (fe,t) <- lexFracExp s ]
1357 | otherwise = [] -- bad character
1359 isSingle c = c `elem` ",;()[]{}_`"
1360 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1361 isIdChar c = isAlphaNum c || c `elem` "_'"
1363 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1365 lexFracExp s = [("",s)]
1367 lexExp (e:s) | e `elem` "eE"
1368 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
1369 (ds,u) <- lexDigits t] ++
1370 [(e:ds,t) | (ds,t) <- lexDigits s]
1373 lexDigits :: ReadS String
1374 lexDigits = nonnull isDigit
1376 nonnull :: (Char -> Bool) -> ReadS String
1377 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1379 lexLitChar :: ReadS String
1380 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1382 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- "
1383 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
1384 lexEsc s@(d:_) | isDigit d = lexDigits s
1385 lexEsc s@(c:_) | isUpper c
1386 = let table = ('\DEL',"DEL") : asciiTab
1387 in case [(mne,s') | (c, mne) <- table,
1388 ([],s') <- [lexmatch mne s]]
1392 lexLitChar (c:s) = [([c],s)]
1395 isOctDigit c = c >= '0' && c <= '7'
1396 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
1397 || c >= 'a' && c <= 'f'
1399 lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
1400 lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
1401 lexmatch xs ys = (xs,ys)
1403 asciiTab = zip ['\NUL'..' ']
1404 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1405 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
1406 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1407 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
1410 readLitChar :: ReadS Char
1411 readLitChar ('\\':s) = readEsc s
1413 readEsc ('a':s) = [('\a',s)]
1414 readEsc ('b':s) = [('\b',s)]
1415 readEsc ('f':s) = [('\f',s)]
1416 readEsc ('n':s) = [('\n',s)]
1417 readEsc ('r':s) = [('\r',s)]
1418 readEsc ('t':s) = [('\t',s)]
1419 readEsc ('v':s) = [('\v',s)]
1420 readEsc ('\\':s) = [('\\',s)]
1421 readEsc ('"':s) = [('"',s)]
1422 readEsc ('\'':s) = [('\'',s)]
1423 readEsc ('^':c:s) | c >= '@' && c <= '_'
1424 = [(toEnum (fromEnum c - fromEnum '@'), s)]
1425 readEsc s@(d:_) | isDigit d
1426 = [(toEnum n, t) | (n,t) <- readDec s]
1427 readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
1428 readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
1429 readEsc s@(c:_) | isUpper c
1430 = let table = ('\DEL',"DEL") : asciiTab
1431 in case [(c,s') | (c, mne) <- table,
1432 ([],s') <- [lexmatch mne s]]
1436 readLitChar (c:s) = [(c,s)]
1438 showLitChar :: Char -> ShowS
1439 showLitChar c | c > '\DEL' = showChar '\\' .
1440 protectEsc isDigit (shows (fromEnum c))
1441 showLitChar '\DEL' = showString "\\DEL"
1442 showLitChar '\\' = showString "\\\\"
1443 showLitChar c | c >= ' ' = showChar c
1444 showLitChar '\a' = showString "\\a"
1445 showLitChar '\b' = showString "\\b"
1446 showLitChar '\f' = showString "\\f"
1447 showLitChar '\n' = showString "\\n"
1448 showLitChar '\r' = showString "\\r"
1449 showLitChar '\t' = showString "\\t"
1450 showLitChar '\v' = showString "\\v"
1451 showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
1452 showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
1454 protectEsc p f = f . cont
1455 where cont s@(c:_) | p c = "\\&" ++ s
1458 -- Unsigned readers for various bases
1459 readDec, readOct, readHex :: Integral a => ReadS a
1460 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1461 readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1462 readHex = readInt 16 isHexDigit hex
1463 where hex d = fromEnum d -
1466 else fromEnum (if isUpper d then 'A' else 'a') - 10)
1468 -- readInt reads a string of digits using an arbitrary base.
1469 -- Leading minus signs must be handled elsewhere.
1471 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1472 readInt radix isDig digToInt s =
1473 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1474 | (ds,r) <- nonnull isDig s ]
1476 -- showInt is used for positive numbers only
1477 showInt :: Integral a => a -> ShowS
1480 = error "Numeric.showInt: can't show negative numbers"
1483 = let (n',d) = quotRem n 10
1484 r' = toEnum (fromEnum '0' + fromIntegral d) : r
1485 in if n' == 0 then r' else showInt n' r'
1487 = case quotRem n 10 of { (n',d) ->
1488 let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1489 in if n' == 0 then r' else showInt n' r'
1493 readSigned:: Real a => ReadS a -> ReadS a
1494 readSigned readPos = readParen False read'
1495 where read' r = read'' r ++
1496 [(-x,t) | ("-",s) <- lex r,
1498 read'' r = [(n,s) | (str,s) <- lex r,
1499 (n,"") <- readPos str]
1501 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1502 showSigned showPos p x = if x < 0 then showParen (p > 6)
1503 (showChar '-' . showPos (-x))
1506 readFloat :: RealFloat a => ReadS a
1507 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1509 where readFix r = [(read (ds++ds'), length ds', t)
1510 | (ds, s) <- lexDigits r
1511 , (ds',t) <- lexFrac s ]
1513 lexFrac ('.':s) = lexDigits s
1514 lexFrac s = [("",s)]
1516 readExp (e:s) | e `elem` "eE" = readExp' s
1519 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1520 readExp' ('+':s) = readDec s
1521 readExp' s = readDec s
1524 -- Hooks for primitives: -----------------------------------------------------
1525 -- Do not mess with these!
1527 primCompAux :: Ord a => a -> a -> Ordering -> Ordering
1528 primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1530 primPmInt :: Num a => Int -> a -> Bool
1531 primPmInt n x = fromInt n == x
1533 primPmInteger :: Num a => Integer -> a -> Bool
1534 primPmInteger n x = fromInteger n == x
1536 primPmDouble :: Fractional a => Double -> a -> Bool
1537 primPmDouble n x = fromDouble n == x
1539 -- ToDo: make the message more informative.
1541 primPmFail = error "Pattern Match Failure"
1543 -- used in desugaring Foreign functions
1544 primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1547 primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1548 primCreateAdjThunk fun typestr callconv
1549 = do sp <- makeStablePtr fun
1550 p <- copy_String_to_cstring typestr -- is never freed
1551 a <- primCreateAdjThunkARCH sp p callconv
1554 -- The following primitives are only needed if (n+k) patterns are enabled:
1555 primPmNpk :: Integral a => Int -> a -> Maybe a
1556 primPmNpk n x = if n'<=x then Just (x-n') else Nothing
1557 where n' = fromInt n
1559 primPmSub :: Integral a => Int -> a -> a
1560 primPmSub n x = x - fromInt n
1562 -- Unpack strings generated by the Hugs code generator.
1563 -- Strings can contain \0 provided they're coded right.
1565 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1567 primUnpackString :: Addr -> String
1568 primUnpackString a = unpack 0
1570 -- The following decoding is based on evalString in the old machine.c
1573 | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1574 then '\\' : unpack (i+2)
1575 else '\0' : unpack (i+2)
1576 | otherwise = c : unpack (i+1)
1578 c = primIndexCharOffAddr a i
1581 -- Monadic I/O: --------------------------------------------------------------
1583 type FilePath = String
1585 --data IOError = ...
1586 --instance Eq IOError ...
1587 --instance Show IOError ...
1589 data IOError = IOError String
1590 instance Show IOError where
1591 showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1593 ioError :: IOError -> IO a
1594 ioError (IOError s) = primRaise (IOExcept s)
1596 userError :: String -> IOError
1597 userError s = primRaise (ErrorCall s)
1599 catch :: IO a -> (IOError -> IO a) -> IO a
1601 = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
1603 e2ioe (IOExcept s) = IOError s
1604 e2ioe other = IOError (show other)
1606 putChar :: Char -> IO ()
1607 putChar c = nh_stdout >>= \h -> nh_write h c
1609 putStr :: String -> IO ()
1610 putStr s = nh_stdout >>= \h ->
1611 let loop [] = nh_flush h
1612 loop (c:cs) = nh_write h c >> loop cs
1615 putStrLn :: String -> IO ()
1616 putStrLn s = do { putStr s; putChar '\n' }
1618 print :: Show a => a -> IO ()
1619 print = putStrLn . show
1622 getChar = unsafeInterleaveIO (
1624 nh_read h >>= \ci ->
1625 return (primIntToChar ci)
1628 getLine :: IO String
1629 getLine = do c <- getChar
1630 if c=='\n' then return ""
1631 else do cs <- getLine
1634 getContents :: IO String
1635 getContents = nh_stdin >>= \h -> readfromhandle h
1637 interact :: (String -> String) -> IO ()
1638 interact f = getContents >>= (putStr . f)
1640 readFile :: FilePath -> IO String
1642 = copy_String_to_cstring fname >>= \ptr ->
1643 nh_open ptr 0 >>= \h ->
1645 nh_errno >>= \errno ->
1646 if (isNullAddr h || errno /= 0)
1647 then (ioError.IOError) ("readFile: can't open file " ++ fname)
1648 else readfromhandle h
1650 writeFile :: FilePath -> String -> IO ()
1651 writeFile fname contents
1652 = copy_String_to_cstring fname >>= \ptr ->
1653 nh_open ptr 1 >>= \h ->
1655 nh_errno >>= \errno ->
1656 if (isNullAddr h || errno /= 0)
1657 then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1658 else writetohandle fname h contents
1660 appendFile :: FilePath -> String -> IO ()
1661 appendFile fname contents
1662 = copy_String_to_cstring fname >>= \ptr ->
1663 nh_open ptr 2 >>= \h ->
1665 nh_errno >>= \errno ->
1666 if (isNullAddr h || errno /= 0)
1667 then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1668 else writetohandle fname h contents
1671 -- raises an exception instead of an error
1672 readIO :: Read a => String -> IO a
1673 readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1675 [] -> ioError (userError "PreludeIO.readIO: no parse")
1676 _ -> ioError (userError
1677 "PreludeIO.readIO: ambiguous parse")
1679 readLn :: Read a => IO a
1680 readLn = do l <- getLine
1685 -- End of Hugs standard prelude ----------------------------------------------
1691 instance Show Exception where
1692 showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1693 showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
1695 data IOResult = IOResult deriving (Show)
1697 type FILE_STAR = Addr -- FILE *
1699 foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR
1700 foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
1701 foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
1702 foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Char -> IO ()
1703 foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int
1704 foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR
1705 foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO ()
1706 foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO ()
1707 foreign import "nHandle" "nh_errno" nh_errno :: IO Int
1709 foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
1710 foreign import "nHandle" "nh_free" nh_free :: Addr -> IO ()
1711 foreign import "nHandle" "nh_store" nh_store :: Addr -> Char -> IO ()
1712 foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Char
1713 foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
1715 copy_String_to_cstring :: String -> IO Addr
1716 copy_String_to_cstring s
1717 = nh_malloc (1 + length s) >>= \ptr0 ->
1718 let loop ptr [] = nh_store ptr (chr 0) >> return ptr0
1719 loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs
1722 then error "copy_String_to_cstring: malloc failed"
1725 copy_cstring_to_String :: Addr -> IO String
1726 copy_cstring_to_String ptr
1727 = nh_load ptr >>= \ci ->
1730 else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1733 readfromhandle :: FILE_STAR -> IO String
1735 = unsafeInterleaveIO (
1736 nh_read h >>= \ci ->
1737 if ci == -1 {-EOF-} then return "" else
1738 readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1741 writetohandle :: String -> FILE_STAR -> String -> IO ()
1742 writetohandle fname h []
1744 nh_errno >>= \errno ->
1747 else error ( "writeFile/appendFile: error closing file " ++ fname)
1748 writetohandle fname h (c:cs)
1749 = nh_write h c >> writetohandle fname h cs
1751 primGetRawArgs :: IO [String]
1753 = primGetArgc >>= \argc ->
1754 sequence (map get_one_arg [0 .. argc-1])
1756 get_one_arg :: Int -> IO String
1758 = primGetArgv argno >>= \a ->
1759 copy_cstring_to_String a
1761 primGetEnv :: String -> IO String
1763 = copy_String_to_cstring v >>= \ptr ->
1764 nh_getenv ptr >>= \ptr2 ->
1769 copy_cstring_to_String ptr2 >>= \result ->
1773 ------------------------------------------------------------------------------
1774 -- ST, IO --------------------------------------------------------------------
1775 ------------------------------------------------------------------------------
1777 newtype ST s a = ST (s -> (a,s))
1780 type IO a = ST RealWorld a
1783 --primRunST :: (forall s. ST s a) -> a
1784 primRunST :: ST RealWorld a -> a
1785 primRunST m = fst (unST m theWorld)
1787 theWorld :: RealWorld
1788 theWorld = error "primRunST: entered the RealWorld"
1792 instance Functor (ST s) where
1793 fmap f x = x >>= (return . f)
1795 instance Monad (ST s) where
1796 m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1797 return x = ST (\s -> (x,s))
1798 m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1801 -- used when Hugs invokes top level function
1802 primRunIO :: IO () -> ()
1804 = protect (fst (unST m realWorld))
1806 realWorld = error "primRunIO: entered the RealWorld"
1809 = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1811 trace :: String -> a -> a
1813 = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x
1815 unsafeInterleaveST :: ST s a -> ST s a
1816 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1818 unsafeInterleaveIO :: IO a -> IO a
1819 unsafeInterleaveIO = unsafeInterleaveST
1822 ------------------------------------------------------------------------------
1823 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
1824 ------------------------------------------------------------------------------
1828 nullAddr = primIntToAddr 0
1829 incAddr a = primIntToAddr (1 + primAddrToInt a)
1830 isNullAddr a = 0 == primAddrToInt a
1832 instance Eq Addr where
1836 instance Ord Addr where
1845 instance Eq Word where
1849 instance Ord Word where
1858 makeStablePtr :: a -> IO (StablePtr a)
1859 makeStablePtr = primMakeStablePtr
1860 deRefStablePtr :: StablePtr a -> IO a
1861 deRefStablePtr = primDeRefStablePtr
1862 freeStablePtr :: StablePtr a -> IO ()
1863 freeStablePtr = primFreeStablePtr
1866 data PrimArray a -- immutable arrays with Int indices
1869 data Ref s a -- mutable variables
1870 data PrimMutableArray s a -- mutable arrays with Int indices
1871 data PrimMutableByteArray s
1875 -- showFloat ------------------------------------------------------------------
1877 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1878 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1879 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
1880 showFloat :: (RealFloat a) => a -> ShowS
1882 showEFloat d x = showString (formatRealFloat FFExponent d x)
1883 showFFloat d x = showString (formatRealFloat FFFixed d x)
1884 showGFloat d x = showString (formatRealFloat FFGeneric d x)
1885 showFloat = showGFloat Nothing
1887 -- These are the format types. This type is not exported.
1889 data FFFormat = FFExponent | FFFixed | FFGeneric
1891 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
1892 formatRealFloat fmt decs x = s
1896 else if isInfinite x then
1897 if x < 0 then "-Infinity" else "Infinity"
1898 else if x < 0 || isNegativeZero x then
1899 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
1901 doFmt fmt (floatToDigits (toInteger base) x)
1903 let ds = map intToDigit is
1906 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
1913 [d] -> d : ".0e" ++ show (e-1)
1914 d:ds -> d : '.' : ds ++ 'e':show (e-1)
1916 let dec' = max dec 1 in
1918 [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
1920 let (ei, is') = roundTo base (dec'+1) is
1921 d:ds = map intToDigit
1922 (if ei > 0 then init is' else is')
1923 in d:'.':ds ++ "e" ++ show (e-1+ei)
1927 let f 0 s ds = mk0 s ++ "." ++ mk0 ds
1928 f n s "" = f (n-1) (s++"0") ""
1929 f n s (d:ds) = f (n-1) (s++[d]) ds
1934 let dec' = max dec 0 in
1936 let (ei, is') = roundTo base (dec' + e) is
1937 (ls, rs) = splitAt (e+ei) (map intToDigit is')
1938 in (if null ls then "0" else ls) ++
1939 (if null rs then "" else '.' : rs)
1941 let (ei, is') = roundTo base dec'
1942 (replicate (-e) 0 ++ is)
1943 d : ds = map intToDigit
1944 (if ei > 0 then is' else 0:is')
1947 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
1948 roundTo base d is = case f d is of
1950 (1, is) -> (1, 1 : is)
1951 where b2 = base `div` 2
1952 f n [] = (0, replicate n 0)
1953 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
1955 let (c, ds) = f (d-1) is
1957 in if i' == base then (1, 0:ds) else (0, i':ds)
1959 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
1960 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
1961 -- This version uses a much slower logarithm estimator. It should be improved.
1963 -- This function returns a list of digits (Ints in [0..base-1]) and an
1966 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
1968 floatToDigits _ 0 = ([0], 0)
1969 floatToDigits base x =
1970 let (f0, e0) = decodeFloat x
1971 (minExp0, _) = floatRange x
1974 minExp = minExp0 - p -- the real minimum exponent
1975 -- Haskell requires that f be adjusted so denormalized numbers
1976 -- will have an impossibly low exponent. Adjust for this.
1977 (f, e) = let n = minExp - e0
1978 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
1983 if f == b^(p-1) then
1984 (f*be*b*2, 2*b, be*b, b)
1988 if e > minExp && f == b^(p-1) then
1989 (f*b*2, b^(-e+1)*2, b, 1)
1991 (f*2, b^(-e)*2, 1, 1)
1994 if b == 2 && base == 10 then
1995 -- logBase 10 2 is slightly bigger than 3/10 so
1996 -- the following will err on the low side. Ignoring
1997 -- the fraction will make it err even more.
1998 -- Haskell promises that p-1 <= logBase b f < p.
1999 (p - 1 + e0) * 3 `div` 10
2001 ceiling ((log (fromInteger (f+1)) +
2002 fromInt e * log (fromInteger b)) /
2003 log (fromInteger base))
2006 if r + mUp <= expt base n * s then n else fixup (n+1)
2008 if expt base (-n) * (r + mUp) <= s then n
2012 gen ds rn sN mUpN mDnN =
2013 let (dn, rn') = (rn * base) `divMod` sN
2016 in case (rn' < mDnN', rn' + mUpN' > sN) of
2017 (True, False) -> dn : ds
2018 (False, True) -> dn+1 : ds
2019 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2020 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2023 gen [] r (s * expt base k) mUp mDn
2025 let bk = expt base (-k)
2026 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
2027 in (map toInt (reverse rds), k)
2030 -- Exponentiation with a cache for the most common numbers.
2033 expt :: Integer -> Int -> Integer
2035 if base == 2 && n >= minExpt && n <= maxExpt then
2036 expts !! (n-minExpt)
2041 expts = [2^n | n <- [minExpt .. maxExpt]]