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