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
310 fromDouble :: Double -> a
312 -- Minimal complete definition: fromRational and ((/) or recip)
316 class (Fractional a) => Floating a where
318 exp, log, sqrt :: a -> a
319 (**), logBase :: a -> a -> a
320 sin, cos, tan :: a -> a
321 asin, acos, atan :: a -> a
322 sinh, cosh, tanh :: a -> a
323 asinh, acosh, atanh :: a -> a
325 -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
326 -- asinh, acosh, atanh
327 x ** y = exp (log x * y)
328 logBase x y = log y / log x
330 tan x = sin x / cos x
331 sinh x = (exp x - exp (-x)) / 2
332 cosh x = (exp x + exp (-x)) / 2
333 tanh x = sinh x / cosh x
334 asinh x = log (x + sqrt (x*x + 1))
335 acosh x = log (x + sqrt (x*x - 1))
336 atanh x = (log (1 + x) - log (1 - x)) / 2
338 class (Real a, Fractional a) => RealFrac a where
339 properFraction :: (Integral b) => a -> (b,a)
340 truncate, round :: (Integral b) => a -> b
341 ceiling, floor :: (Integral b) => a -> b
343 -- Minimal complete definition: properFraction
344 truncate x = m where (m,_) = properFraction x
346 round x = let (n,r) = properFraction x
347 m = if r < 0 then n - 1 else n + 1
348 in case signum (abs r - 0.5) of
350 0 -> if even n then n else m
353 ceiling x = if r > 0 then n + 1 else n
354 where (n,r) = properFraction x
356 floor x = if r < 0 then n - 1 else n
357 where (n,r) = properFraction x
359 class (RealFrac a, Floating a) => RealFloat a where
360 floatRadix :: a -> Integer
361 floatDigits :: a -> Int
362 floatRange :: a -> (Int,Int)
363 decodeFloat :: a -> (Integer,Int)
364 encodeFloat :: Integer -> Int -> a
366 significand :: a -> a
367 scaleFloat :: Int -> a -> a
368 isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
372 -- Minimal complete definition: All, except exponent, signficand,
374 exponent x = if m==0 then 0 else n + floatDigits x
375 where (m,n) = decodeFloat x
376 significand x = encodeFloat m (- floatDigits x)
377 where (m,_) = decodeFloat x
378 scaleFloat k x = encodeFloat m (n+k)
379 where (m,n) = decodeFloat x
383 | x<0 && y>0 = pi + atan (y/x)
385 (x<0 && isNegativeZero y) ||
386 (isNegativeZero x && isNegativeZero y)
388 | y==0 && (x<0 || isNegativeZero x)
389 = pi -- must be after the previous test on zero y
390 | x==0 && y==0 = y -- must be after the other double zero tests
391 | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
393 -- Numeric functions --------------------------------------------------------
395 subtract :: Num a => a -> a -> a
398 gcd :: Integral a => a -> a -> a
399 gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
400 gcd x y = gcd' (abs x) (abs y)
402 gcd' x y = gcd' y (x `rem` y)
404 lcm :: (Integral a) => a -> a -> a
407 lcm x y = abs ((x `quot` gcd x y) * y)
409 (^) :: (Num a, Integral b) => a -> b -> a
411 x ^ n | n > 0 = f x (n-1) x
413 f x n y = g x n where
414 g x n | even n = g (x*x) (n`quot`2)
415 | otherwise = f x (n-1) (x*y)
416 _ ^ _ = error "Prelude.^: negative exponent"
418 (^^) :: (Fractional a, Integral b) => a -> b -> a
419 x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
421 fromIntegral :: (Integral a, Num b) => a -> b
422 fromIntegral = fromInteger . toInteger
424 realToFrac :: (Real a, Fractional b) => a -> b
425 realToFrac = fromRational . toRational
427 -- Index and Enumeration classes --------------------------------------------
429 class (Ord a) => Ix a where
430 range :: (a,a) -> [a]
431 index :: (a,a) -> a -> Int
432 inRange :: (a,a) -> a -> Bool
433 rangeSize :: (a,a) -> Int
437 | otherwise = index r u + 1
443 enumFrom :: a -> [a] -- [n..]
444 enumFromThen :: a -> a -> [a] -- [n,m..]
445 enumFromTo :: a -> a -> [a] -- [n..m]
446 enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
448 -- Minimal complete definition: toEnum, fromEnum
449 succ = toEnum . (1+) . fromEnum
450 pred = toEnum . subtract 1 . fromEnum
451 enumFrom x = map toEnum [ fromEnum x .. ]
452 enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
453 enumFromThen x y = map toEnum [ fromEnum x, fromEnum y .. ]
454 enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
456 -- Read and Show classes ------------------------------------------------------
458 type ReadS a = String -> [(a,String)]
459 type ShowS = String -> String
462 readsPrec :: Int -> ReadS a
463 readList :: ReadS [a]
465 -- Minimal complete definition: readsPrec
466 readList = readParen False (\r -> [pr | ("[",s) <- lex r,
468 where readl s = [([],t) | ("]",t) <- lex s] ++
469 [(x:xs,u) | (x,t) <- reads s,
471 readl' s = [([],t) | ("]",t) <- lex s] ++
472 [(x:xs,v) | (",",t) <- lex s,
478 showsPrec :: Int -> a -> ShowS
479 showList :: [a] -> ShowS
481 -- Minimal complete definition: show or showsPrec
482 show x = showsPrec 0 x ""
483 showsPrec _ x s = show x ++ s
484 showList [] = showString "[]"
485 showList (x:xs) = showChar '[' . shows x . showl xs
486 where showl [] = showChar ']'
487 showl (x:xs) = showChar ',' . shows x . showl xs
489 -- Monad classes ------------------------------------------------------------
491 class Functor f where
492 fmap :: (a -> b) -> (f a -> f b)
496 (>>=) :: m a -> (a -> m b) -> m b
497 (>>) :: m a -> m b -> m b
498 fail :: String -> m a
500 -- Minimal complete definition: (>>=), return
501 p >> q = p >>= \ _ -> q
504 sequence :: Monad m => [m a] -> m [a]
505 sequence [] = return []
506 sequence (c:cs) = do x <- c
510 sequence_ :: Monad m => [m a] -> m ()
511 sequence_ = foldr (>>) (return ())
513 mapM :: Monad m => (a -> m b) -> [a] -> m [b]
514 mapM f = sequence . map f
516 mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
517 mapM_ f = sequence_ . map f
519 (=<<) :: Monad m => (a -> m b) -> m a -> m b
522 -- Evaluation and strictness ------------------------------------------------
525 seq x y = primSeq x y
527 ($!) :: (a -> b) -> a -> b
528 f $! x = x `primSeq` f x
530 -- Trivial type -------------------------------------------------------------
532 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
537 instance Ord () where
543 inRange ((),()) () = True
545 instance Enum () where
549 enumFromThen () () = [()]
551 instance Read () where
552 readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
555 instance Show () where
556 showsPrec p () = showString "()"
558 instance Bounded () where
562 -- Boolean type -------------------------------------------------------------
564 data Bool = False | True
565 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
567 (&&), (||) :: Bool -> Bool -> Bool
580 -- Character type -----------------------------------------------------------
582 data Char -- builtin datatype of ISO Latin characters
583 type String = [Char] -- strings are lists of characters
585 instance Eq Char where (==) = primEqChar
586 instance Ord Char where (<=) = primLeChar
588 instance Enum Char where
589 toEnum = primIntToChar
590 fromEnum = primCharToInt
591 enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
592 enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
593 where lastChar = if d < c then minBound else maxBound
595 instance Ix Char where
596 range (c,c') = [c..c']
598 | inRange b ci = fromEnum ci - fromEnum c
599 | otherwise = error "Ix.index: Index out of range."
600 inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
601 where i = fromEnum ci
603 instance Read Char where
604 readsPrec p = readParen False
605 (\r -> [(c,t) | ('\'':s,t) <- lex r,
606 (c,"\'") <- readLitChar s ])
607 readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
609 where readl ('"':s) = [("",s)]
610 readl ('\\':'&':s) = readl s
611 readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
613 instance Show Char where
614 showsPrec p '\'' = showString "'\\''"
615 showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
617 showList cs = showChar '"' . showl cs
618 where showl "" = showChar '"'
619 showl ('"':cs) = showString "\\\"" . showl cs
620 showl (c:cs) = showLitChar c . showl cs
622 instance Bounded Char where
626 isAscii, isControl, isPrint, isSpace :: Char -> Bool
627 isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
629 isAscii c = fromEnum c < 128
630 isControl c = c < ' ' || c == '\DEL'
631 isPrint c = c >= ' ' && c <= '~'
632 isSpace c = c == ' ' || c == '\t' || c == '\n' ||
633 c == '\r' || c == '\f' || c == '\v'
634 isUpper c = c >= 'A' && c <= 'Z'
635 isLower c = c >= 'a' && c <= 'z'
636 isAlpha c = isUpper c || isLower c
637 isDigit c = c >= '0' && c <= '9'
638 isAlphaNum c = isAlpha c || isDigit c
640 -- Digit conversion operations
641 digitToInt :: Char -> Int
643 | isDigit c = fromEnum c - fromEnum '0'
644 | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
645 | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
646 | otherwise = error "Char.digitToInt: not a digit"
648 intToDigit :: Int -> Char
650 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
651 | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
652 | otherwise = error "Char.intToDigit: not a digit"
654 toUpper, toLower :: Char -> Char
655 toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
658 toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
667 -- Maybe type ---------------------------------------------------------------
669 data Maybe a = Nothing | Just a
670 deriving (Eq, Ord, Read, Show)
672 maybe :: b -> (a -> b) -> Maybe a -> b
673 maybe n f Nothing = n
674 maybe n f (Just x) = f x
676 instance Functor Maybe where
677 fmap f Nothing = Nothing
678 fmap f (Just x) = Just (f x)
680 instance Monad Maybe where
682 Nothing >>= k = Nothing
686 -- Either type --------------------------------------------------------------
688 data Either a b = Left a | Right b
689 deriving (Eq, Ord, Read, Show)
691 either :: (a -> c) -> (b -> c) -> Either a b -> c
692 either l r (Left x) = l x
693 either l r (Right y) = r y
695 -- Ordering type ------------------------------------------------------------
697 data Ordering = LT | EQ | GT
698 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
700 -- Lists --------------------------------------------------------------------
702 --data [a] = [] | a : [a] deriving (Eq, Ord)
704 instance Eq a => Eq [a] where
706 (x:xs) == (y:ys) = x==y && xs==ys
709 instance Ord a => Ord [a] where
710 compare [] (_:_) = LT
712 compare (_:_) [] = GT
713 compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys)
715 instance Functor [] where
718 instance Monad [ ] where
719 (x:xs) >>= f = f x ++ (xs >>= f)
724 instance Read a => Read [a] where
725 readsPrec p = readList
727 instance Show a => Show [a] where
728 showsPrec p = showList
730 -- Tuples -------------------------------------------------------------------
732 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
735 -- Standard Integral types --------------------------------------------------
737 data Int -- builtin datatype of fixed size integers
738 data Integer -- builtin datatype of arbitrary size integers
740 instance Eq Integer where
741 (==) x y = primCompareInteger x y == 0
743 instance Ord Integer where
744 compare x y = case primCompareInteger x y of
749 instance Eq Int where
753 instance Ord Int where
759 instance Num Int where
762 negate = primNegateInt
766 fromInteger = primIntegerToInt
769 instance Bounded Int where
770 minBound = primMinInt
771 maxBound = primMaxInt
773 instance Num Integer where
774 (+) = primPlusInteger
775 (-) = primMinusInteger
776 negate = primNegateInteger
777 (*) = primTimesInteger
781 fromInt = primIntToInteger
783 absReal x | x >= 0 = x
786 signumReal x | x == 0 = 0
790 instance Real Int where
791 toRational x = toInteger x % 1
793 instance Real Integer where
796 instance Integral Int where
797 quotRem = primQuotRemInt
798 toInteger = primIntToInteger
801 instance Integral Integer where
802 quotRem = primQuotRemInteger
804 toInt = primIntegerToInt
806 instance Ix Int where
809 | inRange b i = i - m
810 | otherwise = error "index: Index out of range"
811 inRange (m,n) i = m <= i && i <= n
813 instance Ix Integer where
816 | inRange b i = fromInteger (i - m)
817 | otherwise = error "index: Index out of range"
818 inRange (m,n) i = m <= i && i <= n
820 instance Enum Int where
823 enumFrom = numericEnumFrom
824 enumFromTo = numericEnumFromTo
825 enumFromThen = numericEnumFromThen
826 enumFromThenTo = numericEnumFromThenTo
828 instance Enum Integer where
829 toEnum = primIntToInteger
830 fromEnum = primIntegerToInt
831 enumFrom = numericEnumFrom
832 enumFromTo = numericEnumFromTo
833 enumFromThen = numericEnumFromThen
834 enumFromThenTo = numericEnumFromThenTo
836 numericEnumFrom :: Real a => a -> [a]
837 numericEnumFromThen :: Real a => a -> a -> [a]
838 numericEnumFromTo :: Real a => a -> a -> [a]
839 numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
840 numericEnumFrom n = n : (numericEnumFrom $! (n+1))
841 numericEnumFromThen n m = iterate ((m-n)+) n
842 numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
843 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
844 where p | n' >= n = (<= m)
847 instance Read Int where
848 readsPrec p = readSigned readDec
850 instance Show Int where
852 | n == minBound = showSigned showInt p (toInteger n)
853 | otherwise = showSigned showInt p n
855 instance Read Integer where
856 readsPrec p = readSigned readDec
858 instance Show Integer where
859 showsPrec = showSigned showInt
862 -- Standard Floating types --------------------------------------------------
864 data Float -- builtin datatype of single precision floating point numbers
865 data Double -- builtin datatype of double precision floating point numbers
867 instance Eq Float where
871 instance Ord Float where
877 instance Num Float where
880 negate = primNegateFloat
884 fromInteger = primIntegerToFloat
885 fromInt = primIntToFloat
889 instance Eq Double where
893 instance Ord Double where
899 instance Num Double where
901 (-) = primMinusDouble
902 negate = primNegateDouble
903 (*) = primTimesDouble
906 fromInteger = primIntegerToDouble
907 fromInt = primIntToDouble
911 instance Real Float where
912 toRational = floatToRational
914 instance Real Double where
915 toRational = doubleToRational
917 -- Calls to these functions are optimised when passed as arguments to
919 floatToRational :: Float -> Rational
920 doubleToRational :: Double -> Rational
921 floatToRational x = realFloatToRational x
922 doubleToRational x = realFloatToRational x
924 realFloatToRational x = (m%1)*(b%1)^^n
925 where (m,n) = decodeFloat x
928 instance Fractional Float where
929 (/) = primDivideFloat
930 fromRational = rationalToRealFloat
931 fromDouble = primDoubleToFloat
933 instance Fractional Double where
934 (/) = primDivideDouble
935 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
1118 fromDouble = doubleToRatio
1120 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1121 doubleToRatio :: Integral a => Double -> Ratio a
1123 | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
1124 | otherwise = fromInteger m % (fromInteger b ^ (-n))
1125 where (m,n) = decodeFloat x
1128 instance Integral a => RealFrac (Ratio a) where
1129 properFraction (x:%y) = (fromIntegral q, r:%y)
1130 where (q,r) = quotRem x y
1132 instance Integral a => Enum (Ratio a) where
1135 enumFrom = numericEnumFrom
1136 enumFromThen = numericEnumFromThen
1138 instance (Read a, Integral a) => Read (Ratio a) where
1139 readsPrec p = readParen (p > 7)
1140 (\r -> [(x%y,u) | (x,s) <- reads r,
1144 instance Integral a => Show (Ratio a) where
1145 showsPrec p (x:%y) = showParen (p > 7)
1146 (shows x . showString " % " . shows y)
1148 approxRational :: RealFrac a => a -> a -> Rational
1149 approxRational x eps = simplest (x-eps) (x+eps)
1150 where simplest x y | y < x = simplest y x
1152 | x > 0 = simplest' n d n' d'
1153 | y < 0 = - simplest' (-n') d' (-n) d
1154 | otherwise = 0 :% 1
1155 where xr@(n:%d) = toRational x
1156 (n':%d') = toRational y
1157 simplest' n d n' d' -- assumes 0 < n%d < n'%d'
1159 | q /= q' = (q+1) :% 1
1160 | otherwise = (q*n''+d'') :% n''
1161 where (q,r) = quotRem n d
1162 (q',r') = quotRem n' d'
1163 (n'':%d'') = simplest' d' r' d r
1165 -- Standard list functions {PreludeList} ------------------------------------
1172 last (_:xs) = last xs
1179 init (x:xs) = x : init xs
1185 (++) :: [a] -> [a] -> [a]
1187 (x:xs) ++ ys = x : (xs ++ ys)
1189 map :: (a -> b) -> [a] -> [b]
1191 map f (x:xs) = f x : map f xs
1194 filter :: (a -> Bool) -> [a] -> [a]
1196 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1199 concat :: [[a]] -> [a]
1201 concat (xs:xss) = xs ++ concat xss
1203 length :: [a] -> Int
1204 length = foldl' (\n _ -> n + 1) 0
1206 (!!) :: [b] -> Int -> b
1208 (_:xs) !! n | n>0 = xs !! (n-1)
1209 (_:_) !! _ = error "Prelude.!!: negative index"
1210 [] !! _ = error "Prelude.!!: index too large"
1212 foldl :: (a -> b -> a) -> a -> [b] -> a
1214 foldl f z (x:xs) = foldl f (f z x) xs
1216 foldl' :: (a -> b -> a) -> a -> [b] -> a
1218 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1220 foldl1 :: (a -> a -> a) -> [a] -> a
1221 foldl1 f (x:xs) = foldl f x xs
1223 scanl :: (a -> b -> a) -> a -> [b] -> [a]
1224 scanl f q xs = q : (case xs of
1226 x:xs -> scanl f (f q x) xs)
1228 scanl1 :: (a -> a -> a) -> [a] -> [a]
1229 scanl1 f (x:xs) = scanl f x xs
1231 foldr :: (a -> b -> b) -> b -> [a] -> b
1233 foldr f z (x:xs) = f x (foldr f z xs)
1235 foldr1 :: (a -> a -> a) -> [a] -> a
1237 foldr1 f (x:xs) = f x (foldr1 f xs)
1239 scanr :: (a -> b -> b) -> b -> [a] -> [b]
1240 scanr f q0 [] = [q0]
1241 scanr f q0 (x:xs) = f x q : qs
1242 where qs@(q:_) = scanr f q0 xs
1244 scanr1 :: (a -> a -> a) -> [a] -> [a]
1246 scanr1 f (x:xs) = f x q : qs
1247 where qs@(q:_) = scanr1 f xs
1249 iterate :: (a -> a) -> a -> [a]
1250 iterate f x = x : iterate f (f x)
1253 repeat x = xs where xs = x:xs
1255 replicate :: Int -> a -> [a]
1256 replicate n x = take n (repeat x)
1259 cycle [] = error "Prelude.cycle: empty list"
1260 cycle xs = xs' where xs'=xs++xs'
1262 take :: Int -> [a] -> [a]
1265 take n (x:xs) | n>0 = x : take (n-1) xs
1266 take _ _ = error "Prelude.take: negative argument"
1268 drop :: Int -> [a] -> [a]
1271 drop n (_:xs) | n>0 = drop (n-1) xs
1272 drop _ _ = error "Prelude.drop: negative argument"
1274 splitAt :: Int -> [a] -> ([a], [a])
1275 splitAt 0 xs = ([],xs)
1276 splitAt _ [] = ([],[])
1277 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1278 splitAt _ _ = error "Prelude.splitAt: negative argument"
1280 takeWhile :: (a -> Bool) -> [a] -> [a]
1283 | p x = x : takeWhile p xs
1286 dropWhile :: (a -> Bool) -> [a] -> [a]
1288 dropWhile p xs@(x:xs')
1289 | p x = dropWhile p xs'
1292 span, break :: (a -> Bool) -> [a] -> ([a],[a])
1296 | otherwise = ([],xs)
1297 where (ys,zs) = span p xs'
1298 break p = span (not . p)
1300 lines :: String -> [String]
1302 lines s = let (l,s') = break ('\n'==) s
1303 in l : case s' of [] -> []
1304 (_:s'') -> lines s''
1306 words :: String -> [String]
1307 words s = case dropWhile isSpace s of
1310 where (w,s'') = break isSpace s'
1312 unlines :: [String] -> String
1313 unlines = concatMap (\l -> l ++ "\n")
1315 unwords :: [String] -> String
1317 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1319 reverse :: [a] -> [a]
1320 --reverse = foldl (flip (:)) []
1321 reverse xs = ri [] xs
1322 where ri acc [] = acc
1323 ri acc (x:xs) = ri (x:acc) xs
1325 and, or :: [Bool] -> Bool
1326 --and = foldr (&&) True
1327 --or = foldr (||) False
1329 and (x:xs) = if x then and xs else x
1331 or (x:xs) = if x then x else or xs
1333 any, all :: (a -> Bool) -> [a] -> Bool
1334 --any p = or . map p
1335 --all p = and . map p
1337 any p (x:xs) = if p x then True else any p xs
1339 all p (x:xs) = if p x then all p xs else False
1341 elem, notElem :: Eq a => a -> [a] -> Bool
1343 --notElem = all . (/=)
1345 elem x (y:ys) = if x==y then True else elem x ys
1347 notElem x (y:ys) = if x==y then False else notElem x ys
1349 lookup :: Eq a => a -> [(a,b)] -> Maybe b
1350 lookup k [] = Nothing
1351 lookup k ((x,y):xys)
1353 | otherwise = lookup k xys
1355 sum, product :: Num a => [a] -> a
1357 product = foldl' (*) 1
1359 maximum, minimum :: Ord a => [a] -> a
1360 maximum = foldl1 max
1361 minimum = foldl1 min
1363 concatMap :: (a -> [b]) -> [a] -> [b]
1364 concatMap f = concat . map f
1366 zip :: [a] -> [b] -> [(a,b)]
1367 zip = zipWith (\a b -> (a,b))
1369 zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
1370 zip3 = zipWith3 (\a b c -> (a,b,c))
1372 zipWith :: (a->b->c) -> [a]->[b]->[c]
1373 zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
1376 zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1377 zipWith3 z (a:as) (b:bs) (c:cs)
1378 = z a b c : zipWith3 z as bs cs
1379 zipWith3 _ _ _ _ = []
1381 unzip :: [(a,b)] -> ([a],[b])
1382 unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1384 unzip3 :: [(a,b,c)] -> ([a],[b],[c])
1385 unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1388 -- PreludeText ----------------------------------------------------------------
1390 reads :: Read a => ReadS a
1393 shows :: Show a => a -> ShowS
1396 read :: Read a => String -> a
1397 read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1399 [] -> error "Prelude.read: no parse"
1400 _ -> error "Prelude.read: ambiguous parse"
1402 showChar :: Char -> ShowS
1405 showString :: String -> ShowS
1408 showParen :: Bool -> ShowS -> ShowS
1409 showParen b p = if b then showChar '(' . p . showChar ')' else p
1411 hugsprimShowField :: Show a => String -> a -> ShowS
1412 hugsprimShowField m v = showString m . showChar '=' . shows v
1414 readParen :: Bool -> ReadS a -> ReadS a
1415 readParen b g = if b then mandatory else optional
1416 where optional r = g r ++ mandatory r
1417 mandatory r = [(x,u) | ("(",s) <- lex r,
1418 (x,t) <- optional s,
1422 hugsprimReadField :: Read a => String -> ReadS a
1423 hugsprimReadField m s0 = [ r | (t, s1) <- lex s0, t == m,
1429 lex (c:s) | isSpace c = lex (dropWhile isSpace s)
1430 lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
1432 lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
1434 lexString ('"':s) = [("\"",s)]
1435 lexString s = [(ch++str, u)
1436 | (ch,t) <- lexStrItem s,
1437 (str,u) <- lexString t ]
1439 lexStrItem ('\\':'&':s) = [("\\&",s)]
1440 lexStrItem ('\\':c:s) | isSpace c
1441 = [("",t) | '\\':t <- [dropWhile isSpace s]]
1442 lexStrItem s = lexLitChar s
1444 lex (c:s) | isSingle c = [([c],s)]
1445 | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
1446 | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
1447 | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
1448 (fe,t) <- lexFracExp s ]
1449 | otherwise = [] -- bad character
1451 isSingle c = c `elem` ",;()[]{}_`"
1452 isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
1453 isIdChar c = isAlphaNum c || c `elem` "_'"
1455 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1457 lexFracExp s = [("",s)]
1459 lexExp (e:s) | e `elem` "eE"
1460 = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
1461 (ds,u) <- lexDigits t] ++
1462 [(e:ds,t) | (ds,t) <- lexDigits s]
1465 lexDigits :: ReadS String
1466 lexDigits = nonnull isDigit
1468 nonnull :: (Char -> Bool) -> ReadS String
1469 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
1471 lexLitChar :: ReadS String
1472 lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
1474 lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- "
1475 lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
1476 lexEsc s@(d:_) | isDigit d = lexDigits s
1477 lexEsc s@(c:_) | isUpper c
1478 = let table = ('\DEL',"DEL") : asciiTab
1479 in case [(mne,s') | (c, mne) <- table,
1480 ([],s') <- [lexmatch mne s]]
1484 lexLitChar (c:s) = [([c],s)]
1487 isOctDigit c = c >= '0' && c <= '7'
1488 isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
1489 || c >= 'a' && c <= 'f'
1491 lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
1492 lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
1493 lexmatch xs ys = (xs,ys)
1495 asciiTab = zip ['\NUL'..' ']
1496 ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1497 "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
1498 "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1499 "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
1502 readLitChar :: ReadS Char
1503 readLitChar ('\\':s) = readEsc s
1505 readEsc ('a':s) = [('\a',s)]
1506 readEsc ('b':s) = [('\b',s)]
1507 readEsc ('f':s) = [('\f',s)]
1508 readEsc ('n':s) = [('\n',s)]
1509 readEsc ('r':s) = [('\r',s)]
1510 readEsc ('t':s) = [('\t',s)]
1511 readEsc ('v':s) = [('\v',s)]
1512 readEsc ('\\':s) = [('\\',s)]
1513 readEsc ('"':s) = [('"',s)]
1514 readEsc ('\'':s) = [('\'',s)]
1515 readEsc ('^':c:s) | c >= '@' && c <= '_'
1516 = [(toEnum (fromEnum c - fromEnum '@'), s)]
1517 readEsc s@(d:_) | isDigit d
1518 = [(toEnum n, t) | (n,t) <- readDec s]
1519 readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
1520 readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
1521 readEsc s@(c:_) | isUpper c
1522 = let table = ('\DEL',"DEL") : asciiTab
1523 in case [(c,s') | (c, mne) <- table,
1524 ([],s') <- [lexmatch mne s]]
1528 readLitChar (c:s) = [(c,s)]
1530 showLitChar :: Char -> ShowS
1531 showLitChar c | c > '\DEL' = showChar '\\' .
1532 protectEsc isDigit (shows (fromEnum c))
1533 showLitChar '\DEL' = showString "\\DEL"
1534 showLitChar '\\' = showString "\\\\"
1535 showLitChar c | c >= ' ' = showChar c
1536 showLitChar '\a' = showString "\\a"
1537 showLitChar '\b' = showString "\\b"
1538 showLitChar '\f' = showString "\\f"
1539 showLitChar '\n' = showString "\\n"
1540 showLitChar '\r' = showString "\\r"
1541 showLitChar '\t' = showString "\\t"
1542 showLitChar '\v' = showString "\\v"
1543 showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
1544 showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
1546 protectEsc p f = f . cont
1547 where cont s@(c:_) | p c = "\\&" ++ s
1550 -- Unsigned readers for various bases
1551 readDec, readOct, readHex :: Integral a => ReadS a
1552 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1553 readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1554 readHex = readInt 16 isHexDigit hex
1555 where hex d = fromEnum d -
1558 else fromEnum (if isUpper d then 'A' else 'a') - 10)
1560 -- readInt reads a string of digits using an arbitrary base.
1561 -- Leading minus signs must be handled elsewhere.
1563 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1564 readInt radix isDig digToInt s =
1565 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1566 | (ds,r) <- nonnull isDig s ]
1568 -- showInt is used for positive numbers only
1569 showInt :: Integral a => a -> ShowS
1572 = error "Numeric.showInt: can't show negative numbers"
1575 = let (n',d) = quotRem n 10
1576 r' = toEnum (fromEnum '0' + fromIntegral d) : r
1577 in if n' == 0 then r' else showInt n' r'
1579 = case quotRem n 10 of { (n',d) ->
1580 let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1581 in if n' == 0 then r' else showInt n' r'
1585 readSigned:: Real a => ReadS a -> ReadS a
1586 readSigned readPos = readParen False read'
1587 where read' r = read'' r ++
1588 [(-x,t) | ("-",s) <- lex r,
1590 read'' r = [(n,s) | (str,s) <- lex r,
1591 (n,"") <- readPos str]
1593 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1594 showSigned showPos p x = if x < 0 then showParen (p > 6)
1595 (showChar '-' . showPos (-x))
1598 readFloat :: RealFloat a => ReadS a
1599 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1601 where readFix r = [(read (ds++ds'), length ds', t)
1602 | (ds, s) <- lexDigits r
1603 , (ds',t) <- lexFrac s ]
1605 lexFrac ('.':s) = lexDigits s
1606 lexFrac s = [("",s)]
1608 readExp (e:s) | e `elem` "eE" = readExp' s
1611 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1612 readExp' ('+':s) = readDec s
1613 readExp' s = readDec s
1616 -- Hooks for primitives: -----------------------------------------------------
1617 -- Do not mess with these!
1619 hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering
1620 hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1622 hugsprimEqChar :: Char -> Char -> Bool
1623 hugsprimEqChar c1 c2 = primEqChar c1 c2
1625 hugsprimPmInt :: Num a => Int -> a -> Bool
1626 hugsprimPmInt n x = fromInt n == x
1628 hugsprimPmInteger :: Num a => Integer -> a -> Bool
1629 hugsprimPmInteger n x = fromInteger n == x
1631 hugsprimPmDouble :: Fractional a => Double -> a -> Bool
1632 hugsprimPmDouble n x = fromDouble n == x
1634 -- ToDo: make the message more informative.
1636 hugsprimPmFail = error "Pattern Match Failure"
1638 -- used in desugaring Foreign functions
1639 -- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
1640 -- bit of code of type RealWorld -> (a,RealWorld) into a proper IO value.
1641 -- What follows is the version for standalone mode. ghc/lib/std/PrelHugs.lhs
1642 -- contains a version used in combined mode. That version takes care of
1643 -- switching between the GHC and Hugs IO representations, which are different.
1644 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1647 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1648 hugsprimCreateAdjThunk fun typestr callconv
1649 = do sp <- makeStablePtr fun
1650 p <- copy_String_to_cstring typestr -- is never freed
1651 a <- primCreateAdjThunkARCH sp p callconv
1654 -- The following primitives are only needed if (n+k) patterns are enabled:
1655 hugsprimPmSub :: Integral a => Int -> a -> a
1656 hugsprimPmSub n x = x - fromInt n
1658 hugsprimPmFromInteger :: Integral a => Integer -> a
1659 hugsprimPmFromInteger = fromIntegral
1661 hugsprimPmSubtract :: Integral a => a -> a -> a
1662 hugsprimPmSubtract x y = x - y
1664 hugsprimPmLe :: Integral a => a -> a -> Bool
1665 hugsprimPmLe x y = x <= y
1667 -- Unpack strings generated by the Hugs code generator.
1668 -- Strings can contain \0 provided they're coded right.
1670 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1672 hugsprimUnpackString :: Addr -> String
1673 hugsprimUnpackString a = unpack 0
1675 -- The following decoding is based on evalString in the old machine.c
1678 | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1679 then '\\' : unpack (i+2)
1680 else '\0' : unpack (i+2)
1681 | otherwise = c : unpack (i+1)
1683 c = primIndexCharOffAddr a i
1686 -- Monadic I/O: --------------------------------------------------------------
1688 type FilePath = String
1690 --data IOError = ...
1691 --instance Eq IOError ...
1692 --instance Show IOError ...
1694 data IOError = IOError String
1695 instance Show IOError where
1696 showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1698 ioError :: IOError -> IO a
1699 ioError e@(IOError _) = primRaise (IOException e)
1701 userError :: String -> IOError
1702 userError s = primRaise (ErrorCall s)
1704 throw :: Exception -> a
1705 throw exception = primRaise exception
1707 catchException :: IO a -> (Exception -> IO a) -> IO a
1708 catchException m k = IO (\s -> unIO m s `primCatch` \ err -> unIO (k err) s)
1710 catch :: IO a -> (IOError -> IO a) -> IO a
1711 catch m k = catchException m handler
1712 where handler (IOException err) = k err
1713 handler other = throw other
1715 putChar :: Char -> IO ()
1716 putChar c = nh_stdout >>= \h -> nh_write h c
1718 putStr :: String -> IO ()
1719 putStr s = nh_stdout >>= \h ->
1720 let loop [] = nh_flush h
1721 loop (c:cs) = nh_write h c >> loop cs
1724 putStrLn :: String -> IO ()
1725 putStrLn s = do { putStr s; putChar '\n' }
1727 print :: Show a => a -> IO ()
1728 print = putStrLn . show
1731 getChar = nh_stdin >>= \h ->
1732 nh_read h >>= \ci ->
1733 return (primIntToChar ci)
1735 getLine :: IO String
1736 getLine = do c <- getChar
1737 if c=='\n' then return ""
1738 else do cs <- getLine
1741 getContents :: IO String
1742 getContents = nh_stdin >>= \h -> readfromhandle h
1744 interact :: (String -> String) -> IO ()
1745 interact f = getContents >>= (putStr . f)
1747 readFile :: FilePath -> IO String
1749 = copy_String_to_cstring fname >>= \ptr ->
1750 nh_open ptr 0 >>= \h ->
1752 nh_errno >>= \errno ->
1753 if (isNullAddr h || errno /= 0)
1754 then (ioError.IOError) ("readFile: can't open file " ++ fname)
1755 else readfromhandle h
1757 writeFile :: FilePath -> String -> IO ()
1758 writeFile fname contents
1759 = copy_String_to_cstring fname >>= \ptr ->
1760 nh_open ptr 1 >>= \h ->
1762 nh_errno >>= \errno ->
1763 if (isNullAddr h || errno /= 0)
1764 then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1765 else writetohandle fname h contents
1767 appendFile :: FilePath -> String -> IO ()
1768 appendFile fname contents
1769 = copy_String_to_cstring fname >>= \ptr ->
1770 nh_open ptr 2 >>= \h ->
1772 nh_errno >>= \errno ->
1773 if (isNullAddr h || errno /= 0)
1774 then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1775 else writetohandle fname h contents
1778 -- raises an exception instead of an error
1779 readIO :: Read a => String -> IO a
1780 readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
1782 [] -> ioError (userError "PreludeIO.readIO: no parse")
1783 _ -> ioError (userError
1784 "PreludeIO.readIO: ambiguous parse")
1786 readLn :: Read a => IO a
1787 readLn = do l <- getLine
1792 -- End of Hugs standard prelude ----------------------------------------------
1794 = IOException IOError -- IO exceptions (from 'ioError')
1795 | ArithException ArithException -- Arithmetic exceptions
1796 | ErrorCall String -- Calls to 'error'
1797 | NoMethodError String -- A non-existent method was invoked
1798 | PatternMatchFail String -- A pattern match failed
1799 | NonExhaustiveGuards String -- A guard match failed
1800 | RecSelError String -- Selecting a non-existent field
1801 | RecConError String -- Field missing in record construction
1802 | RecUpdError String -- Record doesn't contain updated field
1803 | AssertionFailed String -- Assertions
1804 | DynException Dynamic -- Dynamic exceptions
1805 | AsyncException AsyncException -- Externally generated errors
1806 | PutFullMVar -- Put on a full MVar
1823 stackOverflow, heapOverflow :: Exception -- for the RTS
1824 stackOverflow = AsyncException StackOverflow
1825 heapOverflow = AsyncException HeapOverflow
1827 instance Show ArithException where
1828 showsPrec _ Overflow = showString "arithmetic overflow"
1829 showsPrec _ Underflow = showString "arithmetic underflow"
1830 showsPrec _ LossOfPrecision = showString "loss of precision"
1831 showsPrec _ DivideByZero = showString "divide by zero"
1832 showsPrec _ Denormal = showString "denormal"
1834 instance Show AsyncException where
1835 showsPrec _ StackOverflow = showString "stack overflow"
1836 showsPrec _ HeapOverflow = showString "heap overflow"
1837 showsPrec _ ThreadKilled = showString "thread killed"
1839 instance Show Exception where
1840 showsPrec _ (IOException err) = shows err
1841 showsPrec _ (ArithException err) = shows err
1842 showsPrec _ (ErrorCall err) = showString ("error: " ++ err)
1843 showsPrec _ (NoMethodError err) = showString err
1844 showsPrec _ (PatternMatchFail err) = showString err
1845 showsPrec _ (NonExhaustiveGuards err) = showString err
1846 showsPrec _ (RecSelError err) = showString err
1847 showsPrec _ (RecConError err) = showString err
1848 showsPrec _ (RecUpdError err) = showString err
1849 showsPrec _ (AssertionFailed err) = showString err
1850 showsPrec _ (AsyncException e) = shows e
1851 showsPrec _ (DynException _err) = showString "unknown exception"
1852 showsPrec _ (PutFullMVar) = showString "putMVar: full MVar"
1853 showsPrec _ (NonTermination) = showString "<<loop>>"
1855 data Dynamic = Dynamic TypeRep Obj
1857 data Obj = Obj -- dummy type to hold the dynamically typed value.
1859 = App TyCon [TypeRep]
1860 | Fun TypeRep TypeRep
1863 data TyCon = TyCon Int String
1865 instance Eq TyCon where
1866 (TyCon t1 _) == (TyCon t2 _) = t1 == t2
1868 data IOResult = IOResult deriving (Show)
1870 type FILE_STAR = Addr -- FILE *
1872 foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR
1873 foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
1874 foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
1875 foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Char -> IO ()
1876 foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int
1877 foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR
1878 foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO ()
1879 foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO ()
1880 foreign import "nHandle" "nh_errno" nh_errno :: IO Int
1882 foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
1883 foreign import "nHandle" "nh_free" nh_free :: Addr -> IO ()
1884 foreign import "nHandle" "nh_store" nh_store :: Addr -> Char -> IO ()
1885 foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Char
1886 foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
1887 foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int
1888 foreign import "nHandle" "nh_iseof" nh_iseof :: FILE_STAR -> IO Int
1889 foreign import "nHandle" "nh_system" nh_system :: Addr -> IO Int
1890 foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO ()
1891 foreign import "nHandle" "nh_getPID" nh_getPID :: IO Int
1893 foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double
1894 foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double
1896 copy_String_to_cstring :: String -> IO Addr
1897 copy_String_to_cstring s
1898 = nh_malloc (1 + length s) >>= \ptr0 ->
1899 let loop ptr [] = nh_store ptr (chr 0) >> return ptr0
1900 loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs
1903 then error "copy_String_to_cstring: malloc failed"
1906 copy_cstring_to_String :: Addr -> IO String
1907 copy_cstring_to_String ptr
1908 = nh_load ptr >>= \ci ->
1911 else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1914 readfromhandle :: FILE_STAR -> IO String
1916 = unsafeInterleaveIO (
1917 nh_read h >>= \ci ->
1918 if ci == -1 {-EOF-} then return "" else
1919 readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1922 writetohandle :: String -> FILE_STAR -> String -> IO ()
1923 writetohandle fname h []
1925 nh_errno >>= \errno ->
1928 else error ( "writeFile/appendFile: error closing file " ++ fname)
1929 writetohandle fname h (c:cs)
1930 = nh_write h c >> writetohandle fname h cs
1932 primGetRawArgs :: IO [String]
1934 = primGetArgc >>= \argc ->
1935 sequence (map get_one_arg [0 .. argc-1])
1937 get_one_arg :: Int -> IO String
1939 = primGetArgv argno >>= \a ->
1940 copy_cstring_to_String a
1942 primGetEnv :: String -> IO String
1944 = copy_String_to_cstring v >>= \ptr ->
1945 nh_getenv ptr >>= \ptr2 ->
1948 then ioError (IOError "getEnv failed")
1950 copy_cstring_to_String ptr2 >>= \result ->
1954 ------------------------------------------------------------------------------
1955 -- ST ------------------------------------------------------------------------
1956 ------------------------------------------------------------------------------
1958 newtype ST s a = ST (s -> (a,s))
1959 unST :: ST s a -> s -> (a,s)
1961 mkST :: (s -> (a,s)) -> ST s a
1965 runST :: (__forall s . ST s a) -> a
1966 runST m = fst (unST m alpha)
1968 alpha = error "runST: entered the RealWorld"
1970 instance Functor (ST s) where
1971 fmap f x = x >>= (return . f)
1973 instance Monad (ST s) where
1974 m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1975 return x = ST (\s -> (x,s))
1976 m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1978 unsafeInterleaveST :: ST s a -> ST s a
1979 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1981 ------------------------------------------------------------------------------
1982 -- IO ------------------------------------------------------------------------
1983 ------------------------------------------------------------------------------
1985 newtype IO a = IO (RealWorld -> (a,RealWorld))
1988 stToIO :: ST RealWorld a -> IO a
1989 stToIO (ST fn) = IO fn
1991 ioToST :: IO a -> ST RealWorld a
1992 ioToST (IO fn) = ST fn
1994 unsafePerformIO :: IO a -> a
1995 unsafePerformIO m = fst (unIO m theWorld)
1997 theWorld :: RealWorld
1998 theWorld = error "unsafePerformIO: entered the RealWorld"
2000 instance Functor IO where
2001 fmap f x = x >>= (return . f)
2003 instance Monad IO where
2004 m >> k = IO (\s -> case unIO m s of { (a,s') -> unIO k s' })
2005 return x = IO (\s -> (x,s))
2006 m >>= k = IO (\s -> case unIO m s of { (a,s') -> unIO (k a) s' })
2008 -- Library IO has a global variable which accumulates Handles
2009 -- as they are opened. We keep here a second global variable
2010 -- into which a cleanup action may be specified. When evaluation
2011 -- finishes, either normally or as a result of System.exitWith,
2012 -- this cleanup action is run, closing all known-about Handles.
2013 -- Doing it like this means the Prelude does not have to know
2014 -- anything about the grotty details of the Handle implementation.
2015 prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
2016 prelCleanupAfterRunAction = unsafePerformIO (newIORef Nothing)
2018 -- used when Hugs invokes top level function
2019 hugsprimRunIO_toplevel :: IO a -> ()
2020 hugsprimRunIO_toplevel m
2021 = protect 5 (fst (unIO composite_action realWorld))
2024 = do writeIORef prelCleanupAfterRunAction Nothing
2026 cleanup_handles <- readIORef prelCleanupAfterRunAction
2027 case cleanup_handles of
2028 Nothing -> return ()
2031 realWorld = error "primRunIO: entered the RealWorld"
2032 protect :: Int -> () -> ()
2036 = primCatch (protect (n-1) comp)
2037 (\e -> fst (unIO (putStr (show e ++ "\n")) realWorld))
2039 unsafeInterleaveIO :: IO a -> IO a
2040 unsafeInterleaveIO m = IO (\ s -> (fst (unIO m s), s))
2042 ------------------------------------------------------------------------------
2043 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
2044 ------------------------------------------------------------------------------
2048 nullAddr = primIntToAddr 0
2049 incAddr a = primIntToAddr (1 + primAddrToInt a)
2050 isNullAddr a = 0 == primAddrToInt a
2052 instance Eq Addr where
2056 instance Ord Addr where
2064 instance Eq Word where
2068 instance Ord Word where
2076 makeStablePtr :: a -> IO (StablePtr a)
2077 makeStablePtr = primMakeStablePtr
2078 deRefStablePtr :: StablePtr a -> IO a
2079 deRefStablePtr = primDeRefStablePtr
2080 freeStablePtr :: StablePtr a -> IO ()
2081 freeStablePtr = primFreeStablePtr
2084 data PrimArray a -- immutable arrays with Int indices
2087 data STRef s a -- mutable variables
2088 data PrimMutableArray s a -- mutable arrays with Int indices
2089 data PrimMutableByteArray s
2091 newSTRef :: a -> ST s (STRef s a)
2092 newSTRef = primNewRef
2093 readSTRef :: STRef s a -> ST s a
2094 readSTRef = primReadRef
2095 writeSTRef :: STRef s a -> a -> ST s ()
2096 writeSTRef = primWriteRef
2098 newtype IORef a = IORef (STRef RealWorld a)
2099 newIORef :: a -> IO (IORef a)
2100 newIORef a = stToIO (primNewRef a >>= \ ref ->return (IORef ref))
2101 readIORef :: IORef a -> IO a
2102 readIORef (IORef ref) = stToIO (primReadRef ref)
2103 writeIORef :: IORef a -> a -> IO ()
2104 writeIORef (IORef ref) a = stToIO (primWriteRef ref a)
2107 ------------------------------------------------------------------------------
2108 -- ThreadId, MVar, concurrency stuff -----------------------------------------
2109 ------------------------------------------------------------------------------
2113 newEmptyMVar :: IO (MVar a)
2114 newEmptyMVar = primNewEmptyMVar
2116 putMVar :: MVar a -> a -> IO ()
2117 putMVar = primPutMVar
2119 takeMVar :: MVar a -> IO a
2121 = IO (\world -> primTakeMVar m cont world)
2123 -- cont :: a -> RealWorld -> (a,RealWorld)
2124 -- where 'a' is as in the top-level signature
2125 cont x world = (x,world)
2127 -- the type of the handwritten BCO (threesome) primTakeMVar is
2128 -- primTakeMVar :: MVar a
2129 -- -> (a -> RealWorld -> (a,RealWorld))
2133 -- primTakeMVar behaves like this:
2135 -- primTakeMVar (MVar# m#) cont world
2136 -- = primTakeMVar_wrk m# cont world
2138 -- primTakeMVar_wrk m# cont world
2139 -- = cont (takeMVar# m#) world
2141 -- primTakeMVar_wrk has the special property that it is
2142 -- restartable by the scheduler, should the MVar be empty.
2144 newMVar :: a -> IO (MVar a)
2146 newEmptyMVar >>= \ mvar ->
2147 putMVar mvar value >>
2150 readMVar :: MVar a -> IO a
2152 takeMVar mvar >>= \ value ->
2153 putMVar mvar value >>
2156 swapMVar :: MVar a -> a -> IO a
2158 takeMVar mvar >>= \ old ->
2162 isEmptyMVar var = error "isEmptyMVar is not (yet) implemented in Hugs"
2164 instance Eq (MVar a) where
2165 m1 == m2 = primSameMVar m1 m2
2169 instance Eq ThreadId where
2170 tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
2172 instance Ord ThreadId where
2174 = let r = primCmpThreadIds tid1 tid2
2175 in if r < 0 then LT else if r > 0 then GT else EQ
2178 forkIO :: IO a -> IO ThreadId
2179 -- Simple version; doesn't catch exceptions in computation
2180 -- forkIO computation
2181 -- = primForkIO (unsafePerformIO computation)
2186 (unIO computation realWorld `primSeq` ())
2187 (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
2190 realWorld = error "primForkIO: entered the RealWorld"
2193 = (unsafePerformIO (putStr (s ++ "\n"))) `seq` x
2196 -- Foreign ------------------------------------------------------------------
2200 -- showFloat ------------------------------------------------------------------
2202 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2203 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2204 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
2205 showFloat :: (RealFloat a) => a -> ShowS
2207 showEFloat d x = showString (formatRealFloat FFExponent d x)
2208 showFFloat d x = showString (formatRealFloat FFFixed d x)
2209 showGFloat d x = showString (formatRealFloat FFGeneric d x)
2210 showFloat = showGFloat Nothing
2212 -- These are the format types. This type is not exported.
2214 data FFFormat = FFExponent | FFFixed | FFGeneric
2216 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2217 formatRealFloat fmt decs x = s
2221 else if isInfinite x then
2222 if x < 0 then "-Infinity" else "Infinity"
2223 else if x < 0 || isNegativeZero x then
2224 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2226 doFmt fmt (floatToDigits (toInteger base) x)
2228 let ds = map intToDigit is
2231 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2238 [d] -> d : ".0e" ++ show (e-1)
2239 d:ds -> d : '.' : ds ++ 'e':show (e-1)
2241 let dec' = max dec 1 in
2243 [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2245 let (ei, is') = roundTo base (dec'+1) is
2246 d:ds = map intToDigit
2247 (if ei > 0 then init is' else is')
2248 in d:'.':ds ++ "e" ++ show (e-1+ei)
2252 let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2253 f n s "" = f (n-1) (s++"0") ""
2254 f n s (d:ds) = f (n-1) (s++[d]) ds
2259 let dec' = max dec 0 in
2261 let (ei, is') = roundTo base (dec' + e) is
2262 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2263 in (if null ls then "0" else ls) ++
2264 (if null rs then "" else '.' : rs)
2266 let (ei, is') = roundTo base dec'
2267 (replicate (-e) 0 ++ is)
2268 d : ds = map intToDigit
2269 (if ei > 0 then is' else 0:is')
2272 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2273 roundTo base d is = case f d is of
2275 (1, is) -> (1, 1 : is)
2276 where b2 = base `div` 2
2277 f n [] = (0, replicate n 0)
2278 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2280 let (c, ds) = f (d-1) is
2282 in if i' == base then (1, 0:ds) else (0, i':ds)
2284 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2285 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2286 -- This version uses a much slower logarithm estimator. It should be improved.
2288 -- This function returns a list of digits (Ints in [0..base-1]) and an
2291 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2293 floatToDigits _ 0 = ([0], 0)
2294 floatToDigits base x =
2295 let (f0, e0) = decodeFloat x
2296 (minExp0, _) = floatRange x
2299 minExp = minExp0 - p -- the real minimum exponent
2300 -- Haskell requires that f be adjusted so denormalized numbers
2301 -- will have an impossibly low exponent. Adjust for this.
2302 (f, e) = let n = minExp - e0
2303 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2308 if f == b^(p-1) then
2309 (f*be*b*2, 2*b, be*b, b)
2313 if e > minExp && f == b^(p-1) then
2314 (f*b*2, b^(-e+1)*2, b, 1)
2316 (f*2, b^(-e)*2, 1, 1)
2319 if b == 2 && base == 10 then
2320 -- logBase 10 2 is slightly bigger than 3/10 so
2321 -- the following will err on the low side. Ignoring
2322 -- the fraction will make it err even more.
2323 -- Haskell promises that p-1 <= logBase b f < p.
2324 (p - 1 + e0) * 3 `div` 10
2326 ceiling ((log (fromInteger (f+1)) +
2327 fromInt e * log (fromInteger b)) /
2328 log (fromInteger base))
2331 if r + mUp <= expt base n * s then n else fixup (n+1)
2333 if expt base (-n) * (r + mUp) <= s then n
2337 gen ds rn sN mUpN mDnN =
2338 let (dn, rn') = (rn * base) `divMod` sN
2341 in case (rn' < mDnN', rn' + mUpN' > sN) of
2342 (True, False) -> dn : ds
2343 (False, True) -> dn+1 : ds
2344 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2345 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2348 gen [] r (s * expt base k) mUp mDn
2350 let bk = expt base (-k)
2351 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
2352 in (map toInt (reverse rds), k)
2355 -- Exponentiation with a cache for the most common numbers.
2358 expt :: Integer -> Int -> Integer
2360 if base == 2 && n >= minExpt && n <= maxExpt then
2361 expts !! (n-minExpt)
2366 expts = [2^n | n <- [minExpt .. maxExpt]]
2370 , noMethodBindingError
2371 , nonExhaustiveGuardsError
2375 , recUpdError :: String -> a
2377 noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
2378 irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
2379 nonExhaustiveGuardsError s = throw (NonExhaustiveGuards (untangle s "Non-exhaustive guards in"))
2380 patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
2381 recSelError s = throw (RecSelError (untangle s "Missing field in record selection"))
2382 recConError s = throw (RecConError (untangle s "Missing field in record construction"))
2383 recUpdError s = throw (RecUpdError (untangle s "Record doesn't contain field(s) to be updated"))
2386 tangleMessage :: String -> Int -> String
2387 tangleMessage "" line = show line
2388 tangleMessage str line = str ++ show line
2390 assertError :: String -> Bool -> a -> a
2391 assertError str pred v
2393 | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
2396 (untangle coded message) expects "coded" to be of the form
2402 location message details
2405 untangle :: String -> String -> String
2406 untangle coded message
2414 = case (span not_bar coded) of { (loc, rest) ->
2416 ('|':det) -> (loc, ' ' : det)
2419 not_bar c = c /= '|'
2421 -- By default, we ignore asserts, but optionally, Hugs translates
2422 -- assert ==> assertError "<location info>"
2424 assert :: Bool -> a -> a