+++ /dev/null
-{----------------------------------------------------------------------------
-__ __ __ __ ____ ___ _______________________________________________
-|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system
-||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999
-||---|| ___|| World Wide Web: http://haskell.org/hugs
-|| || Report bugs to: hugs-bugs@haskell.org
-|| || Version: STG Hugs _______________________________________________
-
- This is the Hugs 98 Standard Prelude, based very closely on the Standard
- Prelude for Haskell 98.
-
- WARNING: This file is an integral part of the Hugs source code. Changes to
- the definitions in this file without corresponding modifications in other
- parts of the program may cause the interpreter to fail unexpectedly. Under
- normal circumstances, you should not attempt to modify this file in any way!
-
------------------------------------------------------------------------------
- Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell
- Group 1994-99, and is distributed as Open Source software under the
- Artistic License; see the file "Artistic" that is included in the
- distribution for details.
-----------------------------------------------------------------------------}
-
-module PrelPrim (
--- module PreludeList,
- map, (++), concat, filter,
- head, last, tail, init, null, length, (!!),
- foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
- iterate, repeat, replicate, cycle,
- take, drop, splitAt, takeWhile, dropWhile, span, break,
- lines, words, unlines, unwords, reverse, and, or,
- any, all, elem, notElem, lookup,
- sum, product, maximum, minimum, concatMap,
- zip, zip3, zipWith, zipWith3, unzip, unzip3,
--- module PreludeText,
- ReadS, ShowS,
- Read(readsPrec, readList),
- Show(show, showsPrec, showList),
- reads, shows, read, lex,
- showChar, showString, readParen, showParen,
--- module PreludeIO,
- FilePath, IOError, ioError, userError, catch,
- putChar, putStr, putStrLn, print,
- getChar, getLine, getContents, interact,
- readFile, writeFile, appendFile, readIO, readLn,
--- module Ix,
- Ix(range, index, inRange, rangeSize),
--- module Char,
- isAscii, isControl, isPrint, isSpace, isUpper, isLower,
- isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
- digitToInt, intToDigit,
- toUpper, toLower,
- ord, chr,
- readLitChar, showLitChar, lexLitChar,
--- module Numeric
- showSigned, showInt,
- readSigned, readInt,
- readDec, readOct, readHex, readSigned,
- readFloat, lexDigits,
--- module Ratio,
- Ratio, Rational, (%), numerator, denominator, approxRational,
--- Non-standard exports
- IOResult(..), Addr, StablePtr,
- makeStablePtr, freeStablePtr, deRefStablePtr,
-
- Bool(False, True),
- Maybe(Nothing, Just),
- Either(Left, Right),
- Ordering(LT, EQ, GT),
- Char, String, Int, Integer, Float, Double, IO,
--- List type: []((:), [])
- (:),
--- Tuple types: (,), (,,), etc.
--- Trivial type: ()
--- Functions: (->)
- Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
- Eq((==), (/=)),
- Ord(compare, (<), (<=), (>=), (>), max, min),
- Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
- enumFromTo, enumFromThenTo),
- Bounded(minBound, maxBound),
--- Num((+), (-), (*), negate, abs, signum, fromInteger),
- Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
- Real(toRational),
--- Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
- Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
- Fractional((/), recip, fromRational, fromDouble),
- Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
- asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
- RealFrac(properFraction, truncate, round, ceiling, floor),
- RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
- encodeFloat, exponent, significand, scaleFloat, isNaN,
- isInfinite, isDenormalized, isIEEE, isNegativeZero),
- Monad((>>=), (>>), return, fail),
- Functor(fmap),
- mapM, mapM_, sequence, sequence_, (=<<),
- maybe, either,
- (&&), (||), not, otherwise,
- subtract, even, odd, gcd, lcm, (^), (^^),
- fromIntegral, realToFrac, atan2,
- fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
- asTypeOf, error, undefined,
- seq, ($!)
- -- Now we have the extra (non standard) thing.
-
- , ArithException(..)
- , AsyncException(..)
- , Dynamic(..)
- , Exception
- , Exception(..)
- , IORef
- , MVar
- , MVar
- , PrimArray
- , PrimMutableArray
- , RealWorld
- , ST
- , STRef
- , ThreadId
- , TyCon(..)
- , TypeRep(..)
- , Word
- , absReal
- , absReal
- , assert
- , catchException
- , copy_String_to_cstring
- , forkIO
- , ioToST
- , isEmptyMVar
- , mkST
- , newEmptyMVar
- , newEmptyMVar
- , newIORef
- , newMVar
- , newMVar
- , newSTRef
- , nh_close
- , nh_errno
- , nh_exitwith
- , nh_filesize
- , nh_flush
- , nh_free
- , nh_getCPUprec
- , nh_getCPUtime
- , nh_getPID
- , nh_iseof
- , nh_open
- , nh_read
- , nh_stderr
- , nh_stdin
- , nh_stdout
- , nh_system
- , nh_write
- , nullAddr
- , numericEnumFrom
- , numericEnumFromThen
- , numericEnumFromThenTo
- , numericEnumFromTo
- , prelCleanupAfterRunAction
- , primAndInt
- , primAndWord
- , primDelay
- , primDoubleToFloat
- , primFloatToDouble
- , primGetEnv
- , primGetRawArgs
- , primGetThreadId
- , primIndexArray
- , primIndexArray
- , primIntToChar
- , primIntToWord
- , primKillThread
- , primMaxWord
- , primMinusWord
- , primNegateWord
- , primNewArray
- , primOrInt
- , primOrWord
- , primPlusWord
- , primRaiseInThread
- , primReadArray
- , primReallyUnsafePtrEquality
- , primShiftLInt
- , primShiftLWord
- , primShiftRAInt
- , primShiftRLWord
- , primSizeArray
- , primSizeMutableArray
- , primTimesWord
- , primUnsafeCoerce
- , primUnsafeFreezeArray
- , primWaitRead
- , primWaitWrite
- , primWordToInt
- , primWriteArray
- , primWriteArray
- , primWriteCharOffAddr
- , primXorInt
- , primXorWord
- , primYield
- , putMVar
- , readIORef
- , readMVar
- , readSTRef
- , runST
- , signumReal
- , signumReal
- , stToIO
- , swapMVar
- , takeMVar
- , throw
- , unST
- , unsafeInterleaveIO
- , unsafeInterleaveST
- , unsafePerformIO
- , writeIORef
- , writeSTRef
- ) where
-
--- Standard value bindings {Prelude} ----------------------------------------
-
-infixr 9 .
-infixl 9 !!
-infixr 8 ^, ^^, **
-infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
-infixl 6 +, -
---infixr 5 : -- this fixity declaration is hard-wired into Hugs
-infixr 5 ++
-infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
-infixr 3 &&
-infixr 2 ||
-infixl 1 >>, >>=
-infixr 1 =<<
-infixr 0 $, $!, `seq`
-
--- Equality and Ordered classes ---------------------------------------------
-
-class Eq a where
- (==), (/=) :: a -> a -> Bool
-
- -- Minimal complete definition: (==) or (/=)
- x == y = not (x/=y)
- x /= y = not (x==y)
-
-class (Eq a) => Ord a where
- compare :: a -> a -> Ordering
- (<), (<=), (>=), (>) :: a -> a -> Bool
- max, min :: a -> a -> a
-
- -- Minimal complete definition: (<=) or compare
- -- using compare can be more efficient for complex types
- compare x y | x==y = EQ
- | x<=y = LT
- | otherwise = GT
-
- x <= y = compare x y /= GT
- x < y = compare x y == LT
- x >= y = compare x y /= LT
- x > y = compare x y == GT
-
- max x y | x >= y = x
- | otherwise = y
- min x y | x <= y = x
- | otherwise = y
-
-class Bounded a where
- minBound, maxBound :: a
- -- Minimal complete definition: All
-
--- Numeric classes ----------------------------------------------------------
-
-class (Eq a, Show a) => Num a where
- (+), (-), (*) :: a -> a -> a
- negate :: a -> a
- abs, signum :: a -> a
- fromInteger :: Integer -> a
- fromInt :: Int -> a
-
- -- Minimal complete definition: All, except negate or (-)
- x - y = x + negate y
- fromInt = fromIntegral
- negate x = 0 - x
-
-class (Num a, Ord a) => Real a where
- toRational :: a -> Rational
-
-class (Real a, Enum a) => Integral a where
- quot, rem, div, mod :: a -> a -> a
- quotRem, divMod :: a -> a -> (a,a)
- even, odd :: a -> Bool
- toInteger :: a -> Integer
- toInt :: a -> Int
-
- -- Minimal complete definition: quotRem and toInteger
- n `quot` d = q where (q,r) = quotRem n d
- n `rem` d = r where (q,r) = quotRem n d
- n `div` d = q where (q,r) = divMod n d
- n `mod` d = r where (q,r) = divMod n d
- divMod n d = if signum r == - signum d then (q-1, r+d) else qr
- where qr@(q,r) = quotRem n d
- even n = n `rem` 2 == 0
- odd = not . even
- toInt = toInt . toInteger
-
-class (Num a) => Fractional a where
- (/) :: a -> a -> a
- recip :: a -> a
- fromRational :: Rational -> a
- fromDouble :: Double -> a
-
- -- Minimal complete definition: fromRational and ((/) or recip)
- recip x = 1 / x
- x / y = x * recip y
-
-class (Fractional a) => Floating a where
- pi :: a
- exp, log, sqrt :: a -> a
- (**), logBase :: a -> a -> a
- sin, cos, tan :: a -> a
- asin, acos, atan :: a -> a
- sinh, cosh, tanh :: a -> a
- asinh, acosh, atanh :: a -> a
-
- -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
- -- asinh, acosh, atanh
- x ** y = exp (log x * y)
- logBase x y = log y / log x
- sqrt x = x ** 0.5
- tan x = sin x / cos x
- sinh x = (exp x - exp (-x)) / 2
- cosh x = (exp x + exp (-x)) / 2
- tanh x = sinh x / cosh x
- asinh x = log (x + sqrt (x*x + 1))
- acosh x = log (x + sqrt (x*x - 1))
- atanh x = (log (1 + x) - log (1 - x)) / 2
-
-class (Real a, Fractional a) => RealFrac a where
- properFraction :: (Integral b) => a -> (b,a)
- truncate, round :: (Integral b) => a -> b
- ceiling, floor :: (Integral b) => a -> b
-
- -- Minimal complete definition: properFraction
- truncate x = m where (m,_) = properFraction x
-
- round x = let (n,r) = properFraction x
- m = if r < 0 then n - 1 else n + 1
- in case signum (abs r - 0.5) of
- -1 -> n
- 0 -> if even n then n else m
- 1 -> m
-
- ceiling x = if r > 0 then n + 1 else n
- where (n,r) = properFraction x
-
- floor x = if r < 0 then n - 1 else n
- where (n,r) = properFraction x
-
-class (RealFrac a, Floating a) => RealFloat a where
- floatRadix :: a -> Integer
- floatDigits :: a -> Int
- floatRange :: a -> (Int,Int)
- decodeFloat :: a -> (Integer,Int)
- encodeFloat :: Integer -> Int -> a
- exponent :: a -> Int
- significand :: a -> a
- scaleFloat :: Int -> a -> a
- isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
- :: a -> Bool
- atan2 :: a -> a -> a
-
- -- Minimal complete definition: All, except exponent, signficand,
- -- scaleFloat, atan2
- exponent x = if m==0 then 0 else n + floatDigits x
- where (m,n) = decodeFloat x
- significand x = encodeFloat m (- floatDigits x)
- where (m,_) = decodeFloat x
- scaleFloat k x = encodeFloat m (n+k)
- where (m,n) = decodeFloat x
- atan2 y x
- | x>0 = atan (y/x)
- | x==0 && y>0 = pi/2
- | x<0 && y>0 = pi + atan (y/x)
- | (x<=0 && y<0) ||
- (x<0 && isNegativeZero y) ||
- (isNegativeZero x && isNegativeZero y)
- = - atan2 (-y) x
- | y==0 && (x<0 || isNegativeZero x)
- = pi -- must be after the previous test on zero y
- | x==0 && y==0 = y -- must be after the other double zero tests
- | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
-
--- Numeric functions --------------------------------------------------------
-
-subtract :: Num a => a -> a -> a
-subtract = flip (-)
-
-gcd :: Integral a => a -> a -> a
-gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
-gcd x y = gcd' (abs x) (abs y)
- where gcd' x 0 = x
- gcd' x y = gcd' y (x `rem` y)
-
-lcm :: (Integral a) => a -> a -> a
-lcm _ 0 = 0
-lcm 0 _ = 0
-lcm x y = abs ((x `quot` gcd x y) * y)
-
-(^) :: (Num a, Integral b) => a -> b -> a
-x ^ 0 = 1
-x ^ n | n > 0 = f x (n-1) x
- where f _ 0 y = y
- f x n y = g x n where
- g x n | even n = g (x*x) (n`quot`2)
- | otherwise = f x (n-1) (x*y)
-_ ^ _ = error "Prelude.^: negative exponent"
-
-(^^) :: (Fractional a, Integral b) => a -> b -> a
-x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
-
-fromIntegral :: (Integral a, Num b) => a -> b
-fromIntegral = fromInteger . toInteger
-
-realToFrac :: (Real a, Fractional b) => a -> b
-realToFrac = fromRational . toRational
-
--- Index and Enumeration classes --------------------------------------------
-
-class (Ord a) => Ix a where
- range :: (a,a) -> [a]
- index :: (a,a) -> a -> Int
- inRange :: (a,a) -> a -> Bool
- rangeSize :: (a,a) -> Int
-
- rangeSize r@(l,u)
- | l > u = 0
- | otherwise = index r u + 1
-
-class Enum a where
- succ, pred :: a -> a
- toEnum :: Int -> a
- fromEnum :: a -> Int
- enumFrom :: a -> [a] -- [n..]
- enumFromThen :: a -> a -> [a] -- [n,m..]
- enumFromTo :: a -> a -> [a] -- [n..m]
- enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
-
- -- Minimal complete definition: toEnum, fromEnum
- succ = toEnum . (1+) . fromEnum
- pred = toEnum . subtract 1 . fromEnum
- enumFrom x = map toEnum [ fromEnum x .. ]
- enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
- enumFromThen x y = map toEnum [ fromEnum x, fromEnum y .. ]
- enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
-
--- Read and Show classes ------------------------------------------------------
-
-type ReadS a = String -> [(a,String)]
-type ShowS = String -> String
-
-class Read a where
- readsPrec :: Int -> ReadS a
- readList :: ReadS [a]
-
- -- Minimal complete definition: readsPrec
- readList = readParen False (\r -> [pr | ("[",s) <- lex r,
- pr <- readl s ])
- where readl s = [([],t) | ("]",t) <- lex s] ++
- [(x:xs,u) | (x,t) <- reads s,
- (xs,u) <- readl' t]
- readl' s = [([],t) | ("]",t) <- lex s] ++
- [(x:xs,v) | (",",t) <- lex s,
- (x,u) <- reads t,
- (xs,v) <- readl' u]
-
-class Show a where
- show :: a -> String
- showsPrec :: Int -> a -> ShowS
- showList :: [a] -> ShowS
-
- -- Minimal complete definition: show or showsPrec
- show x = showsPrec 0 x ""
- showsPrec _ x s = show x ++ s
- showList [] = showString "[]"
- showList (x:xs) = showChar '[' . shows x . showl xs
- where showl [] = showChar ']'
- showl (x:xs) = showChar ',' . shows x . showl xs
-
--- Monad classes ------------------------------------------------------------
-
-class Functor f where
- fmap :: (a -> b) -> (f a -> f b)
-
-class Monad m where
- return :: a -> m a
- (>>=) :: m a -> (a -> m b) -> m b
- (>>) :: m a -> m b -> m b
- fail :: String -> m a
-
- -- Minimal complete definition: (>>=), return
- p >> q = p >>= \ _ -> q
- fail s = error s
-
-sequence :: Monad m => [m a] -> m [a]
-sequence [] = return []
-sequence (c:cs) = do x <- c
- xs <- sequence cs
- return (x:xs)
-
-sequence_ :: Monad m => [m a] -> m ()
-sequence_ = foldr (>>) (return ())
-
-mapM :: Monad m => (a -> m b) -> [a] -> m [b]
-mapM f = sequence . map f
-
-mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
-mapM_ f = sequence_ . map f
-
-(=<<) :: Monad m => (a -> m b) -> m a -> m b
-f =<< x = x >>= f
-
--- Evaluation and strictness ------------------------------------------------
-
-seq :: a -> b -> b
-seq x y = primSeq x y
-
-($!) :: (a -> b) -> a -> b
-f $! x = x `primSeq` f x
-
--- Trivial type -------------------------------------------------------------
-
--- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
-
-instance Eq () where
- () == () = True
-
-instance Ord () where
- compare () () = EQ
-
-instance Ix () where
- range ((),()) = [()]
- index ((),()) () = 0
- inRange ((),()) () = True
-
-instance Enum () where
- toEnum 0 = ()
- fromEnum () = 0
- enumFrom () = [()]
- enumFromThen () () = [()]
-
-instance Read () where
- readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
- (")",t) <- lex s ])
-
-instance Show () where
- showsPrec p () = showString "()"
-
-instance Bounded () where
- minBound = ()
- maxBound = ()
-
--- Boolean type -------------------------------------------------------------
-
-data Bool = False | True
- deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
-
-(&&), (||) :: Bool -> Bool -> Bool
-False && x = False
-True && x = x
-False || x = x
-True || x = True
-
-not :: Bool -> Bool
-not True = False
-not False = True
-
-otherwise :: Bool
-otherwise = True
-
--- Character type -----------------------------------------------------------
-
-data Char -- builtin datatype of ISO Latin characters
-type String = [Char] -- strings are lists of characters
-
-instance Eq Char where (==) = primEqChar
-instance Ord Char where (<=) = primLeChar
-
-instance Enum Char where
- toEnum = primIntToChar
- fromEnum = primCharToInt
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
- where lastChar = if d < c then minBound else maxBound
-
-instance Ix Char where
- range (c,c') = [c..c']
- index b@(c,c') ci
- | inRange b ci = fromEnum ci - fromEnum c
- | otherwise = error "Ix.index: Index out of range."
- inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
- where i = fromEnum ci
-
-instance Read Char where
- readsPrec p = readParen False
- (\r -> [(c,t) | ('\'':s,t) <- lex r,
- (c,"\'") <- readLitChar s ])
- readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
- (l,_) <- readl s ])
- where readl ('"':s) = [("",s)]
- readl ('\\':'&':s) = readl s
- readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
- (cs,u) <- readl t ]
-instance Show Char where
- showsPrec p '\'' = showString "'\\''"
- showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
-
- showList cs = showChar '"' . showl cs
- where showl "" = showChar '"'
- showl ('"':cs) = showString "\\\"" . showl cs
- showl (c:cs) = showLitChar c . showl cs
-
-instance Bounded Char where
- minBound = '\0'
- maxBound = '\255'
-
-isAscii, isControl, isPrint, isSpace :: Char -> Bool
-isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
-
-isAscii c = fromEnum c < 128
-isControl c = c < ' ' || c == '\DEL'
-isPrint c = c >= ' ' && c <= '~'
-isSpace c = c == ' ' || c == '\t' || c == '\n' ||
- c == '\r' || c == '\f' || c == '\v'
-isUpper c = c >= 'A' && c <= 'Z'
-isLower c = c >= 'a' && c <= 'z'
-isAlpha c = isUpper c || isLower c
-isDigit c = c >= '0' && c <= '9'
-isAlphaNum c = isAlpha c || isDigit c
-
--- Digit conversion operations
-digitToInt :: Char -> Int
-digitToInt c
- | isDigit c = fromEnum c - fromEnum '0'
- | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
- | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
- | otherwise = error "Char.digitToInt: not a digit"
-
-intToDigit :: Int -> Char
-intToDigit i
- | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
- | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
- | otherwise = error "Char.intToDigit: not a digit"
-
-toUpper, toLower :: Char -> Char
-toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
- | otherwise = c
-
-toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
- | otherwise = c
-
-ord :: Char -> Int
-ord = fromEnum
-
-chr :: Int -> Char
-chr = toEnum
-
--- Maybe type ---------------------------------------------------------------
-
-data Maybe a = Nothing | Just a
- deriving (Eq, Ord, Read, Show)
-
-maybe :: b -> (a -> b) -> Maybe a -> b
-maybe n f Nothing = n
-maybe n f (Just x) = f x
-
-instance Functor Maybe where
- fmap f Nothing = Nothing
- fmap f (Just x) = Just (f x)
-
-instance Monad Maybe where
- Just x >>= k = k x
- Nothing >>= k = Nothing
- return = Just
- fail s = Nothing
-
--- Either type --------------------------------------------------------------
-
-data Either a b = Left a | Right b
- deriving (Eq, Ord, Read, Show)
-
-either :: (a -> c) -> (b -> c) -> Either a b -> c
-either l r (Left x) = l x
-either l r (Right y) = r y
-
--- Ordering type ------------------------------------------------------------
-
-data Ordering = LT | EQ | GT
- deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
-
--- Lists --------------------------------------------------------------------
-
---data [a] = [] | a : [a] deriving (Eq, Ord)
-
-instance Eq a => Eq [a] where
- [] == [] = True
- (x:xs) == (y:ys) = x==y && xs==ys
- _ == _ = False
-
-instance Ord a => Ord [a] where
- compare [] (_:_) = LT
- compare [] [] = EQ
- compare (_:_) [] = GT
- compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys)
-
-instance Functor [] where
- fmap = map
-
-instance Monad [ ] where
- (x:xs) >>= f = f x ++ (xs >>= f)
- [] >>= f = []
- return x = [x]
- fail s = []
-
-instance Read a => Read [a] where
- readsPrec p = readList
-
-instance Show a => Show [a] where
- showsPrec p = showList
-
--- Tuples -------------------------------------------------------------------
-
--- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
--- etc..
-
--- Standard Integral types --------------------------------------------------
-
-data Int -- builtin datatype of fixed size integers
-data Integer -- builtin datatype of arbitrary size integers
-
-instance Eq Integer where
- (==) x y = primCompareInteger x y == 0
-
-instance Ord Integer where
- compare x y = case primCompareInteger x y of
- -1 -> LT
- 0 -> EQ
- 1 -> GT
-
-instance Eq Int where
- (==) = primEqInt
- (/=) = primNeInt
-
-instance Ord Int where
- (<) = primLtInt
- (<=) = primLeInt
- (>=) = primGeInt
- (>) = primGtInt
-
-instance Num Int where
- (+) = primPlusInt
- (-) = primMinusInt
- negate = primNegateInt
- (*) = primTimesInt
- abs = absReal
- signum = signumReal
- fromInteger = primIntegerToInt
- fromInt x = x
-
-instance Bounded Int where
- minBound = primMinInt
- maxBound = primMaxInt
-
-instance Num Integer where
- (+) = primPlusInteger
- (-) = primMinusInteger
- negate = primNegateInteger
- (*) = primTimesInteger
- abs = absReal
- signum = signumReal
- fromInteger x = x
- fromInt = primIntToInteger
-
-absReal x | x >= 0 = x
- | otherwise = -x
-
-signumReal x | x == 0 = 0
- | x > 0 = 1
- | otherwise = -1
-
-instance Real Int where
- toRational x = toInteger x % 1
-
-instance Real Integer where
- toRational x = x % 1
-
-instance Integral Int where
- quotRem = primQuotRemInt
- toInteger = primIntToInteger
- toInt x = x
-
-instance Integral Integer where
- quotRem = primQuotRemInteger
- toInteger = id
- toInt = primIntegerToInt
-
-instance Ix Int where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = i - m
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Ix Integer where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = fromInteger (i - m)
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Int where
- toEnum = id
- fromEnum = id
- enumFrom = numericEnumFrom
- enumFromTo = numericEnumFromTo
- enumFromThen = numericEnumFromThen
- enumFromThenTo = numericEnumFromThenTo
-
-instance Enum Integer where
- toEnum = primIntToInteger
- fromEnum = primIntegerToInt
- enumFrom = numericEnumFrom
- enumFromTo = numericEnumFromTo
- enumFromThen = numericEnumFromThen
- enumFromThenTo = numericEnumFromThenTo
-
-numericEnumFrom :: Real a => a -> [a]
-numericEnumFromThen :: Real a => a -> a -> [a]
-numericEnumFromTo :: Real a => a -> a -> [a]
-numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
-numericEnumFrom n = n : (numericEnumFrom $! (n+1))
-numericEnumFromThen n m = iterate ((m-n)+) n
-numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
-numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
- where p | n' >= n = (<= m)
- | otherwise = (>= m)
-
-instance Read Int where
- readsPrec p = readSigned readDec
-
-instance Show Int where
- showsPrec p n
- | n == minBound = showSigned showInt p (toInteger n)
- | otherwise = showSigned showInt p n
-
-instance Read Integer where
- readsPrec p = readSigned readDec
-
-instance Show Integer where
- showsPrec = showSigned showInt
-
-
--- Standard Floating types --------------------------------------------------
-
-data Float -- builtin datatype of single precision floating point numbers
-data Double -- builtin datatype of double precision floating point numbers
-
-instance Eq Float where
- (==) = primEqFloat
- (/=) = primNeFloat
-
-instance Ord Float where
- (<) = primLtFloat
- (<=) = primLeFloat
- (>=) = primGeFloat
- (>) = primGtFloat
-
-instance Num Float where
- (+) = primPlusFloat
- (-) = primMinusFloat
- negate = primNegateFloat
- (*) = primTimesFloat
- abs = absReal
- signum = signumReal
- fromInteger = primIntegerToFloat
- fromInt = primIntToFloat
-
-
-
-instance Eq Double where
- (==) = primEqDouble
- (/=) = primNeDouble
-
-instance Ord Double where
- (<) = primLtDouble
- (<=) = primLeDouble
- (>=) = primGeDouble
- (>) = primGtDouble
-
-instance Num Double where
- (+) = primPlusDouble
- (-) = primMinusDouble
- negate = primNegateDouble
- (*) = primTimesDouble
- abs = absReal
- signum = signumReal
- fromInteger = primIntegerToDouble
- fromInt = primIntToDouble
-
-
-
-instance Real Float where
- toRational = floatToRational
-
-instance Real Double where
- toRational = doubleToRational
-
--- Calls to these functions are optimised when passed as arguments to
--- fromRational.
-floatToRational :: Float -> Rational
-doubleToRational :: Double -> Rational
-floatToRational x = realFloatToRational x
-doubleToRational x = realFloatToRational x
-
-realFloatToRational x = (m%1)*(b%1)^^n
- where (m,n) = decodeFloat x
- b = floatRadix x
-
-instance Fractional Float where
- (/) = primDivideFloat
- fromRational = rationalToRealFloat
- fromDouble = primDoubleToFloat
-
-instance Fractional Double where
- (/) = primDivideDouble
- fromRational = rationalToRealFloat
- fromDouble x = x
-
-rationalToRealFloat x = x'
- where x' = f e
- f e = if e' == e then y else f e'
- where y = encodeFloat (round (x * (1%b)^^e)) e
- (_,e') = decodeFloat y
- (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
- / fromInteger (denominator x))
- b = floatRadix x'
-
-instance Floating Float where
- pi = 3.14159265358979323846
- exp = primExpFloat
- log = primLogFloat
- sqrt = primSqrtFloat
- sin = primSinFloat
- cos = primCosFloat
- tan = primTanFloat
- asin = primAsinFloat
- acos = primAcosFloat
- atan = primAtanFloat
-
-instance Floating Double where
- pi = 3.14159265358979323846
- exp = primExpDouble
- log = primLogDouble
- sqrt = primSqrtDouble
- sin = primSinDouble
- cos = primCosDouble
- tan = primTanDouble
- asin = primAsinDouble
- acos = primAcosDouble
- atan = primAtanDouble
-
-instance RealFrac Float where
- properFraction = floatProperFraction
-
-instance RealFrac Double where
- properFraction = floatProperFraction
-
-floatProperFraction x
- | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
- | otherwise = (fromInteger w, encodeFloat r n)
- where (m,n) = decodeFloat x
- b = floatRadix x
- (w,r) = quotRem m (b^(-n))
-
-instance RealFloat Float where
- floatRadix _ = toInteger primRadixFloat
- floatDigits _ = primDigitsFloat
- floatRange _ = (primMinExpFloat,primMaxExpFloat)
- encodeFloat = primEncodeFloatZ
- decodeFloat = primDecodeFloatZ
- isNaN = primIsNaNFloat
- isInfinite = primIsInfiniteFloat
- isDenormalized= primIsDenormalizedFloat
- isNegativeZero= primIsNegativeZeroFloat
- isIEEE = const primIsIEEEFloat
-
-instance RealFloat Double where
- floatRadix _ = toInteger primRadixDouble
- floatDigits _ = primDigitsDouble
- floatRange _ = (primMinExpDouble,primMaxExpDouble)
- encodeFloat = primEncodeDoubleZ
- decodeFloat = primDecodeDoubleZ
- isNaN = primIsNaNDouble
- isInfinite = primIsInfiniteDouble
- isDenormalized= primIsDenormalizedDouble
- isNegativeZero= primIsNegativeZeroDouble
- isIEEE = const primIsIEEEDouble
-
-instance Enum Float where
- toEnum = primIntToFloat
- fromEnum = truncate
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo n m = numericEnumFromTo n (m+1/2)
- enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
-
-instance Enum Double where
- toEnum = primIntToDouble
- fromEnum = truncate
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo n m = numericEnumFromTo n (m+1/2)
- enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
-
-instance Read Float where
- readsPrec p = readSigned readFloat
-
-instance Show Float where
- showsPrec p = showSigned showFloat p
-
-instance Read Double where
- readsPrec p = readSigned readFloat
-
-instance Show Double where
- showsPrec p = showSigned showFloat p
-
-
--- Some standard functions --------------------------------------------------
-
-fst :: (a,b) -> a
-fst (x,_) = x
-
-snd :: (a,b) -> b
-snd (_,y) = y
-
-curry :: ((a,b) -> c) -> (a -> b -> c)
-curry f x y = f (x,y)
-
-uncurry :: (a -> b -> c) -> ((a,b) -> c)
-uncurry f p = f (fst p) (snd p)
-
-id :: a -> a
-id x = x
-
-const :: a -> b -> a
-const k _ = k
-
-(.) :: (b -> c) -> (a -> b) -> (a -> c)
-(f . g) x = f (g x)
-
-flip :: (a -> b -> c) -> b -> a -> c
-flip f x y = f y x
-
-($) :: (a -> b) -> a -> b
-f $ x = f x
-
-until :: (a -> Bool) -> (a -> a) -> a -> a
-until p f x = if p x then x else until p f (f x)
-
-asTypeOf :: a -> a -> a
-asTypeOf = const
-
-error :: String -> a
-error msg = primRaise (ErrorCall msg)
-
-undefined :: a
-undefined | False = undefined
-
--- Standard functions on rational numbers {PreludeRatio} --------------------
-
-data Integral a => Ratio a = a :% a deriving (Eq)
-type Rational = Ratio Integer
-
-(%) :: Integral a => a -> a -> Ratio a
-x % y = reduce (x * signum y) (abs y)
-
-reduce :: Integral a => a -> a -> Ratio a
-reduce x y | y == 0 = error "Ratio.%: zero denominator"
- | otherwise = (x `quot` d) :% (y `quot` d)
- where d = gcd x y
-
-numerator, denominator :: Integral a => Ratio a -> a
-numerator (x :% y) = x
-denominator (x :% y) = y
-
-instance Integral a => Ord (Ratio a) where
- compare (x:%y) (x':%y') = compare (x*y') (x'*y)
-
-instance Integral a => Num (Ratio a) where
- (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
- (x:%y) * (x':%y') = reduce (x*x') (y*y')
- negate (x :% y) = negate x :% y
- abs (x :% y) = abs x :% y
- signum (x :% y) = signum x :% 1
- fromInteger x = fromInteger x :% 1
- fromInt = intToRatio
-
--- Hugs optimises code of the form fromRational (intToRatio x)
-intToRatio :: Integral a => Int -> Ratio a
-intToRatio x = fromInt x :% 1
-
-instance Integral a => Real (Ratio a) where
- toRational (x:%y) = toInteger x :% toInteger y
-
-instance Integral a => Fractional (Ratio a) where
- (x:%y) / (x':%y') = (x*y') % (y*x')
- recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
- fromRational (x:%y) = fromInteger x :% fromInteger y
- fromDouble = doubleToRatio
-
--- Hugs optimises code of the form fromRational (doubleToRatio x)
-doubleToRatio :: Integral a => Double -> Ratio a
-doubleToRatio x
- | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
- | otherwise = fromInteger m % (fromInteger b ^ (-n))
- where (m,n) = decodeFloat x
- b = floatRadix x
-
-instance Integral a => RealFrac (Ratio a) where
- properFraction (x:%y) = (fromIntegral q, r:%y)
- where (q,r) = quotRem x y
-
-instance Integral a => Enum (Ratio a) where
- toEnum = fromInt
- fromEnum = truncate
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
-
-instance (Read a, Integral a) => Read (Ratio a) where
- readsPrec p = readParen (p > 7)
- (\r -> [(x%y,u) | (x,s) <- reads r,
- ("%",t) <- lex s,
- (y,u) <- reads t ])
-
-instance Integral a => Show (Ratio a) where
- showsPrec p (x:%y) = showParen (p > 7)
- (shows x . showString " % " . shows y)
-
-approxRational :: RealFrac a => a -> a -> Rational
-approxRational x eps = simplest (x-eps) (x+eps)
- where simplest x y | y < x = simplest y x
- | x == y = xr
- | x > 0 = simplest' n d n' d'
- | y < 0 = - simplest' (-n') d' (-n) d
- | otherwise = 0 :% 1
- where xr@(n:%d) = toRational x
- (n':%d') = toRational y
- simplest' n d n' d' -- assumes 0 < n%d < n'%d'
- | r == 0 = q :% 1
- | q /= q' = (q+1) :% 1
- | otherwise = (q*n''+d'') :% n''
- where (q,r) = quotRem n d
- (q',r') = quotRem n' d'
- (n'':%d'') = simplest' d' r' d r
-
--- Standard list functions {PreludeList} ------------------------------------
-
-head :: [a] -> a
-head (x:_) = x
-
-last :: [a] -> a
-last [x] = x
-last (_:xs) = last xs
-
-tail :: [a] -> [a]
-tail (_:xs) = xs
-
-init :: [a] -> [a]
-init [x] = []
-init (x:xs) = x : init xs
-
-null :: [a] -> Bool
-null [] = True
-null (_:_) = False
-
-(++) :: [a] -> [a] -> [a]
-[] ++ ys = ys
-(x:xs) ++ ys = x : (xs ++ ys)
-
-map :: (a -> b) -> [a] -> [b]
-map f [] = []
-map f (x:xs) = f x : map f xs
-
-
-filter :: (a -> Bool) -> [a] -> [a]
-filter p [] = []
-filter p (x:xs) = if p x then x : filter p xs else filter p xs
-
-
-concat :: [[a]] -> [a]
-concat [] = []
-concat (xs:xss) = xs ++ concat xss
-
-length :: [a] -> Int
-length = foldl' (\n _ -> n + 1) 0
-
-(!!) :: [b] -> Int -> b
-(x:_) !! 0 = x
-(_:xs) !! n | n>0 = xs !! (n-1)
-(_:_) !! _ = error "Prelude.!!: negative index"
-[] !! _ = error "Prelude.!!: index too large"
-
-foldl :: (a -> b -> a) -> a -> [b] -> a
-foldl f z [] = z
-foldl f z (x:xs) = foldl f (f z x) xs
-
-foldl' :: (a -> b -> a) -> a -> [b] -> a
-foldl' f a [] = a
-foldl' f a (x:xs) = (foldl' f $! f a x) xs
-
-foldl1 :: (a -> a -> a) -> [a] -> a
-foldl1 f (x:xs) = foldl f x xs
-
-scanl :: (a -> b -> a) -> a -> [b] -> [a]
-scanl f q xs = q : (case xs of
- [] -> []
- x:xs -> scanl f (f q x) xs)
-
-scanl1 :: (a -> a -> a) -> [a] -> [a]
-scanl1 f (x:xs) = scanl f x xs
-
-foldr :: (a -> b -> b) -> b -> [a] -> b
-foldr f z [] = z
-foldr f z (x:xs) = f x (foldr f z xs)
-
-foldr1 :: (a -> a -> a) -> [a] -> a
-foldr1 f [x] = x
-foldr1 f (x:xs) = f x (foldr1 f xs)
-
-scanr :: (a -> b -> b) -> b -> [a] -> [b]
-scanr f q0 [] = [q0]
-scanr f q0 (x:xs) = f x q : qs
- where qs@(q:_) = scanr f q0 xs
-
-scanr1 :: (a -> a -> a) -> [a] -> [a]
-scanr1 f [x] = [x]
-scanr1 f (x:xs) = f x q : qs
- where qs@(q:_) = scanr1 f xs
-
-iterate :: (a -> a) -> a -> [a]
-iterate f x = x : iterate f (f x)
-
-repeat :: a -> [a]
-repeat x = xs where xs = x:xs
-
-replicate :: Int -> a -> [a]
-replicate n x = take n (repeat x)
-
-cycle :: [a] -> [a]
-cycle [] = error "Prelude.cycle: empty list"
-cycle xs = xs' where xs'=xs++xs'
-
-take :: Int -> [a] -> [a]
-take 0 _ = []
-take _ [] = []
-take n (x:xs) | n>0 = x : take (n-1) xs
-take _ _ = error "Prelude.take: negative argument"
-
-drop :: Int -> [a] -> [a]
-drop 0 xs = xs
-drop _ [] = []
-drop n (_:xs) | n>0 = drop (n-1) xs
-drop _ _ = error "Prelude.drop: negative argument"
-
-splitAt :: Int -> [a] -> ([a], [a])
-splitAt 0 xs = ([],xs)
-splitAt _ [] = ([],[])
-splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
-splitAt _ _ = error "Prelude.splitAt: negative argument"
-
-takeWhile :: (a -> Bool) -> [a] -> [a]
-takeWhile p [] = []
-takeWhile p (x:xs)
- | p x = x : takeWhile p xs
- | otherwise = []
-
-dropWhile :: (a -> Bool) -> [a] -> [a]
-dropWhile p [] = []
-dropWhile p xs@(x:xs')
- | p x = dropWhile p xs'
- | otherwise = xs
-
-span, break :: (a -> Bool) -> [a] -> ([a],[a])
-span p [] = ([],[])
-span p xs@(x:xs')
- | p x = (x:ys, zs)
- | otherwise = ([],xs)
- where (ys,zs) = span p xs'
-break p = span (not . p)
-
-lines :: String -> [String]
-lines "" = []
-lines s = let (l,s') = break ('\n'==) s
- in l : case s' of [] -> []
- (_:s'') -> lines s''
-
-words :: String -> [String]
-words s = case dropWhile isSpace s of
- "" -> []
- s' -> w : words s''
- where (w,s'') = break isSpace s'
-
-unlines :: [String] -> String
-unlines = concatMap (\l -> l ++ "\n")
-
-unwords :: [String] -> String
-unwords [] = []
-unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
-
-reverse :: [a] -> [a]
---reverse = foldl (flip (:)) []
-reverse xs = ri [] xs
- where ri acc [] = acc
- ri acc (x:xs) = ri (x:acc) xs
-
-and, or :: [Bool] -> Bool
---and = foldr (&&) True
---or = foldr (||) False
-and [] = True
-and (x:xs) = if x then and xs else x
-or [] = False
-or (x:xs) = if x then x else or xs
-
-any, all :: (a -> Bool) -> [a] -> Bool
---any p = or . map p
---all p = and . map p
-any p [] = False
-any p (x:xs) = if p x then True else any p xs
-all p [] = True
-all p (x:xs) = if p x then all p xs else False
-
-elem, notElem :: Eq a => a -> [a] -> Bool
---elem = any . (==)
---notElem = all . (/=)
-elem x [] = False
-elem x (y:ys) = if x==y then True else elem x ys
-notElem x [] = True
-notElem x (y:ys) = if x==y then False else notElem x ys
-
-lookup :: Eq a => a -> [(a,b)] -> Maybe b
-lookup k [] = Nothing
-lookup k ((x,y):xys)
- | k==x = Just y
- | otherwise = lookup k xys
-
-sum, product :: Num a => [a] -> a
-sum = foldl' (+) 0
-product = foldl' (*) 1
-
-maximum, minimum :: Ord a => [a] -> a
-maximum = foldl1 max
-minimum = foldl1 min
-
-concatMap :: (a -> [b]) -> [a] -> [b]
-concatMap f = concat . map f
-
-zip :: [a] -> [b] -> [(a,b)]
-zip = zipWith (\a b -> (a,b))
-
-zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
-zip3 = zipWith3 (\a b c -> (a,b,c))
-
-zipWith :: (a->b->c) -> [a]->[b]->[c]
-zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
-zipWith _ _ _ = []
-
-zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
-zipWith3 z (a:as) (b:bs) (c:cs)
- = z a b c : zipWith3 z as bs cs
-zipWith3 _ _ _ _ = []
-
-unzip :: [(a,b)] -> ([a],[b])
-unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
-
-unzip3 :: [(a,b,c)] -> ([a],[b],[c])
-unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
- ([],[],[])
-
--- PreludeText ----------------------------------------------------------------
-
-reads :: Read a => ReadS a
-reads = readsPrec 0
-
-shows :: Show a => a -> ShowS
-shows = showsPrec 0
-
-read :: Read a => String -> a
-read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
- [x] -> x
- [] -> error "Prelude.read: no parse"
- _ -> error "Prelude.read: ambiguous parse"
-
-showChar :: Char -> ShowS
-showChar = (:)
-
-showString :: String -> ShowS
-showString = (++)
-
-showParen :: Bool -> ShowS -> ShowS
-showParen b p = if b then showChar '(' . p . showChar ')' else p
-
-hugsprimShowField :: Show a => String -> a -> ShowS
-hugsprimShowField m v = showString m . showChar '=' . shows v
-
-readParen :: Bool -> ReadS a -> ReadS a
-readParen b g = if b then mandatory else optional
- where optional r = g r ++ mandatory r
- mandatory r = [(x,u) | ("(",s) <- lex r,
- (x,t) <- optional s,
- (")",u) <- lex t ]
-
-
-hugsprimReadField :: Read a => String -> ReadS a
-hugsprimReadField m s0 = [ r | (t, s1) <- lex s0, t == m,
- ("=",s2) <- lex s1,
- r <- reads s2 ]
-
-lex :: ReadS String
-lex "" = [("","")]
-lex (c:s) | isSpace c = lex (dropWhile isSpace s)
-lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
- ch /= "'" ]
-lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
- where
- lexString ('"':s) = [("\"",s)]
- lexString s = [(ch++str, u)
- | (ch,t) <- lexStrItem s,
- (str,u) <- lexString t ]
-
- lexStrItem ('\\':'&':s) = [("\\&",s)]
- lexStrItem ('\\':c:s) | isSpace c
- = [("",t) | '\\':t <- [dropWhile isSpace s]]
- lexStrItem s = lexLitChar s
-
-lex (c:s) | isSingle c = [([c],s)]
- | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
- | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
- | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
- (fe,t) <- lexFracExp s ]
- | otherwise = [] -- bad character
- where
- isSingle c = c `elem` ",;()[]{}_`"
- isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
- isIdChar c = isAlphaNum c || c `elem` "_'"
-
- lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
- (e,u) <- lexExp t ]
- lexFracExp s = [("",s)]
-
- lexExp (e:s) | e `elem` "eE"
- = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
- (ds,u) <- lexDigits t] ++
- [(e:ds,t) | (ds,t) <- lexDigits s]
- lexExp s = [("",s)]
-
-lexDigits :: ReadS String
-lexDigits = nonnull isDigit
-
-nonnull :: (Char -> Bool) -> ReadS String
-nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
-
-lexLitChar :: ReadS String
-lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
- where
- lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- "
- lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
- lexEsc s@(d:_) | isDigit d = lexDigits s
- lexEsc s@(c:_) | isUpper c
- = let table = ('\DEL',"DEL") : asciiTab
- in case [(mne,s') | (c, mne) <- table,
- ([],s') <- [lexmatch mne s]]
- of (pr:_) -> [pr]
- [] -> []
- lexEsc _ = []
-lexLitChar (c:s) = [([c],s)]
-lexLitChar "" = []
-
-isOctDigit c = c >= '0' && c <= '7'
-isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
- || c >= 'a' && c <= 'f'
-
-lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
-lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
-lexmatch xs ys = (xs,ys)
-
-asciiTab = zip ['\NUL'..' ']
- ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
- "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
- "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
- "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
- "SP"]
-
-readLitChar :: ReadS Char
-readLitChar ('\\':s) = readEsc s
- where
- readEsc ('a':s) = [('\a',s)]
- readEsc ('b':s) = [('\b',s)]
- readEsc ('f':s) = [('\f',s)]
- readEsc ('n':s) = [('\n',s)]
- readEsc ('r':s) = [('\r',s)]
- readEsc ('t':s) = [('\t',s)]
- readEsc ('v':s) = [('\v',s)]
- readEsc ('\\':s) = [('\\',s)]
- readEsc ('"':s) = [('"',s)]
- readEsc ('\'':s) = [('\'',s)]
- readEsc ('^':c:s) | c >= '@' && c <= '_'
- = [(toEnum (fromEnum c - fromEnum '@'), s)]
- readEsc s@(d:_) | isDigit d
- = [(toEnum n, t) | (n,t) <- readDec s]
- readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
- readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
- readEsc s@(c:_) | isUpper c
- = let table = ('\DEL',"DEL") : asciiTab
- in case [(c,s') | (c, mne) <- table,
- ([],s') <- [lexmatch mne s]]
- of (pr:_) -> [pr]
- [] -> []
- readEsc _ = []
-readLitChar (c:s) = [(c,s)]
-
-showLitChar :: Char -> ShowS
-showLitChar c | c > '\DEL' = showChar '\\' .
- protectEsc isDigit (shows (fromEnum c))
-showLitChar '\DEL' = showString "\\DEL"
-showLitChar '\\' = showString "\\\\"
-showLitChar c | c >= ' ' = showChar c
-showLitChar '\a' = showString "\\a"
-showLitChar '\b' = showString "\\b"
-showLitChar '\f' = showString "\\f"
-showLitChar '\n' = showString "\\n"
-showLitChar '\r' = showString "\\r"
-showLitChar '\t' = showString "\\t"
-showLitChar '\v' = showString "\\v"
-showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
-showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
-
-protectEsc p f = f . cont
- where cont s@(c:_) | p c = "\\&" ++ s
- cont s = s
-
--- Unsigned readers for various bases
-readDec, readOct, readHex :: Integral a => ReadS a
-readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
-readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
-readHex = readInt 16 isHexDigit hex
- where hex d = fromEnum d -
- (if isDigit d
- then fromEnum '0'
- else fromEnum (if isUpper d then 'A' else 'a') - 10)
-
--- readInt reads a string of digits using an arbitrary base.
--- Leading minus signs must be handled elsewhere.
-
-readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
-readInt radix isDig digToInt s =
- [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
- | (ds,r) <- nonnull isDig s ]
-
--- showInt is used for positive numbers only
-showInt :: Integral a => a -> ShowS
-showInt n r
- | n < 0
- = error "Numeric.showInt: can't show negative numbers"
- | otherwise
-{-
- = let (n',d) = quotRem n 10
- r' = toEnum (fromEnum '0' + fromIntegral d) : r
- in if n' == 0 then r' else showInt n' r'
--}
- = case quotRem n 10 of { (n',d) ->
- let r' = toEnum (fromEnum '0' + fromIntegral d) : r
- in if n' == 0 then r' else showInt n' r'
- }
-
-
-readSigned:: Real a => ReadS a -> ReadS a
-readSigned readPos = readParen False read'
- where read' r = read'' r ++
- [(-x,t) | ("-",s) <- lex r,
- (x,t) <- read'' s]
- read'' r = [(n,s) | (str,s) <- lex r,
- (n,"") <- readPos str]
-
-showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
-showSigned showPos p x = if x < 0 then showParen (p > 6)
- (showChar '-' . showPos (-x))
- else showPos x
-
-readFloat :: RealFloat a => ReadS a
-readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
- (k,t) <- readExp s]
- where readFix r = [(read (ds++ds'), length ds', t)
- | (ds, s) <- lexDigits r
- , (ds',t) <- lexFrac s ]
-
- lexFrac ('.':s) = lexDigits s
- lexFrac s = [("",s)]
-
- readExp (e:s) | e `elem` "eE" = readExp' s
- readExp s = [(0,s)]
-
- readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
- readExp' ('+':s) = readDec s
- readExp' s = readDec s
-
-
--- Hooks for primitives: -----------------------------------------------------
--- Do not mess with these!
-
-hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering
-hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
-
-hugsprimEqChar :: Char -> Char -> Bool
-hugsprimEqChar c1 c2 = primEqChar c1 c2
-
-hugsprimPmInt :: Num a => Int -> a -> Bool
-hugsprimPmInt n x = fromInt n == x
-
-hugsprimPmInteger :: Num a => Integer -> a -> Bool
-hugsprimPmInteger n x = fromInteger n == x
-
-hugsprimPmDouble :: Fractional a => Double -> a -> Bool
-hugsprimPmDouble n x = fromDouble n == x
-
--- ToDo: make the message more informative.
-hugsprimPmFail :: a
-hugsprimPmFail = error "Pattern Match Failure"
-
--- used in desugaring Foreign functions
--- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
--- bit of code of type RealWorld -> (a,RealWorld) into a proper IO value.
--- What follows is the version for standalone mode. ghc/lib/std/PrelHugs.lhs
--- contains a version used in combined mode. That version takes care of
--- switching between the GHC and Hugs IO representations, which are different.
-hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
-hugsprimMkIO = IO
-
-hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
-hugsprimCreateAdjThunk fun typestr callconv
- = do sp <- makeStablePtr fun
- p <- copy_String_to_cstring typestr -- is never freed
- a <- primCreateAdjThunkARCH sp p callconv
- return a
-
--- The following primitives are only needed if (n+k) patterns are enabled:
-hugsprimPmSub :: Integral a => Int -> a -> a
-hugsprimPmSub n x = x - fromInt n
-
-hugsprimPmFromInteger :: Integral a => Integer -> a
-hugsprimPmFromInteger = fromIntegral
-
-hugsprimPmSubtract :: Integral a => a -> a -> a
-hugsprimPmSubtract x y = x - y
-
-hugsprimPmLe :: Integral a => a -> a -> Bool
-hugsprimPmLe x y = x <= y
-
--- Unpack strings generated by the Hugs code generator.
--- Strings can contain \0 provided they're coded right.
---
--- ToDo: change this (and Hugs code generator) to use ByteArrays
-
-hugsprimUnpackString :: Addr -> String
-hugsprimUnpackString a = unpack 0
- where
- -- The following decoding is based on evalString in the old machine.c
- unpack i
- | c == '\0' = []
- | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
- then '\\' : unpack (i+2)
- else '\0' : unpack (i+2)
- | otherwise = c : unpack (i+1)
- where
- c = primIndexCharOffAddr a i
-
-
--- Monadic I/O: --------------------------------------------------------------
-
-type FilePath = String
-
---data IOError = ...
---instance Eq IOError ...
---instance Show IOError ...
-
-data IOError = IOError String
-instance Show IOError where
- showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
-
-ioError :: IOError -> IO a
-ioError e@(IOError _) = primRaise (IOException e)
-
-userError :: String -> IOError
-userError s = primRaise (ErrorCall s)
-
-throw :: Exception -> a
-throw exception = primRaise exception
-
-catchException :: IO a -> (Exception -> IO a) -> IO a
-catchException m k = IO (\s -> unIO m s `primCatch` \ err -> unIO (k err) s)
-
-catch :: IO a -> (IOError -> IO a) -> IO a
-catch m k = catchException m handler
- where handler (IOException err) = k err
- handler other = throw other
-
-putChar :: Char -> IO ()
-putChar c = nh_stdout >>= \h -> nh_write h c
-
-putStr :: String -> IO ()
-putStr s = nh_stdout >>= \h ->
- let loop [] = nh_flush h
- loop (c:cs) = nh_write h c >> loop cs
- in loop s
-
-putStrLn :: String -> IO ()
-putStrLn s = do { putStr s; putChar '\n' }
-
-print :: Show a => a -> IO ()
-print = putStrLn . show
-
-getChar :: IO Char
-getChar = nh_stdin >>= \h ->
- nh_read h >>= \ci ->
- return (primIntToChar ci)
-
-getLine :: IO String
-getLine = do c <- getChar
- if c=='\n' then return ""
- else do cs <- getLine
- return (c:cs)
-
-getContents :: IO String
-getContents = nh_stdin >>= \h -> readfromhandle h
-
-interact :: (String -> String) -> IO ()
-interact f = getContents >>= (putStr . f)
-
-readFile :: FilePath -> IO String
-readFile fname
- = copy_String_to_cstring fname >>= \ptr ->
- nh_open ptr 0 >>= \h ->
- nh_free ptr >>
- nh_errno >>= \errno ->
- if (isNullAddr h || errno /= 0)
- then (ioError.IOError) ("readFile: can't open file " ++ fname)
- else readfromhandle h
-
-writeFile :: FilePath -> String -> IO ()
-writeFile fname contents
- = copy_String_to_cstring fname >>= \ptr ->
- nh_open ptr 1 >>= \h ->
- nh_free ptr >>
- nh_errno >>= \errno ->
- if (isNullAddr h || errno /= 0)
- then (ioError.IOError) ("writeFile: can't create file " ++ fname)
- else writetohandle fname h contents
-
-appendFile :: FilePath -> String -> IO ()
-appendFile fname contents
- = copy_String_to_cstring fname >>= \ptr ->
- nh_open ptr 2 >>= \h ->
- nh_free ptr >>
- nh_errno >>= \errno ->
- if (isNullAddr h || errno /= 0)
- then (ioError.IOError) ("appendFile: can't open file " ++ fname)
- else writetohandle fname h contents
-
-
--- raises an exception instead of an error
-readIO :: Read a => String -> IO a
-readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
- [x] -> return x
- [] -> ioError (userError "PreludeIO.readIO: no parse")
- _ -> ioError (userError
- "PreludeIO.readIO: ambiguous parse")
-
-readLn :: Read a => IO a
-readLn = do l <- getLine
- r <- readIO l
- return r
-
-
--- End of Hugs standard prelude ----------------------------------------------
-data Exception
- = IOException IOError -- IO exceptions (from 'ioError')
- | ArithException ArithException -- Arithmetic exceptions
- | ErrorCall String -- Calls to 'error'
- | NoMethodError String -- A non-existent method was invoked
- | PatternMatchFail String -- A pattern match failed
- | NonExhaustiveGuards String -- A guard match failed
- | RecSelError String -- Selecting a non-existent field
- | RecConError String -- Field missing in record construction
- | RecUpdError String -- Record doesn't contain updated field
- | AssertionFailed String -- Assertions
- | DynException Dynamic -- Dynamic exceptions
- | AsyncException AsyncException -- Externally generated errors
- | PutFullMVar -- Put on a full MVar
- | NonTermination
-
-data ArithException
- = Overflow
- | Underflow
- | LossOfPrecision
- | DivideByZero
- | Denormal
- deriving (Eq, Ord)
-
-data AsyncException
- = StackOverflow
- | HeapOverflow
- | ThreadKilled
- deriving (Eq, Ord)
-
-stackOverflow, heapOverflow :: Exception -- for the RTS
-stackOverflow = AsyncException StackOverflow
-heapOverflow = AsyncException HeapOverflow
-
-instance Show ArithException where
- showsPrec _ Overflow = showString "arithmetic overflow"
- showsPrec _ Underflow = showString "arithmetic underflow"
- showsPrec _ LossOfPrecision = showString "loss of precision"
- showsPrec _ DivideByZero = showString "divide by zero"
- showsPrec _ Denormal = showString "denormal"
-
-instance Show AsyncException where
- showsPrec _ StackOverflow = showString "stack overflow"
- showsPrec _ HeapOverflow = showString "heap overflow"
- showsPrec _ ThreadKilled = showString "thread killed"
-
-instance Show Exception where
- showsPrec _ (IOException err) = shows err
- showsPrec _ (ArithException err) = shows err
- showsPrec _ (ErrorCall err) = showString ("error: " ++ err)
- showsPrec _ (NoMethodError err) = showString err
- showsPrec _ (PatternMatchFail err) = showString err
- showsPrec _ (NonExhaustiveGuards err) = showString err
- showsPrec _ (RecSelError err) = showString err
- showsPrec _ (RecConError err) = showString err
- showsPrec _ (RecUpdError err) = showString err
- showsPrec _ (AssertionFailed err) = showString err
- showsPrec _ (AsyncException e) = shows e
- showsPrec _ (DynException _err) = showString "unknown exception"
- showsPrec _ (PutFullMVar) = showString "putMVar: full MVar"
- showsPrec _ (NonTermination) = showString "<<loop>>"
-
-data Dynamic = Dynamic TypeRep Obj
-
-data Obj = Obj -- dummy type to hold the dynamically typed value.
-data TypeRep
- = App TyCon [TypeRep]
- | Fun TypeRep TypeRep
- deriving ( Eq )
-
-data TyCon = TyCon Int String
-
-instance Eq TyCon where
- (TyCon t1 _) == (TyCon t2 _) = t1 == t2
-
-data IOResult = IOResult deriving (Show)
-
-type FILE_STAR = Addr -- FILE *
-
-foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR
-foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
-foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
-foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Char -> IO ()
-foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int
-foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR
-foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO ()
-foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO ()
-foreign import "nHandle" "nh_errno" nh_errno :: IO Int
-
-foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
-foreign import "nHandle" "nh_free" nh_free :: Addr -> IO ()
-foreign import "nHandle" "nh_store" nh_store :: Addr -> Char -> IO ()
-foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Char
-foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
-foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int
-foreign import "nHandle" "nh_iseof" nh_iseof :: FILE_STAR -> IO Int
-foreign import "nHandle" "nh_system" nh_system :: Addr -> IO Int
-foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO ()
-foreign import "nHandle" "nh_getPID" nh_getPID :: IO Int
-
-foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double
-foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double
-
-copy_String_to_cstring :: String -> IO Addr
-copy_String_to_cstring s
- = nh_malloc (1 + length s) >>= \ptr0 ->
- let loop ptr [] = nh_store ptr (chr 0) >> return ptr0
- loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs
- in
- if isNullAddr ptr0
- then error "copy_String_to_cstring: malloc failed"
- else loop ptr0 s
-
-copy_cstring_to_String :: Addr -> IO String
-copy_cstring_to_String ptr
- = nh_load ptr >>= \ci ->
- if ci == '\0'
- then return []
- else copy_cstring_to_String (incAddr ptr) >>= \cs ->
- return (ci : cs)
-
-readfromhandle :: FILE_STAR -> IO String
-readfromhandle h
- = unsafeInterleaveIO (
- nh_read h >>= \ci ->
- if ci == -1 {-EOF-} then return "" else
- readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
- )
-
-writetohandle :: String -> FILE_STAR -> String -> IO ()
-writetohandle fname h []
- = nh_close h >>
- nh_errno >>= \errno ->
- if errno == 0
- then return ()
- else error ( "writeFile/appendFile: error closing file " ++ fname)
-writetohandle fname h (c:cs)
- = nh_write h c >> writetohandle fname h cs
-
-primGetRawArgs :: IO [String]
-primGetRawArgs
- = primGetArgc >>= \argc ->
- sequence (map get_one_arg [0 .. argc-1])
- where
- get_one_arg :: Int -> IO String
- get_one_arg argno
- = primGetArgv argno >>= \a ->
- copy_cstring_to_String a
-
-primGetEnv :: String -> IO String
-primGetEnv v
- = copy_String_to_cstring v >>= \ptr ->
- nh_getenv ptr >>= \ptr2 ->
- nh_free ptr >>
- if isNullAddr ptr2
- then ioError (IOError "getEnv failed")
- else
- copy_cstring_to_String ptr2 >>= \result ->
- return result
-
-
-------------------------------------------------------------------------------
--- ST ------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-newtype ST s a = ST (s -> (a,s))
-unST :: ST s a -> s -> (a,s)
-unST (ST a) = a
-mkST :: (s -> (a,s)) -> ST s a
-mkST = ST
-data RealWorld
-
-runST :: (__forall s . ST s a) -> a
-runST m = fst (unST m alpha)
- where
- alpha = error "runST: entered the RealWorld"
-
-instance Functor (ST s) where
- fmap f x = x >>= (return . f)
-
-instance Monad (ST s) where
- m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
- return x = ST (\s -> (x,s))
- m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
-
-unsafeInterleaveST :: ST s a -> ST s a
-unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
-
-------------------------------------------------------------------------------
--- IO ------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-newtype IO a = IO (RealWorld -> (a,RealWorld))
-unIO (IO a) = a
-
-stToIO :: ST RealWorld a -> IO a
-stToIO (ST fn) = IO fn
-
-ioToST :: IO a -> ST RealWorld a
-ioToST (IO fn) = ST fn
-
-unsafePerformIO :: IO a -> a
-unsafePerformIO m = fst (unIO m theWorld)
- where
- theWorld :: RealWorld
- theWorld = error "unsafePerformIO: entered the RealWorld"
-
-instance Functor IO where
- fmap f x = x >>= (return . f)
-
-instance Monad IO where
- m >> k = IO (\s -> case unIO m s of { (a,s') -> unIO k s' })
- return x = IO (\s -> (x,s))
- m >>= k = IO (\s -> case unIO m s of { (a,s') -> unIO (k a) s' })
-
--- Library IO has a global variable which accumulates Handles
--- as they are opened. We keep here a second global variable
--- into which a cleanup action may be specified. When evaluation
--- finishes, either normally or as a result of System.exitWith,
--- this cleanup action is run, closing all known-about Handles.
--- Doing it like this means the Prelude does not have to know
--- anything about the grotty details of the Handle implementation.
-prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
-prelCleanupAfterRunAction = unsafePerformIO (newIORef Nothing)
-
--- used when Hugs invokes top level function
-hugsprimRunIO_toplevel :: IO a -> ()
-hugsprimRunIO_toplevel m
- = protect 5 (fst (unIO composite_action realWorld))
- where
- composite_action
- = do writeIORef prelCleanupAfterRunAction Nothing
- m
- cleanup_handles <- readIORef prelCleanupAfterRunAction
- case cleanup_handles of
- Nothing -> return ()
- Just xx -> xx
-
- realWorld = error "primRunIO: entered the RealWorld"
- protect :: Int -> () -> ()
- protect 0 comp
- = comp
- protect n comp
- = primCatch (protect (n-1) comp)
- (\e -> fst (unIO (putStr (show e ++ "\n")) realWorld))
-
-unsafeInterleaveIO :: IO a -> IO a
-unsafeInterleaveIO m = IO (\ s -> (fst (unIO m s), s))
-
-------------------------------------------------------------------------------
--- Word, Addr, StablePtr, Prim*Array -----------------------------------------
-------------------------------------------------------------------------------
-
-data Addr
-
-nullAddr = primIntToAddr 0
-incAddr a = primIntToAddr (1 + primAddrToInt a)
-isNullAddr a = 0 == primAddrToInt a
-
-instance Eq Addr where
- (==) = primEqAddr
- (/=) = primNeAddr
-
-instance Ord Addr where
- (<) = primLtAddr
- (<=) = primLeAddr
- (>=) = primGeAddr
- (>) = primGtAddr
-
-data Word
-
-instance Eq Word where
- (==) = primEqWord
- (/=) = primNeWord
-
-instance Ord Word where
- (<) = primLtWord
- (<=) = primLeWord
- (>=) = primGeWord
- (>) = primGtWord
-
-data StablePtr a
-
-makeStablePtr :: a -> IO (StablePtr a)
-makeStablePtr = primMakeStablePtr
-deRefStablePtr :: StablePtr a -> IO a
-deRefStablePtr = primDeRefStablePtr
-freeStablePtr :: StablePtr a -> IO ()
-freeStablePtr = primFreeStablePtr
-
-
-data PrimArray a -- immutable arrays with Int indices
-data PrimByteArray
-
-data STRef s a -- mutable variables
-data PrimMutableArray s a -- mutable arrays with Int indices
-data PrimMutableByteArray s
-
-newSTRef :: a -> ST s (STRef s a)
-newSTRef = primNewRef
-readSTRef :: STRef s a -> ST s a
-readSTRef = primReadRef
-writeSTRef :: STRef s a -> a -> ST s ()
-writeSTRef = primWriteRef
-
-newtype IORef a = IORef (STRef RealWorld a)
-newIORef :: a -> IO (IORef a)
-newIORef a = stToIO (primNewRef a >>= \ ref ->return (IORef ref))
-readIORef :: IORef a -> IO a
-readIORef (IORef ref) = stToIO (primReadRef ref)
-writeIORef :: IORef a -> a -> IO ()
-writeIORef (IORef ref) a = stToIO (primWriteRef ref a)
-
-
-------------------------------------------------------------------------------
--- ThreadId, MVar, concurrency stuff -----------------------------------------
-------------------------------------------------------------------------------
-
-data MVar a
-
-newEmptyMVar :: IO (MVar a)
-newEmptyMVar = primNewEmptyMVar
-
-putMVar :: MVar a -> a -> IO ()
-putMVar = primPutMVar
-
-takeMVar :: MVar a -> IO a
-takeMVar m
- = IO (\world -> primTakeMVar m cont world)
- where
- -- cont :: a -> RealWorld -> (a,RealWorld)
- -- where 'a' is as in the top-level signature
- cont x world = (x,world)
-
- -- the type of the handwritten BCO (threesome) primTakeMVar is
- -- primTakeMVar :: MVar a
- -- -> (a -> RealWorld -> (a,RealWorld))
- -- -> RealWorld
- -- -> (a,RealWorld)
- --
- -- primTakeMVar behaves like this:
- --
- -- primTakeMVar (MVar# m#) cont world
- -- = primTakeMVar_wrk m# cont world
- --
- -- primTakeMVar_wrk m# cont world
- -- = cont (takeMVar# m#) world
- --
- -- primTakeMVar_wrk has the special property that it is
- -- restartable by the scheduler, should the MVar be empty.
-
-newMVar :: a -> IO (MVar a)
-newMVar value =
- newEmptyMVar >>= \ mvar ->
- putMVar mvar value >>
- return mvar
-
-readMVar :: MVar a -> IO a
-readMVar mvar =
- takeMVar mvar >>= \ value ->
- putMVar mvar value >>
- return value
-
-swapMVar :: MVar a -> a -> IO a
-swapMVar mvar new =
- takeMVar mvar >>= \ old ->
- putMVar mvar new >>
- return old
-
-isEmptyMVar var = error "isEmptyMVar is not (yet) implemented in Hugs"
-
-instance Eq (MVar a) where
- m1 == m2 = primSameMVar m1 m2
-
-data ThreadId
-
-instance Eq ThreadId where
- tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
-
-instance Ord ThreadId where
- compare tid1 tid2
- = let r = primCmpThreadIds tid1 tid2
- in if r < 0 then LT else if r > 0 then GT else EQ
-
-
-forkIO :: IO a -> IO ThreadId
--- Simple version; doesn't catch exceptions in computation
--- forkIO computation
--- = primForkIO (unsafePerformIO computation)
-
-forkIO computation
- = primForkIO (
- primCatch
- (unIO computation realWorld `primSeq` ())
- (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
- )
- where
- realWorld = error "primForkIO: entered the RealWorld"
-
-trace_quiet s x
- = (unsafePerformIO (putStr (s ++ "\n"))) `seq` x
-
-
--- Foreign ------------------------------------------------------------------
-
-data ForeignObj
-
--- showFloat ------------------------------------------------------------------
-
-showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
-showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
-showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
-showFloat :: (RealFloat a) => a -> ShowS
-
-showEFloat d x = showString (formatRealFloat FFExponent d x)
-showFFloat d x = showString (formatRealFloat FFFixed d x)
-showGFloat d x = showString (formatRealFloat FFGeneric d x)
-showFloat = showGFloat Nothing
-
--- These are the format types. This type is not exported.
-
-data FFFormat = FFExponent | FFFixed | FFGeneric
-
-formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
-formatRealFloat fmt decs x = s
- where base = 10
- s = if isNaN x then
- "NaN"
- else if isInfinite x then
- if x < 0 then "-Infinity" else "Infinity"
- else if x < 0 || isNegativeZero x then
- '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
- else
- doFmt fmt (floatToDigits (toInteger base) x)
- doFmt fmt (is, e) =
- let ds = map intToDigit is
- in case fmt of
- FFGeneric ->
- doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
- (is, e)
- FFExponent ->
- case decs of
- Nothing ->
- case ds of
- ['0'] -> "0.0e0"
- [d] -> d : ".0e" ++ show (e-1)
- d:ds -> d : '.' : ds ++ 'e':show (e-1)
- Just dec ->
- let dec' = max dec 1 in
- case is of
- [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
- _ ->
- let (ei, is') = roundTo base (dec'+1) is
- d:ds = map intToDigit
- (if ei > 0 then init is' else is')
- in d:'.':ds ++ "e" ++ show (e-1+ei)
- FFFixed ->
- case decs of
- Nothing ->
- let f 0 s ds = mk0 s ++ "." ++ mk0 ds
- f n s "" = f (n-1) (s++"0") ""
- f n s (d:ds) = f (n-1) (s++[d]) ds
- mk0 "" = "0"
- mk0 s = s
- in f e "" ds
- Just dec ->
- let dec' = max dec 0 in
- if e >= 0 then
- let (ei, is') = roundTo base (dec' + e) is
- (ls, rs) = splitAt (e+ei) (map intToDigit is')
- in (if null ls then "0" else ls) ++
- (if null rs then "" else '.' : rs)
- else
- let (ei, is') = roundTo base dec'
- (replicate (-e) 0 ++ is)
- d : ds = map intToDigit
- (if ei > 0 then is' else 0:is')
- in d : '.' : ds
-
-roundTo :: Int -> Int -> [Int] -> (Int, [Int])
-roundTo base d is = case f d is of
- (0, is) -> (0, is)
- (1, is) -> (1, 1 : is)
- where b2 = base `div` 2
- f n [] = (0, replicate n 0)
- f 0 (i:_) = (if i >= b2 then 1 else 0, [])
- f d (i:is) =
- let (c, ds) = f (d-1) is
- i' = c + i
- in if i' == base then (1, 0:ds) else (0, i':ds)
-
--- Based on "Printing Floating-Point Numbers Quickly and Accurately"
--- by R.G. Burger and R. K. Dybvig, in PLDI 96.
--- This version uses a much slower logarithm estimator. It should be improved.
-
--- This function returns a list of digits (Ints in [0..base-1]) and an
--- exponent.
-
-floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
-
-floatToDigits _ 0 = ([0], 0)
-floatToDigits base x =
- let (f0, e0) = decodeFloat x
- (minExp0, _) = floatRange x
- p = floatDigits x
- b = floatRadix x
- minExp = minExp0 - p -- the real minimum exponent
- -- Haskell requires that f be adjusted so denormalized numbers
- -- will have an impossibly low exponent. Adjust for this.
- (f, e) = let n = minExp - e0
- in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
-
- (r, s, mUp, mDn) =
- if e >= 0 then
- let be = b^e in
- if f == b^(p-1) then
- (f*be*b*2, 2*b, be*b, b)
- else
- (f*be*2, 2, be, be)
- else
- if e > minExp && f == b^(p-1) then
- (f*b*2, b^(-e+1)*2, b, 1)
- else
- (f*2, b^(-e)*2, 1, 1)
- k =
- let k0 =
- if b == 2 && base == 10 then
- -- logBase 10 2 is slightly bigger than 3/10 so
- -- the following will err on the low side. Ignoring
- -- the fraction will make it err even more.
- -- Haskell promises that p-1 <= logBase b f < p.
- (p - 1 + e0) * 3 `div` 10
- else
- ceiling ((log (fromInteger (f+1)) +
- fromInt e * log (fromInteger b)) /
- log (fromInteger base))
- fixup n =
- if n >= 0 then
- if r + mUp <= expt base n * s then n else fixup (n+1)
- else
- if expt base (-n) * (r + mUp) <= s then n
- else fixup (n+1)
- in fixup k0
-
- gen ds rn sN mUpN mDnN =
- let (dn, rn') = (rn * base) `divMod` sN
- mUpN' = mUpN * base
- mDnN' = mDnN * base
- in case (rn' < mDnN', rn' + mUpN' > sN) of
- (True, False) -> dn : ds
- (False, True) -> dn+1 : ds
- (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
- (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
- rds =
- if k >= 0 then
- gen [] r (s * expt base k) mUp mDn
- else
- let bk = expt base (-k)
- in gen [] (r * bk) s (mUp * bk) (mDn * bk)
- in (map toInt (reverse rds), k)
-
-
--- Exponentiation with a cache for the most common numbers.
-minExpt = 0::Int
-maxExpt = 1100::Int
-expt :: Integer -> Int -> Integer
-expt base n =
- if base == 2 && n >= minExpt && n <= maxExpt then
- expts !! (n-minExpt)
- else
- base^n
-
-expts :: [Integer]
-expts = [2^n | n <- [minExpt .. maxExpt]]
-
-
-irrefutPatError
- , noMethodBindingError
- , nonExhaustiveGuardsError
- , patError
- , recSelError
- , recConError
- , recUpdError :: String -> a
-
-noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
-irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
-nonExhaustiveGuardsError s = throw (NonExhaustiveGuards (untangle s "Non-exhaustive guards in"))
-patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
-recSelError s = throw (RecSelError (untangle s "Missing field in record selection"))
-recConError s = throw (RecConError (untangle s "Missing field in record construction"))
-recUpdError s = throw (RecUpdError (untangle s "Record doesn't contain field(s) to be updated"))
-
-
-tangleMessage :: String -> Int -> String
-tangleMessage "" line = show line
-tangleMessage str line = str ++ show line
-
-assertError :: String -> Bool -> a -> a
-assertError str pred v
- | pred = v
- | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
-
-{-
-(untangle coded message) expects "coded" to be of the form
-
- "location|details"
-
-It prints
-
- location message details
--}
-
-untangle :: String -> String -> String
-untangle coded message
- = location
- ++ ": "
- ++ message
- ++ details
- ++ "\n"
- where
- (location, details)
- = case (span not_bar coded) of { (loc, rest) ->
- case rest of
- ('|':det) -> (loc, ' ' : det)
- _ -> (loc, "")
- }
- not_bar c = c /= '|'
-
--- By default, we ignore asserts, but optionally, Hugs translates
--- assert ==> assertError "<location info>"
-
-assert :: Bool -> a -> a
-assert _ a = a
-
projects / ghc-hetmet.git / commitdiff