--- /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
+ IO, 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.
+
+ , AsyncException(..)
+ , ArithException(..)
+ , Dynamic(..)
+ , Exception(..)
+ , IORef
+ , PrimArray
+ , PrimMutableArray
+ , RealWorld
+ , ST
+ , STRef
+ , TyCon(..)
+ , TypeRep(..)
+ , assert
+ , copy_String_to_cstring
+ , ioToST
+ , ioToST
+ , newIORef
+ , 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
+ , prelCleanupAfterRunAction
+ , primGetEnv
+ , primGetRawArgs
+ , primIndexArray
+ , primIntToChar
+ , primNewArray
+ , primReadArray
+ , primReallyUnsafePtrEquality
+ , primSizeArray
+ , primSizeMutableArray
+ , primUnsafeCoerce
+ , primUnsafeFreezeArray
+ , primWriteArray
+ , primWriteCharOffAddr
+ , readIORef
+ , readSTRef
+ , runST
+ , stToIO
+ , throw
+ , unST
+ , unsafeInterleaveIO
+ , unsafeInterleaveST
+ , unsafePerformIO
+ , unsafePerformIO
+ , writeIORef
+ , writeSTRef
+ , catchException
+ ) 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
+
+ -- Minimal complete definition: fromRational and ((/) or recip)
+ recip x = 1 / x
+ x / y = x * recip y
+
+fromDouble :: Fractional a => Double -> a
+fromDouble n = fromRational (toRational n)
+
+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
+
+instance Fractional Double where
+ (/) = primDivideDouble
+ fromRational = rationalToRealFloat
+
+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
+
+-- 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