1 {----------------------------------------------------------------------------
2 __ __ __ __ ____ ___ _______________________________________________
3 || || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system
4 ||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999
5 ||---|| ___|| World Wide Web: http://haskell.org/hugs
6 || || Report bugs to: hugs-bugs@haskell.org
7 || || Version: STG Hugs _______________________________________________
9 This is the Hugs 98 Standard Prelude, based very closely on the Standard
10 Prelude for Haskell 98.
12 WARNING: This file is an integral part of the Hugs source code. Changes to
13 the definitions in this file without corresponding modifications in other
14 parts of the program may cause the interpreter to fail unexpectedly. Under
15 normal circumstances, you should not attempt to modify this file in any way!
17 -----------------------------------------------------------------------------
18 Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell
19 Group 1994-99, and is distributed as Open Source software under the
20 Artistic License; see the file "Artistic" that is included in the
21 distribution for details.
22 ----------------------------------------------------------------------------}
25 -- module PreludeList,
26 map, (++), concat, filter,
27 head, last, tail, init, null, length, (!!),
28 foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
29 iterate, repeat, replicate, cycle,
30 take, drop, splitAt, takeWhile, dropWhile, span, break,
31 lines, words, unlines, unwords, reverse, and, or,
32 any, all, elem, notElem, lookup,
33 sum, product, maximum, minimum, concatMap,
34 zip, zip3, zipWith, zipWith3, unzip, unzip3,
35 -- module PreludeText,
37 Read(readsPrec, readList),
38 Show(show, showsPrec, showList),
39 reads, shows, read, lex,
40 showChar, showString, readParen, showParen,
42 FilePath, IOError, ioError, userError, catch,
43 putChar, putStr, putStrLn, print,
44 getChar, getLine, getContents, interact,
45 readFile, writeFile, appendFile, readIO, readLn,
47 Ix(range, index, inRange, rangeSize),
49 isAscii, isControl, isPrint, isSpace, isUpper, isLower,
50 isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
51 digitToInt, intToDigit,
54 readLitChar, showLitChar, lexLitChar,
58 readDec, readOct, readHex, readSigned,
61 Ratio, Rational, (%), numerator, denominator, approxRational,
62 -- Non-standard exports
63 IOResult(..), Addr, StablePtr,
64 makeStablePtr, freeStablePtr, deRefStablePtr,
70 Char, String, Int, Integer, Float, Double, IO,
71 -- List type: []((:), [])
73 -- Tuple types: (,), (,,), etc.
76 Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
78 Ord(compare, (<), (<=), (>=), (>), max, min),
79 Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
80 enumFromTo, enumFromThenTo),
81 Bounded(minBound, maxBound),
82 -- Num((+), (-), (*), negate, abs, signum, fromInteger),
83 Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
85 -- Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
86 Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
87 Fractional((/), recip, fromRational), fromDouble,
88 Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
89 asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
90 RealFrac(properFraction, truncate, round, ceiling, floor),
91 RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
92 encodeFloat, exponent, significand, scaleFloat, isNaN,
93 isInfinite, isDenormalized, isIEEE, isNegativeZero),
94 Monad((>>=), (>>), return, fail),
96 mapM, mapM_, sequence, sequence_, (=<<),
98 (&&), (||), not, otherwise,
99 subtract, even, odd, gcd, lcm, (^), (^^),
100 fromIntegral, realToFrac, atan2,
101 fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
102 asTypeOf, error, undefined,
104 -- Now we have the extra (non standard) thing.
127 , copy_String_to_cstring
157 , numericEnumFromThen
158 , numericEnumFromThenTo
160 , prelCleanupAfterRunAction
183 , primReallyUnsafePtrEquality
189 , primSizeMutableArray
192 , primUnsafeFreezeArray
198 , primWriteCharOffAddr
221 -- Standard value bindings {Prelude} ----------------------------------------
226 infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
228 --infixr 5 : -- this fixity declaration is hard-wired into Hugs
230 infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
235 infixr 0 $, $!, `seq`
237 -- Equality and Ordered classes ---------------------------------------------
240 (==), (/=) :: a -> a -> Bool
242 -- Minimal complete definition: (==) or (/=)
246 class (Eq a) => Ord a where
247 compare :: a -> a -> Ordering
248 (<), (<=), (>=), (>) :: a -> a -> Bool
249 max, min :: a -> a -> a
251 -- Minimal complete definition: (<=) or compare
252 -- using compare can be more efficient for complex types
253 compare x y | x==y = EQ
257 x <= y = compare x y /= GT
258 x < y = compare x y == LT
259 x >= y = compare x y /= LT
260 x > y = compare x y == GT
267 class Bounded a where
268 minBound, maxBound :: a
269 -- Minimal complete definition: All
271 -- Numeric classes ----------------------------------------------------------
273 class (Eq a, Show a) => Num a where
274 (+), (-), (*) :: a -> a -> a
276 abs, signum :: a -> a
277 fromInteger :: Integer -> a
280 -- Minimal complete definition: All, except negate or (-)
282 fromInt = fromIntegral
285 class (Num a, Ord a) => Real a where
286 toRational :: a -> Rational
288 class (Real a, Enum a) => Integral a where
289 quot, rem, div, mod :: a -> a -> a
290 quotRem, divMod :: a -> a -> (a,a)
291 even, odd :: a -> Bool
292 toInteger :: a -> Integer
295 -- Minimal complete definition: quotRem and toInteger
296 n `quot` d = q where (q,r) = quotRem n d
297 n `rem` d = r where (q,r) = quotRem n d
298 n `div` d = q where (q,r) = divMod n d
299 n `mod` d = r where (q,r) = divMod n d
300 divMod n d = if signum r == - signum d then (q-1, r+d) else qr
301 where qr@(q,r) = quotRem n d
302 even n = n `rem` 2 == 0
304 toInt = toInt . toInteger
306 class (Num a) => Fractional a where
309 fromRational :: Rational -> a
311 -- Minimal complete definition: fromRational and ((/) or recip)
315 fromDouble :: Fractional a => Double -> a
316 fromDouble n = fromRational (toRational n)
318 class (Fractional a) => Floating a where
320 exp, log, sqrt :: a -> a
321 (**), logBase :: a -> a -> a
322 sin, cos, tan :: a -> a
323 asin, acos, atan :: a -> a
324 sinh, cosh, tanh :: a -> a
325 asinh, acosh, atanh :: a -> a
327 -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
328 -- asinh, acosh, atanh
329 x ** y = exp (log x * y)
330 logBase x y = log y / log x
332 tan x = sin x / cos x
333 sinh x = (exp x - exp (-x)) / 2
334 cosh x = (exp x + exp (-x)) / 2
335 tanh x = sinh x / cosh x
336 asinh x = log (x + sqrt (x*x + 1))
337 acosh x = log (x + sqrt (x*x - 1))
338 atanh x = (log (1 + x) - log (1 - x)) / 2
340 class (Real a, Fractional a) => RealFrac a where
341 properFraction :: (Integral b) => a -> (b,a)
342 truncate, round :: (Integral b) => a -> b
343 ceiling, floor :: (Integral b) => a -> b
345 -- Minimal complete definition: properFraction
346 truncate x = m where (m,_) = properFraction x
348 round x = let (n,r) = properFraction x
349 m = if r < 0 then n - 1 else n + 1
350 in case signum (abs r - 0.5) of
352 0 -> if even n then n else m
355 ceiling x = if r > 0 then n + 1 else n
356 where (n,r) = properFraction x
358 floor x = if r < 0 then n - 1 else n
359 where (n,r) = properFraction x
361 class (RealFrac a, Floating a) => RealFloat a where
362 floatRadix :: a -> Integer
363 floatDigits :: a -> Int
364 floatRange :: a -> (Int,Int)
365 decodeFloat :: a -> (Integer,Int)
366 encodeFloat :: Integer -> Int -> a
368 significand :: a -> a
369 scaleFloat :: Int -> a -> a
370 isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
374 -- Minimal complete definition: All, except exponent, signficand,
376 exponent x = if m==0 then 0 else n + floatDigits x
377 where (m,n) = decodeFloat x
378 significand x = encodeFloat m (- floatDigits x)
379 where (m,_) = decodeFloat x
380 scaleFloat k x = encodeFloat m (n+k)
381 where (m,n) = decodeFloat x
385 | x<0 && y>0 = pi + atan (y/x)
387 (x<0 && isNegativeZero y) ||
388 (isNegativeZero x && isNegativeZero y)
390 | y==0 && (x<0 || isNegativeZero x)
391 = pi -- must be after the previous test on zero y
392 | x==0 && y==0 = y -- must be after the other double zero tests
393 | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
395 -- Numeric functions --------------------------------------------------------
397 subtract :: Num a => a -> a -> a
400 gcd :: Integral a => a -> a -> a
401 gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
402 gcd x y = gcd' (abs x) (abs y)
404 gcd' x y = gcd' y (x `rem` y)
406 lcm :: (Integral a) => a -> a -> a
409 lcm x y = abs ((x `quot` gcd x y) * y)
411 (^) :: (Num a, Integral b) => a -> b -> a
413 x ^ n | n > 0 = f x (n-1) x
415 f x n y = g x n where
416 g x n | even n = g (x*x) (n`quot`2)
417 | otherwise = f x (n-1) (x*y)
418 _ ^ _ = error "Prelude.^: negative exponent"
420 (^^) :: (Fractional a, Integral b) => a -> b -> a
421 x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
423 fromIntegral :: (Integral a, Num b) => a -> b
424 fromIntegral = fromInteger . toInteger
426 realToFrac :: (Real a, Fractional b) => a -> b
427 realToFrac = fromRational . toRational
429 -- Index and Enumeration classes --------------------------------------------
431 class (Ord a) => Ix a where
432 range :: (a,a) -> [a]
433 index :: (a,a) -> a -> Int
434 inRange :: (a,a) -> a -> Bool
435 rangeSize :: (a,a) -> Int
439 | otherwise = index r u + 1
445 enumFrom :: a -> [a] -- [n..]
446 enumFromThen :: a -> a -> [a] -- [n,m..]
447 enumFromTo :: a -> a -> [a] -- [n..m]
448 enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
450 -- Minimal complete definition: toEnum, fromEnum
451 succ = toEnum . (1+) . fromEnum
452 pred = toEnum . subtract 1 . fromEnum
453 enumFrom x = map toEnum [ fromEnum x .. ]
454 enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
455 enumFromThen x y = map toEnum [ fromEnum x, fromEnum y .. ]
456 enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
458 -- Read and Show classes ------------------------------------------------------
460 type ReadS a = String -> [(a,String)]
461 type ShowS = String -> String
464 readsPrec :: Int -> ReadS a
465 readList :: ReadS [a]
467 -- Minimal complete definition: readsPrec
468 readList = readParen False (\r -> [pr | ("[",s) <- lex r,
470 where readl s = [([],t) | ("]",t) <- lex s] ++
471 [(x:xs,u) | (x,t) <- reads s,
473 readl' s = [([],t) | ("]",t) <- lex s] ++
474 [(x:xs,v) | (",",t) <- lex s,
480 showsPrec :: Int -> a -> ShowS
481 showList :: [a] -> ShowS
483 -- Minimal complete definition: show or showsPrec
484 show x = showsPrec 0 x ""
485 showsPrec _ x s = show x ++ s
486 showList [] = showString "[]"
487 showList (x:xs) = showChar '[' . shows x . showl xs
488 where showl [] = showChar ']'
489 showl (x:xs) = showChar ',' . shows x . showl xs
491 -- Monad classes ------------------------------------------------------------
493 class Functor f where
494 fmap :: (a -> b) -> (f a -> f b)
498 (>>=) :: m a -> (a -> m b) -> m b
499 (>>) :: m a -> m b -> m b
500 fail :: String -> m a
502 -- Minimal complete definition: (>>=), return
503 p >> q = p >>= \ _ -> q
506 sequence :: Monad m => [m a] -> m [a]
507 sequence [] = return []
508 sequence (c:cs) = do x <- c
512 sequence_ :: Monad m => [m a] -> m ()
513 sequence_ = foldr (>>) (return ())
515 mapM :: Monad m => (a -> m b) -> [a] -> m [b]
516 mapM f = sequence . map f
518 mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
519 mapM_ f = sequence_ . map f
521 (=<<) :: Monad m => (a -> m b) -> m a -> m b
524 -- Evaluation and strictness ------------------------------------------------
527 seq x y = primSeq x y
529 ($!) :: (a -> b) -> a -> b
530 f $! x = x `primSeq` f x
532 -- Trivial type -------------------------------------------------------------
534 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
539 instance Ord () where
545 inRange ((),()) () = True
547 instance Enum () where
551 enumFromThen () () = [()]
553 instance Read () where
554 readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
557 instance Show () where
558 showsPrec p () = showString "()"
560 instance Bounded () where
564 -- Boolean type -------------------------------------------------------------
566 data Bool = False | True
567 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
569 (&&), (||) :: Bool -> Bool -> Bool
582 -- Character type -----------------------------------------------------------
584 data Char -- builtin datatype of ISO Latin characters
585 type String = [Char] -- strings are lists of characters
587 instance Eq Char where (==) = primEqChar
588 instance Ord Char where (<=) = primLeChar
590 instance Enum Char where
591 toEnum = primIntToChar
592 fromEnum = primCharToInt
593 enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
594 enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
595 where lastChar = if d < c then minBound else maxBound
597 instance Ix Char where
598 range (c,c') = [c..c']
600 | inRange b ci = fromEnum ci - fromEnum c
601 | otherwise = error "Ix.index: Index out of range."
602 inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
603 where i = fromEnum ci
605 instance Read Char where
606 readsPrec p = readParen False
607 (\r -> [(c,t) | ('\'':s,t) <- lex r,
608 (c,"\'") <- readLitChar s ])
609 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
611 where readl ('"':s) = [("",s)]
612 readl ('\\':'&':s) = readl s
613 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
615 instance Show Char where
616 showsPrec p '\'' = showString "'\\''"
617 showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
619 showList cs = showChar '"' . showl cs
620 where showl "" = showChar '"'
621 showl ('"':cs) = showString "\\\"" . showl cs
622 showl (c:cs) = showLitChar c . showl cs
624 instance Bounded Char where
628 isAscii, isControl, isPrint, isSpace :: Char -> Bool
629 isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
631 isAscii c = fromEnum c < 128
632 isControl c = c < ' ' || c == '\DEL'
633 isPrint c = c >= ' ' && c <= '~'
634 isSpace c = c == ' ' || c == '\t' || c == '\n' ||
635 c == '\r' || c == '\f' || c == '\v'
636 isUpper c = c >= 'A' && c <= 'Z'
637 isLower c = c >= 'a' && c <= 'z'
638 isAlpha c = isUpper c || isLower c
639 isDigit c = c >= '0' && c <= '9'
640 isAlphaNum c = isAlpha c || isDigit c
642 -- Digit conversion operations
643 digitToInt :: Char -> Int
645 | isDigit c = fromEnum c - fromEnum '0'
646 | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
647 | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
648 | otherwise = error "Char.digitToInt: not a digit"
650 intToDigit :: Int -> Char
652 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
653 | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
654 | otherwise = error "Char.intToDigit: not a digit"
656 toUpper, toLower :: Char -> Char
657 toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
660 toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
669 -- Maybe type ---------------------------------------------------------------
671 data Maybe a = Nothing | Just a
672 deriving (Eq, Ord, Read, Show)
674 maybe :: b -> (a -> b) -> Maybe a -> b
675 maybe n f Nothing = n
676 maybe n f (Just x) = f x
678 instance Functor Maybe where
679 fmap f Nothing = Nothing
680 fmap f (Just x) = Just (f x)
682 instance Monad Maybe where
684 Nothing >>= k = Nothing
688 -- Either type --------------------------------------------------------------
690 data Either a b = Left a | Right b
691 deriving (Eq, Ord, Read, Show)
693 either :: (a -> c) -> (b -> c) -> Either a b -> c
694 either l r (Left x) = l x
695 either l r (Right y) = r y
697 -- Ordering type ------------------------------------------------------------
699 data Ordering = LT | EQ | GT
700 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
702 -- Lists --------------------------------------------------------------------
704 --data [a] = [] | a : [a] deriving (Eq, Ord)
706 instance Eq a => Eq [a] where
708 (x:xs) == (y:ys) = x==y && xs==ys
711 instance Ord a => Ord [a] where
712 compare [] (_:_) = LT
714 compare (_:_) [] = GT
715 compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys)
717 instance Functor [] where
720 instance Monad [ ] where
721 (x:xs) >>= f = f x ++ (xs >>= f)
726 instance Read a => Read [a] where
727 readsPrec p = readList
729 instance Show a => Show [a] where
730 showsPrec p = showList
732 -- Tuples -------------------------------------------------------------------
734 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
737 -- Standard Integral types --------------------------------------------------
739 data Int -- builtin datatype of fixed size integers
740 data Integer -- builtin datatype of arbitrary size integers
742 instance Eq Integer where
743 (==) x y = primCompareInteger x y == 0
745 instance Ord Integer where
746 compare x y = case primCompareInteger x y of
751 instance Eq Int where
755 instance Ord Int where
761 instance Num Int where
764 negate = primNegateInt
768 fromInteger = primIntegerToInt
771 instance Bounded Int where
772 minBound = primMinInt
773 maxBound = primMaxInt
775 instance Num Integer where
776 (+) = primPlusInteger
777 (-) = primMinusInteger
778 negate = primNegateInteger
779 (*) = primTimesInteger
783 fromInt = primIntToInteger
785 absReal x | x >= 0 = x
788 signumReal x | x == 0 = 0
792 instance Real Int where
793 toRational x = toInteger x % 1
795 instance Real Integer where
798 instance Integral Int where
799 quotRem = primQuotRemInt
800 toInteger = primIntToInteger
803 instance Integral Integer where
804 quotRem = primQuotRemInteger
806 toInt = primIntegerToInt
808 instance Ix Int where
811 | inRange b i = i - m
812 | otherwise = error "index: Index out of range"
813 inRange (m,n) i = m <= i && i <= n
815 instance Ix Integer where
818 | inRange b i = fromInteger (i - m)
819 | otherwise = error "index: Index out of range"
820 inRange (m,n) i = m <= i && i <= n
822 instance Enum Int where
825 enumFrom = numericEnumFrom
826 enumFromTo = numericEnumFromTo
827 enumFromThen = numericEnumFromThen
828 enumFromThenTo = numericEnumFromThenTo
830 instance Enum Integer where
831 toEnum = primIntToInteger
832 fromEnum = primIntegerToInt
833 enumFrom = numericEnumFrom
834 enumFromTo = numericEnumFromTo
835 enumFromThen = numericEnumFromThen
836 enumFromThenTo = numericEnumFromThenTo
838 numericEnumFrom :: Real a => a -> [a]
839 numericEnumFromThen :: Real a => a -> a -> [a]
840 numericEnumFromTo :: Real a => a -> a -> [a]
841 numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
842 numericEnumFrom n = n : (numericEnumFrom $! (n+1))
843 numericEnumFromThen n m = iterate ((m-n)+) n
844 numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
845 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
846 where p | n' >= n = (<= m)
849 instance Read Int where
850 readsPrec p = readSigned readDec
852 instance Show Int where
854 | n == minBound = showSigned showInt p (toInteger n)
855 | otherwise = showSigned showInt p n
857 instance Read Integer where
858 readsPrec p = readSigned readDec
860 instance Show Integer where
861 showsPrec = showSigned showInt
864 -- Standard Floating types --------------------------------------------------
866 data Float -- builtin datatype of single precision floating point numbers
867 data Double -- builtin datatype of double precision floating point numbers
869 instance Eq Float where
873 instance Ord Float where
879 instance Num Float where
882 negate = primNegateFloat
886 fromInteger = primIntegerToFloat
887 fromInt = primIntToFloat
891 instance Eq Double where
895 instance Ord Double where
901 instance Num Double where
903 (-) = primMinusDouble
904 negate = primNegateDouble
905 (*) = primTimesDouble
908 fromInteger = primIntegerToDouble
909 fromInt = primIntToDouble
913 instance Real Float where
914 toRational = floatToRational
916 instance Real Double where
917 toRational = doubleToRational
919 -- Calls to these functions are optimised when passed as arguments to
921 floatToRational :: Float -> Rational
922 doubleToRational :: Double -> Rational
923 floatToRational x = realFloatToRational x
924 doubleToRational x = realFloatToRational x
926 realFloatToRational x = (m%1)*(b%1)^^n
927 where (m,n) = decodeFloat x
930 instance Fractional Float where
931 (/) = primDivideFloat
932 fromRational = rationalToRealFloat
934 instance Fractional Double where
935 (/) = primDivideDouble
936 fromRational = rationalToRealFloat
938 rationalToRealFloat x = x'
940 f e = if e' == e then y else f e'
941 where y = encodeFloat (round (x * (1%b)^^e)) e
942 (_,e') = decodeFloat y
943 (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
944 / fromInteger (denominator x))
947 instance Floating Float where
948 pi = 3.14159265358979323846
959 instance Floating Double where
960 pi = 3.14159265358979323846
963 sqrt = primSqrtDouble
967 asin = primAsinDouble
968 acos = primAcosDouble
969 atan = primAtanDouble
971 instance RealFrac Float where
972 properFraction = floatProperFraction
974 instance RealFrac Double where
975 properFraction = floatProperFraction
977 floatProperFraction x
978 | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
979 | otherwise = (fromInteger w, encodeFloat r n)
980 where (m,n) = decodeFloat x
982 (w,r) = quotRem m (b^(-n))
984 instance RealFloat Float where
985 floatRadix _ = toInteger primRadixFloat
986 floatDigits _ = primDigitsFloat
987 floatRange _ = (primMinExpFloat,primMaxExpFloat)
988 encodeFloat = primEncodeFloatZ
989 decodeFloat = primDecodeFloatZ
990 isNaN = primIsNaNFloat
991 isInfinite = primIsInfiniteFloat
992 isDenormalized= primIsDenormalizedFloat
993 isNegativeZero= primIsNegativeZeroFloat
994 isIEEE = const primIsIEEEFloat
996 instance RealFloat Double where
997 floatRadix _ = toInteger primRadixDouble
998 floatDigits _ = primDigitsDouble
999 floatRange _ = (primMinExpDouble,primMaxExpDouble)
1000 encodeFloat = primEncodeDoubleZ
1001 decodeFloat = primDecodeDoubleZ
1002 isNaN = primIsNaNDouble
1003 isInfinite = primIsInfiniteDouble
1004 isDenormalized= primIsDenormalizedDouble
1005 isNegativeZero= primIsNegativeZeroDouble
1006 isIEEE = const primIsIEEEDouble
1008 instance Enum Float where
1009 toEnum = primIntToFloat
1011 enumFrom = numericEnumFrom
1012 enumFromThen = numericEnumFromThen
1013 enumFromTo n m = numericEnumFromTo n (m+1/2)
1014 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
1016 instance Enum Double where
1017 toEnum = primIntToDouble
1019 enumFrom = numericEnumFrom
1020 enumFromThen = numericEnumFromThen
1021 enumFromTo n m = numericEnumFromTo n (m+1/2)
1022 enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
1024 instance Read Float where
1025 readsPrec p = readSigned readFloat
1027 instance Show Float where
1028 showsPrec p = showSigned showFloat p
1030 instance Read Double where
1031 readsPrec p = readSigned readFloat
1033 instance Show Double where
1034 showsPrec p = showSigned showFloat p
1037 -- Some standard functions --------------------------------------------------
1045 curry :: ((a,b) -> c) -> (a -> b -> c)
1046 curry f x y = f (x,y)
1048 uncurry :: (a -> b -> c) -> ((a,b) -> c)
1049 uncurry f p = f (fst p) (snd p)
1054 const :: a -> b -> a
1057 (.) :: (b -> c) -> (a -> b) -> (a -> c)
1060 flip :: (a -> b -> c) -> b -> a -> c
1063 ($) :: (a -> b) -> a -> b
1066 until :: (a -> Bool) -> (a -> a) -> a -> a
1067 until p f x = if p x then x else until p f (f x)
1069 asTypeOf :: a -> a -> a
1072 error :: String -> a
1073 error msg = primRaise (ErrorCall msg)
1076 undefined | False = undefined
1078 -- Standard functions on rational numbers {PreludeRatio} --------------------
1080 data Integral a => Ratio a = a :% a deriving (Eq)
1081 type Rational = Ratio Integer
1083 (%) :: Integral a => a -> a -> Ratio a
1084 x % y = reduce (x * signum y) (abs y)
1086 reduce :: Integral a => a -> a -> Ratio a
1087 reduce x y | y == 0 = error "Ratio.%: zero denominator"
1088 | otherwise = (x `quot` d) :% (y `quot` d)
1091 numerator, denominator :: Integral a => Ratio a -> a
1092 numerator (x :% y) = x
1093 denominator (x :% y) = y
1095 instance Integral a => Ord (Ratio a) where
1096 compare (x:%y) (x':%y') = compare (x*y') (x'*y)
1098 instance Integral a => Num (Ratio a) where
1099 (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
1100 (x:%y) * (x':%y') = reduce (x*x') (y*y')
1101 negate (x :% y) = negate x :% y
1102 abs (x :% y) = abs x :% y
1103 signum (x :% y) = signum x :% 1
1104 fromInteger x = fromInteger x :% 1
1105 fromInt = intToRatio
1107 -- Hugs optimises code of the form fromRational (intToRatio x)
1108 intToRatio :: Integral a => Int -> Ratio a
1109 intToRatio x = fromInt x :% 1
1111 instance Integral a => Real (Ratio a) where
1112 toRational (x:%y) = toInteger x :% toInteger y
1114 instance Integral a => Fractional (Ratio a) where
1115 (x:%y) / (x':%y') = (x*y') % (y*x')
1116 recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
1117 fromRational (x:%y) = fromInteger x :% fromInteger y
1119 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1120 doubleToRatio :: Integral a => Double -> Ratio a
1122 | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
1123 | otherwise = fromInteger m % (fromInteger b ^ (-n))
1124 where (m,n) = decodeFloat x
1127 instance Integral a => RealFrac (Ratio a) where
1128 properFraction (x:%y) = (fromIntegral q, r:%y)
1129 where (q,r) = quotRem x y
1131 instance Integral a => Enum (Ratio a) where
1134 enumFrom = numericEnumFrom
1135 enumFromThen = numericEnumFromThen
1137 instance (Read a, Integral a) => Read (Ratio a) where
1138 readsPrec p = readParen (p > 7)
1139 (\r -> [(x%y,u) | (x,s) <- reads r,
1143 instance Integral a => Show (Ratio a) where
1144 showsPrec p (x:%y) = showParen (p > 7)
1145 (shows x . showString " % " . shows y)
1147 approxRational :: RealFrac a => a -> a -> Rational
1148 approxRational x eps = simplest (x-eps) (x+eps)
1149 where simplest x y | y < x = simplest y x
1151 | x > 0 = simplest' n d n' d'
1152 | y < 0 = - simplest' (-n') d' (-n) d
1153 | otherwise = 0 :% 1
1154 where xr@(n:%d) = toRational x
1155 (n':%d') = toRational y
1156 simplest' n d n' d' -- assumes 0 < n%d < n'%d'
1158 | q /= q' = (q+1) :% 1
1159 | otherwise = (q*n''+d'') :% n''
1160 where (q,r) = quotRem n d
1161 (q',r') = quotRem n' d'
1162 (n'':%d'') = simplest' d' r' d r
1164 -- Standard list functions {PreludeList} ------------------------------------
1171 last (_:xs) = last xs
1178 init (x:xs) = x : init xs
1184 (++) :: [a] -> [a] -> [a]
1186 (x:xs) ++ ys = x : (xs ++ ys)
1188 map :: (a -> b) -> [a] -> [b]
1190 map f (x:xs) = f x : map f xs
1193 filter :: (a -> Bool) -> [a] -> [a]
1195 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1198 concat :: [[a]] -> [a]
1200 concat (xs:xss) = xs ++ concat xss
1202 length :: [a] -> Int
1203 length = foldl' (\n _ -> n + 1) 0
1205 (!!) :: [b] -> Int -> b
1207 (_:xs) !! n | n>0 = xs !! (n-1)
1208 (_:_) !! _ = error "Prelude.!!: negative index"
1209 [] !! _ = error "Prelude.!!: index too large"
1211 foldl :: (a -> b -> a) -> a -> [b] -> a
1213 foldl f z (x:xs) = foldl f (f z x) xs
1215 foldl' :: (a -> b -> a) -> a -> [b] -> a
1217 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1219 foldl1 :: (a -> a -> a) -> [a] -> a
1220 foldl1 f (x:xs) = foldl f x xs
1222 scanl :: (a -> b -> a) -> a -> [b] -> [a]
1223 scanl f q xs = q : (case xs of
1225 x:xs -> scanl f (f q x) xs)
1227 scanl1 :: (a -> a -> a) -> [a] -> [a]
1228 scanl1 f (x:xs) = scanl f x xs
1230 foldr :: (a -> b -> b) -> b -> [a] -> b
1232 foldr f z (x:xs) = f x (foldr f z xs)
1234 foldr1 :: (a -> a -> a) -> [a] -> a
1236 foldr1 f (x:xs) = f x (foldr1 f xs)
1238 scanr :: (a -> b -> b) -> b -> [a] -> [b]
1239 scanr f q0 [] = [q0]
1240 scanr f q0 (x:xs) = f x q : qs
1241 where qs@(q:_) = scanr f q0 xs
1243 scanr1 :: (a -> a -> a) -> [a] -> [a]
1245 scanr1 f (x:xs) = f x q : qs
1246 where qs@(q:_) = scanr1 f xs
1248 iterate :: (a -> a) -> a -> [a]
1249 iterate f x = x : iterate f (f x)
1252 repeat x = xs where xs = x:xs
1254 replicate :: Int -> a -> [a]
1255 replicate n x = take n (repeat x)
1258 cycle [] = error "Prelude.cycle: empty list"
1259 cycle xs = xs' where xs'=xs++xs'
1261 take :: Int -> [a] -> [a]
1264 take n (x:xs) | n>0 = x : take (n-1) xs
1265 take _ _ = error "Prelude.take: negative argument"
1267 drop :: Int -> [a] -> [a]
1270 drop n (_:xs) | n>0 = drop (n-1) xs
1271 drop _ _ = error "Prelude.drop: negative argument"
1273 splitAt :: Int -> [a] -> ([a], [a])
1274 splitAt 0 xs = ([],xs)
1275 splitAt _ [] = ([],[])
1276 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1277 splitAt _ _ = error "Prelude.splitAt: negative argument"
1279 takeWhile :: (a -> Bool) -> [a] -> [a]
1282 | p x = x : takeWhile p xs
1285 dropWhile :: (a -> Bool) -> [a] -> [a]
1287 dropWhile p xs@(x:xs')
1288 | p x = dropWhile p xs'
1291 span, break :: (a -> Bool) -> [a] -> ([a],[a])
1295 | otherwise = ([],xs)
1296 where (ys,zs) = span p xs'
1297 break p = span (not . p)
1299 lines :: String -> [String]
1301 lines s = let (l,s') = break ('\n'==) s
1302 in l : case s' of [] -> []
1303 (_:s'') -> lines s''
1305 words :: String -> [String]
1306 words s = case dropWhile isSpace s of
1309 where (w,s'') = break isSpace s'
1311 unlines :: [String] -> String
1312 unlines = concatMap (\l -> l ++ "\n")
1314 unwords :: [String] -> String
1316 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1318 reverse :: [a] -> [a]
1319 --reverse = foldl (flip (:)) []
1320 reverse xs = ri [] xs
1321 where ri acc [] = acc
1322 ri acc (x:xs) = ri (x:acc) xs
1324 and, or :: [Bool] -> Bool
1325 --and = foldr (&&) True
1326 --or = foldr (||) False
1328 and (x:xs) = if x then and xs else x
1330 or (x:xs) = if x then x else or xs
1332 any, all :: (a -> Bool) -> [a] -> Bool
1333 --any p = or . map p
1334 --all p = and . map p
1336 any p (x:xs) = if p x then True else any p xs
1338 all p (x:xs) = if p x then all p xs else False
1340 elem, notElem :: Eq a => a -> [a] -> Bool
1342 --notElem = all . (/=)
1344 elem x (y:ys) = if x==y then True else elem x ys
1346 notElem x (y:ys) = if x==y then False else notElem x ys
1348 lookup :: Eq a => a -> [(a,b)] -> Maybe b
1349 lookup k [] = Nothing
1350 lookup k ((x,y):xys)
1352 | otherwise = lookup k xys
1354 sum, product :: Num a => [a] -> a
1356 product = foldl' (*) 1
1358 maximum, minimum :: Ord a => [a] -> a
1359 maximum = foldl1 max
1360 minimum = foldl1 min
1362 concatMap :: (a -> [b]) -> [a] -> [b]
1363 concatMap f = concat . map f
1365 zip :: [a] -> [b] -> [(a,b)]
1366 zip = zipWith (\a b -> (a,b))
1368 zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
1369 zip3 = zipWith3 (\a b c -> (a,b,c))
1371 zipWith :: (a->b->c) -> [a]->[b]->[c]
1372 zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
1375 zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1376 zipWith3 z (a:as) (b:bs) (c:cs)
1377 = z a b c : zipWith3 z as bs cs
1378 zipWith3 _ _ _ _ = []
1380 unzip :: [(a,b)] -> ([a],[b])
1381 unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1383 unzip3 :: [(a,b,c)] -> ([a],[b],[c])
1384 unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1387 -- PreludeText ----------------------------------------------------------------
1389 reads :: Read a => ReadS a
1392 shows :: Show a => a -> ShowS
1395 read :: Read a => String -> a
1396 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1398 [] -> error "Prelude.read: no parse"
1399 _ -> error "Prelude.read: ambiguous parse"
1401 showChar :: Char -> ShowS
1404 showString :: String -> ShowS
1407 showParen :: Bool -> ShowS -> ShowS
1408 showParen b p = if b then showChar '(' . p . showChar ')' else p
1410 hugsprimShowField :: Show a => String -> a -> ShowS
1411 hugsprimShowField m v = showString m . showChar '=' . shows v
1413 readParen :: Bool -> ReadS a -> ReadS a
1414 readParen b g = if b then mandatory else optional
1415 where optional r = g r ++ mandatory r
1416 mandatory r = [(x,u) | ("(",s) <- lex r,
1417 (x,t) <- optional s,
1421 hugsprimReadField :: Read a => String -> ReadS a
1422 hugsprimReadField m s0 = [ r | (t, s1) <- lex s0, t == m,
1428 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1429 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1431 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1433 lexString ('"':s) = [("\"",s)]
1434 lexString s = [(ch++str, u)
1435 | (ch,t) <- lexStrItem s,
1436 (str,u) <- lexString t ]
1438 lexStrItem ('\\':'&':s) = [("\\&",s)]
1439 lexStrItem ('\\':c:s) | isSpace c
1440 = [("",t) | '\\':t <- [dropWhile isSpace s]]
1441 lexStrItem s = lexLitChar s
1443 lex (c:s) | isSingle c = [([c],s)]
1444 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
1445 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
1446 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
1447 (fe,t) <- lexFracExp s ]
1448 | otherwise = [] -- bad character
1450 isSingle c = c `elem` ",;()[]{}_`"
1451 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1452 isIdChar c = isAlphaNum c || c `elem` "_'"
1454 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1456 lexFracExp s = [("",s)]
1458 lexExp (e:s) | e `elem` "eE"
1459 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
1460 (ds,u) <- lexDigits t] ++
1461 [(e:ds,t) | (ds,t) <- lexDigits s]
1464 lexDigits :: ReadS String
1465 lexDigits = nonnull isDigit
1467 nonnull :: (Char -> Bool) -> ReadS String
1468 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1470 lexLitChar :: ReadS String
1471 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1473 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- "
1474 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
1475 lexEsc s@(d:_) | isDigit d = lexDigits s
1476 lexEsc s@(c:_) | isUpper c
1477 = let table = ('\DEL',"DEL") : asciiTab
1478 in case [(mne,s') | (c, mne) <- table,
1479 ([],s') <- [lexmatch mne s]]
1483 lexLitChar (c:s) = [([c],s)]
1486 isOctDigit c = c >= '0' && c <= '7'
1487 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
1488 || c >= 'a' && c <= 'f'
1490 lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
1491 lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
1492 lexmatch xs ys = (xs,ys)
1494 asciiTab = zip ['\NUL'..' ']
1495 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1496 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
1497 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1498 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
1501 readLitChar :: ReadS Char
1502 readLitChar ('\\':s) = readEsc s
1504 readEsc ('a':s) = [('\a',s)]
1505 readEsc ('b':s) = [('\b',s)]
1506 readEsc ('f':s) = [('\f',s)]
1507 readEsc ('n':s) = [('\n',s)]
1508 readEsc ('r':s) = [('\r',s)]
1509 readEsc ('t':s) = [('\t',s)]
1510 readEsc ('v':s) = [('\v',s)]
1511 readEsc ('\\':s) = [('\\',s)]
1512 readEsc ('"':s) = [('"',s)]
1513 readEsc ('\'':s) = [('\'',s)]
1514 readEsc ('^':c:s) | c >= '@' && c <= '_'
1515 = [(toEnum (fromEnum c - fromEnum '@'), s)]
1516 readEsc s@(d:_) | isDigit d
1517 = [(toEnum n, t) | (n,t) <- readDec s]
1518 readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
1519 readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
1520 readEsc s@(c:_) | isUpper c
1521 = let table = ('\DEL',"DEL") : asciiTab
1522 in case [(c,s') | (c, mne) <- table,
1523 ([],s') <- [lexmatch mne s]]
1527 readLitChar (c:s) = [(c,s)]
1529 showLitChar :: Char -> ShowS
1530 showLitChar c | c > '\DEL' = showChar '\\' .
1531 protectEsc isDigit (shows (fromEnum c))
1532 showLitChar '\DEL' = showString "\\DEL"
1533 showLitChar '\\' = showString "\\\\"
1534 showLitChar c | c >= ' ' = showChar c
1535 showLitChar '\a' = showString "\\a"
1536 showLitChar '\b' = showString "\\b"
1537 showLitChar '\f' = showString "\\f"
1538 showLitChar '\n' = showString "\\n"
1539 showLitChar '\r' = showString "\\r"
1540 showLitChar '\t' = showString "\\t"
1541 showLitChar '\v' = showString "\\v"
1542 showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
1543 showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
1545 protectEsc p f = f . cont
1546 where cont s@(c:_) | p c = "\\&" ++ s
1549 -- Unsigned readers for various bases
1550 readDec, readOct, readHex :: Integral a => ReadS a
1551 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1552 readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1553 readHex = readInt 16 isHexDigit hex
1554 where hex d = fromEnum d -
1557 else fromEnum (if isUpper d then 'A' else 'a') - 10)
1559 -- readInt reads a string of digits using an arbitrary base.
1560 -- Leading minus signs must be handled elsewhere.
1562 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1563 readInt radix isDig digToInt s =
1564 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1565 | (ds,r) <- nonnull isDig s ]
1567 -- showInt is used for positive numbers only
1568 showInt :: Integral a => a -> ShowS
1571 = error "Numeric.showInt: can't show negative numbers"
1574 = let (n',d) = quotRem n 10
1575 r' = toEnum (fromEnum '0' + fromIntegral d) : r
1576 in if n' == 0 then r' else showInt n' r'
1578 = case quotRem n 10 of { (n',d) ->
1579 let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1580 in if n' == 0 then r' else showInt n' r'
1584 readSigned:: Real a => ReadS a -> ReadS a
1585 readSigned readPos = readParen False read'
1586 where read' r = read'' r ++
1587 [(-x,t) | ("-",s) <- lex r,
1589 read'' r = [(n,s) | (str,s) <- lex r,
1590 (n,"") <- readPos str]
1592 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1593 showSigned showPos p x = if x < 0 then showParen (p > 6)
1594 (showChar '-' . showPos (-x))
1597 readFloat :: RealFloat a => ReadS a
1598 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1600 where readFix r = [(read (ds++ds'), length ds', t)
1601 | (ds, s) <- lexDigits r
1602 , (ds',t) <- lexFrac s ]
1604 lexFrac ('.':s) = lexDigits s
1605 lexFrac s = [("",s)]
1607 readExp (e:s) | e `elem` "eE" = readExp' s
1610 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1611 readExp' ('+':s) = readDec s
1612 readExp' s = readDec s
1615 -- Hooks for primitives: -----------------------------------------------------
1616 -- Do not mess with these!
1618 hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering
1619 hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1621 hugsprimEqChar :: Char -> Char -> Bool
1622 hugsprimEqChar c1 c2 = primEqChar c1 c2
1624 hugsprimPmInt :: Num a => Int -> a -> Bool
1625 hugsprimPmInt n x = fromInt n == x
1627 hugsprimPmInteger :: Num a => Integer -> a -> Bool
1628 hugsprimPmInteger n x = fromInteger n == x
1630 hugsprimPmDouble :: Fractional a => Double -> a -> Bool
1631 hugsprimPmDouble n x = fromDouble n == x
1633 -- ToDo: make the message more informative.
1635 hugsprimPmFail = error "Pattern Match Failure"
1637 -- used in desugaring Foreign functions
1638 -- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
1639 -- bit of code of type RealWorld -> (a,RealWorld) into a proper IO value.
1640 -- What follows is the version for standalone mode. ghc/lib/std/PrelHugs.lhs
1641 -- contains a version used in combined mode. That version takes care of
1642 -- switching between the GHC and Hugs IO representations, which are different.
1643 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1646 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1647 hugsprimCreateAdjThunk fun typestr callconv
1648 = do sp <- makeStablePtr fun
1649 p <- copy_String_to_cstring typestr -- is never freed
1650 a <- primCreateAdjThunkARCH sp p callconv
1653 -- The following primitives are only needed if (n+k) patterns are enabled:
1654 hugsprimPmSub :: Integral a => Int -> a -> a
1655 hugsprimPmSub n x = x - fromInt n
1657 hugsprimPmFromInteger :: Integral a => Integer -> a
1658 hugsprimPmFromInteger = fromIntegral
1660 hugsprimPmSubtract :: Integral a => a -> a -> a
1661 hugsprimPmSubtract x y = x - y
1663 hugsprimPmLe :: Integral a => a -> a -> Bool
1664 hugsprimPmLe x y = x <= y
1666 -- Unpack strings generated by the Hugs code generator.
1667 -- Strings can contain \0 provided they're coded right.
1669 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1671 hugsprimUnpackString :: Addr -> String
1672 hugsprimUnpackString a = unpack 0
1674 -- The following decoding is based on evalString in the old machine.c
1677 | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1678 then '\\' : unpack (i+2)
1679 else '\0' : unpack (i+2)
1680 | otherwise = c : unpack (i+1)
1682 c = primIndexCharOffAddr a i
1685 -- Monadic I/O: --------------------------------------------------------------
1687 type FilePath = String
1689 --data IOError = ...
1690 --instance Eq IOError ...
1691 --instance Show IOError ...
1693 data IOError = IOError String
1694 instance Show IOError where
1695 showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1697 ioError :: IOError -> IO a
1698 ioError e@(IOError _) = primRaise (IOException e)
1700 userError :: String -> IOError
1701 userError s = primRaise (ErrorCall s)
1703 throw :: Exception -> a
1704 throw exception = primRaise exception
1706 catchException :: IO a -> (Exception -> IO a) -> IO a
1707 catchException m k = IO (\s -> unIO m s `primCatch` \ err -> unIO (k err) s)
1709 catch :: IO a -> (IOError -> IO a) -> IO a
1710 catch m k = catchException m handler
1711 where handler (IOException err) = k err
1712 handler other = throw other
1714 putChar :: Char -> IO ()
1715 putChar c = nh_stdout >>= \h -> nh_write h c
1717 putStr :: String -> IO ()
1718 putStr s = nh_stdout >>= \h ->
1719 let loop [] = nh_flush h
1720 loop (c:cs) = nh_write h c >> loop cs
1723 putStrLn :: String -> IO ()
1724 putStrLn s = do { putStr s; putChar '\n' }
1726 print :: Show a => a -> IO ()
1727 print = putStrLn . show
1730 getChar = nh_stdin >>= \h ->
1731 nh_read h >>= \ci ->
1732 return (primIntToChar ci)
1734 getLine :: IO String
1735 getLine = do c <- getChar
1736 if c=='\n' then return ""
1737 else do cs <- getLine
1740 getContents :: IO String
1741 getContents = nh_stdin >>= \h -> readfromhandle h
1743 interact :: (String -> String) -> IO ()
1744 interact f = getContents >>= (putStr . f)
1746 readFile :: FilePath -> IO String
1748 = copy_String_to_cstring fname >>= \ptr ->
1749 nh_open ptr 0 >>= \h ->
1751 nh_errno >>= \errno ->
1752 if (isNullAddr h || errno /= 0)
1753 then (ioError.IOError) ("readFile: can't open file " ++ fname)
1754 else readfromhandle h
1756 writeFile :: FilePath -> String -> IO ()
1757 writeFile fname contents
1758 = copy_String_to_cstring fname >>= \ptr ->
1759 nh_open ptr 1 >>= \h ->
1761 nh_errno >>= \errno ->
1762 if (isNullAddr h || errno /= 0)
1763 then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1764 else writetohandle fname h contents
1766 appendFile :: FilePath -> String -> IO ()
1767 appendFile fname contents
1768 = copy_String_to_cstring fname >>= \ptr ->
1769 nh_open ptr 2 >>= \h ->
1771 nh_errno >>= \errno ->
1772 if (isNullAddr h || errno /= 0)
1773 then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1774 else writetohandle fname h contents
1777 -- raises an exception instead of an error
1778 readIO :: Read a => String -> IO a
1779 readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1781 [] -> ioError (userError "PreludeIO.readIO: no parse")
1782 _ -> ioError (userError
1783 "PreludeIO.readIO: ambiguous parse")
1785 readLn :: Read a => IO a
1786 readLn = do l <- getLine
1791 -- End of Hugs standard prelude ----------------------------------------------
1793 = IOException IOError -- IO exceptions (from 'ioError')
1794 | ArithException ArithException -- Arithmetic exceptions
1795 | ErrorCall String -- Calls to 'error'
1796 | NoMethodError String -- A non-existent method was invoked
1797 | PatternMatchFail String -- A pattern match failed
1798 | NonExhaustiveGuards String -- A guard match failed
1799 | RecSelError String -- Selecting a non-existent field
1800 | RecConError String -- Field missing in record construction
1801 | RecUpdError String -- Record doesn't contain updated field
1802 | AssertionFailed String -- Assertions
1803 | DynException Dynamic -- Dynamic exceptions
1804 | AsyncException AsyncException -- Externally generated errors
1805 | PutFullMVar -- Put on a full MVar
1822 stackOverflow, heapOverflow :: Exception -- for the RTS
1823 stackOverflow = AsyncException StackOverflow
1824 heapOverflow = AsyncException HeapOverflow
1826 instance Show ArithException where
1827 showsPrec _ Overflow = showString "arithmetic overflow"
1828 showsPrec _ Underflow = showString "arithmetic underflow"
1829 showsPrec _ LossOfPrecision = showString "loss of precision"
1830 showsPrec _ DivideByZero = showString "divide by zero"
1831 showsPrec _ Denormal = showString "denormal"
1833 instance Show AsyncException where
1834 showsPrec _ StackOverflow = showString "stack overflow"
1835 showsPrec _ HeapOverflow = showString "heap overflow"
1836 showsPrec _ ThreadKilled = showString "thread killed"
1838 instance Show Exception where
1839 showsPrec _ (IOException err) = shows err
1840 showsPrec _ (ArithException err) = shows err
1841 showsPrec _ (ErrorCall err) = showString ("error: " ++ err)
1842 showsPrec _ (NoMethodError err) = showString err
1843 showsPrec _ (PatternMatchFail err) = showString err
1844 showsPrec _ (NonExhaustiveGuards err) = showString err
1845 showsPrec _ (RecSelError err) = showString err
1846 showsPrec _ (RecConError err) = showString err
1847 showsPrec _ (RecUpdError err) = showString err
1848 showsPrec _ (AssertionFailed err) = showString err
1849 showsPrec _ (AsyncException e) = shows e
1850 showsPrec _ (DynException _err) = showString "unknown exception"
1851 showsPrec _ (PutFullMVar) = showString "putMVar: full MVar"
1852 showsPrec _ (NonTermination) = showString "<<loop>>"
1854 data Dynamic = Dynamic TypeRep Obj
1856 data Obj = Obj -- dummy type to hold the dynamically typed value.
1858 = App TyCon [TypeRep]
1859 | Fun TypeRep TypeRep
1862 data TyCon = TyCon Int String
1864 instance Eq TyCon where
1865 (TyCon t1 _) == (TyCon t2 _) = t1 == t2
1867 data IOResult = IOResult deriving (Show)
1869 type FILE_STAR = Addr -- FILE *
1871 foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR
1872 foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
1873 foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
1874 foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Char -> IO ()
1875 foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int
1876 foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR
1877 foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO ()
1878 foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO ()
1879 foreign import "nHandle" "nh_errno" nh_errno :: IO Int
1881 foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
1882 foreign import "nHandle" "nh_free" nh_free :: Addr -> IO ()
1883 foreign import "nHandle" "nh_store" nh_store :: Addr -> Char -> IO ()
1884 foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Char
1885 foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
1886 foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int
1887 foreign import "nHandle" "nh_iseof" nh_iseof :: FILE_STAR -> IO Int
1888 foreign import "nHandle" "nh_system" nh_system :: Addr -> IO Int
1889 foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO ()
1890 foreign import "nHandle" "nh_getPID" nh_getPID :: IO Int
1892 foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double
1893 foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double
1895 copy_String_to_cstring :: String -> IO Addr
1896 copy_String_to_cstring s
1897 = nh_malloc (1 + length s) >>= \ptr0 ->
1898 let loop ptr [] = nh_store ptr (chr 0) >> return ptr0
1899 loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs
1902 then error "copy_String_to_cstring: malloc failed"
1905 copy_cstring_to_String :: Addr -> IO String
1906 copy_cstring_to_String ptr
1907 = nh_load ptr >>= \ci ->
1910 else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1913 readfromhandle :: FILE_STAR -> IO String
1915 = unsafeInterleaveIO (
1916 nh_read h >>= \ci ->
1917 if ci == -1 {-EOF-} then return "" else
1918 readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1921 writetohandle :: String -> FILE_STAR -> String -> IO ()
1922 writetohandle fname h []
1924 nh_errno >>= \errno ->
1927 else error ( "writeFile/appendFile: error closing file " ++ fname)
1928 writetohandle fname h (c:cs)
1929 = nh_write h c >> writetohandle fname h cs
1931 primGetRawArgs :: IO [String]
1933 = primGetArgc >>= \argc ->
1934 sequence (map get_one_arg [0 .. argc-1])
1936 get_one_arg :: Int -> IO String
1938 = primGetArgv argno >>= \a ->
1939 copy_cstring_to_String a
1941 primGetEnv :: String -> IO String
1943 = copy_String_to_cstring v >>= \ptr ->
1944 nh_getenv ptr >>= \ptr2 ->
1947 then ioError (IOError "getEnv failed")
1949 copy_cstring_to_String ptr2 >>= \result ->
1953 ------------------------------------------------------------------------------
1954 -- ST ------------------------------------------------------------------------
1955 ------------------------------------------------------------------------------
1957 newtype ST s a = ST (s -> (a,s))
1958 unST :: ST s a -> s -> (a,s)
1960 mkST :: (s -> (a,s)) -> ST s a
1964 runST :: (__forall s . ST s a) -> a
1965 runST m = fst (unST m alpha)
1967 alpha = error "runST: entered the RealWorld"
1969 instance Functor (ST s) where
1970 fmap f x = x >>= (return . f)
1972 instance Monad (ST s) where
1973 m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1974 return x = ST (\s -> (x,s))
1975 m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1977 unsafeInterleaveST :: ST s a -> ST s a
1978 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1980 ------------------------------------------------------------------------------
1981 -- IO ------------------------------------------------------------------------
1982 ------------------------------------------------------------------------------
1984 newtype IO a = IO (RealWorld -> (a,RealWorld))
1987 stToIO :: ST RealWorld a -> IO a
1988 stToIO (ST fn) = IO fn
1990 ioToST :: IO a -> ST RealWorld a
1991 ioToST (IO fn) = ST fn
1993 unsafePerformIO :: IO a -> a
1994 unsafePerformIO m = fst (unIO m theWorld)
1996 theWorld :: RealWorld
1997 theWorld = error "unsafePerformIO: entered the RealWorld"
1999 instance Functor IO where
2000 fmap f x = x >>= (return . f)
2002 instance Monad IO where
2003 m >> k = IO (\s -> case unIO m s of { (a,s') -> unIO k s' })
2004 return x = IO (\s -> (x,s))
2005 m >>= k = IO (\s -> case unIO m s of { (a,s') -> unIO (k a) s' })
2007 -- Library IO has a global variable which accumulates Handles
2008 -- as they are opened. We keep here a second global variable
2009 -- into which a cleanup action may be specified. When evaluation
2010 -- finishes, either normally or as a result of System.exitWith,
2011 -- this cleanup action is run, closing all known-about Handles.
2012 -- Doing it like this means the Prelude does not have to know
2013 -- anything about the grotty details of the Handle implementation.
2014 prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
2015 prelCleanupAfterRunAction = unsafePerformIO (newIORef Nothing)
2017 -- used when Hugs invokes top level function
2018 hugsprimRunIO_toplevel :: IO a -> ()
2019 hugsprimRunIO_toplevel m
2020 = protect 5 (fst (unIO composite_action realWorld))
2023 = do writeIORef prelCleanupAfterRunAction Nothing
2025 cleanup_handles <- readIORef prelCleanupAfterRunAction
2026 case cleanup_handles of
2027 Nothing -> return ()
2030 realWorld = error "primRunIO: entered the RealWorld"
2031 protect :: Int -> () -> ()
2035 = primCatch (protect (n-1) comp)
2036 (\e -> fst (unIO (putStr (show e ++ "\n")) realWorld))
2038 unsafeInterleaveIO :: IO a -> IO a
2039 unsafeInterleaveIO m = IO (\ s -> (fst (unIO m s), s))
2041 ------------------------------------------------------------------------------
2042 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
2043 ------------------------------------------------------------------------------
2047 nullAddr = primIntToAddr 0
2048 incAddr a = primIntToAddr (1 + primAddrToInt a)
2049 isNullAddr a = 0 == primAddrToInt a
2051 instance Eq Addr where
2055 instance Ord Addr where
2063 instance Eq Word where
2067 instance Ord Word where
2075 makeStablePtr :: a -> IO (StablePtr a)
2076 makeStablePtr = primMakeStablePtr
2077 deRefStablePtr :: StablePtr a -> IO a
2078 deRefStablePtr = primDeRefStablePtr
2079 freeStablePtr :: StablePtr a -> IO ()
2080 freeStablePtr = primFreeStablePtr
2083 data PrimArray a -- immutable arrays with Int indices
2086 data STRef s a -- mutable variables
2087 data PrimMutableArray s a -- mutable arrays with Int indices
2088 data PrimMutableByteArray s
2090 newSTRef :: a -> ST s (STRef s a)
2091 newSTRef = primNewRef
2092 readSTRef :: STRef s a -> ST s a
2093 readSTRef = primReadRef
2094 writeSTRef :: STRef s a -> a -> ST s ()
2095 writeSTRef = primWriteRef
2097 newtype IORef a = IORef (STRef RealWorld a)
2098 newIORef :: a -> IO (IORef a)
2099 newIORef a = stToIO (primNewRef a >>= \ ref ->return (IORef ref))
2100 readIORef :: IORef a -> IO a
2101 readIORef (IORef ref) = stToIO (primReadRef ref)
2102 writeIORef :: IORef a -> a -> IO ()
2103 writeIORef (IORef ref) a = stToIO (primWriteRef ref a)
2106 ------------------------------------------------------------------------------
2107 -- ThreadId, MVar, concurrency stuff -----------------------------------------
2108 ------------------------------------------------------------------------------
2112 newEmptyMVar :: IO (MVar a)
2113 newEmptyMVar = primNewEmptyMVar
2115 putMVar :: MVar a -> a -> IO ()
2116 putMVar = primPutMVar
2118 takeMVar :: MVar a -> IO a
2120 = IO (\world -> primTakeMVar m cont world)
2122 -- cont :: a -> RealWorld -> (a,RealWorld)
2123 -- where 'a' is as in the top-level signature
2124 cont x world = (x,world)
2126 -- the type of the handwritten BCO (threesome) primTakeMVar is
2127 -- primTakeMVar :: MVar a
2128 -- -> (a -> RealWorld -> (a,RealWorld))
2132 -- primTakeMVar behaves like this:
2134 -- primTakeMVar (MVar# m#) cont world
2135 -- = primTakeMVar_wrk m# cont world
2137 -- primTakeMVar_wrk m# cont world
2138 -- = cont (takeMVar# m#) world
2140 -- primTakeMVar_wrk has the special property that it is
2141 -- restartable by the scheduler, should the MVar be empty.
2143 newMVar :: a -> IO (MVar a)
2145 newEmptyMVar >>= \ mvar ->
2146 putMVar mvar value >>
2149 readMVar :: MVar a -> IO a
2151 takeMVar mvar >>= \ value ->
2152 putMVar mvar value >>
2155 swapMVar :: MVar a -> a -> IO a
2157 takeMVar mvar >>= \ old ->
2161 isEmptyMVar var = error "isEmptyMVar is not (yet) implemented in Hugs"
2163 instance Eq (MVar a) where
2164 m1 == m2 = primSameMVar m1 m2
2168 instance Eq ThreadId where
2169 tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
2171 instance Ord ThreadId where
2173 = let r = primCmpThreadIds tid1 tid2
2174 in if r < 0 then LT else if r > 0 then GT else EQ
2177 forkIO :: IO a -> IO ThreadId
2178 -- Simple version; doesn't catch exceptions in computation
2179 -- forkIO computation
2180 -- = primForkIO (unsafePerformIO computation)
2185 (unIO computation realWorld `primSeq` ())
2186 (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
2189 realWorld = error "primForkIO: entered the RealWorld"
2192 = (unsafePerformIO (putStr (s ++ "\n"))) `seq` x
2195 -- Foreign ------------------------------------------------------------------
2199 -- showFloat ------------------------------------------------------------------
2201 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2202 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2203 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2204 showFloat :: (RealFloat a) => a -> ShowS
2206 showEFloat d x = showString (formatRealFloat FFExponent d x)
2207 showFFloat d x = showString (formatRealFloat FFFixed d x)
2208 showGFloat d x = showString (formatRealFloat FFGeneric d x)
2209 showFloat = showGFloat Nothing
2211 -- These are the format types. This type is not exported.
2213 data FFFormat = FFExponent | FFFixed | FFGeneric
2215 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2216 formatRealFloat fmt decs x = s
2220 else if isInfinite x then
2221 if x < 0 then "-Infinity" else "Infinity"
2222 else if x < 0 || isNegativeZero x then
2223 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2225 doFmt fmt (floatToDigits (toInteger base) x)
2227 let ds = map intToDigit is
2230 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2237 [d] -> d : ".0e" ++ show (e-1)
2238 d:ds -> d : '.' : ds ++ 'e':show (e-1)
2240 let dec' = max dec 1 in
2242 [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2244 let (ei, is') = roundTo base (dec'+1) is
2245 d:ds = map intToDigit
2246 (if ei > 0 then init is' else is')
2247 in d:'.':ds ++ "e" ++ show (e-1+ei)
2251 let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2252 f n s "" = f (n-1) (s++"0") ""
2253 f n s (d:ds) = f (n-1) (s++[d]) ds
2258 let dec' = max dec 0 in
2260 let (ei, is') = roundTo base (dec' + e) is
2261 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2262 in (if null ls then "0" else ls) ++
2263 (if null rs then "" else '.' : rs)
2265 let (ei, is') = roundTo base dec'
2266 (replicate (-e) 0 ++ is)
2267 d : ds = map intToDigit
2268 (if ei > 0 then is' else 0:is')
2271 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2272 roundTo base d is = case f d is of
2274 (1, is) -> (1, 1 : is)
2275 where b2 = base `div` 2
2276 f n [] = (0, replicate n 0)
2277 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2279 let (c, ds) = f (d-1) is
2281 in if i' == base then (1, 0:ds) else (0, i':ds)
2283 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2284 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2285 -- This version uses a much slower logarithm estimator. It should be improved.
2287 -- This function returns a list of digits (Ints in [0..base-1]) and an
2290 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2292 floatToDigits _ 0 = ([0], 0)
2293 floatToDigits base x =
2294 let (f0, e0) = decodeFloat x
2295 (minExp0, _) = floatRange x
2298 minExp = minExp0 - p -- the real minimum exponent
2299 -- Haskell requires that f be adjusted so denormalized numbers
2300 -- will have an impossibly low exponent. Adjust for this.
2301 (f, e) = let n = minExp - e0
2302 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2307 if f == b^(p-1) then
2308 (f*be*b*2, 2*b, be*b, b)
2312 if e > minExp && f == b^(p-1) then
2313 (f*b*2, b^(-e+1)*2, b, 1)
2315 (f*2, b^(-e)*2, 1, 1)
2318 if b == 2 && base == 10 then
2319 -- logBase 10 2 is slightly bigger than 3/10 so
2320 -- the following will err on the low side. Ignoring
2321 -- the fraction will make it err even more.
2322 -- Haskell promises that p-1 <= logBase b f < p.
2323 (p - 1 + e0) * 3 `div` 10
2325 ceiling ((log (fromInteger (f+1)) +
2326 fromInt e * log (fromInteger b)) /
2327 log (fromInteger base))
2330 if r + mUp <= expt base n * s then n else fixup (n+1)
2332 if expt base (-n) * (r + mUp) <= s then n
2336 gen ds rn sN mUpN mDnN =
2337 let (dn, rn') = (rn * base) `divMod` sN
2340 in case (rn' < mDnN', rn' + mUpN' > sN) of
2341 (True, False) -> dn : ds
2342 (False, True) -> dn+1 : ds
2343 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2344 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2347 gen [] r (s * expt base k) mUp mDn
2349 let bk = expt base (-k)
2350 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
2351 in (map toInt (reverse rds), k)
2354 -- Exponentiation with a cache for the most common numbers.
2357 expt :: Integer -> Int -> Integer
2359 if base == 2 && n >= minExpt && n <= maxExpt then
2360 expts !! (n-minExpt)
2365 expts = [2^n | n <- [minExpt .. maxExpt]]
2369 , noMethodBindingError
2370 , nonExhaustiveGuardsError
2374 , recUpdError :: String -> a
2376 noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
2377 irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
2378 nonExhaustiveGuardsError s = throw (NonExhaustiveGuards (untangle s "Non-exhaustive guards in"))
2379 patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
2380 recSelError s = throw (RecSelError (untangle s "Missing field in record selection"))
2381 recConError s = throw (RecConError (untangle s "Missing field in record construction"))
2382 recUpdError s = throw (RecUpdError (untangle s "Record doesn't contain field(s) to be updated"))
2385 tangleMessage :: String -> Int -> String
2386 tangleMessage "" line = show line
2387 tangleMessage str line = str ++ show line
2389 assertError :: String -> Bool -> a -> a
2390 assertError str pred v
2392 | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
2395 (untangle coded message) expects "coded" to be of the form
2401 location message details
2404 untangle :: String -> String -> String
2405 untangle coded message
2413 = case (span not_bar coded) of { (loc, rest) ->
2415 ('|':det) -> (loc, ' ' : det)
2418 not_bar c = c /= '|'
2420 -- By default, we ignore asserts, but optionally, Hugs translates
2421 -- assert ==> assertError "<location info>"
2423 assert :: Bool -> a -> a