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,
106 , MVar, newEmptyMVar, newMVar, putMVar, takeMVar, readMVar, swapMVar
110 , STRef, newSTRef, readSTRef, writeSTRef
111 , IORef, newIORef, readIORef, writeIORef
113 -- This lot really shouldn't be exported, but are needed to
114 -- implement various libs.
115 ,hugsprimCompAux,PrimArray,primRunST,primNewArray,primWriteArray
116 ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv
117 ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open
118 ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar
119 ,unsafeInterleaveIO,nh_write,primCharToInt,
120 nullAddr, incAddr, isNullAddr,
121 nh_filesize, nh_iseof, nh_system, nh_exitwith, nh_getPID,
122 nh_getCPUtime, nh_getCPUprec, prelCleanupAfterRunAction,
125 primGtWord, primGeWord, primEqWord, primNeWord,
126 primLtWord, primLeWord, primMinWord, primMaxWord,
127 primPlusWord, primMinusWord, primTimesWord, primQuotWord,
128 primRemWord, primQuotRemWord, primNegateWord, primAndWord,
129 primOrWord, primXorWord, primNotWord, primShiftLWord,
130 primShiftRAWord, primShiftRLWord, primIntToWord, primWordToInt,
132 primAndInt, primOrInt, primXorInt, primNotInt,
133 primShiftLInt, primShiftRAInt, primShiftRLInt,
135 primAddrToInt, primIntToAddr,
137 primDoubleToFloat, primFloatToDouble,
141 -- Standard value bindings {Prelude} ----------------------------------------
146 infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
148 --infixr 5 : -- this fixity declaration is hard-wired into Hugs
150 infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
155 infixr 0 $, $!, `seq`
157 -- Equality and Ordered classes ---------------------------------------------
160 (==), (/=) :: a -> a -> Bool
162 -- Minimal complete definition: (==) or (/=)
166 class (Eq a) => Ord a where
167 compare :: a -> a -> Ordering
168 (<), (<=), (>=), (>) :: a -> a -> Bool
169 max, min :: a -> a -> a
171 -- Minimal complete definition: (<=) or compare
172 -- using compare can be more efficient for complex types
173 compare x y | x==y = EQ
177 x <= y = compare x y /= GT
178 x < y = compare x y == LT
179 x >= y = compare x y /= LT
180 x > y = compare x y == GT
187 class Bounded a where
188 minBound, maxBound :: a
189 -- Minimal complete definition: All
191 -- Numeric classes ----------------------------------------------------------
193 class (Eq a, Show a) => Num a where
194 (+), (-), (*) :: a -> a -> a
196 abs, signum :: a -> a
197 fromInteger :: Integer -> a
200 -- Minimal complete definition: All, except negate or (-)
202 fromInt = fromIntegral
205 class (Num a, Ord a) => Real a where
206 toRational :: a -> Rational
208 class (Real a, Enum a) => Integral a where
209 quot, rem, div, mod :: a -> a -> a
210 quotRem, divMod :: a -> a -> (a,a)
211 even, odd :: a -> Bool
212 toInteger :: a -> Integer
215 -- Minimal complete definition: quotRem and toInteger
216 n `quot` d = q where (q,r) = quotRem n d
217 n `rem` d = r where (q,r) = quotRem n d
218 n `div` d = q where (q,r) = divMod n d
219 n `mod` d = r where (q,r) = divMod n d
220 divMod n d = if signum r == - signum d then (q-1, r+d) else qr
221 where qr@(q,r) = quotRem n d
222 even n = n `rem` 2 == 0
224 toInt = toInt . toInteger
226 class (Num a) => Fractional a where
229 fromRational :: Rational -> a
230 fromDouble :: Double -> a
232 -- Minimal complete definition: fromRational and ((/) or recip)
234 fromDouble = fromRational . toRational
238 class (Fractional a) => Floating a where
240 exp, log, sqrt :: a -> a
241 (**), logBase :: a -> a -> a
242 sin, cos, tan :: a -> a
243 asin, acos, atan :: a -> a
244 sinh, cosh, tanh :: a -> a
245 asinh, acosh, atanh :: a -> a
247 -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
248 -- asinh, acosh, atanh
249 x ** y = exp (log x * y)
250 logBase x y = log y / log x
252 tan x = sin x / cos x
253 sinh x = (exp x - exp (-x)) / 2
254 cosh x = (exp x + exp (-x)) / 2
255 tanh x = sinh x / cosh x
256 asinh x = log (x + sqrt (x*x + 1))
257 acosh x = log (x + sqrt (x*x - 1))
258 atanh x = (log (1 + x) - log (1 - x)) / 2
260 class (Real a, Fractional a) => RealFrac a where
261 properFraction :: (Integral b) => a -> (b,a)
262 truncate, round :: (Integral b) => a -> b
263 ceiling, floor :: (Integral b) => a -> b
265 -- Minimal complete definition: properFraction
266 truncate x = m where (m,_) = properFraction x
268 round x = let (n,r) = properFraction x
269 m = if r < 0 then n - 1 else n + 1
270 in case signum (abs r - 0.5) of
272 0 -> if even n then n else m
275 ceiling x = if r > 0 then n + 1 else n
276 where (n,r) = properFraction x
278 floor x = if r < 0 then n - 1 else n
279 where (n,r) = properFraction x
281 class (RealFrac a, Floating a) => RealFloat a where
282 floatRadix :: a -> Integer
283 floatDigits :: a -> Int
284 floatRange :: a -> (Int,Int)
285 decodeFloat :: a -> (Integer,Int)
286 encodeFloat :: Integer -> Int -> a
288 significand :: a -> a
289 scaleFloat :: Int -> a -> a
290 isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
294 -- Minimal complete definition: All, except exponent, signficand,
296 exponent x = if m==0 then 0 else n + floatDigits x
297 where (m,n) = decodeFloat x
298 significand x = encodeFloat m (- floatDigits x)
299 where (m,_) = decodeFloat x
300 scaleFloat k x = encodeFloat m (n+k)
301 where (m,n) = decodeFloat x
305 | x<0 && y>0 = pi + atan (y/x)
307 (x<0 && isNegativeZero y) ||
308 (isNegativeZero x && isNegativeZero y)
310 | y==0 && (x<0 || isNegativeZero x)
311 = pi -- must be after the previous test on zero y
312 | x==0 && y==0 = y -- must be after the other double zero tests
313 | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
315 -- Numeric functions --------------------------------------------------------
317 subtract :: Num a => a -> a -> a
320 gcd :: Integral a => a -> a -> a
321 gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
322 gcd x y = gcd' (abs x) (abs y)
324 gcd' x y = gcd' y (x `rem` y)
326 lcm :: (Integral a) => a -> a -> a
329 lcm x y = abs ((x `quot` gcd x y) * y)
331 (^) :: (Num a, Integral b) => a -> b -> a
333 x ^ n | n > 0 = f x (n-1) x
335 f x n y = g x n where
336 g x n | even n = g (x*x) (n`quot`2)
337 | otherwise = f x (n-1) (x*y)
338 _ ^ _ = error "Prelude.^: negative exponent"
340 (^^) :: (Fractional a, Integral b) => a -> b -> a
341 x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
343 fromIntegral :: (Integral a, Num b) => a -> b
344 fromIntegral = fromInteger . toInteger
346 realToFrac :: (Real a, Fractional b) => a -> b
347 realToFrac = fromRational . toRational
349 -- Index and Enumeration classes --------------------------------------------
351 class (Ord a) => Ix a where
352 range :: (a,a) -> [a]
353 index :: (a,a) -> a -> Int
354 inRange :: (a,a) -> a -> Bool
355 rangeSize :: (a,a) -> Int
359 | otherwise = index r u + 1
365 enumFrom :: a -> [a] -- [n..]
366 enumFromThen :: a -> a -> [a] -- [n,m..]
367 enumFromTo :: a -> a -> [a] -- [n..m]
368 enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
370 -- Minimal complete definition: toEnum, fromEnum
371 succ = toEnum . (1+) . fromEnum
372 pred = toEnum . subtract 1 . fromEnum
373 enumFrom x = map toEnum [ fromEnum x .. ]
374 enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
375 enumFromThen x y = map toEnum [ fromEnum x, fromEnum y .. ]
376 enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
378 -- Read and Show classes ------------------------------------------------------
380 type ReadS a = String -> [(a,String)]
381 type ShowS = String -> String
384 readsPrec :: Int -> ReadS a
385 readList :: ReadS [a]
387 -- Minimal complete definition: readsPrec
388 readList = readParen False (\r -> [pr | ("[",s) <- lex r,
390 where readl s = [([],t) | ("]",t) <- lex s] ++
391 [(x:xs,u) | (x,t) <- reads s,
393 readl' s = [([],t) | ("]",t) <- lex s] ++
394 [(x:xs,v) | (",",t) <- lex s,
400 showsPrec :: Int -> a -> ShowS
401 showList :: [a] -> ShowS
403 -- Minimal complete definition: show or showsPrec
404 show x = showsPrec 0 x ""
405 showsPrec _ x s = show x ++ s
406 showList [] = showString "[]"
407 showList (x:xs) = showChar '[' . shows x . showl xs
408 where showl [] = showChar ']'
409 showl (x:xs) = showChar ',' . shows x . showl xs
411 -- Monad classes ------------------------------------------------------------
413 class Functor f where
414 fmap :: (a -> b) -> (f a -> f b)
418 (>>=) :: m a -> (a -> m b) -> m b
419 (>>) :: m a -> m b -> m b
420 fail :: String -> m a
422 -- Minimal complete definition: (>>=), return
423 p >> q = p >>= \ _ -> q
426 sequence :: Monad m => [m a] -> m [a]
427 sequence [] = return []
428 sequence (c:cs) = do x <- c
432 sequence_ :: Monad m => [m a] -> m ()
433 sequence_ = foldr (>>) (return ())
435 mapM :: Monad m => (a -> m b) -> [a] -> m [b]
436 mapM f = sequence . map f
438 mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
439 mapM_ f = sequence_ . map f
441 (=<<) :: Monad m => (a -> m b) -> m a -> m b
444 -- Evaluation and strictness ------------------------------------------------
447 seq x y = primSeq x y
449 ($!) :: (a -> b) -> a -> b
450 f $! x = x `primSeq` f x
452 -- Trivial type -------------------------------------------------------------
454 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
459 instance Ord () where
465 inRange ((),()) () = True
467 instance Enum () where
471 enumFromThen () () = [()]
473 instance Read () where
474 readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
477 instance Show () where
478 showsPrec p () = showString "()"
480 instance Bounded () where
484 -- Boolean type -------------------------------------------------------------
486 data Bool = False | True
487 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
489 (&&), (||) :: Bool -> Bool -> Bool
502 -- Character type -----------------------------------------------------------
504 data Char -- builtin datatype of ISO Latin characters
505 type String = [Char] -- strings are lists of characters
507 instance Eq Char where (==) = primEqChar
508 instance Ord Char where (<=) = primLeChar
510 instance Enum Char where
511 toEnum = primIntToChar
512 fromEnum = primCharToInt
513 enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
514 enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
515 where lastChar = if d < c then minBound else maxBound
517 instance Ix Char where
518 range (c,c') = [c..c']
520 | inRange b ci = fromEnum ci - fromEnum c
521 | otherwise = error "Ix.index: Index out of range."
522 inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
523 where i = fromEnum ci
525 instance Read Char where
526 readsPrec p = readParen False
527 (\r -> [(c,t) | ('\'':s,t) <- lex r,
528 (c,"\'") <- readLitChar s ])
529 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
531 where readl ('"':s) = [("",s)]
532 readl ('\\':'&':s) = readl s
533 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
535 instance Show Char where
536 showsPrec p '\'' = showString "'\\''"
537 showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
539 showList cs = showChar '"' . showl cs
540 where showl "" = showChar '"'
541 showl ('"':cs) = showString "\\\"" . showl cs
542 showl (c:cs) = showLitChar c . showl cs
544 instance Bounded Char where
548 isAscii, isControl, isPrint, isSpace :: Char -> Bool
549 isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
551 isAscii c = fromEnum c < 128
552 isControl c = c < ' ' || c == '\DEL'
553 isPrint c = c >= ' ' && c <= '~'
554 isSpace c = c == ' ' || c == '\t' || c == '\n' ||
555 c == '\r' || c == '\f' || c == '\v'
556 isUpper c = c >= 'A' && c <= 'Z'
557 isLower c = c >= 'a' && c <= 'z'
558 isAlpha c = isUpper c || isLower c
559 isDigit c = c >= '0' && c <= '9'
560 isAlphaNum c = isAlpha c || isDigit c
562 -- Digit conversion operations
563 digitToInt :: Char -> Int
565 | isDigit c = fromEnum c - fromEnum '0'
566 | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
567 | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
568 | otherwise = error "Char.digitToInt: not a digit"
570 intToDigit :: Int -> Char
572 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
573 | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
574 | otherwise = error "Char.intToDigit: not a digit"
576 toUpper, toLower :: Char -> Char
577 toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
580 toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
589 -- Maybe type ---------------------------------------------------------------
591 data Maybe a = Nothing | Just a
592 deriving (Eq, Ord, Read, Show)
594 maybe :: b -> (a -> b) -> Maybe a -> b
595 maybe n f Nothing = n
596 maybe n f (Just x) = f x
598 instance Functor Maybe where
599 fmap f Nothing = Nothing
600 fmap f (Just x) = Just (f x)
602 instance Monad Maybe where
604 Nothing >>= k = Nothing
608 -- Either type --------------------------------------------------------------
610 data Either a b = Left a | Right b
611 deriving (Eq, Ord, Read, Show)
613 either :: (a -> c) -> (b -> c) -> Either a b -> c
614 either l r (Left x) = l x
615 either l r (Right y) = r y
617 -- Ordering type ------------------------------------------------------------
619 data Ordering = LT | EQ | GT
620 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
622 -- Lists --------------------------------------------------------------------
624 --data [a] = [] | a : [a] deriving (Eq, Ord)
626 instance Eq a => Eq [a] where
628 (x:xs) == (y:ys) = x==y && xs==ys
631 instance Ord a => Ord [a] where
632 compare [] (_:_) = LT
634 compare (_:_) [] = GT
635 compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys)
637 instance Functor [] where
640 instance Monad [ ] where
641 (x:xs) >>= f = f x ++ (xs >>= f)
646 instance Read a => Read [a] where
647 readsPrec p = readList
649 instance Show a => Show [a] where
650 showsPrec p = showList
652 -- Tuples -------------------------------------------------------------------
654 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
657 -- Standard Integral types --------------------------------------------------
659 data Int -- builtin datatype of fixed size integers
660 data Integer -- builtin datatype of arbitrary size integers
662 instance Eq Integer where
663 (==) x y = primCompareInteger x y == 0
665 instance Ord Integer where
666 compare x y = case primCompareInteger x y of
671 instance Eq Int where
675 instance Ord Int where
681 instance Num Int where
684 negate = primNegateInt
688 fromInteger = primIntegerToInt
691 instance Bounded Int where
692 minBound = primMinInt
693 maxBound = primMaxInt
695 instance Num Integer where
696 (+) = primPlusInteger
697 (-) = primMinusInteger
698 negate = primNegateInteger
699 (*) = primTimesInteger
703 fromInt = primIntToInteger
705 absReal x | x >= 0 = x
708 signumReal x | x == 0 = 0
712 instance Real Int where
713 toRational x = toInteger x % 1
715 instance Real Integer where
718 instance Integral Int where
719 quotRem = primQuotRemInt
720 toInteger = primIntToInteger
723 instance Integral Integer where
724 quotRem = primQuotRemInteger
725 --divMod = primDivModInteger
727 toInt = primIntegerToInt
729 instance Ix Int where
732 | inRange b i = i - m
733 | otherwise = error "index: Index out of range"
734 inRange (m,n) i = m <= i && i <= n
736 instance Ix Integer where
739 | inRange b i = fromInteger (i - m)
740 | otherwise = error "index: Index out of range"
741 inRange (m,n) i = m <= i && i <= n
743 instance Enum Int where
746 enumFrom = numericEnumFrom
747 enumFromTo = numericEnumFromTo
748 enumFromThen = numericEnumFromThen
749 enumFromThenTo = numericEnumFromThenTo
751 instance Enum Integer where
752 toEnum = primIntToInteger
753 fromEnum = primIntegerToInt
754 enumFrom = numericEnumFrom
755 enumFromTo = numericEnumFromTo
756 enumFromThen = numericEnumFromThen
757 enumFromThenTo = numericEnumFromThenTo
759 numericEnumFrom :: Real a => a -> [a]
760 numericEnumFromThen :: Real a => a -> a -> [a]
761 numericEnumFromTo :: Real a => a -> a -> [a]
762 numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
763 numericEnumFrom n = n : (numericEnumFrom $! (n+1))
764 numericEnumFromThen n m = iterate ((m-n)+) n
765 numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
766 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
767 where p | n' >= n = (<= m)
770 instance Read Int where
771 readsPrec p = readSigned readDec
773 instance Show Int where
775 | n == minBound = showSigned showInt p (toInteger n)
776 | otherwise = showSigned showInt p n
778 instance Read Integer where
779 readsPrec p = readSigned readDec
781 instance Show Integer where
782 showsPrec = showSigned showInt
785 -- Standard Floating types --------------------------------------------------
787 data Float -- builtin datatype of single precision floating point numbers
788 data Double -- builtin datatype of double precision floating point numbers
790 instance Eq Float where
794 instance Ord Float where
800 instance Num Float where
803 negate = primNegateFloat
807 fromInteger = primIntegerToFloat
808 fromInt = primIntToFloat
812 instance Eq Double where
816 instance Ord Double where
822 instance Num Double where
824 (-) = primMinusDouble
825 negate = primNegateDouble
826 (*) = primTimesDouble
829 fromInteger = primIntegerToDouble
830 fromInt = primIntToDouble
834 instance Real Float where
835 toRational = floatToRational
837 instance Real Double where
838 toRational = doubleToRational
840 -- Calls to these functions are optimised when passed as arguments to
842 floatToRational :: Float -> Rational
843 doubleToRational :: Double -> Rational
844 floatToRational x = realFloatToRational x
845 doubleToRational x = realFloatToRational x
847 realFloatToRational x = (m%1)*(b%1)^^n
848 where (m,n) = decodeFloat x
851 instance Fractional Float where
852 (/) = primDivideFloat
853 fromRational = rationalToRealFloat
854 fromDouble = primDoubleToFloat
857 instance Fractional Double where
858 (/) = primDivideDouble
859 fromRational = rationalToRealFloat
862 rationalToRealFloat x = x'
864 f e = if e' == e then y else f e'
865 where y = encodeFloat (round (x * (1%b)^^e)) e
866 (_,e') = decodeFloat y
867 (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
868 / fromInteger (denominator x))
871 instance Floating Float where
872 pi = 3.14159265358979323846
883 instance Floating Double where
884 pi = 3.14159265358979323846
887 sqrt = primSqrtDouble
891 asin = primAsinDouble
892 acos = primAcosDouble
893 atan = primAtanDouble
895 instance RealFrac Float where
896 properFraction = floatProperFraction
898 instance RealFrac Double where
899 properFraction = floatProperFraction
901 floatProperFraction x
902 | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
903 | otherwise = (fromInteger w, encodeFloat r n)
904 where (m,n) = decodeFloat x
906 (w,r) = quotRem m (b^(-n))
908 instance RealFloat Float where
909 floatRadix _ = toInteger primRadixFloat
910 floatDigits _ = primDigitsFloat
911 floatRange _ = (primMinExpFloat,primMaxExpFloat)
912 encodeFloat = primEncodeFloatZ
913 decodeFloat = primDecodeFloatZ
914 isNaN = primIsNaNFloat
915 isInfinite = primIsInfiniteFloat
916 isDenormalized= primIsDenormalizedFloat
917 isNegativeZero= primIsNegativeZeroFloat
918 isIEEE = const primIsIEEEFloat
920 instance RealFloat Double where
921 floatRadix _ = toInteger primRadixDouble
922 floatDigits _ = primDigitsDouble
923 floatRange _ = (primMinExpDouble,primMaxExpDouble)
924 encodeFloat = primEncodeDoubleZ
925 decodeFloat = primDecodeDoubleZ
926 isNaN = primIsNaNDouble
927 isInfinite = primIsInfiniteDouble
928 isDenormalized= primIsDenormalizedDouble
929 isNegativeZero= primIsNegativeZeroDouble
930 isIEEE = const primIsIEEEDouble
932 instance Enum Float where
933 toEnum = primIntToFloat
935 enumFrom = numericEnumFrom
936 enumFromThen = numericEnumFromThen
937 enumFromTo n m = numericEnumFromTo n (m+1/2)
938 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
940 instance Enum Double where
941 toEnum = primIntToDouble
943 enumFrom = numericEnumFrom
944 enumFromThen = numericEnumFromThen
945 enumFromTo n m = numericEnumFromTo n (m+1/2)
946 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
948 instance Read Float where
949 readsPrec p = readSigned readFloat
951 instance Show Float where
952 showsPrec p = showSigned showFloat p
954 instance Read Double where
955 readsPrec p = readSigned readFloat
957 instance Show Double where
958 showsPrec p = showSigned showFloat p
961 -- Some standard functions --------------------------------------------------
969 curry :: ((a,b) -> c) -> (a -> b -> c)
970 curry f x y = f (x,y)
972 uncurry :: (a -> b -> c) -> ((a,b) -> c)
973 uncurry f p = f (fst p) (snd p)
981 (.) :: (b -> c) -> (a -> b) -> (a -> c)
984 flip :: (a -> b -> c) -> b -> a -> c
987 ($) :: (a -> b) -> a -> b
990 until :: (a -> Bool) -> (a -> a) -> a -> a
991 until p f x = if p x then x else until p f (f x)
993 asTypeOf :: a -> a -> a
997 error msg = primRaise (ErrorCall msg)
1000 undefined | False = undefined
1002 -- Standard functions on rational numbers {PreludeRatio} --------------------
1004 data Integral a => Ratio a = a :% a deriving (Eq)
1005 type Rational = Ratio Integer
1007 (%) :: Integral a => a -> a -> Ratio a
1008 x % y = reduce (x * signum y) (abs y)
1010 reduce :: Integral a => a -> a -> Ratio a
1011 reduce x y | y == 0 = error "Ratio.%: zero denominator"
1012 | otherwise = (x `quot` d) :% (y `quot` d)
1015 numerator, denominator :: Integral a => Ratio a -> a
1016 numerator (x :% y) = x
1017 denominator (x :% y) = y
1019 instance Integral a => Ord (Ratio a) where
1020 compare (x:%y) (x':%y') = compare (x*y') (x'*y)
1022 instance Integral a => Num (Ratio a) where
1023 (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
1024 (x:%y) * (x':%y') = reduce (x*x') (y*y')
1025 negate (x :% y) = negate x :% y
1026 abs (x :% y) = abs x :% y
1027 signum (x :% y) = signum x :% 1
1028 fromInteger x = fromInteger x :% 1
1029 fromInt = intToRatio
1031 -- Hugs optimises code of the form fromRational (intToRatio x)
1032 intToRatio :: Integral a => Int -> Ratio a
1033 intToRatio x = fromInt x :% 1
1035 instance Integral a => Real (Ratio a) where
1036 toRational (x:%y) = toInteger x :% toInteger y
1038 instance Integral a => Fractional (Ratio a) where
1039 (x:%y) / (x':%y') = (x*y') % (y*x')
1040 recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
1041 fromRational (x:%y) = fromInteger x :% fromInteger y
1042 fromDouble = doubleToRatio
1044 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1045 doubleToRatio :: Integral a => Double -> Ratio a
1047 | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
1048 | otherwise = fromInteger m % (fromInteger b ^ (-n))
1049 where (m,n) = decodeFloat x
1052 instance Integral a => RealFrac (Ratio a) where
1053 properFraction (x:%y) = (fromIntegral q, r:%y)
1054 where (q,r) = quotRem x y
1056 instance Integral a => Enum (Ratio a) where
1059 enumFrom = numericEnumFrom
1060 enumFromThen = numericEnumFromThen
1062 instance (Read a, Integral a) => Read (Ratio a) where
1063 readsPrec p = readParen (p > 7)
1064 (\r -> [(x%y,u) | (x,s) <- reads r,
1068 instance Integral a => Show (Ratio a) where
1069 showsPrec p (x:%y) = showParen (p > 7)
1070 (shows x . showString " % " . shows y)
1072 approxRational :: RealFrac a => a -> a -> Rational
1073 approxRational x eps = simplest (x-eps) (x+eps)
1074 where simplest x y | y < x = simplest y x
1076 | x > 0 = simplest' n d n' d'
1077 | y < 0 = - simplest' (-n') d' (-n) d
1078 | otherwise = 0 :% 1
1079 where xr@(n:%d) = toRational x
1080 (n':%d') = toRational y
1081 simplest' n d n' d' -- assumes 0 < n%d < n'%d'
1083 | q /= q' = (q+1) :% 1
1084 | otherwise = (q*n''+d'') :% n''
1085 where (q,r) = quotRem n d
1086 (q',r') = quotRem n' d'
1087 (n'':%d'') = simplest' d' r' d r
1089 -- Standard list functions {PreludeList} ------------------------------------
1096 last (_:xs) = last xs
1103 init (x:xs) = x : init xs
1109 (++) :: [a] -> [a] -> [a]
1111 (x:xs) ++ ys = x : (xs ++ ys)
1113 map :: (a -> b) -> [a] -> [b]
1114 --map f xs = [ f x | x <- xs ]
1116 map f (x:xs) = f x : map f xs
1119 filter :: (a -> Bool) -> [a] -> [a]
1120 --filter p xs = [ x | x <- xs, p x ]
1122 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1125 concat :: [[a]] -> [a]
1126 --concat = foldr (++) []
1128 concat (xs:xss) = xs ++ concat xss
1130 length :: [a] -> Int
1131 --length = foldl' (\n _ -> n + 1) 0
1133 length (x:xs) = let n = length xs in primSeq n (1+n)
1135 (!!) :: [b] -> Int -> b
1137 (_:xs) !! n | n>0 = xs !! (n-1)
1138 (_:_) !! _ = error "Prelude.!!: negative index"
1139 [] !! _ = error "Prelude.!!: index too large"
1141 foldl :: (a -> b -> a) -> a -> [b] -> a
1143 foldl f z (x:xs) = foldl f (f z x) xs
1145 foldl' :: (a -> b -> a) -> a -> [b] -> a
1147 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1149 foldl1 :: (a -> a -> a) -> [a] -> a
1150 foldl1 f (x:xs) = foldl f x xs
1152 scanl :: (a -> b -> a) -> a -> [b] -> [a]
1153 scanl f q xs = q : (case xs of
1155 x:xs -> scanl f (f q x) xs)
1157 scanl1 :: (a -> a -> a) -> [a] -> [a]
1158 scanl1 f (x:xs) = scanl f x xs
1160 foldr :: (a -> b -> b) -> b -> [a] -> b
1162 foldr f z (x:xs) = f x (foldr f z xs)
1164 foldr1 :: (a -> a -> a) -> [a] -> a
1166 foldr1 f (x:xs) = f x (foldr1 f xs)
1168 scanr :: (a -> b -> b) -> b -> [a] -> [b]
1169 scanr f q0 [] = [q0]
1170 scanr f q0 (x:xs) = f x q : qs
1171 where qs@(q:_) = scanr f q0 xs
1173 scanr1 :: (a -> a -> a) -> [a] -> [a]
1175 scanr1 f (x:xs) = f x q : qs
1176 where qs@(q:_) = scanr1 f xs
1178 iterate :: (a -> a) -> a -> [a]
1179 iterate f x = x : iterate f (f x)
1182 repeat x = xs where xs = x:xs
1184 replicate :: Int -> a -> [a]
1185 replicate n x = take n (repeat x)
1188 cycle [] = error "Prelude.cycle: empty list"
1189 cycle xs = xs' where xs'=xs++xs'
1191 take :: Int -> [a] -> [a]
1194 take n (x:xs) | n>0 = x : take (n-1) xs
1195 take _ _ = error "Prelude.take: negative argument"
1197 drop :: Int -> [a] -> [a]
1200 drop n (_:xs) | n>0 = drop (n-1) xs
1201 drop _ _ = error "Prelude.drop: negative argument"
1203 splitAt :: Int -> [a] -> ([a], [a])
1204 splitAt 0 xs = ([],xs)
1205 splitAt _ [] = ([],[])
1206 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1207 splitAt _ _ = error "Prelude.splitAt: negative argument"
1209 takeWhile :: (a -> Bool) -> [a] -> [a]
1212 | p x = x : takeWhile p xs
1215 dropWhile :: (a -> Bool) -> [a] -> [a]
1217 dropWhile p xs@(x:xs')
1218 | p x = dropWhile p xs'
1221 span, break :: (a -> Bool) -> [a] -> ([a],[a])
1225 | otherwise = ([],xs)
1226 where (ys,zs) = span p xs'
1227 break p = span (not . p)
1229 lines :: String -> [String]
1231 lines s = let (l,s') = break ('\n'==) s
1232 in l : case s' of [] -> []
1233 (_:s'') -> lines s''
1235 words :: String -> [String]
1236 words s = case dropWhile isSpace s of
1239 where (w,s'') = break isSpace s'
1241 unlines :: [String] -> String
1242 unlines = concatMap (\l -> l ++ "\n")
1244 unwords :: [String] -> String
1246 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1248 reverse :: [a] -> [a]
1249 --reverse = foldl (flip (:)) []
1250 reverse xs = ri [] xs
1251 where ri acc [] = acc
1252 ri acc (x:xs) = ri (x:acc) xs
1254 and, or :: [Bool] -> Bool
1255 --and = foldr (&&) True
1256 --or = foldr (||) False
1258 and (x:xs) = if x then and xs else x
1260 or (x:xs) = if x then x else or xs
1262 any, all :: (a -> Bool) -> [a] -> Bool
1263 --any p = or . map p
1264 --all p = and . map p
1266 any p (x:xs) = if p x then True else any p xs
1268 all p (x:xs) = if p x then all p xs else False
1270 elem, notElem :: Eq a => a -> [a] -> Bool
1272 --notElem = all . (/=)
1274 elem x (y:ys) = if x==y then True else elem x ys
1276 notElem x (y:ys) = if x==y then False else notElem x ys
1278 lookup :: Eq a => a -> [(a,b)] -> Maybe b
1279 lookup k [] = Nothing
1280 lookup k ((x,y):xys)
1282 | otherwise = lookup k xys
1284 sum, product :: Num a => [a] -> a
1286 product = foldl' (*) 1
1288 maximum, minimum :: Ord a => [a] -> a
1289 maximum = foldl1 max
1290 minimum = foldl1 min
1292 concatMap :: (a -> [b]) -> [a] -> [b]
1293 concatMap f = concat . map f
1295 zip :: [a] -> [b] -> [(a,b)]
1296 zip = zipWith (\a b -> (a,b))
1298 zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
1299 zip3 = zipWith3 (\a b c -> (a,b,c))
1301 zipWith :: (a->b->c) -> [a]->[b]->[c]
1302 zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
1305 zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1306 zipWith3 z (a:as) (b:bs) (c:cs)
1307 = z a b c : zipWith3 z as bs cs
1308 zipWith3 _ _ _ _ = []
1310 unzip :: [(a,b)] -> ([a],[b])
1311 unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1313 unzip3 :: [(a,b,c)] -> ([a],[b],[c])
1314 unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1317 -- PreludeText ----------------------------------------------------------------
1319 reads :: Read a => ReadS a
1322 shows :: Show a => a -> ShowS
1325 read :: Read a => String -> a
1326 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1328 [] -> error "Prelude.read: no parse"
1329 _ -> error "Prelude.read: ambiguous parse"
1331 showChar :: Char -> ShowS
1334 showString :: String -> ShowS
1337 showParen :: Bool -> ShowS -> ShowS
1338 showParen b p = if b then showChar '(' . p . showChar ')' else p
1340 hugsprimShowField :: Show a => String -> a -> ShowS
1341 hugsprimShowField m v = showString m . showChar '=' . shows v
1343 readParen :: Bool -> ReadS a -> ReadS a
1344 readParen b g = if b then mandatory else optional
1345 where optional r = g r ++ mandatory r
1346 mandatory r = [(x,u) | ("(",s) <- lex r,
1347 (x,t) <- optional s,
1351 hugsprimReadField :: Read a => String -> ReadS a
1352 hugsprimReadField m s0 = [ r | (t, s1) <- lex s0, t == m,
1358 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1359 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1361 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1363 lexString ('"':s) = [("\"",s)]
1364 lexString s = [(ch++str, u)
1365 | (ch,t) <- lexStrItem s,
1366 (str,u) <- lexString t ]
1368 lexStrItem ('\\':'&':s) = [("\\&",s)]
1369 lexStrItem ('\\':c:s) | isSpace c
1370 = [("",t) | '\\':t <- [dropWhile isSpace s]]
1371 lexStrItem s = lexLitChar s
1373 lex (c:s) | isSingle c = [([c],s)]
1374 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
1375 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
1376 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
1377 (fe,t) <- lexFracExp s ]
1378 | otherwise = [] -- bad character
1380 isSingle c = c `elem` ",;()[]{}_`"
1381 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1382 isIdChar c = isAlphaNum c || c `elem` "_'"
1384 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1386 lexFracExp s = [("",s)]
1388 lexExp (e:s) | e `elem` "eE"
1389 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
1390 (ds,u) <- lexDigits t] ++
1391 [(e:ds,t) | (ds,t) <- lexDigits s]
1394 lexDigits :: ReadS String
1395 lexDigits = nonnull isDigit
1397 nonnull :: (Char -> Bool) -> ReadS String
1398 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1400 lexLitChar :: ReadS String
1401 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1403 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- "
1404 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
1405 lexEsc s@(d:_) | isDigit d = lexDigits s
1406 lexEsc s@(c:_) | isUpper c
1407 = let table = ('\DEL',"DEL") : asciiTab
1408 in case [(mne,s') | (c, mne) <- table,
1409 ([],s') <- [lexmatch mne s]]
1413 lexLitChar (c:s) = [([c],s)]
1416 isOctDigit c = c >= '0' && c <= '7'
1417 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
1418 || c >= 'a' && c <= 'f'
1420 lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
1421 lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
1422 lexmatch xs ys = (xs,ys)
1424 asciiTab = zip ['\NUL'..' ']
1425 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1426 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
1427 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1428 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
1431 readLitChar :: ReadS Char
1432 readLitChar ('\\':s) = readEsc s
1434 readEsc ('a':s) = [('\a',s)]
1435 readEsc ('b':s) = [('\b',s)]
1436 readEsc ('f':s) = [('\f',s)]
1437 readEsc ('n':s) = [('\n',s)]
1438 readEsc ('r':s) = [('\r',s)]
1439 readEsc ('t':s) = [('\t',s)]
1440 readEsc ('v':s) = [('\v',s)]
1441 readEsc ('\\':s) = [('\\',s)]
1442 readEsc ('"':s) = [('"',s)]
1443 readEsc ('\'':s) = [('\'',s)]
1444 readEsc ('^':c:s) | c >= '@' && c <= '_'
1445 = [(toEnum (fromEnum c - fromEnum '@'), s)]
1446 readEsc s@(d:_) | isDigit d
1447 = [(toEnum n, t) | (n,t) <- readDec s]
1448 readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
1449 readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
1450 readEsc s@(c:_) | isUpper c
1451 = let table = ('\DEL',"DEL") : asciiTab
1452 in case [(c,s') | (c, mne) <- table,
1453 ([],s') <- [lexmatch mne s]]
1457 readLitChar (c:s) = [(c,s)]
1459 showLitChar :: Char -> ShowS
1460 showLitChar c | c > '\DEL' = showChar '\\' .
1461 protectEsc isDigit (shows (fromEnum c))
1462 showLitChar '\DEL' = showString "\\DEL"
1463 showLitChar '\\' = showString "\\\\"
1464 showLitChar c | c >= ' ' = showChar c
1465 showLitChar '\a' = showString "\\a"
1466 showLitChar '\b' = showString "\\b"
1467 showLitChar '\f' = showString "\\f"
1468 showLitChar '\n' = showString "\\n"
1469 showLitChar '\r' = showString "\\r"
1470 showLitChar '\t' = showString "\\t"
1471 showLitChar '\v' = showString "\\v"
1472 showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
1473 showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
1475 protectEsc p f = f . cont
1476 where cont s@(c:_) | p c = "\\&" ++ s
1479 -- Unsigned readers for various bases
1480 readDec, readOct, readHex :: Integral a => ReadS a
1481 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1482 readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1483 readHex = readInt 16 isHexDigit hex
1484 where hex d = fromEnum d -
1487 else fromEnum (if isUpper d then 'A' else 'a') - 10)
1489 -- readInt reads a string of digits using an arbitrary base.
1490 -- Leading minus signs must be handled elsewhere.
1492 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1493 readInt radix isDig digToInt s =
1494 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1495 | (ds,r) <- nonnull isDig s ]
1497 -- showInt is used for positive numbers only
1498 showInt :: Integral a => a -> ShowS
1501 = error "Numeric.showInt: can't show negative numbers"
1504 = let (n',d) = quotRem n 10
1505 r' = toEnum (fromEnum '0' + fromIntegral d) : r
1506 in if n' == 0 then r' else showInt n' r'
1508 = case quotRem n 10 of { (n',d) ->
1509 let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1510 in if n' == 0 then r' else showInt n' r'
1514 readSigned:: Real a => ReadS a -> ReadS a
1515 readSigned readPos = readParen False read'
1516 where read' r = read'' r ++
1517 [(-x,t) | ("-",s) <- lex r,
1519 read'' r = [(n,s) | (str,s) <- lex r,
1520 (n,"") <- readPos str]
1522 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1523 showSigned showPos p x = if x < 0 then showParen (p > 6)
1524 (showChar '-' . showPos (-x))
1527 readFloat :: RealFloat a => ReadS a
1528 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1530 where readFix r = [(read (ds++ds'), length ds', t)
1531 | (ds, s) <- lexDigits r
1532 , (ds',t) <- lexFrac s ]
1534 lexFrac ('.':s) = lexDigits s
1535 lexFrac s = [("",s)]
1537 readExp (e:s) | e `elem` "eE" = readExp' s
1540 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1541 readExp' ('+':s) = readDec s
1542 readExp' s = readDec s
1545 -- Hooks for primitives: -----------------------------------------------------
1546 -- Do not mess with these!
1548 hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering
1549 hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1551 hugsprimEqChar :: Char -> Char -> Bool
1552 hugsprimEqChar c1 c2 = primEqChar c1 c2
1554 hugsprimPmInt :: Num a => Int -> a -> Bool
1555 hugsprimPmInt n x = fromInt n == x
1557 hugsprimPmInteger :: Num a => Integer -> a -> Bool
1558 hugsprimPmInteger n x = fromInteger n == x
1560 hugsprimPmDouble :: Fractional a => Double -> a -> Bool
1561 hugsprimPmDouble n x = fromDouble n == x
1563 -- ToDo: make the message more informative.
1565 hugsprimPmFail = error "Pattern Match Failure"
1567 -- used in desugaring Foreign functions
1568 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1571 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1572 hugsprimCreateAdjThunk fun typestr callconv
1573 = do sp <- makeStablePtr fun
1574 p <- copy_String_to_cstring typestr -- is never freed
1575 a <- primCreateAdjThunkARCH sp p callconv
1578 -- The following primitives are only needed if (n+k) patterns are enabled:
1579 hugsprimPmSub :: Integral a => Int -> a -> a
1580 hugsprimPmSub n x = x - fromInt n
1582 hugsprimPmFromInteger :: Integral a => Integer -> a
1583 hugsprimPmFromInteger = fromIntegral
1585 hugsprimPmSubtract :: Integral a => a -> a -> a
1586 hugsprimPmSubtract x y = x - y
1588 hugsprimPmLe :: Integral a => a -> a -> Bool
1589 hugsprimPmLe x y = x <= y
1591 -- Unpack strings generated by the Hugs code generator.
1592 -- Strings can contain \0 provided they're coded right.
1594 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1596 hugsprimUnpackString :: Addr -> String
1597 hugsprimUnpackString a = unpack 0
1599 -- The following decoding is based on evalString in the old machine.c
1602 | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1603 then '\\' : unpack (i+2)
1604 else '\0' : unpack (i+2)
1605 | otherwise = c : unpack (i+1)
1607 c = primIndexCharOffAddr a i
1610 -- Monadic I/O: --------------------------------------------------------------
1612 type FilePath = String
1614 --data IOError = ...
1615 --instance Eq IOError ...
1616 --instance Show IOError ...
1618 data IOError = IOError String
1619 instance Show IOError where
1620 showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1622 ioError :: IOError -> IO a
1623 ioError (IOError s) = primRaise (IOExcept s)
1625 userError :: String -> IOError
1626 userError s = primRaise (ErrorCall s)
1628 catch :: IO a -> (IOError -> IO a) -> IO a
1630 = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
1632 e2ioe (IOExcept s) = IOError s
1633 e2ioe other = IOError (show other)
1635 putChar :: Char -> IO ()
1636 putChar c = nh_stdout >>= \h -> nh_write h c
1638 putStr :: String -> IO ()
1639 putStr s = nh_stdout >>= \h ->
1640 let loop [] = nh_flush h
1641 loop (c:cs) = nh_write h c >> loop cs
1644 putStrLn :: String -> IO ()
1645 putStrLn s = do { putStr s; putChar '\n' }
1647 print :: Show a => a -> IO ()
1648 print = putStrLn . show
1651 getChar = unsafeInterleaveIO (
1653 nh_read h >>= \ci ->
1654 return (primIntToChar ci)
1657 getLine :: IO String
1658 getLine = do c <- getChar
1659 if c=='\n' then return ""
1660 else do cs <- getLine
1663 getContents :: IO String
1664 getContents = nh_stdin >>= \h -> readfromhandle h
1666 interact :: (String -> String) -> IO ()
1667 interact f = getContents >>= (putStr . f)
1669 readFile :: FilePath -> IO String
1671 = copy_String_to_cstring fname >>= \ptr ->
1672 nh_open ptr 0 >>= \h ->
1674 nh_errno >>= \errno ->
1675 if (isNullAddr h || errno /= 0)
1676 then (ioError.IOError) ("readFile: can't open file " ++ fname)
1677 else readfromhandle h
1679 writeFile :: FilePath -> String -> IO ()
1680 writeFile fname contents
1681 = copy_String_to_cstring fname >>= \ptr ->
1682 nh_open ptr 1 >>= \h ->
1684 nh_errno >>= \errno ->
1685 if (isNullAddr h || errno /= 0)
1686 then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1687 else writetohandle fname h contents
1689 appendFile :: FilePath -> String -> IO ()
1690 appendFile fname contents
1691 = copy_String_to_cstring fname >>= \ptr ->
1692 nh_open ptr 2 >>= \h ->
1694 nh_errno >>= \errno ->
1695 if (isNullAddr h || errno /= 0)
1696 then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1697 else writetohandle fname h contents
1700 -- raises an exception instead of an error
1701 readIO :: Read a => String -> IO a
1702 readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1704 [] -> ioError (userError "PreludeIO.readIO: no parse")
1705 _ -> ioError (userError
1706 "PreludeIO.readIO: ambiguous parse")
1708 readLn :: Read a => IO a
1709 readLn = do l <- getLine
1714 -- End of Hugs standard prelude ----------------------------------------------
1720 instance Show Exception where
1721 showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1722 showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
1724 data IOResult = IOResult deriving (Show)
1726 type FILE_STAR = Addr -- FILE *
1728 foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR
1729 foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
1730 foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
1731 foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Char -> IO ()
1732 foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int
1733 foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR
1734 foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO ()
1735 foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO ()
1736 foreign import "nHandle" "nh_errno" nh_errno :: IO Int
1738 foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
1739 foreign import "nHandle" "nh_free" nh_free :: Addr -> IO ()
1740 foreign import "nHandle" "nh_store" nh_store :: Addr -> Char -> IO ()
1741 foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Char
1742 foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
1743 foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int
1744 foreign import "nHandle" "nh_iseof" nh_iseof :: FILE_STAR -> IO Int
1745 foreign import "nHandle" "nh_system" nh_system :: Addr -> IO Int
1746 foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO ()
1747 foreign import "nHandle" "nh_getPID" nh_getPID :: IO Int
1749 foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double
1750 foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double
1752 copy_String_to_cstring :: String -> IO Addr
1753 copy_String_to_cstring s
1754 = nh_malloc (1 + length s) >>= \ptr0 ->
1755 let loop ptr [] = nh_store ptr (chr 0) >> return ptr0
1756 loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs
1759 then error "copy_String_to_cstring: malloc failed"
1762 copy_cstring_to_String :: Addr -> IO String
1763 copy_cstring_to_String ptr
1764 = nh_load ptr >>= \ci ->
1767 else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1770 readfromhandle :: FILE_STAR -> IO String
1772 = unsafeInterleaveIO (
1773 nh_read h >>= \ci ->
1774 if ci == -1 {-EOF-} then return "" else
1775 readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1778 writetohandle :: String -> FILE_STAR -> String -> IO ()
1779 writetohandle fname h []
1781 nh_errno >>= \errno ->
1784 else error ( "writeFile/appendFile: error closing file " ++ fname)
1785 writetohandle fname h (c:cs)
1786 = nh_write h c >> writetohandle fname h cs
1788 primGetRawArgs :: IO [String]
1790 = primGetArgc >>= \argc ->
1791 sequence (map get_one_arg [0 .. argc-1])
1793 get_one_arg :: Int -> IO String
1795 = primGetArgv argno >>= \a ->
1796 copy_cstring_to_String a
1798 primGetEnv :: String -> IO String
1800 = copy_String_to_cstring v >>= \ptr ->
1801 nh_getenv ptr >>= \ptr2 ->
1806 copy_cstring_to_String ptr2 >>= \result ->
1810 ------------------------------------------------------------------------------
1811 -- ST, IO --------------------------------------------------------------------
1812 ------------------------------------------------------------------------------
1814 newtype ST s a = ST (s -> (a,s))
1817 type IO a = ST RealWorld a
1819 --primRunST :: (forall s. ST s a) -> a
1820 primRunST :: ST RealWorld a -> a
1821 primRunST m = fst (unST m theWorld)
1823 theWorld :: RealWorld
1824 theWorld = error "primRunST: entered the RealWorld"
1828 instance Functor (ST s) where
1829 fmap f x = x >>= (return . f)
1831 instance Monad (ST s) where
1832 m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1833 return x = ST (\s -> (x,s))
1834 m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1837 -- Library IO has a global variable which accumulates Handles
1838 -- as they are opened. We keep here a second global variable
1839 -- into which a cleanup action may be specified. When evaluation
1840 -- finishes, either normally or as a result of System.exitWith,
1841 -- this cleanup action is run, closing all known-about Handles.
1842 -- Doing it like this means the Prelude does not have to know
1843 -- anything about the grotty details of the Handle implementation.
1844 prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
1845 prelCleanupAfterRunAction = primRunST (newIORef Nothing)
1847 -- used when Hugs invokes top level function
1848 hugsprimRunIO_toplevel :: IO a -> ()
1849 hugsprimRunIO_toplevel m
1850 = protect 5 (fst (unST composite_action realWorld))
1853 = do writeIORef prelCleanupAfterRunAction Nothing
1855 cleanup_handles <- readIORef prelCleanupAfterRunAction
1856 case cleanup_handles of
1857 Nothing -> return ()
1860 realWorld = error "primRunIO: entered the RealWorld"
1861 protect :: Int -> () -> ()
1865 = primCatch (protect (n-1) comp)
1866 (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1868 trace, trace_quiet :: String -> a -> a
1870 = trace_quiet ("trace: " ++ s) x
1872 = (primRunST (putStr (s ++ "\n"))) `seq` x
1874 unsafeInterleaveST :: ST s a -> ST s a
1875 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1877 unsafeInterleaveIO :: IO a -> IO a
1878 unsafeInterleaveIO = unsafeInterleaveST
1881 ------------------------------------------------------------------------------
1882 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
1883 ------------------------------------------------------------------------------
1887 nullAddr = primIntToAddr 0
1888 incAddr a = primIntToAddr (1 + primAddrToInt a)
1889 isNullAddr a = 0 == primAddrToInt a
1891 instance Eq Addr where
1895 instance Ord Addr where
1903 instance Eq Word where
1907 instance Ord Word where
1915 makeStablePtr :: a -> IO (StablePtr a)
1916 makeStablePtr = primMakeStablePtr
1917 deRefStablePtr :: StablePtr a -> IO a
1918 deRefStablePtr = primDeRefStablePtr
1919 freeStablePtr :: StablePtr a -> IO ()
1920 freeStablePtr = primFreeStablePtr
1923 data PrimArray a -- immutable arrays with Int indices
1926 data STRef s a -- mutable variables
1927 data PrimMutableArray s a -- mutable arrays with Int indices
1928 data PrimMutableByteArray s
1930 newSTRef :: a -> ST s (STRef s a)
1931 newSTRef = primNewRef
1932 readSTRef :: STRef s a -> ST s a
1933 readSTRef = primReadRef
1934 writeSTRef :: STRef s a -> a -> ST s ()
1935 writeSTRef = primWriteRef
1937 type IORef a = STRef RealWorld a
1938 newIORef :: a -> IO (IORef a)
1939 newIORef = primNewRef
1940 readIORef :: IORef a -> IO a
1941 readIORef = primReadRef
1942 writeIORef :: IORef a -> a -> IO ()
1943 writeIORef = primWriteRef
1946 ------------------------------------------------------------------------------
1947 -- ThreadId, MVar, concurrency stuff -----------------------------------------
1948 ------------------------------------------------------------------------------
1952 newEmptyMVar :: IO (MVar a)
1953 newEmptyMVar = primNewEmptyMVar
1955 putMVar :: MVar a -> a -> IO ()
1956 putMVar = primPutMVar
1958 takeMVar :: MVar a -> IO a
1960 = ST (\world -> primTakeMVar m cont world)
1962 -- cont :: a -> RealWorld -> (a,RealWorld)
1963 -- where 'a' is as in the top-level signature
1964 cont x world = (x,world)
1966 -- the type of the handwritten BCO (threesome) primTakeMVar is
1967 -- primTakeMVar :: MVar a
1968 -- -> (a -> RealWorld -> (a,RealWorld))
1972 -- primTakeMVar behaves like this:
1974 -- primTakeMVar (MVar# m#) cont world
1975 -- = primTakeMVar_wrk m# cont world
1977 -- primTakeMVar_wrk m# cont world
1978 -- = cont (takeMVar# m#) world
1980 -- primTakeMVar_wrk has the special property that it is
1981 -- restartable by the scheduler, should the MVar be empty.
1983 newMVar :: a -> IO (MVar a)
1985 newEmptyMVar >>= \ mvar ->
1986 putMVar mvar value >>
1989 readMVar :: MVar a -> IO a
1991 takeMVar mvar >>= \ value ->
1992 putMVar mvar value >>
1995 swapMVar :: MVar a -> a -> IO a
1997 takeMVar mvar >>= \ old ->
2001 instance Eq (MVar a) where
2002 m1 == m2 = primSameMVar m1 m2
2007 instance Eq ThreadId where
2008 tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
2010 instance Ord ThreadId where
2012 = let r = primCmpThreadIds tid1 tid2
2013 in if r < 0 then LT else if r > 0 then GT else EQ
2016 forkIO :: IO a -> IO ThreadId
2017 -- Simple version; doesn't catch exceptions in computation
2018 -- forkIO computation
2019 -- = primForkIO (primRunST computation)
2024 (unST computation realWorld `primSeq` ())
2025 (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
2028 realWorld = error "primForkIO: entered the RealWorld"
2031 -- showFloat ------------------------------------------------------------------
2033 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2034 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2035 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2036 showFloat :: (RealFloat a) => a -> ShowS
2038 showEFloat d x = showString (formatRealFloat FFExponent d x)
2039 showFFloat d x = showString (formatRealFloat FFFixed d x)
2040 showGFloat d x = showString (formatRealFloat FFGeneric d x)
2041 showFloat = showGFloat Nothing
2043 -- These are the format types. This type is not exported.
2045 data FFFormat = FFExponent | FFFixed | FFGeneric
2047 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2048 formatRealFloat fmt decs x = s
2052 else if isInfinite x then
2053 if x < 0 then "-Infinity" else "Infinity"
2054 else if x < 0 || isNegativeZero x then
2055 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2057 doFmt fmt (floatToDigits (toInteger base) x)
2059 let ds = map intToDigit is
2062 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2069 [d] -> d : ".0e" ++ show (e-1)
2070 d:ds -> d : '.' : ds ++ 'e':show (e-1)
2072 let dec' = max dec 1 in
2074 [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2076 let (ei, is') = roundTo base (dec'+1) is
2077 d:ds = map intToDigit
2078 (if ei > 0 then init is' else is')
2079 in d:'.':ds ++ "e" ++ show (e-1+ei)
2083 let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2084 f n s "" = f (n-1) (s++"0") ""
2085 f n s (d:ds) = f (n-1) (s++[d]) ds
2090 let dec' = max dec 0 in
2092 let (ei, is') = roundTo base (dec' + e) is
2093 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2094 in (if null ls then "0" else ls) ++
2095 (if null rs then "" else '.' : rs)
2097 let (ei, is') = roundTo base dec'
2098 (replicate (-e) 0 ++ is)
2099 d : ds = map intToDigit
2100 (if ei > 0 then is' else 0:is')
2103 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2104 roundTo base d is = case f d is of
2106 (1, is) -> (1, 1 : is)
2107 where b2 = base `div` 2
2108 f n [] = (0, replicate n 0)
2109 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2111 let (c, ds) = f (d-1) is
2113 in if i' == base then (1, 0:ds) else (0, i':ds)
2115 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2116 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2117 -- This version uses a much slower logarithm estimator. It should be improved.
2119 -- This function returns a list of digits (Ints in [0..base-1]) and an
2122 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2124 floatToDigits _ 0 = ([0], 0)
2125 floatToDigits base x =
2126 let (f0, e0) = decodeFloat x
2127 (minExp0, _) = floatRange x
2130 minExp = minExp0 - p -- the real minimum exponent
2131 -- Haskell requires that f be adjusted so denormalized numbers
2132 -- will have an impossibly low exponent. Adjust for this.
2133 (f, e) = let n = minExp - e0
2134 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2139 if f == b^(p-1) then
2140 (f*be*b*2, 2*b, be*b, b)
2144 if e > minExp && f == b^(p-1) then
2145 (f*b*2, b^(-e+1)*2, b, 1)
2147 (f*2, b^(-e)*2, 1, 1)
2150 if b == 2 && base == 10 then
2151 -- logBase 10 2 is slightly bigger than 3/10 so
2152 -- the following will err on the low side. Ignoring
2153 -- the fraction will make it err even more.
2154 -- Haskell promises that p-1 <= logBase b f < p.
2155 (p - 1 + e0) * 3 `div` 10
2157 ceiling ((log (fromInteger (f+1)) +
2158 fromInt e * log (fromInteger b)) /
2159 log (fromInteger base))
2162 if r + mUp <= expt base n * s then n else fixup (n+1)
2164 if expt base (-n) * (r + mUp) <= s then n
2168 gen ds rn sN mUpN mDnN =
2169 let (dn, rn') = (rn * base) `divMod` sN
2172 in case (rn' < mDnN', rn' + mUpN' > sN) of
2173 (True, False) -> dn : ds
2174 (False, True) -> dn+1 : ds
2175 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2176 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2179 gen [] r (s * expt base k) mUp mDn
2181 let bk = expt base (-k)
2182 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
2183 in (map toInt (reverse rds), k)
2186 -- Exponentiation with a cache for the most common numbers.
2189 expt :: Integer -> Int -> Integer
2191 if base == 2 && n >= minExpt && n <= maxExpt then
2192 expts !! (n-minExpt)
2197 expts = [2^n | n <- [minExpt .. maxExpt]]