ghc/interpreter/lib/Prelude.hs

   1 {----------------------------------------------------------------------------
   2 __   __ __  __  ____   ___    _______________________________________________
   3 ||   || ||  || ||  || ||__    Hugs 98: The Nottingham and Yale Haskell system
   4 ||___|| ||__|| ||__||  __||   Copyright (c) 1994-1999
   5 ||---||         ___||         World Wide Web: http://haskell.org/hugs
   6 ||   ||                       Report bugs to: hugs-bugs@haskell.org
   7 ||   || Version: January 1999 _______________________________________________
   8
   9  This is the Hugs 98 Standard Prelude, based very closely on the Standard
  10  Prelude for Haskell 98.
  11
  12  WARNING: This file is an integral part of the Hugs source code.  Changes to
  13  the definitions in this file without corresponding modifications in other
  14  parts of the program may cause the interpreter to fail unexpectedly.  Under
  15  normal circumstances, you should not attempt to modify this file in any way!
  16
  17 -----------------------------------------------------------------------------
  18  Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell
  19  Group 1994-99, and is distributed as Open Source software under the
  20  Artistic License; see the file "Artistic" that is included in the
  21  distribution for details.
  22 ----------------------------------------------------------------------------}
  23
  24 module Prelude (
  25 --  module PreludeList,
  26     map, (++), concat, filter,
  27     head, last, tail, init, null, length, (!!),
  28     foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
  29     iterate, repeat, replicate, cycle,
  30     take, drop, splitAt, takeWhile, dropWhile, span, break,
  31     lines, words, unlines, unwords, reverse, and, or,
  32     any, all, elem, notElem, lookup,
  33     sum, product, maximum, minimum, concatMap,
  34     zip, zip3, zipWith, zipWith3, unzip, unzip3,
  35 --  module PreludeText,
  36     ReadS, ShowS,
  37     Read(readsPrec, readList),
  38     Show(show, showsPrec, showList),
  39     reads, shows, read, lex,
  40     showChar, showString, readParen, showParen,
  41 --  module PreludeIO,
  42     FilePath, IOError, ioError, userError, catch,
  43     putChar, putStr, putStrLn, print,
  44     getChar, getLine, getContents, interact,
  45     readFile, writeFile, appendFile, readIO, readLn,
  46 --  module Ix,
  47     Ix(range, index, inRange, rangeSize),
  48 --  module Char,
  49     isAscii, isControl, isPrint, isSpace, isUpper, isLower,
  50     isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
  51     digitToInt, intToDigit,
  52     toUpper, toLower,
  53     ord, chr,
  54     readLitChar, showLitChar, lexLitChar,
  55 --  module Numeric
  56     showSigned, showInt,
  57     readSigned, readInt,
  58     readDec, readOct, readHex, readSigned,
  59     readFloat, lexDigits,
  60 --  module Ratio,
  61     Ratio, Rational, (%), numerator, denominator, approxRational,
  62 --  Non-standard exports
  63     IO(..), IOResult(..), Addr,
  64
  65     Bool(False, True),
  66     Maybe(Nothing, Just),
  67     Either(Left, Right),
  68     Ordering(LT, EQ, GT),
  69     Char, String, Int, Integer, Float, Double, IO,
  70 --  List type: []((:), [])
  71     (:),
  72 --  Tuple types: (,), (,,), etc.
  73 --  Trivial type: ()
  74 --  Functions: (->)
  75     Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
  76     Eq((==), (/=)),
  77     Ord(compare, (<), (<=), (>=), (>), max, min),
  78     Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
  79          enumFromTo, enumFromThenTo),
  80     Bounded(minBound, maxBound),
  81 --  Num((+), (-), (*), negate, abs, signum, fromInteger),
  82     Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
  83     Real(toRational),
  84 --  Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
  85     Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
  86 --  Fractional((/), recip, fromRational),
  87     Fractional((/), recip, fromRational, fromDouble),
  88     Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
  89              asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
  90     RealFrac(properFraction, truncate, round, ceiling, floor),
  91     RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
  92               encodeFloat, exponent, significand, scaleFloat, isNaN,
  93               isInfinite, isDenormalized, isIEEE, isNegativeZero),
  94     Monad((>>=), (>>), return, fail),
  95     Functor(fmap),
  96     mapM, mapM_, accumulate, sequence, (=<<),
  97     maybe, either,
  98     (&&), (||), not, otherwise,
  99     subtract, even, odd, gcd, lcm, (^), (^^),
 100     fromIntegral, realToFrac, atan2,
 101     fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
 102     asTypeOf, error, undefined,
 103     seq, ($!)
 104
 105     ,trace
 106     -- Arrrggghhh!!! Help! Help! Help!
 107     -- What?!  Prelude.hs doesn't even _define_ most of these things!
 108     ,primCompAux,PrimArray,primRunST,primNewArray,primWriteArray
 109     ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv
 110     ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open
 111     ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar
 112     ,unsafeInterleaveIO,nh_write,primCharToInt
 113
 114     -- ToDo: rm -- these are only for debugging
 115     ,primPlusInt,primEqChar,primRunIO
 116   ) where
 117
 118 -- Standard value bindings {Prelude} ----------------------------------------
 119
 120 infixr 9  .
 121 infixl 9  !!
 122 infixr 8  ^, ^^, **
 123 infixl 7  *, /, `quot`, `rem`, `div`, `mod`, :%, %
 124 infixl 6  +, -
 125 --infixr 5  :    -- this fixity declaration is hard-wired into Hugs
 126 infixr 5  ++
 127 infix  4  ==, /=, <, <=, >=, >, `elem`, `notElem`
 128 infixr 3  &&
 129 infixr 2  ||
 130 infixl 1  >>, >>=
 131 infixr 1  =<<
 132 infixr 0  $, $!, `seq`
 133
 134 -- Equality and Ordered classes ---------------------------------------------
 135
 136 class Eq a where
 137     (==), (/=) :: a -> a -> Bool
 138
 139     -- Minimal complete definition: (==) or (/=)
 140     x == y      = not (x/=y)
 141     x /= y      = not (x==y)
 142
 143 class (Eq a) => Ord a where
 144     compare                :: a -> a -> Ordering
 145     (<), (<=), (>=), (>)   :: a -> a -> Bool
 146     max, min               :: a -> a -> a
 147
 148     -- Minimal complete definition: (<=) or compare
 149     -- using compare can be more efficient for complex types
 150     compare x y | x==y      = EQ
 151                 | x<=y      = LT
 152                 | otherwise = GT
 153
 154     x <= y                  = compare x y /= GT
 155     x <  y                  = compare x y == LT
 156     x >= y                  = compare x y /= LT
 157     x >  y                  = compare x y == GT
 158
 159     max x y   | x >= y      = x
 160               | otherwise   = y
 161     min x y   | x <= y      = x
 162               | otherwise   = y
 163
 164 class Bounded a where
 165     minBound, maxBound :: a
 166     -- Minimal complete definition: All
 167
 168 -- Numeric classes ----------------------------------------------------------
 169
 170 class (Eq a, Show a) => Num a where
 171     (+), (-), (*)  :: a -> a -> a
 172     negate         :: a -> a
 173     abs, signum    :: a -> a
 174     fromInteger    :: Integer -> a
 175     fromInt        :: Int -> a
 176
 177     -- Minimal complete definition: All, except negate or (-)
 178     x - y           = x + negate y
 179     fromInt         = fromIntegral
 180     negate x        = 0 - x
 181
 182 class (Num a, Ord a) => Real a where
 183     toRational     :: a -> Rational
 184
 185 class (Real a, Enum a) => Integral a where
 186     quot, rem, div, mod :: a -> a -> a
 187     quotRem, divMod     :: a -> a -> (a,a)
 188     even, odd           :: a -> Bool
 189     toInteger           :: a -> Integer
 190     toInt               :: a -> Int
 191
 192     -- Minimal complete definition: quotRem and toInteger
 193     n `quot` d           = q where (q,r) = quotRem n d
 194     n `rem` d            = r where (q,r) = quotRem n d
 195     n `div` d            = q where (q,r) = divMod n d
 196     n `mod` d            = r where (q,r) = divMod n d
 197     divMod n d           = if signum r == - signum d then (q-1, r+d) else qr
 198                            where qr@(q,r) = quotRem n d
 199     even n               = n `rem` 2 == 0
 200     odd                  = not . even
 201     toInt                = toInt . toInteger
 202
 203 class (Num a) => Fractional a where
 204     (/)          :: a -> a -> a
 205     recip        :: a -> a
 206     fromRational :: Rational -> a
 207     fromDouble   :: Double -> a
 208
 209     -- Minimal complete definition: fromRational and ((/) or recip)
 210     recip x       = 1 / x
 211     fromDouble    = fromRational . toRational
 212     x / y         = x * recip y
 213
 214
 215 class (Fractional a) => Floating a where
 216     pi                  :: a
 217     exp, log, sqrt      :: a -> a
 218     (**), logBase       :: a -> a -> a
 219     sin, cos, tan       :: a -> a
 220     asin, acos, atan    :: a -> a
 221     sinh, cosh, tanh    :: a -> a
 222     asinh, acosh, atanh :: a -> a
 223
 224     -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
 225     --                              asinh, acosh, atanh
 226     x ** y               = exp (log x * y)
 227     logBase x y          = log y / log x
 228     sqrt x               = x ** 0.5
 229     tan x                = sin x / cos x
 230     sinh x               = (exp x - exp (-x)) / 2
 231     cosh x               = (exp x + exp (-x)) / 2
 232     tanh x               = sinh x / cosh x
 233     asinh x              = log (x + sqrt (x*x + 1))
 234     acosh x              = log (x + sqrt (x*x - 1))
 235     atanh x              = (log (1 + x) - log (1 - x)) / 2
 236
 237 class (Real a, Fractional a) => RealFrac a where
 238     properFraction   :: (Integral b) => a -> (b,a)
 239     truncate, round  :: (Integral b) => a -> b
 240     ceiling, floor   :: (Integral b) => a -> b
 241
 242     -- Minimal complete definition: properFraction
 243     truncate x        = m where (m,_) = properFraction x
 244
 245     round x           = let (n,r) = properFraction x
 246                             m     = if r < 0 then n - 1 else n + 1
 247                         in case signum (abs r - 0.5) of
 248                             -1 -> n
 249                             0  -> if even n then n else m
 250                             1  -> m
 251
 252     ceiling x         = if r > 0 then n + 1 else n
 253                         where (n,r) = properFraction x
 254
 255     floor x           = if r < 0 then n - 1 else n
 256                         where (n,r) = properFraction x
 257
 258 class (RealFrac a, Floating a) => RealFloat a where
 259     floatRadix       :: a -> Integer
 260     floatDigits      :: a -> Int
 261     floatRange       :: a -> (Int,Int)
 262     decodeFloat      :: a -> (Integer,Int)
 263     encodeFloat      :: Integer -> Int -> a
 264     exponent         :: a -> Int
 265     significand      :: a -> a
 266     scaleFloat       :: Int -> a -> a
 267     isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
 268                      :: a -> Bool
 269     atan2            :: a -> a -> a
 270
 271     -- Minimal complete definition: All, except exponent, signficand,
 272     --                              scaleFloat, atan2
 273     exponent x        = if m==0 then 0 else n + floatDigits x
 274                         where (m,n) = decodeFloat x
 275     significand x     = encodeFloat m (- floatDigits x)
 276                         where (m,_) = decodeFloat x
 277     scaleFloat k x    = encodeFloat m (n+k)
 278                         where (m,n) = decodeFloat x
 279     atan2 y x
 280       | x>0           = atan (y/x)
 281       | x==0 && y>0   = pi/2
 282       | x<0 && y>0    = pi + atan (y/x)
 283       | (x<=0 && y<0) ||
 284         (x<0 && isNegativeZero y) ||
 285         (isNegativeZero x && isNegativeZero y)
 286                       = - atan2 (-y) x
 287       | y==0 && (x<0 || isNegativeZero x)
 288                       = pi    -- must be after the previous test on zero y
 289       | x==0 && y==0  = y     -- must be after the other double zero tests
 290       | otherwise     = x + y -- x or y is a NaN, return a NaN (via +)
 291
 292 -- Numeric functions --------------------------------------------------------
 293
 294 subtract       :: Num a => a -> a -> a
 295 subtract        = flip (-)
 296
 297 gcd            :: Integral a => a -> a -> a
 298 gcd 0 0         = error "Prelude.gcd: gcd 0 0 is undefined"
 299 gcd x y         = gcd' (abs x) (abs y)
 300                   where gcd' x 0 = x
 301                         gcd' x y = gcd' y (x `rem` y)
 302
 303 lcm            :: (Integral a) => a -> a -> a
 304 lcm _ 0         = 0
 305 lcm 0 _         = 0
 306 lcm x y         = abs ((x `quot` gcd x y) * y)
 307
 308 (^)            :: (Num a, Integral b) => a -> b -> a
 309 x ^ 0           = 1
 310 x ^ n  | n > 0  = f x (n-1) x
 311                   where f _ 0 y = y
 312                         f x n y = g x n where
 313                                   g x n | even n    = g (x*x) (n`quot`2)
 314                                         | otherwise = f x (n-1) (x*y)
 315 _ ^ _           = error "Prelude.^: negative exponent"
 316
 317 (^^)           :: (Fractional a, Integral b) => a -> b -> a
 318 x ^^ n          = if n >= 0 then x ^ n else recip (x^(-n))
 319
 320 fromIntegral   :: (Integral a, Num b) => a -> b
 321 fromIntegral    = fromInteger . toInteger
 322
 323 realToFrac     :: (Real a, Fractional b) => a -> b
 324 realToFrac      = fromRational . toRational
 325
 326 -- Index and Enumeration classes --------------------------------------------
 327
 328 class (Ord a) => Ix a where
 329     range                :: (a,a) -> [a]
 330     index                :: (a,a) -> a -> Int
 331     inRange              :: (a,a) -> a -> Bool
 332     rangeSize            :: (a,a) -> Int
 333
 334     rangeSize r@(l,u)
 335              | l > u      = 0
 336              | otherwise  = index r u + 1
 337
 338 class Enum a where
 339     succ, pred           :: a -> a
 340     toEnum               :: Int -> a
 341     fromEnum             :: a -> Int
 342     enumFrom             :: a -> [a]              -- [n..]
 343     enumFromThen         :: a -> a -> [a]         -- [n,m..]
 344     enumFromTo           :: a -> a -> [a]         -- [n..m]
 345     enumFromThenTo       :: a -> a -> a -> [a]    -- [n,n'..m]
 346
 347     -- Minimal complete definition: toEnum, fromEnum
 348     succ                  = toEnum . (1+)       . fromEnum
 349     pred                  = toEnum . subtract 1 . fromEnum
 350     enumFromTo x y        = map toEnum [ fromEnum x .. fromEnum y ]
 351     enumFromThenTo x y z  = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
 352
 353 -- Read and Show classes ------------------------------------------------------
 354
 355 type ReadS a = String -> [(a,String)]
 356 type ShowS   = String -> String
 357
 358 class Read a where
 359     readsPrec :: Int -> ReadS a
 360     readList  :: ReadS [a]
 361
 362     -- Minimal complete definition: readsPrec
 363     readList   = readParen False (\r -> [pr | ("[",s) <- lex r,
 364                                               pr      <- readl s ])
 365                  where readl  s = [([],t)   | ("]",t) <- lex s] ++
 366                                   [(x:xs,u) | (x,t)   <- reads s,
 367                                               (xs,u)  <- readl' t]
 368                        readl' s = [([],t)   | ("]",t) <- lex s] ++
 369                                   [(x:xs,v) | (",",t) <- lex s,
 370                                               (x,u)   <- reads t,
 371                                               (xs,v)  <- readl' u]
 372
 373 class Show a where
 374     show      :: a -> String
 375     showsPrec :: Int -> a -> ShowS
 376     showList  :: [a] -> ShowS
 377
 378     -- Minimal complete definition: show or showsPrec
 379     show x          = showsPrec 0 x ""
 380     showsPrec _ x s = show x ++ s
 381     showList []     = showString "[]"
 382     showList (x:xs) = showChar '[' . shows x . showl xs
 383                       where showl []     = showChar ']'
 384                             showl (x:xs) = showChar ',' . shows x . showl xs
 385
 386 -- Monad classes ------------------------------------------------------------
 387
 388 class Functor f where
 389     fmap :: (a -> b) -> (f a -> f b)
 390
 391 class Monad m where
 392     return :: a -> m a
 393     (>>=)  :: m a -> (a -> m b) -> m b
 394     (>>)   :: m a -> m b -> m b
 395     fail   :: String -> m a
 396
 397     -- Minimal complete definition: (>>=), return
 398     p >> q  = p >>= \ _ -> q
 399     fail s  = error s
 400
 401 accumulate       :: Monad m => [m a] -> m [a]
 402 accumulate []     = return []
 403 accumulate (c:cs) = do x  <- c
 404                        xs <- accumulate cs
 405                        return (x:xs)
 406
 407 sequence         :: Monad m => [m a] -> m ()
 408 sequence          = foldr (>>) (return ())
 409
 410 mapM             :: Monad m => (a -> m b) -> [a] -> m [b]
 411 mapM f            = accumulate . map f
 412
 413 mapM_            :: Monad m => (a -> m b) -> [a] -> m ()
 414 mapM_ f           = sequence . map f
 415
 416 (=<<)            :: Monad m => (a -> m b) -> m a -> m b
 417 f =<< x           = x >>= f
 418
 419 -- Evaluation and strictness ------------------------------------------------
 420
 421 seq           :: a -> b -> b
 422 seq x y       =  --case primForce x of () -> y
 423                  primSeq x y
 424
 425 ($!)          :: (a -> b) -> a -> b
 426 f $! x        =  x `seq` f x
 427
 428 -- Trivial type -------------------------------------------------------------
 429
 430 -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
 431
 432 instance Eq () where
 433     () == ()  =  True
 434
 435 instance Ord () where
 436     compare () () = EQ
 437
 438 instance Ix () where
 439     range ((),())      = [()]
 440     index ((),()) ()   = 0
 441     inRange ((),()) () = True
 442
 443 instance Enum () where
 444     toEnum 0           = ()
 445     fromEnum ()        = 0
 446     enumFrom ()        = [()]
 447     enumFromThen () () = [()]
 448
 449 instance Read () where
 450     readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
 451                                                    (")",t) <- lex s ])
 452
 453 instance Show () where
 454     showsPrec p () = showString "()"
 455
 456 instance Bounded () where
 457     minBound = ()
 458     maxBound = ()
 459
 460 -- Boolean type -------------------------------------------------------------
 461
 462 data Bool    = False | True
 463                deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
 464
 465 (&&), (||)  :: Bool -> Bool -> Bool
 466 False && x   = False
 467 True  && x   = x
 468 False || x   = x
 469 True  || x   = True
 470
 471 not         :: Bool -> Bool
 472 not True     = False
 473 not False    = True
 474
 475 otherwise   :: Bool
 476 otherwise    = True
 477
 478 -- Character type -----------------------------------------------------------
 479
 480 data Char               -- builtin datatype of ISO Latin characters
 481 type String = [Char]    -- strings are lists of characters
 482
 483 instance Eq Char  where (==) = primEqChar
 484 instance Ord Char where (<=) = primLeChar
 485
 486 instance Enum Char where
 487     toEnum           = primIntToChar
 488     fromEnum         = primCharToInt
 489     enumFrom c       = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
 490     enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
 491                        where lastChar = if d < c then minBound else maxBound
 492
 493 instance Ix Char where
 494     range (c,c')      = [c..c']
 495     index b@(c,c') ci
 496        | inRange b ci = fromEnum ci - fromEnum c
 497        | otherwise    = error "Ix.index: Index out of range."
 498     inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
 499                         where i = fromEnum ci
 500
 501 instance Read Char where
 502     readsPrec p      = readParen False
 503                             (\r -> [(c,t) | ('\'':s,t) <- lex r,
 504                                             (c,"\'")   <- readLitChar s ])
 505     readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
 506                                                (l,_)      <- readl s ])
 507                where readl ('"':s)      = [("",s)]
 508                      readl ('\\':'&':s) = readl s
 509                      readl s            = [(c:cs,u) | (c ,t) <- readLitChar s,
 510                                                       (cs,u) <- readl t ]
 511 instance Show Char where
 512     showsPrec p '\'' = showString "'\\''"
 513     showsPrec p c    = showChar '\'' . showLitChar c . showChar '\''
 514
 515     showList cs   = showChar '"' . showl cs
 516                     where showl ""       = showChar '"'
 517                           showl ('"':cs) = showString "\\\"" . showl cs
 518                           showl (c:cs)   = showLitChar c . showl cs
 519
 520 instance Bounded Char where
 521     minBound = '\0'
 522     maxBound = '\255'
 523
 524 isAscii, isControl, isPrint, isSpace            :: Char -> Bool
 525 isUpper, isLower, isAlpha, isDigit, isAlphaNum  :: Char -> Bool
 526
 527 isAscii c              =  fromEnum c < 128
 528 isControl c            =  c < ' ' ||  c == '\DEL'
 529 isPrint c              =  c >= ' ' &&  c <= '~'
 530 isSpace c              =  c == ' ' || c == '\t' || c == '\n' ||
 531                           c == '\r' || c == '\f' || c == '\v'
 532 isUpper c              =  c >= 'A'   &&  c <= 'Z'
 533 isLower c              =  c >= 'a'   &&  c <= 'z'
 534 isAlpha c              =  isUpper c  ||  isLower c
 535 isDigit c              =  c >= '0'   &&  c <= '9'
 536 isAlphaNum c           =  isAlpha c  ||  isDigit c
 537
 538 -- Digit conversion operations
 539 digitToInt :: Char -> Int
 540 digitToInt c
 541   | isDigit c            =  fromEnum c - fromEnum '0'
 542   | c >= 'a' && c <= 'f' =  fromEnum c - fromEnum 'a' + 10
 543   | c >= 'A' && c <= 'F' =  fromEnum c - fromEnum 'A' + 10
 544   | otherwise            =  error "Char.digitToInt: not a digit"
 545
 546 intToDigit :: Int -> Char
 547 intToDigit i
 548   | i >= 0  && i <=  9   =  toEnum (fromEnum '0' + i)
 549   | i >= 10 && i <= 15   =  toEnum (fromEnum 'a' + i - 10)
 550   | otherwise            =  error "Char.intToDigit: not a digit"
 551
 552 toUpper, toLower      :: Char -> Char
 553 toUpper c | isLower c  = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
 554           | otherwise  = c
 555
 556 toLower c | isUpper c  = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
 557           | otherwise  = c
 558
 559 ord                   :: Char -> Int
 560 ord                    = fromEnum
 561
 562 chr                   :: Int -> Char
 563 chr                    = toEnum
 564
 565 -- Maybe type ---------------------------------------------------------------
 566
 567 data Maybe a = Nothing | Just a
 568                deriving (Eq, Ord, Read, Show)
 569
 570 maybe             :: b -> (a -> b) -> Maybe a -> b
 571 maybe n f Nothing  = n
 572 maybe n f (Just x) = f x
 573
 574 instance Functor Maybe where
 575     fmap f Nothing  = Nothing
 576     fmap f (Just x) = Just (f x)
 577
 578 instance Monad Maybe where
 579     Just x  >>= k = k x
 580     Nothing >>= k = Nothing
 581     return        = Just
 582     fail s        = Nothing
 583
 584 -- Either type --------------------------------------------------------------
 585
 586 data Either a b = Left a | Right b
 587                   deriving (Eq, Ord, Read, Show)
 588
 589 either              :: (a -> c) -> (b -> c) -> Either a b -> c
 590 either l r (Left x)  = l x
 591 either l r (Right y) = r y
 592
 593 -- Ordering type ------------------------------------------------------------
 594
 595 data Ordering = LT | EQ | GT
 596                 deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
 597
 598 -- Lists --------------------------------------------------------------------
 599
 600 --data [a] = [] | a : [a] deriving (Eq, Ord)
 601
 602 instance Eq a => Eq [a] where
 603     []     == []     =  True
 604     (x:xs) == (y:ys) =  x==y && xs==ys
 605     _      == _      =  False
 606
 607 instance Ord a => Ord [a] where
 608     compare []     (_:_)  = LT
 609     compare []     []     = EQ
 610     compare (_:_)  []     = GT
 611     compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
 612
 613 instance Functor [] where
 614     fmap = map
 615
 616 instance Monad [ ] where
 617     (x:xs) >>= f = f x ++ (xs >>= f)
 618     []     >>= f = []
 619     return x     = [x]
 620     fail s       = []
 621
 622 instance Read a => Read [a]  where
 623     readsPrec p = readList
 624
 625 instance Show a => Show [a]  where
 626     showsPrec p = showList
 627
 628 -- Tuples -------------------------------------------------------------------
 629
 630 -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
 631 -- etc..
 632
 633 -- Functions ----------------------------------------------------------------
 634
 635 instance Show (a -> b) where
 636     showsPrec p f = showString "<<function>>"
 637
 638 instance Functor ((->) a) where
 639     fmap = (.)
 640
 641 -- Standard Integral types --------------------------------------------------
 642
 643 data Int      -- builtin datatype of fixed size integers
 644 data Integer  -- builtin datatype of arbitrary size integers
 645
 646 instance Eq Integer where
 647     (==) x y = primCompareInteger x y == 0
 648
 649 instance Ord Integer where
 650     compare x y = case primCompareInteger x y of
 651                       -1 -> LT
 652                       0  -> EQ
 653                       1  -> GT
 654
 655 instance Eq Int where
 656     (==)          = primEqInt
 657     (/=)          = primNeInt
 658
 659 instance Ord Int     where
 660     (<)           = primLtInt
 661     (<=)          = primLeInt
 662     (>=)          = primGeInt
 663     (>)           = primGtInt
 664
 665 instance Num Int where
 666     (+)           = primPlusInt
 667     (-)           = primMinusInt
 668     negate        = primNegateInt
 669     (*)           = primTimesInt
 670     abs           = absReal
 671     signum        = signumReal
 672     fromInteger   = primIntegerToInt
 673     fromInt x     = x
 674
 675 instance Bounded Int where
 676     minBound = primMinInt
 677     maxBound = primMaxInt
 678
 679 instance Num Integer where
 680     (+)           = primPlusInteger
 681     (-)           = primMinusInteger
 682     negate        = primNegateInteger
 683     (*)           = primTimesInteger
 684     abs           = absReal
 685     signum        = signumReal
 686     fromInteger x = x
 687     fromInt       = primIntToInteger
 688
 689 absReal x    | x >= 0    = x
 690              | otherwise = -x
 691
 692 signumReal x | x == 0    =  0
 693              | x > 0     =  1
 694              | otherwise = -1
 695
 696 instance Real Int where
 697     toRational x = toInteger x % 1
 698
 699 instance Real Integer where
 700     toRational x = x % 1
 701
 702 instance Integral Int where
 703     quotRem   = primQuotRemInt
 704     toInteger = primIntToInteger
 705     toInt x   = x
 706
 707 instance Integral Integer where
 708     quotRem       = primQuotRemInteger
 709     --divMod        = primDivModInteger
 710     toInteger     = id
 711     toInt         = primIntegerToInt
 712
 713 instance Ix Int where
 714     range (m,n)          = [m..n]
 715     index b@(m,n) i
 716            | inRange b i = i - m
 717            | otherwise   = error "index: Index out of range"
 718     inRange (m,n) i      = m <= i && i <= n
 719
 720 instance Ix Integer where
 721     range (m,n)          = [m..n]
 722     index b@(m,n) i
 723            | inRange b i = fromInteger (i - m)
 724            | otherwise   = error "index: Index out of range"
 725     inRange (m,n) i      = m <= i && i <= n
 726
 727 instance Enum Int where
 728     toEnum               = id
 729     fromEnum             = id
 730     enumFrom       = numericEnumFrom
 731     enumFromTo     = numericEnumFromTo
 732     enumFromThen   = numericEnumFromThen
 733     enumFromThenTo = numericEnumFromThenTo
 734
 735 instance Enum Integer where
 736     toEnum         = primIntToInteger
 737     fromEnum       = primIntegerToInt
 738     enumFrom       = numericEnumFrom
 739     enumFromTo     = numericEnumFromTo
 740     enumFromThen   = numericEnumFromThen
 741     enumFromThenTo = numericEnumFromThenTo
 742
 743 numericEnumFrom        :: Real a => a -> [a]
 744 numericEnumFromThen    :: Real a => a -> a -> [a]
 745 numericEnumFromTo      :: Real a => a -> a -> [a]
 746 numericEnumFromThenTo  :: Real a => a -> a -> a -> [a]
 747 numericEnumFrom n            = n : (numericEnumFrom $! (n+1))
 748 numericEnumFromThen n m      = iterate ((m-n)+) n
 749 numericEnumFromTo n m        = takeWhile (<= m) (numericEnumFrom n)
 750 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
 751                                where p | n' >= n   = (<= m)
 752                                        | otherwise = (>= m)
 753
 754 instance Read Int where
 755     readsPrec p = readSigned readDec
 756
 757 instance  Show Int  where
 758     showsPrec p n
 759       | n == minBound = showSigned showInt p (toInteger n)
 760       | otherwise     = showSigned showInt p n
 761
 762 instance Read Integer where
 763     readsPrec p = readSigned readDec
 764
 765 instance Show Integer where
 766     showsPrec   = showSigned showInt
 767
 768
 769 -- Standard Floating types --------------------------------------------------
 770
 771 data Float     -- builtin datatype of single precision floating point numbers
 772 data Double    -- builtin datatype of double precision floating point numbers
 773
 774 instance Eq  Float  where
 775     (==)          = primEqFloat
 776     (/=)          = primNeFloat
 777
 778 instance Ord Float  where
 779     (<)           = primLtFloat
 780     (<=)          = primLeFloat
 781     (>=)          = primGeFloat
 782     (>)           = primGtFloat
 783
 784 instance Num Float where
 785     (+)           = primPlusFloat
 786     (-)           = primMinusFloat
 787     negate        = primNegateFloat
 788     (*)           = primTimesFloat
 789     abs           = absReal
 790     signum        = signumReal
 791     fromInteger   = primIntegerToFloat
 792     fromInt       = primIntToFloat
 793
 794
 795
 796 instance Eq  Double  where
 797     (==)         = primEqDouble
 798     (/=)         = primNeDouble
 799
 800 instance Ord Double  where
 801     (<)          = primLtDouble
 802     (<=)         = primLeDouble
 803     (>=)         = primGeDouble
 804     (>)          = primGtDouble
 805
 806 instance Num Double where
 807     (+)          = primPlusDouble
 808     (-)          = primMinusDouble
 809     negate       = primNegateDouble
 810     (*)          = primTimesDouble
 811     abs          = absReal
 812     signum       = signumReal
 813     fromInteger  = primIntegerToDouble
 814     fromInt      = primIntToDouble
 815
 816
 817
 818 instance Real Float where
 819     toRational = floatToRational
 820
 821 instance Real Double where
 822     toRational = doubleToRational
 823
 824 -- Calls to these functions are optimised when passed as arguments to
 825 -- fromRational.
 826 floatToRational  :: Float  -> Rational
 827 doubleToRational :: Double -> Rational
 828 floatToRational  x = realFloatToRational x
 829 doubleToRational x = realFloatToRational x
 830
 831 realFloatToRational x = (m%1)*(b%1)^^n
 832                         where (m,n) = decodeFloat x
 833                               b     = floatRadix x
 834
 835 instance Fractional Float where
 836     (/)           = primDivideFloat
 837     fromRational  = rationalToRealFloat
 838     fromDouble    = primDoubleToFloat
 839
 840
 841 instance Fractional Double where
 842     (/)          = primDivideDouble
 843     fromRational = rationalToRealFloat
 844     fromDouble x = x
 845
 846 rationalToRealFloat x = x'
 847  where x'    = f e
 848        f e   = if e' == e then y else f e'
 849                where y      = encodeFloat (round (x * (1%b)^^e)) e
 850                      (_,e') = decodeFloat y
 851        (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
 852                              / fromInteger (denominator x))
 853        b     = floatRadix x'
 854
 855 instance Floating Float where
 856     pi    = 3.14159265358979323846
 857     exp   = primExpFloat
 858     log   = primLogFloat
 859     sqrt  = primSqrtFloat
 860     sin   = primSinFloat
 861     cos   = primCosFloat
 862     tan   = primTanFloat
 863     asin  = primAsinFloat
 864     acos  = primAcosFloat
 865     atan  = primAtanFloat
 866
 867 instance Floating Double where
 868     pi    = 3.14159265358979323846
 869     exp   = primExpDouble
 870     log   = primLogDouble
 871     sqrt  = primSqrtDouble
 872     sin   = primSinDouble
 873     cos   = primCosDouble
 874     tan   = primTanDouble
 875     asin  = primAsinDouble
 876     acos  = primAcosDouble
 877     atan  = primAtanDouble
 878
 879 instance RealFrac Float where
 880     properFraction = floatProperFraction
 881
 882 instance RealFrac Double where
 883     properFraction = floatProperFraction
 884
 885 floatProperFraction x
 886    | n >= 0      = (fromInteger m * fromInteger b ^ n, 0)
 887    | otherwise   = (fromInteger w, encodeFloat r n)
 888                    where (m,n) = decodeFloat x
 889                          b     = floatRadix x
 890                          (w,r) = quotRem m (b^(-n))
 891
 892 instance RealFloat Float where
 893     floatRadix  _ = toInteger primRadixFloat
 894     floatDigits _ = primDigitsFloat
 895     floatRange  _ = (primMinExpFloat,primMaxExpFloat)
 896     encodeFloat   = primEncodeFloatZ
 897     decodeFloat   = primDecodeFloatZ
 898     isNaN         = primIsNaNFloat
 899     isInfinite    = primIsInfiniteFloat
 900     isDenormalized= primIsDenormalizedFloat
 901     isNegativeZero= primIsNegativeZeroFloat
 902     isIEEE        = const primIsIEEEFloat
 903
 904 instance RealFloat Double where
 905     floatRadix  _ = toInteger primRadixDouble
 906     floatDigits _ = primDigitsDouble
 907     floatRange  _ = (primMinExpDouble,primMaxExpDouble)
 908     encodeFloat   = primEncodeDoubleZ
 909     decodeFloat   = primDecodeDoubleZ
 910     isNaN         = primIsNaNDouble
 911     isInfinite    = primIsInfiniteDouble
 912     isDenormalized= primIsDenormalizedDouble
 913     isNegativeZero= primIsNegativeZeroDouble
 914     isIEEE        = const primIsIEEEDouble
 915
 916 instance Enum Float where
 917     toEnum                = primIntToFloat
 918     fromEnum              = truncate
 919     enumFrom              = numericEnumFrom
 920     enumFromThen          = numericEnumFromThen
 921     enumFromTo n m        = numericEnumFromTo n (m+1/2)
 922     enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
 923
 924 instance Enum Double where
 925     toEnum                = primIntToDouble
 926     fromEnum              = truncate
 927     enumFrom              = numericEnumFrom
 928     enumFromThen          = numericEnumFromThen
 929     enumFromTo n m        = numericEnumFromTo n (m+1/2)
 930     enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
 931
 932 instance Read Float where
 933     readsPrec p = readSigned readFloat
 934
 935 instance Show Float where
 936     showsPrec p = showSigned showFloat p
 937
 938 instance Read Double where
 939     readsPrec p = readSigned readFloat
 940
 941 instance Show Double where
 942     showsPrec p = showSigned showFloat p
 943
 944
 945 -- Some standard functions --------------------------------------------------
 946
 947 fst            :: (a,b) -> a
 948 fst (x,_)       = x
 949
 950 snd            :: (a,b) -> b
 951 snd (_,y)       = y
 952
 953 curry          :: ((a,b) -> c) -> (a -> b -> c)
 954 curry f x y     = f (x,y)
 955
 956 uncurry        :: (a -> b -> c) -> ((a,b) -> c)
 957 uncurry f p     = f (fst p) (snd p)
 958
 959 id             :: a -> a
 960 id    x         = x
 961
 962 const          :: a -> b -> a
 963 const k _       = k
 964
 965 (.)            :: (b -> c) -> (a -> b) -> (a -> c)
 966 (f . g) x       = f (g x)
 967
 968 flip           :: (a -> b -> c) -> b -> a -> c
 969 flip f x y      = f y x
 970
 971 ($)            :: (a -> b) -> a -> b
 972 f $ x           = f x
 973
 974 until          :: (a -> Bool) -> (a -> a) -> a -> a
 975 until p f x     = if p x then x else until p f (f x)
 976
 977 asTypeOf       :: a -> a -> a
 978 asTypeOf        = const
 979
 980 error          :: String -> a
 981 error msg      =  primRaise (ErrorCall msg)
 982
 983 undefined         :: a
 984 undefined | False = undefined
 985
 986 -- Standard functions on rational numbers {PreludeRatio} --------------------
 987
 988 data Integral a => Ratio a = a :% a deriving (Eq)
 989 type Rational              = Ratio Integer
 990
 991 (%)                       :: Integral a => a -> a -> Ratio a
 992 x % y                      = reduce (x * signum y) (abs y)
 993
 994 reduce                    :: Integral a => a -> a -> Ratio a
 995 reduce x y | y == 0        = error "Ratio.%: zero denominator"
 996            | otherwise     = (x `quot` d) :% (y `quot` d)
 997                              where d = gcd x y
 998
 999 numerator, denominator    :: Integral a => Ratio a -> a
1000 numerator (x :% y)         = x
1001 denominator (x :% y)       = y
1002
1003 instance Integral a => Ord (Ratio a) where
1004     compare (x:%y) (x':%y') = compare (x*y') (x'*y)
1005
1006 instance Integral a => Num (Ratio a) where
1007     (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
1008     (x:%y) * (x':%y') = reduce (x*x') (y*y')
1009     negate (x :% y)   = negate x :% y
1010     abs (x :% y)      = abs x :% y
1011     signum (x :% y)   = signum x :% 1
1012     fromInteger x     = fromInteger x :% 1
1013     fromInt           = intToRatio
1014
1015 -- Hugs optimises code of the form fromRational (intToRatio x)
1016 intToRatio :: Integral a => Int -> Ratio a
1017 intToRatio x = fromInt x :% 1
1018
1019 instance Integral a => Real (Ratio a) where
1020     toRational (x:%y) = toInteger x :% toInteger y
1021
1022 instance Integral a => Fractional (Ratio a) where
1023     (x:%y) / (x':%y')   = (x*y') % (y*x')
1024     recip (x:%y)        = if x < 0 then (-y) :% (-x) else y :% x
1025     fromRational (x:%y) = fromInteger x :% fromInteger y
1026     fromDouble          = doubleToRatio
1027
1028 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1029 doubleToRatio :: Integral a => Double -> Ratio a
1030 doubleToRatio x
1031             | n>=0      = (fromInteger m * fromInteger b ^ n) % 1
1032             | otherwise = fromInteger m % (fromInteger b ^ (-n))
1033                           where (m,n) = decodeFloat x
1034                                 b     = floatRadix x
1035
1036 instance Integral a => RealFrac (Ratio a) where
1037     properFraction (x:%y) = (fromIntegral q, r:%y)
1038                             where (q,r) = quotRem x y
1039
1040 instance Integral a => Enum (Ratio a) where
1041     toEnum       = fromInt
1042     fromEnum     = truncate
1043     enumFrom     = numericEnumFrom
1044     enumFromThen = numericEnumFromThen
1045
1046 instance (Read a, Integral a) => Read (Ratio a) where
1047     readsPrec p = readParen (p > 7)
1048                             (\r -> [(x%y,u) | (x,s)   <- reads r,
1049                                               ("%",t) <- lex s,
1050                                               (y,u)   <- reads t ])
1051
1052 instance Integral a => Show (Ratio a) where
1053     showsPrec p (x:%y) = showParen (p > 7)
1054                              (shows x . showString " % " . shows y)
1055
1056 approxRational      :: RealFrac a => a -> a -> Rational
1057 approxRational x eps = simplest (x-eps) (x+eps)
1058  where simplest x y | y < x     = simplest y x
1059                     | x == y    = xr
1060                     | x > 0     = simplest' n d n' d'
1061                     | y < 0     = - simplest' (-n') d' (-n) d
1062                     | otherwise = 0 :% 1
1063                                   where xr@(n:%d) = toRational x
1064                                         (n':%d')  = toRational y
1065        simplest' n d n' d'        -- assumes 0 < n%d < n'%d'
1066                     | r == 0    = q :% 1
1067                     | q /= q'   = (q+1) :% 1
1068                     | otherwise = (q*n''+d'') :% n''
1069                                   where (q,r)      = quotRem n d
1070                                         (q',r')    = quotRem n' d'
1071                                         (n'':%d'') = simplest' d' r' d r
1072
1073 -- Standard list functions {PreludeList} ------------------------------------
1074
1075 head             :: [a] -> a
1076 head (x:_)        = x
1077
1078 last             :: [a] -> a
1079 last [x]          = x
1080 last (_:xs)       = last xs
1081
1082 tail             :: [a] -> [a]
1083 tail (_:xs)       = xs
1084
1085 init             :: [a] -> [a]
1086 init [x]          = []
1087 init (x:xs)       = x : init xs
1088
1089 null             :: [a] -> Bool
1090 null []           = True
1091 null (_:_)        = False
1092
1093 (++)             :: [a] -> [a] -> [a]
1094 []     ++ ys      = ys
1095 (x:xs) ++ ys      = x : (xs ++ ys)
1096
1097 map              :: (a -> b) -> [a] -> [b]
1098 map f xs          = [ f x | x <- xs ]
1099
1100 filter           :: (a -> Bool) -> [a] -> [a]
1101 filter p xs       = [ x | x <- xs, p x ]
1102
1103 concat           :: [[a]] -> [a]
1104 concat            = foldr (++) []
1105
1106 length           :: [a] -> Int
1107 length            = foldl' (\n _ -> n + 1) 0
1108
1109 (!!)             :: [b] -> Int -> b
1110 (x:_)  !! 0       = x
1111 (_:xs) !! n | n>0 = xs !! (n-1)
1112 (_:_)  !! _       = error "Prelude.!!: negative index"
1113 []     !! _       = error "Prelude.!!: index too large"
1114
1115 foldl            :: (a -> b -> a) -> a -> [b] -> a
1116 foldl f z []      = z
1117 foldl f z (x:xs)  = foldl f (f z x) xs
1118
1119 foldl'           :: (a -> b -> a) -> a -> [b] -> a
1120 foldl' f a []     = a
1121 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1122
1123 foldl1           :: (a -> a -> a) -> [a] -> a
1124 foldl1 f (x:xs)   = foldl f x xs
1125
1126 scanl            :: (a -> b -> a) -> a -> [b] -> [a]
1127 scanl f q xs      = q : (case xs of
1128                          []   -> []
1129                          x:xs -> scanl f (f q x) xs)
1130
1131 scanl1           :: (a -> a -> a) -> [a] -> [a]
1132 scanl1 f (x:xs)   = scanl f x xs
1133
1134 foldr            :: (a -> b -> b) -> b -> [a] -> b
1135 foldr f z []      = z
1136 foldr f z (x:xs)  = f x (foldr f z xs)
1137
1138 foldr1           :: (a -> a -> a) -> [a] -> a
1139 foldr1 f [x]      = x
1140 foldr1 f (x:xs)   = f x (foldr1 f xs)
1141
1142 scanr            :: (a -> b -> b) -> b -> [a] -> [b]
1143 scanr f q0 []     = [q0]
1144 scanr f q0 (x:xs) = f x q : qs
1145                     where qs@(q:_) = scanr f q0 xs
1146
1147 scanr1           :: (a -> a -> a) -> [a] -> [a]
1148 scanr1 f [x]      = [x]
1149 scanr1 f (x:xs)   = f x q : qs
1150                     where qs@(q:_) = scanr1 f xs
1151
1152 iterate          :: (a -> a) -> a -> [a]
1153 iterate f x       = x : iterate f (f x)
1154
1155 repeat           :: a -> [a]
1156 repeat x          = xs where xs = x:xs
1157
1158 replicate        :: Int -> a -> [a]
1159 replicate n x     = take n (repeat x)
1160
1161 cycle            :: [a] -> [a]
1162 cycle []          = error "Prelude.cycle: empty list"
1163 cycle xs          = xs' where xs'=xs++xs'
1164
1165 take                :: Int -> [a] -> [a]
1166 take 0 _             = []
1167 take _ []            = []
1168 take n (x:xs) | n>0  = x : take (n-1) xs
1169 take _ _             = error "Prelude.take: negative argument"
1170
1171 drop                :: Int -> [a] -> [a]
1172 drop 0 xs            = xs
1173 drop _ []            = []
1174 drop n (_:xs) | n>0  = drop (n-1) xs
1175 drop _ _             = error "Prelude.drop: negative argument"
1176
1177 splitAt               :: Int -> [a] -> ([a], [a])
1178 splitAt 0 xs           = ([],xs)
1179 splitAt _ []           = ([],[])
1180 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1181 splitAt _ _            = error "Prelude.splitAt: negative argument"
1182
1183 takeWhile           :: (a -> Bool) -> [a] -> [a]
1184 takeWhile p []       = []
1185 takeWhile p (x:xs)
1186          | p x       = x : takeWhile p xs
1187          | otherwise = []
1188
1189 dropWhile           :: (a -> Bool) -> [a] -> [a]
1190 dropWhile p []       = []
1191 dropWhile p xs@(x:xs')
1192          | p x       = dropWhile p xs'
1193          | otherwise = xs
1194
1195 span, break         :: (a -> Bool) -> [a] -> ([a],[a])
1196 span p []            = ([],[])
1197 span p xs@(x:xs')
1198          | p x       = (x:ys, zs)
1199          | otherwise = ([],xs)
1200                        where (ys,zs) = span p xs'
1201 break p              = span (not . p)
1202
1203 lines     :: String -> [String]
1204 lines ""   = []
1205 lines s    = let (l,s') = break ('\n'==) s
1206              in l : case s' of []      -> []
1207                                (_:s'') -> lines s''
1208
1209 words     :: String -> [String]
1210 words s    = case dropWhile isSpace s of
1211                   "" -> []
1212                   s' -> w : words s''
1213                         where (w,s'') = break isSpace s'
1214
1215 unlines   :: [String] -> String
1216 unlines    = concatMap (\l -> l ++ "\n")
1217
1218 unwords   :: [String] -> String
1219 unwords [] = []
1220 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1221
1222 reverse   :: [a] -> [a]
1223 reverse    = foldl (flip (:)) []
1224
1225 and, or   :: [Bool] -> Bool
1226 and        = foldr (&&) True
1227 or         = foldr (||) False
1228
1229 any, all  :: (a -> Bool) -> [a] -> Bool
1230 any p      = or  . map p
1231 all p      = and . map p
1232
1233 elem, notElem    :: Eq a => a -> [a] -> Bool
1234 elem              = any . (==)
1235 notElem           = all . (/=)
1236
1237 lookup           :: Eq a => a -> [(a,b)] -> Maybe b
1238 lookup k []       = Nothing
1239 lookup k ((x,y):xys)
1240       | k==x      = Just y
1241       | otherwise = lookup k xys
1242
1243 sum, product     :: Num a => [a] -> a
1244 sum               = foldl' (+) 0
1245 product           = foldl' (*) 1
1246
1247 maximum, minimum :: Ord a => [a] -> a
1248 maximum           = foldl1 max
1249 minimum           = foldl1 min
1250
1251 concatMap        :: (a -> [b]) -> [a] -> [b]
1252 concatMap f       = concat . map f
1253
1254 zip              :: [a] -> [b] -> [(a,b)]
1255 zip               = zipWith  (\a b -> (a,b))
1256
1257 zip3             :: [a] -> [b] -> [c] -> [(a,b,c)]
1258 zip3              = zipWith3 (\a b c -> (a,b,c))
1259
1260 zipWith                  :: (a->b->c) -> [a]->[b]->[c]
1261 zipWith z (a:as) (b:bs)   = z a b : zipWith z as bs
1262 zipWith _ _      _        = []
1263
1264 zipWith3                 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1265 zipWith3 z (a:as) (b:bs) (c:cs)
1266                           = z a b c : zipWith3 z as bs cs
1267 zipWith3 _ _ _ _          = []
1268
1269 unzip                    :: [(a,b)] -> ([a],[b])
1270 unzip                     = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1271
1272 unzip3                   :: [(a,b,c)] -> ([a],[b],[c])
1273 unzip3                    = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1274                                   ([],[],[])
1275
1276 -- PreludeText ----------------------------------------------------------------
1277
1278 reads        :: Read a => ReadS a
1279 reads         = readsPrec 0
1280
1281 shows        :: Show a => a -> ShowS
1282 shows         = showsPrec 0
1283
1284 read         :: Read a => String -> a
1285 read s        =  case [x | (x,t) <- reads s, ("","") <- lex t] of
1286                       [x] -> x
1287                       []  -> error "Prelude.read: no parse"
1288                       _   -> error "Prelude.read: ambiguous parse"
1289
1290 showChar     :: Char -> ShowS
1291 showChar      = (:)
1292
1293 showString   :: String -> ShowS
1294 showString    = (++)
1295
1296 showParen    :: Bool -> ShowS -> ShowS
1297 showParen b p = if b then showChar '(' . p . showChar ')' else p
1298
1299 showField    :: Show a => String -> a -> ShowS
1300 showField m v = showString m . showChar '=' . shows v
1301
1302 readParen    :: Bool -> ReadS a -> ReadS a
1303 readParen b g = if b then mandatory else optional
1304                 where optional r  = g r ++ mandatory r
1305                       mandatory r = [(x,u) | ("(",s) <- lex r,
1306                                              (x,t)   <- optional s,
1307                                              (")",u) <- lex t    ]
1308
1309
1310 readField    :: Read a => String -> ReadS a
1311 readField m s0 = [ r | (t,  s1) <- lex s0, t == m,
1312                        ("=",s2) <- lex s1,
1313                        r        <- reads s2 ]
1314
1315 lex                    :: ReadS String
1316 lex ""                  = [("","")]
1317 lex (c:s) | isSpace c   = lex (dropWhile isSpace s)
1318 lex ('\'':s)            = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
1319                                                ch /= "'"                ]
1320 lex ('"':s)             = [('"':str, t)      | (str,t) <- lexString s]
1321                           where
1322                           lexString ('"':s) = [("\"",s)]
1323                           lexString s = [(ch++str, u)
1324                                                 | (ch,t)  <- lexStrItem s,
1325                                                   (str,u) <- lexString t  ]
1326
1327                           lexStrItem ('\\':'&':s) = [("\\&",s)]
1328                           lexStrItem ('\\':c:s) | isSpace c
1329                               = [("",t) | '\\':t <- [dropWhile isSpace s]]
1330                           lexStrItem s            = lexLitChar s
1331
1332 lex (c:s) | isSingle c  = [([c],s)]
1333           | isSym c     = [(c:sym,t)         | (sym,t) <- [span isSym s]]
1334           | isAlpha c   = [(c:nam,t)         | (nam,t) <- [span isIdChar s]]
1335           | isDigit c   = [(c:ds++fe,t)      | (ds,s)  <- [span isDigit s],
1336                                                (fe,t)  <- lexFracExp s     ]
1337           | otherwise   = []    -- bad character
1338                 where
1339                 isSingle c  =  c `elem` ",;()[]{}_`"
1340                 isSym c     =  c `elem` "!@#$%&*+./<=>?\\^|:-~"
1341                 isIdChar c  =  isAlphaNum c || c `elem` "_'"
1342
1343                 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1344                                                       (e,u)  <- lexExp t    ]
1345                 lexFracExp s       = [("",s)]
1346
1347                 lexExp (e:s) | e `elem` "eE"
1348                          = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
1349                                                    (ds,u) <- lexDigits t] ++
1350                            [(e:ds,t)   | (ds,t) <- lexDigits s]
1351                 lexExp s = [("",s)]
1352
1353 lexDigits               :: ReadS String
1354 lexDigits               =  nonnull isDigit
1355
1356 nonnull                 :: (Char -> Bool) -> ReadS String
1357 nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
1358
1359 lexLitChar              :: ReadS String
1360 lexLitChar ('\\':s)     =  [('\\':esc, t) | (esc,t) <- lexEsc s]
1361         where
1362         lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]
1363         lexEsc ('^':c:s) | c >= '@' && c <= '_'    = [(['^',c],s)]
1364         lexEsc s@(d:_)   | isDigit d               = lexDigits s
1365         lexEsc s@(c:_)   | isUpper c
1366                           = let table = ('\DEL',"DEL") : asciiTab
1367                             in case [(mne,s') | (c, mne) <- table,
1368                                                 ([],s') <- [lexmatch mne s]]
1369                                of (pr:_) -> [pr]
1370                                   []     -> []
1371         lexEsc _                                   = []
1372 lexLitChar (c:s)        =  [([c],s)]
1373 lexLitChar ""           =  []
1374
1375 isOctDigit c  =  c >= '0' && c <= '7'
1376 isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'
1377                            || c >= 'a' && c <= 'f'
1378
1379 lexmatch                   :: (Eq a) => [a] -> [a] -> ([a],[a])
1380 lexmatch (x:xs) (y:ys) | x == y  =  lexmatch xs ys
1381 lexmatch xs     ys               =  (xs,ys)
1382
1383 asciiTab = zip ['\NUL'..' ']
1384            ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1385             "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
1386             "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1387             "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
1388             "SP"]
1389
1390 readLitChar            :: ReadS Char
1391 readLitChar ('\\':s)    = readEsc s
1392  where
1393        readEsc ('a':s)  = [('\a',s)]
1394        readEsc ('b':s)  = [('\b',s)]
1395        readEsc ('f':s)  = [('\f',s)]
1396        readEsc ('n':s)  = [('\n',s)]
1397        readEsc ('r':s)  = [('\r',s)]
1398        readEsc ('t':s)  = [('\t',s)]
1399        readEsc ('v':s)  = [('\v',s)]
1400        readEsc ('\\':s) = [('\\',s)]
1401        readEsc ('"':s)  = [('"',s)]
1402        readEsc ('\'':s) = [('\'',s)]
1403        readEsc ('^':c:s) | c >= '@' && c <= '_'
1404                         = [(toEnum (fromEnum c - fromEnum '@'), s)]
1405        readEsc s@(d:_) | isDigit d
1406                         = [(toEnum n, t) | (n,t) <- readDec s]
1407        readEsc ('o':s)  = [(toEnum n, t) | (n,t) <- readOct s]
1408        readEsc ('x':s)  = [(toEnum n, t) | (n,t) <- readHex s]
1409        readEsc s@(c:_) | isUpper c
1410                         = let table = ('\DEL',"DEL") : asciiTab
1411                           in case [(c,s') | (c, mne) <- table,
1412                                             ([],s') <- [lexmatch mne s]]
1413                              of (pr:_) -> [pr]
1414                                 []     -> []
1415        readEsc _        = []
1416 readLitChar (c:s)       = [(c,s)]
1417
1418 showLitChar               :: Char -> ShowS
1419 showLitChar c | c > '\DEL' = showChar '\\' .
1420                              protectEsc isDigit (shows (fromEnum c))
1421 showLitChar '\DEL'         = showString "\\DEL"
1422 showLitChar '\\'           = showString "\\\\"
1423 showLitChar c | c >= ' '   = showChar c
1424 showLitChar '\a'           = showString "\\a"
1425 showLitChar '\b'           = showString "\\b"
1426 showLitChar '\f'           = showString "\\f"
1427 showLitChar '\n'           = showString "\\n"
1428 showLitChar '\r'           = showString "\\r"
1429 showLitChar '\t'           = showString "\\t"
1430 showLitChar '\v'           = showString "\\v"
1431 showLitChar '\SO'          = protectEsc ('H'==) (showString "\\SO")
1432 showLitChar c              = showString ('\\' : snd (asciiTab!!fromEnum c))
1433
1434 protectEsc p f             = f . cont
1435  where cont s@(c:_) | p c  = "\\&" ++ s
1436        cont s              = s
1437
1438 -- Unsigned readers for various bases
1439 readDec, readOct, readHex :: Integral a => ReadS a
1440 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1441 readOct = readInt  8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1442 readHex = readInt 16 isHexDigit hex
1443           where hex d = fromEnum d -
1444                         (if isDigit d
1445                            then fromEnum '0'
1446                            else fromEnum (if isUpper d then 'A' else 'a') - 10)
1447
1448 -- readInt reads a string of digits using an arbitrary base.
1449 -- Leading minus signs must be handled elsewhere.
1450
1451 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1452 readInt radix isDig digToInt s =
1453     [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1454         | (ds,r) <- nonnull isDig s ]
1455
1456 -- showInt is used for positive numbers only
1457 showInt    :: Integral a => a -> ShowS
1458 showInt n r
1459    | n < 0
1460    = error "Numeric.showInt: can't show negative numbers"
1461    | otherwise
1462 {-
1463    = let (n',d) = quotRem n 10
1464          r'     = toEnum (fromEnum '0' + fromIntegral d) : r
1465      in  if n' == 0 then r' else showInt n' r'
1466 -}
1467    = case quotRem n 10 of { (n',d) ->
1468      let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1469      in  if n' == 0 then r' else showInt n' r'
1470      }
1471
1472
1473 readSigned:: Real a => ReadS a -> ReadS a
1474 readSigned readPos = readParen False read'
1475                      where read' r  = read'' r ++
1476                                       [(-x,t) | ("-",s) <- lex r,
1477                                                 (x,t)   <- read'' s]
1478                            read'' r = [(n,s)  | (str,s) <- lex r,
1479                                                 (n,"")  <- readPos str]
1480
1481 showSigned    :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1482 showSigned showPos p x = if x < 0 then showParen (p > 6)
1483                                                  (showChar '-' . showPos (-x))
1484                                   else showPos x
1485
1486 readFloat     :: RealFloat a => ReadS a
1487 readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1488                                                        (k,t)   <- readExp s]
1489                  where readFix r = [(read (ds++ds'), length ds', t)
1490                                         | (ds, s) <- lexDigits r
1491                                         , (ds',t) <- lexFrac s   ]
1492
1493                        lexFrac ('.':s) = lexDigits s
1494                        lexFrac s       = [("",s)]
1495
1496                        readExp (e:s) | e `elem` "eE" = readExp' s
1497                        readExp s                     = [(0,s)]
1498
1499                        readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1500                        readExp' ('+':s) = readDec s
1501                        readExp' s       = readDec s
1502
1503
1504 -- Hooks for primitives: -----------------------------------------------------
1505 -- Do not mess with these!
1506
1507 primCompAux      :: Ord a => a -> a -> Ordering -> Ordering
1508 primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1509
1510 primPmInt        :: Num a => Int -> a -> Bool
1511 primPmInt n x     = fromInt n == x
1512
1513 primPmInteger    :: Num a => Integer -> a -> Bool
1514 primPmInteger n x = fromInteger n == x
1515
1516 primPmFlt        :: Fractional a => Double -> a -> Bool
1517 primPmFlt n x     = fromDouble n == x
1518
1519 -- ToDo: make the message more informative.
1520 primPmFail       :: a
1521 primPmFail        = error "Pattern Match Failure"
1522
1523 -- used in desugaring Foreign functions
1524 primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1525 primMkIO = ST
1526
1527 -- The following primitives are only needed if (n+k) patterns are enabled:
1528 primPmNpk        :: Integral a => Int -> a -> Maybe a
1529 primPmNpk n x     = if n'<=x then Just (x-n') else Nothing
1530                     where n' = fromInt n
1531
1532 primPmSub        :: Integral a => Int -> a -> a
1533 primPmSub n x     = x - fromInt n
1534
1535 -- Unpack strings generated by the Hugs code generator.
1536 -- Strings can contain \0 provided they're coded right.
1537 --
1538 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1539
1540 primUnpackString :: Addr -> String
1541 primUnpackString a = unpack 0
1542  where
1543   -- The following decoding is based on evalString in the old machine.c
1544   unpack i
1545     | c == '\0' = []
1546     | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1547                   then '\\' : unpack (i+2)
1548                   else '\0' : unpack (i+2)
1549     | otherwise = c : unpack (i+1)
1550    where
1551     c = primIndexCharOffAddr a i
1552
1553
1554 -- Monadic I/O: --------------------------------------------------------------
1555
1556 type FilePath = String
1557
1558 --data IOError = ...
1559 --instance Eq IOError ...
1560 --instance Show IOError ...
1561
1562 data IOError = IOError String
1563 instance Show IOError where
1564    showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1565
1566 ioError :: IOError -> IO a
1567 ioError (IOError s) = primRaise (IOExcept s)
1568
1569 userError :: String -> IOError
1570 userError s = primRaise (ErrorCall s)
1571
1572 catch :: IO a -> (IOError -> IO a) -> IO a
1573 catch m k
1574   = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
1575     where
1576        e2ioe (IOExcept s) = IOError s
1577        e2ioe other        = IOError (show other)
1578
1579 putChar :: Char -> IO ()
1580 putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c)
1581
1582 putStr :: String -> IO ()
1583 putStr s = --mapM_ putChar s -- correct, but slow
1584            nh_stdout >>= \h ->
1585            let loop []     = return ()
1586                loop (c:cs) = nh_write h (primCharToInt c) >> loop cs
1587            in  loop s
1588
1589 putStrLn :: String -> IO ()
1590 putStrLn s = do { putStr s; putChar '\n' }
1591
1592 print :: Show a => a -> IO ()
1593 print = putStrLn . show
1594
1595 getChar :: IO Char
1596 getChar = unsafeInterleaveIO (
1597           nh_stdin  >>= \h ->
1598           nh_read h >>= \ci ->
1599           return (primIntToChar ci)
1600           )
1601
1602 getLine :: IO String
1603 getLine    = do c <- getChar
1604                 if c=='\n' then return ""
1605                            else do cs <- getLine
1606                                    return (c:cs)
1607
1608 getContents :: IO String
1609 getContents = nh_stdin >>= \h -> readfromhandle h
1610
1611 interact  :: (String -> String) -> IO ()
1612 interact f = getContents >>= (putStr . f)
1613
1614 readFile :: FilePath -> IO String
1615 readFile fname
1616    = copy_String_to_cstring fname  >>= \ptr ->
1617      nh_open ptr 0                 >>= \h ->
1618      nh_free ptr                   >>
1619      nh_errno                      >>= \errno ->
1620      if   (h == 0 || errno /= 0)
1621      then (ioError.IOError) ("readFile: can't open file " ++ fname)
1622      else readfromhandle h
1623
1624 writeFile :: FilePath -> String -> IO ()
1625 writeFile fname contents
1626    = copy_String_to_cstring fname  >>= \ptr ->
1627      nh_open ptr 1                 >>= \h ->
1628      nh_free ptr                   >>
1629      nh_errno                      >>= \errno ->
1630      if   (h == 0 || errno /= 0)
1631      then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1632      else writetohandle fname h contents
1633
1634
1635 appendFile :: FilePath -> String -> IO ()
1636 appendFile fname contents
1637    = copy_String_to_cstring fname  >>= \ptr ->
1638      nh_open ptr 2                 >>= \h ->
1639      nh_free ptr                   >>
1640      nh_errno                      >>= \errno ->
1641      if   (h == 0 || errno /= 0)
1642      then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1643      else writetohandle fname h contents
1644
1645
1646 -- raises an exception instead of an error
1647 readIO          :: Read a => String -> IO a
1648 readIO s         = case [x | (x,t) <- reads s, ("","") <- lex t] of
1649                         [x] -> return x
1650                         []  -> ioError (userError "PreludeIO.readIO: no parse")
1651                         _   -> ioError (userError
1652                                        "PreludeIO.readIO: ambiguous parse")
1653
1654 readLn          :: Read a => IO a
1655 readLn           = do l <- getLine
1656                       r <- readIO l
1657                       return r
1658
1659
1660 -- End of Hugs standard prelude ----------------------------------------------
1661
1662 data Exception
1663    = ErrorCall String
1664    | IOExcept  String
1665
1666 instance Show Exception where
1667    showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1668    showsPrec _ (IOExcept s)  = showString ("I/O error: " ++ s)
1669
1670 data IOResult  = IOResult  deriving (Show)
1671
1672 type FILE_STAR = Int   -- FILE *
1673 type Ptr       = Int   -- char *
1674
1675 foreign import stdcall "nHandle.so" "nh_stdin"  nh_stdin  :: IO FILE_STAR
1676 foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR
1677 foreign import stdcall "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR
1678 foreign import stdcall "nHandle.so" "nh_write"  nh_write  :: FILE_STAR -> Int -> IO ()
1679 foreign import stdcall "nHandle.so" "nh_read"   nh_read   :: FILE_STAR -> IO Int
1680 foreign import stdcall "nHandle.so" "nh_open"   nh_open   :: Int -> Int -> IO FILE_STAR
1681 foreign import stdcall "nHandle.so" "nh_flush"  nh_flush  :: FILE_STAR -> IO ()
1682 foreign import stdcall "nHandle.so" "nh_close"  nh_close  :: FILE_STAR -> IO ()
1683 foreign import stdcall "nHandle.so" "nh_errno"  nh_errno  :: IO Int
1684
1685 foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Ptr
1686 foreign import stdcall "nHandle.so" "nh_free"   nh_free   :: Ptr -> IO ()
1687 foreign import stdcall "nHandle.so" "nh_store"  nh_store  :: Ptr -> Int -> IO ()
1688 foreign import stdcall "nHandle.so" "nh_load"   nh_load   :: Ptr -> IO Int
1689
1690 foreign import stdcall "nHandle.so" "nh_argc"   nh_argc   :: IO Int
1691 foreign import stdcall "nHandle.so" "nh_argvb"  nh_argvb  :: Int -> Int -> IO Int
1692 foreign import stdcall "nHandle.so" "nh_getenv" nh_getenv :: Ptr -> IO Ptr
1693
1694 copy_String_to_cstring :: String -> IO Ptr
1695 copy_String_to_cstring s
1696    = nh_malloc (1 + length s) >>= \ptr0 ->
1697      let loop ptr []     = nh_store ptr 0 >> return ptr0
1698          loop ptr (c:cs) = --trace ("Out `" ++ [c] ++ "'") (
1699                            nh_store ptr (primCharToInt c) >> loop (ptr+1) cs
1700                            --)
1701      in
1702          loop ptr0 s
1703
1704 copy_cstring_to_String :: Ptr -> IO String
1705 copy_cstring_to_String ptr
1706    = nh_load ptr >>= \ci ->
1707      if   ci == 0
1708      then return []
1709      else copy_cstring_to_String (ptr+1) >>= \cs ->
1710           --trace ("In " ++ show ci) (
1711           return ((primIntToChar ci) : cs)
1712           --)
1713
1714 readfromhandle :: FILE_STAR -> IO String
1715 readfromhandle h
1716    = unsafeInterleaveIO (
1717      nh_read h >>= \ci ->
1718      if ci == -1 {-EOF-} then return "" else
1719      readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1720      )
1721
1722 writetohandle :: String -> FILE_STAR -> String -> IO ()
1723 writetohandle fname h []
1724    = nh_close h                  >>
1725      nh_errno                    >>= \errno ->
1726      if   errno == 0
1727      then return ()
1728      else error ( "writeFile/appendFile: error closing file " ++ fname)
1729 writetohandle fname h (c:cs)
1730    = nh_write h (primCharToInt c) >>
1731      writetohandle fname h cs
1732
1733 primGetRawArgs :: IO [String]
1734 primGetRawArgs
1735    = nh_argc >>= \argc ->
1736      accumulate (map (get_one_arg 0) [0 .. argc-1])
1737      where
1738         get_one_arg :: Int -> Int -> IO String
1739         get_one_arg offset argno
1740            = nh_argvb argno offset >>= \cb ->
1741              if   cb == 0
1742              then return []
1743              else get_one_arg (offset+1) argno >>= \s ->
1744                   return ((primIntToChar cb):s)
1745
1746 primGetEnv :: String -> IO String
1747 primGetEnv v
1748    = copy_String_to_cstring v     >>= \ptr ->
1749      nh_getenv ptr                >>= \ptr2 ->
1750      nh_free ptr                  >>
1751      if   ptr2 == 0
1752      then return []
1753      else
1754      copy_cstring_to_String ptr2  >>= \result ->
1755      return result
1756
1757
1758 ------------------------------------------------------------------------------
1759 -- ST, IO --------------------------------------------------------------------
1760 ------------------------------------------------------------------------------
1761
1762 newtype ST s a = ST (s -> (a,s))
1763
1764 data RealWorld
1765 type IO a = ST RealWorld a
1766
1767
1768 --primRunST :: (forall s. ST s a) -> a
1769 primRunST :: ST RealWorld a -> a
1770 primRunST m = fst (unST m theWorld)
1771    where
1772       theWorld :: RealWorld
1773       theWorld = error "primRunST: entered the RealWorld"
1774
1775 unST (ST a) = a
1776
1777 instance Functor (ST s) where
1778    fmap f x = x >>= (return . f)
1779
1780 instance Monad (ST s) where
1781     m >> k      =  m >>= \ _ -> k
1782     return x    =  ST $ \ s -> (x,s)
1783     m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' }
1784
1785
1786 -- used when Hugs invokes top level function
1787 primRunIO :: IO () -> ()
1788 primRunIO m
1789    = protect (fst (unST m realWorld))
1790      where
1791         realWorld = error "panic: Hugs entered the real world"
1792         protect :: () -> ()
1793         protect comp
1794            = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1795
1796 trace :: String -> a -> a
1797 trace s x
1798    = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x
1799
1800 unsafeInterleaveST :: ST s a -> ST s a
1801 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1802
1803 unsafeInterleaveIO :: IO a -> IO a
1804 unsafeInterleaveIO = unsafeInterleaveST
1805
1806
1807 ------------------------------------------------------------------------------
1808 -- Word, Addr, ForeignObj, Prim*Array ----------------------------------------
1809 ------------------------------------------------------------------------------
1810
1811 data Addr
1812
1813 nullAddr = primIntToAddr 0
1814
1815 instance Eq Addr where
1816   (==)            = primEqAddr
1817   (/=)            = primNeAddr
1818
1819 instance Ord Addr where
1820   (<)             = primLtAddr
1821   (<=)            = primLeAddr
1822   (>=)            = primGeAddr
1823   (>)             = primGtAddr
1824
1825
1826 data Word
1827
1828 instance Eq Word where
1829   (==)            = primEqWord
1830   (/=)            = primNeWord
1831
1832 instance Ord Word where
1833   (<)             = primLtWord
1834   (<=)            = primLeWord
1835   (>=)            = primGeWord
1836   (>)             = primGtWord
1837
1838
1839 --data ForeignObj
1840 --makeForeignObj :: Addr -> IO ForeignObj
1841 --makeForeignObj = primMakeForeignObj
1842
1843
1844 data PrimArray              a -- immutable arrays with Int indices
1845 data PrimByteArray
1846
1847 data Ref                  s a -- mutable variables
1848 data PrimMutableArray     s a -- mutable arrays with Int indices
1849 data PrimMutableByteArray s
1850
1851
1852
1853 ------------------------------------------------------------------------------
1854 -- hooks to call libHS_cbits -------------------------------------------------
1855 ------------------------------------------------------------------------------
1856 {-
1857 type FILE_OBJ     = ForeignObj -- as passed into functions
1858 type CString      = PrimByteArray
1859 type How          = Int
1860 type Binary       = Int
1861 type OpenFlags    = Int
1862 type IOFileAddr   = Addr  -- as returned from functions
1863 type FD           = Int
1864 type OpenStdFlags = Int
1865 type Readable     = Int  -- really Bool
1866 type Exclusive    = Int  -- really Bool
1867 type RC           = Int  -- standard return code
1868 type Bytes        = PrimMutableByteArray RealWorld
1869 type Flush        = Int  -- really Bool
1870
1871 foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
1872    freeStdFileObject     :: ForeignObj -> IO ()
1873
1874 foreign import stdcall "libHS_cbits.so" "freeFileObject"
1875    freeFileObject        :: ForeignObj -> IO ()
1876
1877 foreign import stdcall "libHS_cbits.so" "setBuf"
1878    prim_setBuf           :: FILE_OBJ -> Addr -> Int -> IO ()
1879
1880 foreign import stdcall "libHS_cbits.so" "getBufSize"
1881    prim_getBufSize       :: FILE_OBJ -> IO Int
1882
1883 foreign import stdcall "libHS_cbits.so" "inputReady"
1884    prim_inputReady       :: FILE_OBJ -> Int -> IO RC
1885
1886 foreign import stdcall "libHS_cbits.so" "fileGetc"
1887    prim_fileGetc         :: FILE_OBJ -> IO Int
1888
1889 foreign import stdcall "libHS_cbits.so" "fileLookAhead"
1890    prim_fileLookAhead    :: FILE_OBJ -> IO Int
1891
1892 foreign import stdcall "libHS_cbits.so" "readBlock"
1893    prim_readBlock        :: FILE_OBJ -> IO Int
1894
1895 foreign import stdcall "libHS_cbits.so" "readLine"
1896    prim_readLine         :: FILE_OBJ -> IO Int
1897
1898 foreign import stdcall "libHS_cbits.so" "readChar"
1899    prim_readChar         :: FILE_OBJ -> IO Int
1900
1901 foreign import stdcall "libHS_cbits.so" "writeFileObject"
1902    prim_writeFileObject  :: FILE_OBJ -> Int -> IO RC
1903
1904 foreign import stdcall "libHS_cbits.so" "filePutc"
1905    prim_filePutc         :: FILE_OBJ -> Char -> IO RC
1906
1907 foreign import stdcall "libHS_cbits.so" "getBufStart"
1908    prim_getBufStart      :: FILE_OBJ -> Int -> IO Addr
1909
1910 foreign import stdcall "libHS_cbits.so" "getWriteableBuf"
1911    prim_getWriteableBuf  :: FILE_OBJ -> IO Addr
1912
1913 foreign import stdcall "libHS_cbits.so" "getBufWPtr"
1914    prim_getBufWPtr       :: FILE_OBJ -> IO Int
1915
1916 foreign import stdcall "libHS_cbits.so" "setBufWPtr"
1917    prim_setBufWPtr       :: FILE_OBJ -> Int -> IO ()
1918
1919 foreign import stdcall "libHS_cbits.so" "closeFile"
1920    prim_closeFile        :: FILE_OBJ -> Flush -> IO RC
1921
1922 foreign import stdcall "libHS_cbits.so" "fileEOF"
1923    prim_fileEOF          :: FILE_OBJ -> IO RC
1924
1925 foreign import stdcall "libHS_cbits.so" "setBuffering"
1926    prim_setBuffering     :: FILE_OBJ -> Int -> IO RC
1927
1928 foreign import stdcall "libHS_cbits.so" "flushFile"
1929    prim_flushFile        :: FILE_OBJ -> IO RC
1930
1931 foreign import stdcall "libHS_cbits.so" "getBufferMode"
1932    prim_getBufferMode    :: FILE_OBJ -> IO RC
1933
1934 foreign import stdcall "libHS_cbits.so" "seekFileP"
1935    prim_seekFileP        :: FILE_OBJ -> IO RC
1936
1937 foreign import stdcall "libHS_cbits.so" "setTerminalEcho"
1938    prim_setTerminalEcho  :: FILE_OBJ -> Int -> IO RC
1939
1940 foreign import stdcall "libHS_cbits.so" "getTerminalEcho"
1941    prim_getTerminalEcho  :: FILE_OBJ -> IO RC
1942
1943 foreign import stdcall "libHS_cbits.so" "isTerminalDevice"
1944    prim_isTerminalDevice :: FILE_OBJ -> IO RC
1945
1946 foreign import stdcall "libHS_cbits.so" "setConnectedTo"
1947    prim_setConnectedTo   :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
1948
1949 foreign import stdcall "libHS_cbits.so" "ungetChar"
1950    prim_ungetChar    :: FILE_OBJ -> Char -> IO RC
1951
1952 foreign import stdcall "libHS_cbits.so" "readChunk"
1953    prim_readChunk    :: FILE_OBJ -> Addr      -> Int -> IO RC
1954
1955 foreign import stdcall "libHS_cbits.so" "writeBuf"
1956    prim_writeBuf     :: FILE_OBJ -> Addr -> Int -> IO RC
1957
1958 foreign import stdcall "libHS_cbits.so" "getFileFd"
1959    prim_getFileFd    :: FILE_OBJ -> IO FD
1960
1961 foreign import stdcall "libHS_cbits.so" "fileSize_int64"
1962    prim_fileSize_int64   :: FILE_OBJ -> Bytes -> IO RC
1963
1964 foreign import stdcall "libHS_cbits.so" "getFilePosn"
1965    prim_getFilePosn      :: FILE_OBJ -> IO Int
1966
1967 foreign import stdcall "libHS_cbits.so" "setFilePosn"
1968    prim_setFilePosn      :: FILE_OBJ -> Int -> IO Int
1969
1970 foreign import stdcall "libHS_cbits.so" "getConnFileFd"
1971    prim_getConnFileFd    :: FILE_OBJ -> IO FD
1972
1973 foreign import stdcall "libHS_cbits.so" "allocMemory__"
1974    prim_allocMemory__    :: Int -> IO Addr
1975
1976 foreign import stdcall "libHS_cbits.so" "getLock"
1977    prim_getLock      :: FD -> Exclusive -> IO RC
1978
1979 foreign import stdcall "libHS_cbits.so" "openStdFile"
1980    prim_openStdFile      :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
1981
1982 foreign import stdcall "libHS_cbits.so" "openFile"
1983    prim_openFile     :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
1984
1985 foreign import stdcall "libHS_cbits.so" "freeFileObject"
1986    prim_freeFileObject    :: FILE_OBJ -> IO ()
1987
1988 foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
1989    prim_freeStdFileObject :: FILE_OBJ -> IO ()
1990
1991 foreign import stdcall "libHS_cbits.so" "const_BUFSIZ"
1992    const_BUFSIZ      :: Int
1993
1994 foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__"
1995    prim_setConnNonBlockingIOFlag__   :: FILE_OBJ -> IO ()
1996
1997 foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__"
1998    prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
1999
2000 foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__"
2001    prim_setNonBlockingIOFlag__   :: FILE_OBJ -> IO ()
2002
2003 foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__"
2004    prim_clearNonBlockingIOFlag__     :: FILE_OBJ -> IO ()
2005
2006 foreign import stdcall "libHS_cbits.so" "getErrStr__"
2007    prim_getErrStr__  :: IO Addr
2008
2009 foreign import stdcall "libHS_cbits.so" "getErrNo__"
2010    prim_getErrNo__   :: IO Int
2011
2012 foreign import stdcall "libHS_cbits.so" "getErrType__"
2013    prim_getErrType__ :: IO Int
2014
2015 --foreign import stdcall "libHS_cbits.so" "seekFile_int64"
2016 --   prim_seekFile_int64   :: FILE_OBJ -> Int -> Int64 -> IO RC
2017 -}
2018
2019 -- showFloat ------------------------------------------------------------------
2020
2021 showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2022 showFFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2023 showGFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2024 showFloat      :: (RealFloat a) => a -> ShowS
2025
2026 showEFloat d x =  showString (formatRealFloat FFExponent d x)
2027 showFFloat d x =  showString (formatRealFloat FFFixed d x)
2028 showGFloat d x =  showString (formatRealFloat FFGeneric d x)
2029 showFloat      =  showGFloat Nothing
2030
2031 -- These are the format types.  This type is not exported.
2032
2033 data FFFormat = FFExponent | FFFixed | FFGeneric
2034
2035 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2036 formatRealFloat fmt decs x = s
2037   where base = 10
2038         s = if isNaN x then
2039                 "NaN"
2040             else if isInfinite x then
2041                 if x < 0 then "-Infinity" else "Infinity"
2042             else if x < 0 || isNegativeZero x then
2043                 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2044             else
2045                 doFmt fmt (floatToDigits (toInteger base) x)
2046         doFmt fmt (is, e) =
2047             let ds = map intToDigit is
2048             in  case fmt of
2049                 FFGeneric ->
2050                     doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2051                           (is, e)
2052                 FFExponent ->
2053                     case decs of
2054                     Nothing ->
2055                         case ds of
2056                          ['0'] -> "0.0e0"
2057                          [d]   -> d : ".0e" ++ show (e-1)
2058                          d:ds  -> d : '.' : ds ++ 'e':show (e-1)
2059                     Just dec ->
2060                         let dec' = max dec 1 in
2061                         case is of
2062                          [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2063                          _ ->
2064                           let (ei, is') = roundTo base (dec'+1) is
2065                               d:ds = map intToDigit
2066                                          (if ei > 0 then init is' else is')
2067                           in d:'.':ds  ++ "e" ++ show (e-1+ei)
2068                 FFFixed ->
2069                     case decs of
2070                     Nothing ->
2071                         let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2072                             f n s "" = f (n-1) (s++"0") ""
2073                             f n s (d:ds) = f (n-1) (s++[d]) ds
2074                             mk0 "" = "0"
2075                             mk0 s = s
2076                         in  f e "" ds
2077                     Just dec ->
2078                         let dec' = max dec 0 in
2079                         if e >= 0 then
2080                             let (ei, is') = roundTo base (dec' + e) is
2081                                 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2082                             in  (if null ls then "0" else ls) ++
2083                                 (if null rs then "" else '.' : rs)
2084                         else
2085                             let (ei, is') = roundTo base dec'
2086                                               (replicate (-e) 0 ++ is)
2087                                 d : ds = map intToDigit
2088                                             (if ei > 0 then is' else 0:is')
2089                             in  d : '.' : ds
2090
2091 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2092 roundTo base d is = case f d is of
2093                 (0, is) -> (0, is)
2094                 (1, is) -> (1, 1 : is)
2095   where b2 = base `div` 2
2096         f n [] = (0, replicate n 0)
2097         f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2098         f d (i:is) =
2099             let (c, ds) = f (d-1) is
2100                 i' = c + i
2101             in  if i' == base then (1, 0:ds) else (0, i':ds)
2102
2103 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2104 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2105 -- This version uses a much slower logarithm estimator.  It should be improved.
2106
2107 -- This function returns a list of digits (Ints in [0..base-1]) and an
2108 -- exponent.
2109
2110 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2111
2112 floatToDigits _ 0 = ([0], 0)
2113 floatToDigits base x =
2114     let (f0, e0) = decodeFloat x
2115         (minExp0, _) = floatRange x
2116         p = floatDigits x
2117         b = floatRadix x
2118         minExp = minExp0 - p            -- the real minimum exponent
2119         -- Haskell requires that f be adjusted so denormalized numbers
2120         -- will have an impossibly low exponent.  Adjust for this.
2121         (f, e) = let n = minExp - e0
2122                  in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2123
2124         (r, s, mUp, mDn) =
2125            if e >= 0 then
2126                let be = b^e in
2127                if f == b^(p-1) then
2128                    (f*be*b*2, 2*b, be*b, b)
2129                else
2130                    (f*be*2, 2, be, be)
2131            else
2132                if e > minExp && f == b^(p-1) then
2133                    (f*b*2, b^(-e+1)*2, b, 1)
2134                else
2135                    (f*2, b^(-e)*2, 1, 1)
2136         k =
2137             let k0 =
2138                     if b == 2 && base == 10 then
2139                          -- logBase 10 2 is slightly bigger than 3/10 so
2140                          -- the following will err on the low side.  Ignoring
2141                          -- the fraction will make it err even more.
2142                          -- Haskell promises that p-1 <= logBase b f < p.
2143                          (p - 1 + e0) * 3 `div` 10
2144                     else
2145                          ceiling ((log (fromInteger (f+1)) +
2146                                   fromInt e * log (fromInteger b)) /
2147                                    log (fromInteger base))
2148                 fixup n =
2149                     if n >= 0 then
2150                         if r + mUp <= expt base n * s then n else fixup (n+1)
2151                     else
2152                         if expt base (-n) * (r + mUp) <= s then n
2153                                                            else fixup (n+1)
2154             in  fixup k0
2155
2156         gen ds rn sN mUpN mDnN =
2157             let (dn, rn') = (rn * base) `divMod` sN
2158                 mUpN' = mUpN * base
2159                 mDnN' = mDnN * base
2160             in  case (rn' < mDnN', rn' + mUpN' > sN) of
2161                 (True,  False) -> dn : ds
2162                 (False, True)  -> dn+1 : ds
2163                 (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2164                 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2165         rds =
2166             if k >= 0 then
2167                 gen [] r (s * expt base k) mUp mDn
2168             else
2169                 let bk = expt base (-k)
2170                 in  gen [] (r * bk) s (mUp * bk) (mDn * bk)
2171     in  (map toInt (reverse rds), k)
2172
2173 {-
2174 -- Exponentiation with(out) a cache for the most common numbers.
2175 expt :: Integer -> Int -> Integer
2176 expt base n = base^n
2177 -}
2178
2179
2180 -- Exponentiation with a cache for the most common numbers.
2181 minExpt = 0::Int
2182 maxExpt = 1100::Int
2183 expt :: Integer -> Int -> Integer
2184 expt base n =
2185     if base == 2 && n >= minExpt && n <= maxExpt then
2186         expts !! (n-minExpt)
2187     else
2188         base^n
2189
2190 expts :: [Integer]
2191 expts = [2^n | n <- [minExpt .. maxExpt]]
2192