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: STG Hugs     _______________________________________________
   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, StablePtr,
  64     makeStablePtr, freeStablePtr, deRefStablePtr,
  65
  66     Bool(False, True),
  67     Maybe(Nothing, Just),
  68     Either(Left, Right),
  69     Ordering(LT, EQ, GT),
  70     Char, String, Int, Integer, Float, Double, IO,
  71 --  List type: []((:), [])
  72     (:),
  73 --  Tuple types: (,), (,,), etc.
  74 --  Trivial type: ()
  75 --  Functions: (->)
  76     Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
  77     Eq((==), (/=)),
  78     Ord(compare, (<), (<=), (>=), (>), max, min),
  79     Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
  80          enumFromTo, enumFromThenTo),
  81     Bounded(minBound, maxBound),
  82 --  Num((+), (-), (*), negate, abs, signum, fromInteger),
  83     Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
  84     Real(toRational),
  85 --  Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
  86     Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
  87     Fractional((/), recip, fromRational), fromDouble,
  88     Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
  89              asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
  90     RealFrac(properFraction, truncate, round, ceiling, floor),
  91     RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
  92               encodeFloat, exponent, significand, scaleFloat, isNaN,
  93               isInfinite, isDenormalized, isIEEE, isNegativeZero),
  94     Monad((>>=), (>>), return, fail),
  95     Functor(fmap),
  96     mapM, mapM_, sequence, 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   ) where
 106
 107 -- Standard value bindings {Prelude} ----------------------------------------
 108
 109 infixr 9  .
 110 infixl 9  !!
 111 infixr 8  ^, ^^, **
 112 infixl 7  *, /, `quot`, `rem`, `div`, `mod`, :%, %
 113 infixl 6  +, -
 114 --infixr 5  :    -- this fixity declaration is hard-wired into Hugs
 115 infixr 5  ++
 116 infix  4  ==, /=, <, <=, >=, >, `elem`, `notElem`
 117 infixr 3  &&
 118 infixr 2  ||
 119 infixl 1  >>, >>=
 120 infixr 1  =<<
 121 infixr 0  $, $!, `seq`
 122
 123 -- Equality and Ordered classes ---------------------------------------------
 124
 125 class Eq a where
 126     (==), (/=) :: a -> a -> Bool
 127
 128     -- Minimal complete definition: (==) or (/=)
 129     x == y      = not (x/=y)
 130     x /= y      = not (x==y)
 131
 132 class (Eq a) => Ord a where
 133     compare                :: a -> a -> Ordering
 134     (<), (<=), (>=), (>)   :: a -> a -> Bool
 135     max, min               :: a -> a -> a
 136
 137     -- Minimal complete definition: (<=) or compare
 138     -- using compare can be more efficient for complex types
 139     compare x y | x==y      = EQ
 140                 | x<=y      = LT
 141                 | otherwise = GT
 142
 143     x <= y                  = compare x y /= GT
 144     x <  y                  = compare x y == LT
 145     x >= y                  = compare x y /= LT
 146     x >  y                  = compare x y == GT
 147
 148     max x y   | x >= y      = x
 149               | otherwise   = y
 150     min x y   | x <= y      = x
 151               | otherwise   = y
 152
 153 class Bounded a where
 154     minBound, maxBound :: a
 155     -- Minimal complete definition: All
 156
 157 -- Numeric classes ----------------------------------------------------------
 158
 159 class (Eq a, Show a) => Num a where
 160     (+), (-), (*)  :: a -> a -> a
 161     negate         :: a -> a
 162     abs, signum    :: a -> a
 163     fromInteger    :: Integer -> a
 164     fromInt        :: Int -> a
 165
 166     -- Minimal complete definition: All, except negate or (-)
 167     x - y           = x + negate y
 168     fromInt         = fromIntegral
 169     negate x        = 0 - x
 170
 171 class (Num a, Ord a) => Real a where
 172     toRational     :: a -> Rational
 173
 174 class (Real a, Enum a) => Integral a where
 175     quot, rem, div, mod :: a -> a -> a
 176     quotRem, divMod     :: a -> a -> (a,a)
 177     even, odd           :: a -> Bool
 178     toInteger           :: a -> Integer
 179     toInt               :: a -> Int
 180
 181     -- Minimal complete definition: quotRem and toInteger
 182     n `quot` d           = q where (q,r) = quotRem n d
 183     n `rem` d            = r where (q,r) = quotRem n d
 184     n `div` d            = q where (q,r) = divMod n d
 185     n `mod` d            = r where (q,r) = divMod n d
 186     divMod n d           = if signum r == - signum d then (q-1, r+d) else qr
 187                            where qr@(q,r) = quotRem n d
 188     even n               = n `rem` 2 == 0
 189     odd                  = not . even
 190     toInt                = toInt . toInteger
 191
 192 class (Num a) => Fractional a where
 193     (/)          :: a -> a -> a
 194     recip        :: a -> a
 195     fromRational :: Rational -> a
 196
 197     -- Minimal complete definition: fromRational and ((/) or recip)
 198     recip x       = 1 / x
 199     x / y         = x * recip y
 200
 201 fromDouble :: Fractional a => Double -> a
 202 fromDouble n = fromRational (toRational n)
 203
 204 class (Fractional a) => Floating a where
 205     pi                  :: a
 206     exp, log, sqrt      :: a -> a
 207     (**), logBase       :: a -> a -> a
 208     sin, cos, tan       :: a -> a
 209     asin, acos, atan    :: a -> a
 210     sinh, cosh, tanh    :: a -> a
 211     asinh, acosh, atanh :: a -> a
 212
 213     -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
 214     --                              asinh, acosh, atanh
 215     x ** y               = exp (log x * y)
 216     logBase x y          = log y / log x
 217     sqrt x               = x ** 0.5
 218     tan x                = sin x / cos x
 219     sinh x               = (exp x - exp (-x)) / 2
 220     cosh x               = (exp x + exp (-x)) / 2
 221     tanh x               = sinh x / cosh x
 222     asinh x              = log (x + sqrt (x*x + 1))
 223     acosh x              = log (x + sqrt (x*x - 1))
 224     atanh x              = (log (1 + x) - log (1 - x)) / 2
 225
 226 class (Real a, Fractional a) => RealFrac a where
 227     properFraction   :: (Integral b) => a -> (b,a)
 228     truncate, round  :: (Integral b) => a -> b
 229     ceiling, floor   :: (Integral b) => a -> b
 230
 231     -- Minimal complete definition: properFraction
 232     truncate x        = m where (m,_) = properFraction x
 233
 234     round x           = let (n,r) = properFraction x
 235                             m     = if r < 0 then n - 1 else n + 1
 236                         in case signum (abs r - 0.5) of
 237                             -1 -> n
 238                             0  -> if even n then n else m
 239                             1  -> m
 240
 241     ceiling x         = if r > 0 then n + 1 else n
 242                         where (n,r) = properFraction x
 243
 244     floor x           = if r < 0 then n - 1 else n
 245                         where (n,r) = properFraction x
 246
 247 class (RealFrac a, Floating a) => RealFloat a where
 248     floatRadix       :: a -> Integer
 249     floatDigits      :: a -> Int
 250     floatRange       :: a -> (Int,Int)
 251     decodeFloat      :: a -> (Integer,Int)
 252     encodeFloat      :: Integer -> Int -> a
 253     exponent         :: a -> Int
 254     significand      :: a -> a
 255     scaleFloat       :: Int -> a -> a
 256     isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
 257                      :: a -> Bool
 258     atan2            :: a -> a -> a
 259
 260     -- Minimal complete definition: All, except exponent, signficand,
 261     --                              scaleFloat, atan2
 262     exponent x        = if m==0 then 0 else n + floatDigits x
 263                         where (m,n) = decodeFloat x
 264     significand x     = encodeFloat m (- floatDigits x)
 265                         where (m,_) = decodeFloat x
 266     scaleFloat k x    = encodeFloat m (n+k)
 267                         where (m,n) = decodeFloat x
 268     atan2 y x
 269       | x>0           = atan (y/x)
 270       | x==0 && y>0   = pi/2
 271       | x<0 && y>0    = pi + atan (y/x)
 272       | (x<=0 && y<0) ||
 273         (x<0 && isNegativeZero y) ||
 274         (isNegativeZero x && isNegativeZero y)
 275                       = - atan2 (-y) x
 276       | y==0 && (x<0 || isNegativeZero x)
 277                       = pi    -- must be after the previous test on zero y
 278       | x==0 && y==0  = y     -- must be after the other double zero tests
 279       | otherwise     = x + y -- x or y is a NaN, return a NaN (via +)
 280
 281 -- Numeric functions --------------------------------------------------------
 282
 283 subtract       :: Num a => a -> a -> a
 284 subtract        = flip (-)
 285
 286 gcd            :: Integral a => a -> a -> a
 287 gcd 0 0         = error "Prelude.gcd: gcd 0 0 is undefined"
 288 gcd x y         = gcd' (abs x) (abs y)
 289                   where gcd' x 0 = x
 290                         gcd' x y = gcd' y (x `rem` y)
 291
 292 lcm            :: (Integral a) => a -> a -> a
 293 lcm _ 0         = 0
 294 lcm 0 _         = 0
 295 lcm x y         = abs ((x `quot` gcd x y) * y)
 296
 297 (^)            :: (Num a, Integral b) => a -> b -> a
 298 x ^ 0           = 1
 299 x ^ n  | n > 0  = f x (n-1) x
 300                   where f _ 0 y = y
 301                         f x n y = g x n where
 302                                   g x n | even n    = g (x*x) (n`quot`2)
 303                                         | otherwise = f x (n-1) (x*y)
 304 _ ^ _           = error "Prelude.^: negative exponent"
 305
 306 (^^)           :: (Fractional a, Integral b) => a -> b -> a
 307 x ^^ n          = if n >= 0 then x ^ n else recip (x^(-n))
 308
 309 fromIntegral   :: (Integral a, Num b) => a -> b
 310 fromIntegral    = fromInteger . toInteger
 311
 312 realToFrac     :: (Real a, Fractional b) => a -> b
 313 realToFrac      = fromRational . toRational
 314
 315 -- Index and Enumeration classes --------------------------------------------
 316
 317 class (Ord a) => Ix a where
 318     range                :: (a,a) -> [a]
 319     index                :: (a,a) -> a -> Int
 320     inRange              :: (a,a) -> a -> Bool
 321     rangeSize            :: (a,a) -> Int
 322
 323     rangeSize r@(l,u)
 324              | l > u      = 0
 325              | otherwise  = index r u + 1
 326
 327 class Enum a where
 328     succ, pred           :: a -> a
 329     toEnum               :: Int -> a
 330     fromEnum             :: a -> Int
 331     enumFrom             :: a -> [a]              -- [n..]
 332     enumFromThen         :: a -> a -> [a]         -- [n,m..]
 333     enumFromTo           :: a -> a -> [a]         -- [n..m]
 334     enumFromThenTo       :: a -> a -> a -> [a]    -- [n,n'..m]
 335
 336     -- Minimal complete definition: toEnum, fromEnum
 337     succ                  = toEnum . (1+)       . fromEnum
 338     pred                  = toEnum . subtract 1 . fromEnum
 339     enumFrom x            = map toEnum [ fromEnum x .. ]
 340     enumFromTo x y        = map toEnum [ fromEnum x .. fromEnum y ]
 341     enumFromThen x y      = map toEnum [ fromEnum x, fromEnum y .. ]
 342     enumFromThenTo x y z  = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
 343
 344 -- Read and Show classes ------------------------------------------------------
 345
 346 type ReadS a = String -> [(a,String)]
 347 type ShowS   = String -> String
 348
 349 class Read a where
 350     readsPrec :: Int -> ReadS a
 351     readList  :: ReadS [a]
 352
 353     -- Minimal complete definition: readsPrec
 354     readList   = readParen False (\r -> [pr | ("[",s) <- lex r,
 355                                               pr      <- readl s ])
 356                  where readl  s = [([],t)   | ("]",t) <- lex s] ++
 357                                   [(x:xs,u) | (x,t)   <- reads s,
 358                                               (xs,u)  <- readl' t]
 359                        readl' s = [([],t)   | ("]",t) <- lex s] ++
 360                                   [(x:xs,v) | (",",t) <- lex s,
 361                                               (x,u)   <- reads t,
 362                                               (xs,v)  <- readl' u]
 363
 364 class Show a where
 365     show      :: a -> String
 366     showsPrec :: Int -> a -> ShowS
 367     showList  :: [a] -> ShowS
 368
 369     -- Minimal complete definition: show or showsPrec
 370     show x          = showsPrec 0 x ""
 371     showsPrec _ x s = show x ++ s
 372     showList []     = showString "[]"
 373     showList (x:xs) = showChar '[' . shows x . showl xs
 374                       where showl []     = showChar ']'
 375                             showl (x:xs) = showChar ',' . shows x . showl xs
 376
 377 -- Monad classes ------------------------------------------------------------
 378
 379 class Functor f where
 380     fmap :: (a -> b) -> (f a -> f b)
 381
 382 class Monad m where
 383     return :: a -> m a
 384     (>>=)  :: m a -> (a -> m b) -> m b
 385     (>>)   :: m a -> m b -> m b
 386     fail   :: String -> m a
 387
 388     -- Minimal complete definition: (>>=), return
 389     p >> q  = p >>= \ _ -> q
 390     fail s  = error s
 391
 392 sequence       :: Monad m => [m a] -> m [a]
 393 sequence []     = return []
 394 sequence (c:cs) = do x  <- c
 395                      xs <- sequence cs
 396                      return (x:xs)
 397
 398 sequence_        :: Monad m => [m a] -> m ()
 399 sequence_        =  foldr (>>) (return ())
 400
 401 mapM             :: Monad m => (a -> m b) -> [a] -> m [b]
 402 mapM f            = sequence . map f
 403
 404 mapM_            :: Monad m => (a -> m b) -> [a] -> m ()
 405 mapM_ f           = sequence_ . map f
 406
 407 (=<<)            :: Monad m => (a -> m b) -> m a -> m b
 408 f =<< x           = x >>= f
 409
 410 -- Evaluation and strictness ------------------------------------------------
 411
 412 seq           :: a -> b -> b
 413 seq x y       =  primSeq x y
 414
 415 ($!)          :: (a -> b) -> a -> b
 416 f $! x        =  x `primSeq` 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) = hugsprimCompAux 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 -- Standard Integral types --------------------------------------------------
 624
 625 data Int      -- builtin datatype of fixed size integers
 626 data Integer  -- builtin datatype of arbitrary size integers
 627
 628 instance Eq Integer where
 629     (==) x y = primCompareInteger x y == 0
 630
 631 instance Ord Integer where
 632     compare x y = case primCompareInteger x y of
 633                       -1 -> LT
 634                       0  -> EQ
 635                       1  -> GT
 636
 637 instance Eq Int where
 638     (==)          = primEqInt
 639     (/=)          = primNeInt
 640
 641 instance Ord Int     where
 642     (<)           = primLtInt
 643     (<=)          = primLeInt
 644     (>=)          = primGeInt
 645     (>)           = primGtInt
 646
 647 instance Num Int where
 648     (+)           = primPlusInt
 649     (-)           = primMinusInt
 650     negate        = primNegateInt
 651     (*)           = primTimesInt
 652     abs           = absReal
 653     signum        = signumReal
 654     fromInteger   = primIntegerToInt
 655     fromInt x     = x
 656
 657 instance Bounded Int where
 658     minBound = primMinInt
 659     maxBound = primMaxInt
 660
 661 instance Num Integer where
 662     (+)           = primPlusInteger
 663     (-)           = primMinusInteger
 664     negate        = primNegateInteger
 665     (*)           = primTimesInteger
 666     abs           = absReal
 667     signum        = signumReal
 668     fromInteger x = x
 669     fromInt       = primIntToInteger
 670
 671 absReal x    | x >= 0    = x
 672              | otherwise = -x
 673
 674 signumReal x | x == 0    =  0
 675              | x > 0     =  1
 676              | otherwise = -1
 677
 678 instance Real Int where
 679     toRational x = toInteger x % 1
 680
 681 instance Real Integer where
 682     toRational x = x % 1
 683
 684 instance Integral Int where
 685     quotRem   = primQuotRemInt
 686     toInteger = primIntToInteger
 687     toInt x   = x
 688
 689 instance Integral Integer where
 690     quotRem       = primQuotRemInteger
 691     toInteger     = id
 692     toInt         = primIntegerToInt
 693
 694 instance Ix Int where
 695     range (m,n)          = [m..n]
 696     index b@(m,n) i
 697            | inRange b i = i - m
 698            | otherwise   = error "index: Index out of range"
 699     inRange (m,n) i      = m <= i && i <= n
 700
 701 instance Ix Integer where
 702     range (m,n)          = [m..n]
 703     index b@(m,n) i
 704            | inRange b i = fromInteger (i - m)
 705            | otherwise   = error "index: Index out of range"
 706     inRange (m,n) i      = m <= i && i <= n
 707
 708 instance Enum Int where
 709     toEnum               = id
 710     fromEnum             = id
 711     enumFrom       = numericEnumFrom
 712     enumFromTo     = numericEnumFromTo
 713     enumFromThen   = numericEnumFromThen
 714     enumFromThenTo = numericEnumFromThenTo
 715
 716 instance Enum Integer where
 717     toEnum         = primIntToInteger
 718     fromEnum       = primIntegerToInt
 719     enumFrom       = numericEnumFrom
 720     enumFromTo     = numericEnumFromTo
 721     enumFromThen   = numericEnumFromThen
 722     enumFromThenTo = numericEnumFromThenTo
 723
 724 numericEnumFrom        :: Real a => a -> [a]
 725 numericEnumFromThen    :: Real a => a -> a -> [a]
 726 numericEnumFromTo      :: Real a => a -> a -> [a]
 727 numericEnumFromThenTo  :: Real a => a -> a -> a -> [a]
 728 numericEnumFrom n            = n : (numericEnumFrom $! (n+1))
 729 numericEnumFromThen n m      = iterate ((m-n)+) n
 730 numericEnumFromTo n m        = takeWhile (<= m) (numericEnumFrom n)
 731 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
 732                                where p | n' >= n   = (<= m)
 733                                        | otherwise = (>= m)
 734
 735 instance Read Int where
 736     readsPrec p = readSigned readDec
 737
 738 instance  Show Int  where
 739     showsPrec p n
 740       | n == minBound = showSigned showInt p (toInteger n)
 741       | otherwise     = showSigned showInt p n
 742
 743 instance Read Integer where
 744     readsPrec p = readSigned readDec
 745
 746 instance Show Integer where
 747     showsPrec   = showSigned showInt
 748
 749
 750 -- Standard Floating types --------------------------------------------------
 751
 752 data Float     -- builtin datatype of single precision floating point numbers
 753 data Double    -- builtin datatype of double precision floating point numbers
 754
 755 instance Eq  Float  where
 756     (==)          = primEqFloat
 757     (/=)          = primNeFloat
 758
 759 instance Ord Float  where
 760     (<)           = primLtFloat
 761     (<=)          = primLeFloat
 762     (>=)          = primGeFloat
 763     (>)           = primGtFloat
 764
 765 instance Num Float where
 766     (+)           = primPlusFloat
 767     (-)           = primMinusFloat
 768     negate        = primNegateFloat
 769     (*)           = primTimesFloat
 770     abs           = absReal
 771     signum        = signumReal
 772     fromInteger   = primIntegerToFloat
 773     fromInt       = primIntToFloat
 774
 775
 776
 777 instance Eq  Double  where
 778     (==)         = primEqDouble
 779     (/=)         = primNeDouble
 780
 781 instance Ord Double  where
 782     (<)          = primLtDouble
 783     (<=)         = primLeDouble
 784     (>=)         = primGeDouble
 785     (>)          = primGtDouble
 786
 787 instance Num Double where
 788     (+)          = primPlusDouble
 789     (-)          = primMinusDouble
 790     negate       = primNegateDouble
 791     (*)          = primTimesDouble
 792     abs          = absReal
 793     signum       = signumReal
 794     fromInteger  = primIntegerToDouble
 795     fromInt      = primIntToDouble
 796
 797
 798
 799 instance Real Float where
 800     toRational = floatToRational
 801
 802 instance Real Double where
 803     toRational = doubleToRational
 804
 805 -- Calls to these functions are optimised when passed as arguments to
 806 -- fromRational.
 807 floatToRational  :: Float  -> Rational
 808 doubleToRational :: Double -> Rational
 809 floatToRational  x = realFloatToRational x
 810 doubleToRational x = realFloatToRational x
 811
 812 realFloatToRational x = (m%1)*(b%1)^^n
 813                         where (m,n) = decodeFloat x
 814                               b     = floatRadix x
 815
 816 instance Fractional Float where
 817     (/)           = primDivideFloat
 818     fromRational  = rationalToRealFloat
 819
 820 instance Fractional Double where
 821     (/)          = primDivideDouble
 822     fromRational = rationalToRealFloat
 823
 824 rationalToRealFloat x = x'
 825  where x'    = f e
 826        f e   = if e' == e then y else f e'
 827                where y      = encodeFloat (round (x * (1%b)^^e)) e
 828                      (_,e') = decodeFloat y
 829        (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
 830                              / fromInteger (denominator x))
 831        b     = floatRadix x'
 832
 833 instance Floating Float where
 834     pi    = 3.14159265358979323846
 835     exp   = primExpFloat
 836     log   = primLogFloat
 837     sqrt  = primSqrtFloat
 838     sin   = primSinFloat
 839     cos   = primCosFloat
 840     tan   = primTanFloat
 841     asin  = primAsinFloat
 842     acos  = primAcosFloat
 843     atan  = primAtanFloat
 844
 845 instance Floating Double where
 846     pi    = 3.14159265358979323846
 847     exp   = primExpDouble
 848     log   = primLogDouble
 849     sqrt  = primSqrtDouble
 850     sin   = primSinDouble
 851     cos   = primCosDouble
 852     tan   = primTanDouble
 853     asin  = primAsinDouble
 854     acos  = primAcosDouble
 855     atan  = primAtanDouble
 856
 857 instance RealFrac Float where
 858     properFraction = floatProperFraction
 859
 860 instance RealFrac Double where
 861     properFraction = floatProperFraction
 862
 863 floatProperFraction x
 864    | n >= 0      = (fromInteger m * fromInteger b ^ n, 0)
 865    | otherwise   = (fromInteger w, encodeFloat r n)
 866                    where (m,n) = decodeFloat x
 867                          b     = floatRadix x
 868                          (w,r) = quotRem m (b^(-n))
 869
 870 instance RealFloat Float where
 871     floatRadix  _ = toInteger primRadixFloat
 872     floatDigits _ = primDigitsFloat
 873     floatRange  _ = (primMinExpFloat,primMaxExpFloat)
 874     encodeFloat   = primEncodeFloatZ
 875     decodeFloat   = primDecodeFloatZ
 876     isNaN         = primIsNaNFloat
 877     isInfinite    = primIsInfiniteFloat
 878     isDenormalized= primIsDenormalizedFloat
 879     isNegativeZero= primIsNegativeZeroFloat
 880     isIEEE        = const primIsIEEEFloat
 881
 882 instance RealFloat Double where
 883     floatRadix  _ = toInteger primRadixDouble
 884     floatDigits _ = primDigitsDouble
 885     floatRange  _ = (primMinExpDouble,primMaxExpDouble)
 886     encodeFloat   = primEncodeDoubleZ
 887     decodeFloat   = primDecodeDoubleZ
 888     isNaN         = primIsNaNDouble
 889     isInfinite    = primIsInfiniteDouble
 890     isDenormalized= primIsDenormalizedDouble
 891     isNegativeZero= primIsNegativeZeroDouble
 892     isIEEE        = const primIsIEEEDouble
 893
 894 instance Enum Float where
 895     toEnum                = primIntToFloat
 896     fromEnum              = truncate
 897     enumFrom              = numericEnumFrom
 898     enumFromThen          = numericEnumFromThen
 899     enumFromTo n m        = numericEnumFromTo n (m+1/2)
 900     enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
 901
 902 instance Enum Double where
 903     toEnum                = primIntToDouble
 904     fromEnum              = truncate
 905     enumFrom              = numericEnumFrom
 906     enumFromThen          = numericEnumFromThen
 907     enumFromTo n m        = numericEnumFromTo n (m+1/2)
 908     enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
 909
 910 instance Read Float where
 911     readsPrec p = readSigned readFloat
 912
 913 instance Show Float where
 914     showsPrec p = showSigned showFloat p
 915
 916 instance Read Double where
 917     readsPrec p = readSigned readFloat
 918
 919 instance Show Double where
 920     showsPrec p = showSigned showFloat p
 921
 922
 923 -- Some standard functions --------------------------------------------------
 924
 925 fst            :: (a,b) -> a
 926 fst (x,_)       = x
 927
 928 snd            :: (a,b) -> b
 929 snd (_,y)       = y
 930
 931 curry          :: ((a,b) -> c) -> (a -> b -> c)
 932 curry f x y     = f (x,y)
 933
 934 uncurry        :: (a -> b -> c) -> ((a,b) -> c)
 935 uncurry f p     = f (fst p) (snd p)
 936
 937 id             :: a -> a
 938 id    x         = x
 939
 940 const          :: a -> b -> a
 941 const k _       = k
 942
 943 (.)            :: (b -> c) -> (a -> b) -> (a -> c)
 944 (f . g) x       = f (g x)
 945
 946 flip           :: (a -> b -> c) -> b -> a -> c
 947 flip f x y      = f y x
 948
 949 ($)            :: (a -> b) -> a -> b
 950 f $ x           = f x
 951
 952 until          :: (a -> Bool) -> (a -> a) -> a -> a
 953 until p f x     = if p x then x else until p f (f x)
 954
 955 asTypeOf       :: a -> a -> a
 956 asTypeOf        = const
 957
 958 error          :: String -> a
 959 error msg      =  primRaise (ErrorCall msg)
 960
 961 undefined         :: a
 962 undefined | False = undefined
 963
 964 -- Standard functions on rational numbers {PreludeRatio} --------------------
 965
 966 data Integral a => Ratio a = a :% a deriving (Eq)
 967 type Rational              = Ratio Integer
 968
 969 (%)                       :: Integral a => a -> a -> Ratio a
 970 x % y                      = reduce (x * signum y) (abs y)
 971
 972 reduce                    :: Integral a => a -> a -> Ratio a
 973 reduce x y | y == 0        = error "Ratio.%: zero denominator"
 974            | otherwise     = (x `quot` d) :% (y `quot` d)
 975                              where d = gcd x y
 976
 977 numerator, denominator    :: Integral a => Ratio a -> a
 978 numerator (x :% y)         = x
 979 denominator (x :% y)       = y
 980
 981 instance Integral a => Ord (Ratio a) where
 982     compare (x:%y) (x':%y') = compare (x*y') (x'*y)
 983
 984 instance Integral a => Num (Ratio a) where
 985     (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
 986     (x:%y) * (x':%y') = reduce (x*x') (y*y')
 987     negate (x :% y)   = negate x :% y
 988     abs (x :% y)      = abs x :% y
 989     signum (x :% y)   = signum x :% 1
 990     fromInteger x     = fromInteger x :% 1
 991     fromInt           = intToRatio
 992
 993 -- Hugs optimises code of the form fromRational (intToRatio x)
 994 intToRatio :: Integral a => Int -> Ratio a
 995 intToRatio x = fromInt x :% 1
 996
 997 instance Integral a => Real (Ratio a) where
 998     toRational (x:%y) = toInteger x :% toInteger y
 999
1000 instance Integral a => Fractional (Ratio a) where
1001     (x:%y) / (x':%y')   = (x*y') % (y*x')
1002     recip (x:%y)        = if x < 0 then (-y) :% (-x) else y :% x
1003     fromRational (x:%y) = fromInteger x :% fromInteger y
1004
1005 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1006 doubleToRatio :: Integral a => Double -> Ratio a
1007 doubleToRatio x
1008             | n>=0      = (fromInteger m * fromInteger b ^ n) % 1
1009             | otherwise = fromInteger m % (fromInteger b ^ (-n))
1010                           where (m,n) = decodeFloat x
1011                                 b     = floatRadix x
1012
1013 instance Integral a => RealFrac (Ratio a) where
1014     properFraction (x:%y) = (fromIntegral q, r:%y)
1015                             where (q,r) = quotRem x y
1016
1017 instance Integral a => Enum (Ratio a) where
1018     toEnum       = fromInt
1019     fromEnum     = truncate
1020     enumFrom     = numericEnumFrom
1021     enumFromThen = numericEnumFromThen
1022
1023 instance (Read a, Integral a) => Read (Ratio a) where
1024     readsPrec p = readParen (p > 7)
1025                             (\r -> [(x%y,u) | (x,s)   <- reads r,
1026                                               ("%",t) <- lex s,
1027                                               (y,u)   <- reads t ])
1028
1029 instance Integral a => Show (Ratio a) where
1030     showsPrec p (x:%y) = showParen (p > 7)
1031                              (shows x . showString " % " . shows y)
1032
1033 approxRational      :: RealFrac a => a -> a -> Rational
1034 approxRational x eps = simplest (x-eps) (x+eps)
1035  where simplest x y | y < x     = simplest y x
1036                     | x == y    = xr
1037                     | x > 0     = simplest' n d n' d'
1038                     | y < 0     = - simplest' (-n') d' (-n) d
1039                     | otherwise = 0 :% 1
1040                                   where xr@(n:%d) = toRational x
1041                                         (n':%d')  = toRational y
1042        simplest' n d n' d'        -- assumes 0 < n%d < n'%d'
1043                     | r == 0    = q :% 1
1044                     | q /= q'   = (q+1) :% 1
1045                     | otherwise = (q*n''+d'') :% n''
1046                                   where (q,r)      = quotRem n d
1047                                         (q',r')    = quotRem n' d'
1048                                         (n'':%d'') = simplest' d' r' d r
1049
1050 -- Standard list functions {PreludeList} ------------------------------------
1051
1052 head             :: [a] -> a
1053 head (x:_)        = x
1054
1055 last             :: [a] -> a
1056 last [x]          = x
1057 last (_:xs)       = last xs
1058
1059 tail             :: [a] -> [a]
1060 tail (_:xs)       = xs
1061
1062 init             :: [a] -> [a]
1063 init [x]          = []
1064 init (x:xs)       = x : init xs
1065
1066 null             :: [a] -> Bool
1067 null []           = True
1068 null (_:_)        = False
1069
1070 (++)             :: [a] -> [a] -> [a]
1071 []     ++ ys      = ys
1072 (x:xs) ++ ys      = x : (xs ++ ys)
1073
1074 map              :: (a -> b) -> [a] -> [b]
1075 --map f xs          = [ f x | x <- xs ]
1076 map f []     = []
1077 map f (x:xs) = f x : map f xs
1078
1079
1080 filter           :: (a -> Bool) -> [a] -> [a]
1081 --filter p xs       = [ x | x <- xs, p x ]
1082 filter p [] = []
1083 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1084
1085
1086 concat           :: [[a]] -> [a]
1087 --concat            = foldr (++) []
1088 concat []       = []
1089 concat (xs:xss) = xs ++ concat xss
1090
1091 length           :: [a] -> Int
1092 --length            = foldl' (\n _ -> n + 1) 0
1093 length []     = 0
1094 length (x:xs) = let n = length xs in primSeq n (1+n)
1095
1096 (!!)             :: [b] -> Int -> b
1097 (x:_)  !! 0       = x
1098 (_:xs) !! n | n>0 = xs !! (n-1)
1099 (_:_)  !! _       = error "Prelude.!!: negative index"
1100 []     !! _       = error "Prelude.!!: index too large"
1101
1102 foldl            :: (a -> b -> a) -> a -> [b] -> a
1103 foldl f z []      = z
1104 foldl f z (x:xs)  = foldl f (f z x) xs
1105
1106 foldl'           :: (a -> b -> a) -> a -> [b] -> a
1107 foldl' f a []     = a
1108 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1109
1110 foldl1           :: (a -> a -> a) -> [a] -> a
1111 foldl1 f (x:xs)   = foldl f x xs
1112
1113 scanl            :: (a -> b -> a) -> a -> [b] -> [a]
1114 scanl f q xs      = q : (case xs of
1115                          []   -> []
1116                          x:xs -> scanl f (f q x) xs)
1117
1118 scanl1           :: (a -> a -> a) -> [a] -> [a]
1119 scanl1 f (x:xs)   = scanl f x xs
1120
1121 foldr            :: (a -> b -> b) -> b -> [a] -> b
1122 foldr f z []      = z
1123 foldr f z (x:xs)  = f x (foldr f z xs)
1124
1125 foldr1           :: (a -> a -> a) -> [a] -> a
1126 foldr1 f [x]      = x
1127 foldr1 f (x:xs)   = f x (foldr1 f xs)
1128
1129 scanr            :: (a -> b -> b) -> b -> [a] -> [b]
1130 scanr f q0 []     = [q0]
1131 scanr f q0 (x:xs) = f x q : qs
1132                     where qs@(q:_) = scanr f q0 xs
1133
1134 scanr1           :: (a -> a -> a) -> [a] -> [a]
1135 scanr1 f [x]      = [x]
1136 scanr1 f (x:xs)   = f x q : qs
1137                     where qs@(q:_) = scanr1 f xs
1138
1139 iterate          :: (a -> a) -> a -> [a]
1140 iterate f x       = x : iterate f (f x)
1141
1142 repeat           :: a -> [a]
1143 repeat x          = xs where xs = x:xs
1144
1145 replicate        :: Int -> a -> [a]
1146 replicate n x     = take n (repeat x)
1147
1148 cycle            :: [a] -> [a]
1149 cycle []          = error "Prelude.cycle: empty list"
1150 cycle xs          = xs' where xs'=xs++xs'
1151
1152 take                :: Int -> [a] -> [a]
1153 take 0 _             = []
1154 take _ []            = []
1155 take n (x:xs) | n>0  = x : take (n-1) xs
1156 take _ _             = error "Prelude.take: negative argument"
1157
1158 drop                :: Int -> [a] -> [a]
1159 drop 0 xs            = xs
1160 drop _ []            = []
1161 drop n (_:xs) | n>0  = drop (n-1) xs
1162 drop _ _             = error "Prelude.drop: negative argument"
1163
1164 splitAt               :: Int -> [a] -> ([a], [a])
1165 splitAt 0 xs           = ([],xs)
1166 splitAt _ []           = ([],[])
1167 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1168 splitAt _ _            = error "Prelude.splitAt: negative argument"
1169
1170 takeWhile           :: (a -> Bool) -> [a] -> [a]
1171 takeWhile p []       = []
1172 takeWhile p (x:xs)
1173          | p x       = x : takeWhile p xs
1174          | otherwise = []
1175
1176 dropWhile           :: (a -> Bool) -> [a] -> [a]
1177 dropWhile p []       = []
1178 dropWhile p xs@(x:xs')
1179          | p x       = dropWhile p xs'
1180          | otherwise = xs
1181
1182 span, break         :: (a -> Bool) -> [a] -> ([a],[a])
1183 span p []            = ([],[])
1184 span p xs@(x:xs')
1185          | p x       = (x:ys, zs)
1186          | otherwise = ([],xs)
1187                        where (ys,zs) = span p xs'
1188 break p              = span (not . p)
1189
1190 lines     :: String -> [String]
1191 lines ""   = []
1192 lines s    = let (l,s') = break ('\n'==) s
1193              in l : case s' of []      -> []
1194                                (_:s'') -> lines s''
1195
1196 words     :: String -> [String]
1197 words s    = case dropWhile isSpace s of
1198                   "" -> []
1199                   s' -> w : words s''
1200                         where (w,s'') = break isSpace s'
1201
1202 unlines   :: [String] -> String
1203 unlines    = concatMap (\l -> l ++ "\n")
1204
1205 unwords   :: [String] -> String
1206 unwords [] = []
1207 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1208
1209 reverse   :: [a] -> [a]
1210 --reverse    = foldl (flip (:)) []
1211 reverse xs = ri [] xs
1212              where ri acc []     = acc
1213                    ri acc (x:xs) = ri (x:acc) xs
1214
1215 and, or   :: [Bool] -> Bool
1216 --and        = foldr (&&) True
1217 --or         = foldr (||) False
1218 and []     = True
1219 and (x:xs) = if x then and xs else x
1220 or  []     = False
1221 or  (x:xs) = if x then x else or xs
1222
1223 any, all  :: (a -> Bool) -> [a] -> Bool
1224 --any p      = or  . map p
1225 --all p      = and . map p
1226 any p []     = False
1227 any p (x:xs) = if p x then True else any p xs
1228 all p []     = True
1229 all p (x:xs) = if p x then all p xs else False
1230
1231 elem, notElem    :: Eq a => a -> [a] -> Bool
1232 --elem              = any . (==)
1233 --notElem           = all . (/=)
1234 elem x []        = False
1235 elem x (y:ys)    = if x==y then True else elem x ys
1236 notElem x []     = True
1237 notElem x (y:ys) = if x==y then False else notElem x ys
1238
1239 lookup           :: Eq a => a -> [(a,b)] -> Maybe b
1240 lookup k []       = Nothing
1241 lookup k ((x,y):xys)
1242       | k==x      = Just y
1243       | otherwise = lookup k xys
1244
1245 sum, product     :: Num a => [a] -> a
1246 sum               = foldl' (+) 0
1247 product           = foldl' (*) 1
1248
1249 maximum, minimum :: Ord a => [a] -> a
1250 maximum           = foldl1 max
1251 minimum           = foldl1 min
1252
1253 concatMap        :: (a -> [b]) -> [a] -> [b]
1254 concatMap f       = concat . map f
1255
1256 zip              :: [a] -> [b] -> [(a,b)]
1257 zip               = zipWith  (\a b -> (a,b))
1258
1259 zip3             :: [a] -> [b] -> [c] -> [(a,b,c)]
1260 zip3              = zipWith3 (\a b c -> (a,b,c))
1261
1262 zipWith                  :: (a->b->c) -> [a]->[b]->[c]
1263 zipWith z (a:as) (b:bs)   = z a b : zipWith z as bs
1264 zipWith _ _      _        = []
1265
1266 zipWith3                 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1267 zipWith3 z (a:as) (b:bs) (c:cs)
1268                           = z a b c : zipWith3 z as bs cs
1269 zipWith3 _ _ _ _          = []
1270
1271 unzip                    :: [(a,b)] -> ([a],[b])
1272 unzip                     = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1273
1274 unzip3                   :: [(a,b,c)] -> ([a],[b],[c])
1275 unzip3                    = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1276                                   ([],[],[])
1277
1278 -- PreludeText ----------------------------------------------------------------
1279
1280 reads        :: Read a => ReadS a
1281 reads         = readsPrec 0
1282
1283 shows        :: Show a => a -> ShowS
1284 shows         = showsPrec 0
1285
1286 read         :: Read a => String -> a
1287 read s        =  case [x | (x,t) <- reads s, ("","") <- lex t] of
1288                       [x] -> x
1289                       []  -> error "Prelude.read: no parse"
1290                       _   -> error "Prelude.read: ambiguous parse"
1291
1292 showChar     :: Char -> ShowS
1293 showChar      = (:)
1294
1295 showString   :: String -> ShowS
1296 showString    = (++)
1297
1298 showParen    :: Bool -> ShowS -> ShowS
1299 showParen b p = if b then showChar '(' . p . showChar ')' else p
1300
1301 hugsprimShowField    :: Show a => String -> a -> ShowS
1302 hugsprimShowField m v = showString m . showChar '=' . shows v
1303
1304 readParen    :: Bool -> ReadS a -> ReadS a
1305 readParen b g = if b then mandatory else optional
1306                 where optional r  = g r ++ mandatory r
1307                       mandatory r = [(x,u) | ("(",s) <- lex r,
1308                                              (x,t)   <- optional s,
1309                                              (")",u) <- lex t    ]
1310
1311
1312 hugsprimReadField    :: Read a => String -> ReadS a
1313 hugsprimReadField m s0 = [ r | (t,  s1) <- lex s0, t == m,
1314                                ("=",s2) <- lex s1,
1315                                r        <- reads s2 ]
1316
1317 lex                    :: ReadS String
1318 lex ""                  = [("","")]
1319 lex (c:s) | isSpace c   = lex (dropWhile isSpace s)
1320 lex ('\'':s)            = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
1321                                                ch /= "'"                ]
1322 lex ('"':s)             = [('"':str, t)      | (str,t) <- lexString s]
1323                           where
1324                           lexString ('"':s) = [("\"",s)]
1325                           lexString s = [(ch++str, u)
1326                                                 | (ch,t)  <- lexStrItem s,
1327                                                   (str,u) <- lexString t  ]
1328
1329                           lexStrItem ('\\':'&':s) = [("\\&",s)]
1330                           lexStrItem ('\\':c:s) | isSpace c
1331                               = [("",t) | '\\':t <- [dropWhile isSpace s]]
1332                           lexStrItem s            = lexLitChar s
1333
1334 lex (c:s) | isSingle c  = [([c],s)]
1335           | isSym c     = [(c:sym,t)         | (sym,t) <- [span isSym s]]
1336           | isAlpha c   = [(c:nam,t)         | (nam,t) <- [span isIdChar s]]
1337           | isDigit c   = [(c:ds++fe,t)      | (ds,s)  <- [span isDigit s],
1338                                                (fe,t)  <- lexFracExp s     ]
1339           | otherwise   = []    -- bad character
1340                 where
1341                 isSingle c  =  c `elem` ",;()[]{}_`"
1342                 isSym c     =  c `elem` "!@#$%&*+./<=>?\\^|:-~"
1343                 isIdChar c  =  isAlphaNum c || c `elem` "_'"
1344
1345                 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1346                                                       (e,u)  <- lexExp t    ]
1347                 lexFracExp s       = [("",s)]
1348
1349                 lexExp (e:s) | e `elem` "eE"
1350                          = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
1351                                                    (ds,u) <- lexDigits t] ++
1352                            [(e:ds,t)   | (ds,t) <- lexDigits s]
1353                 lexExp s = [("",s)]
1354
1355 lexDigits               :: ReadS String
1356 lexDigits               =  nonnull isDigit
1357
1358 nonnull                 :: (Char -> Bool) -> ReadS String
1359 nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
1360
1361 lexLitChar              :: ReadS String
1362 lexLitChar ('\\':s)     =  [('\\':esc, t) | (esc,t) <- lexEsc s]
1363         where
1364         lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]    -- "
1365         lexEsc ('^':c:s) | c >= '@' && c <= '_'    = [(['^',c],s)]
1366         lexEsc s@(d:_)   | isDigit d               = lexDigits s
1367         lexEsc s@(c:_)   | isUpper c
1368                           = let table = ('\DEL',"DEL") : asciiTab
1369                             in case [(mne,s') | (c, mne) <- table,
1370                                                 ([],s') <- [lexmatch mne s]]
1371                                of (pr:_) -> [pr]
1372                                   []     -> []
1373         lexEsc _                                   = []
1374 lexLitChar (c:s)        =  [([c],s)]
1375 lexLitChar ""           =  []
1376
1377 isOctDigit c  =  c >= '0' && c <= '7'
1378 isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'
1379                            || c >= 'a' && c <= 'f'
1380
1381 lexmatch                   :: (Eq a) => [a] -> [a] -> ([a],[a])
1382 lexmatch (x:xs) (y:ys) | x == y  =  lexmatch xs ys
1383 lexmatch xs     ys               =  (xs,ys)
1384
1385 asciiTab = zip ['\NUL'..' ']
1386            ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1387             "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
1388             "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1389             "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
1390             "SP"]
1391
1392 readLitChar            :: ReadS Char
1393 readLitChar ('\\':s)    = readEsc s
1394  where
1395        readEsc ('a':s)  = [('\a',s)]
1396        readEsc ('b':s)  = [('\b',s)]
1397        readEsc ('f':s)  = [('\f',s)]
1398        readEsc ('n':s)  = [('\n',s)]
1399        readEsc ('r':s)  = [('\r',s)]
1400        readEsc ('t':s)  = [('\t',s)]
1401        readEsc ('v':s)  = [('\v',s)]
1402        readEsc ('\\':s) = [('\\',s)]
1403        readEsc ('"':s)  = [('"',s)]
1404        readEsc ('\'':s) = [('\'',s)]
1405        readEsc ('^':c:s) | c >= '@' && c <= '_'
1406                         = [(toEnum (fromEnum c - fromEnum '@'), s)]
1407        readEsc s@(d:_) | isDigit d
1408                         = [(toEnum n, t) | (n,t) <- readDec s]
1409        readEsc ('o':s)  = [(toEnum n, t) | (n,t) <- readOct s]
1410        readEsc ('x':s)  = [(toEnum n, t) | (n,t) <- readHex s]
1411        readEsc s@(c:_) | isUpper c
1412                         = let table = ('\DEL',"DEL") : asciiTab
1413                           in case [(c,s') | (c, mne) <- table,
1414                                             ([],s') <- [lexmatch mne s]]
1415                              of (pr:_) -> [pr]
1416                                 []     -> []
1417        readEsc _        = []
1418 readLitChar (c:s)       = [(c,s)]
1419
1420 showLitChar               :: Char -> ShowS
1421 showLitChar c | c > '\DEL' = showChar '\\' .
1422                              protectEsc isDigit (shows (fromEnum c))
1423 showLitChar '\DEL'         = showString "\\DEL"
1424 showLitChar '\\'           = showString "\\\\"
1425 showLitChar c | c >= ' '   = showChar c
1426 showLitChar '\a'           = showString "\\a"
1427 showLitChar '\b'           = showString "\\b"
1428 showLitChar '\f'           = showString "\\f"
1429 showLitChar '\n'           = showString "\\n"
1430 showLitChar '\r'           = showString "\\r"
1431 showLitChar '\t'           = showString "\\t"
1432 showLitChar '\v'           = showString "\\v"
1433 showLitChar '\SO'          = protectEsc ('H'==) (showString "\\SO")
1434 showLitChar c              = showString ('\\' : snd (asciiTab!!fromEnum c))
1435
1436 protectEsc p f             = f . cont
1437  where cont s@(c:_) | p c  = "\\&" ++ s
1438        cont s              = s
1439
1440 -- Unsigned readers for various bases
1441 readDec, readOct, readHex :: Integral a => ReadS a
1442 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1443 readOct = readInt  8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1444 readHex = readInt 16 isHexDigit hex
1445           where hex d = fromEnum d -
1446                         (if isDigit d
1447                            then fromEnum '0'
1448                            else fromEnum (if isUpper d then 'A' else 'a') - 10)
1449
1450 -- readInt reads a string of digits using an arbitrary base.
1451 -- Leading minus signs must be handled elsewhere.
1452
1453 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1454 readInt radix isDig digToInt s =
1455     [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1456         | (ds,r) <- nonnull isDig s ]
1457
1458 -- showInt is used for positive numbers only
1459 showInt    :: Integral a => a -> ShowS
1460 showInt n r
1461    | n < 0
1462    = error "Numeric.showInt: can't show negative numbers"
1463    | otherwise
1464 {-
1465    = let (n',d) = quotRem n 10
1466          r'     = toEnum (fromEnum '0' + fromIntegral d) : r
1467      in  if n' == 0 then r' else showInt n' r'
1468 -}
1469    = case quotRem n 10 of { (n',d) ->
1470      let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1471      in  if n' == 0 then r' else showInt n' r'
1472      }
1473
1474
1475 readSigned:: Real a => ReadS a -> ReadS a
1476 readSigned readPos = readParen False read'
1477                      where read' r  = read'' r ++
1478                                       [(-x,t) | ("-",s) <- lex r,
1479                                                 (x,t)   <- read'' s]
1480                            read'' r = [(n,s)  | (str,s) <- lex r,
1481                                                 (n,"")  <- readPos str]
1482
1483 showSigned    :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1484 showSigned showPos p x = if x < 0 then showParen (p > 6)
1485                                                  (showChar '-' . showPos (-x))
1486                                   else showPos x
1487
1488 readFloat     :: RealFloat a => ReadS a
1489 readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1490                                                        (k,t)   <- readExp s]
1491                  where readFix r = [(read (ds++ds'), length ds', t)
1492                                         | (ds, s) <- lexDigits r
1493                                         , (ds',t) <- lexFrac s   ]
1494
1495                        lexFrac ('.':s) = lexDigits s
1496                        lexFrac s       = [("",s)]
1497
1498                        readExp (e:s) | e `elem` "eE" = readExp' s
1499                        readExp s                     = [(0,s)]
1500
1501                        readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1502                        readExp' ('+':s) = readDec s
1503                        readExp' s       = readDec s
1504
1505
1506 -- Hooks for primitives: -----------------------------------------------------
1507 -- Do not mess with these!
1508
1509 hugsprimCompAux      :: Ord a => a -> a -> Ordering -> Ordering
1510 hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1511
1512 hugsprimEqChar       :: Char -> Char -> Bool
1513 hugsprimEqChar c1 c2  = primEqChar c1 c2
1514
1515 hugsprimPmInt        :: Num a => Int -> a -> Bool
1516 hugsprimPmInt n x     = fromInt n == x
1517
1518 hugsprimPmInteger    :: Num a => Integer -> a -> Bool
1519 hugsprimPmInteger n x = fromInteger n == x
1520
1521 hugsprimPmDouble     :: Fractional a => Double -> a -> Bool
1522 hugsprimPmDouble n x  = fromDouble n == x
1523
1524 -- ToDo: make the message more informative.
1525 hugsprimPmFail       :: a
1526 hugsprimPmFail        = error "Pattern Match Failure"
1527
1528 -- used in desugaring Foreign functions
1529 -- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
1530 -- bit of code of type   RealWorld -> (a,RealWorld)   into a proper IO value.
1531 -- What follows is the version for standalone mode.  ghc/lib/std/PrelHugs.lhs
1532 -- contains a version used in combined mode.  That version takes care of
1533 -- switching between the GHC and Hugs IO representations, which are different.
1534 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1535 hugsprimMkIO = IO
1536
1537 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1538 hugsprimCreateAdjThunk fun typestr callconv
1539    = do sp <- makeStablePtr fun
1540         p  <- copy_String_to_cstring typestr  -- is never freed
1541         a  <- primCreateAdjThunkARCH sp p callconv
1542         return a
1543
1544 -- The following primitives are only needed if (n+k) patterns are enabled:
1545 hugsprimPmSub           :: Integral a => Int -> a -> a
1546 hugsprimPmSub n x        = x - fromInt n
1547
1548 hugsprimPmFromInteger   :: Integral a => Integer -> a
1549 hugsprimPmFromInteger    = fromIntegral
1550
1551 hugsprimPmSubtract      :: Integral a => a -> a -> a
1552 hugsprimPmSubtract x y   = x - y
1553
1554 hugsprimPmLe            :: Integral a => a -> a -> Bool
1555 hugsprimPmLe x y         = x <= y
1556
1557 -- Unpack strings generated by the Hugs code generator.
1558 -- Strings can contain \0 provided they're coded right.
1559 --
1560 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1561
1562 hugsprimUnpackString :: Addr -> String
1563 hugsprimUnpackString a = unpack 0
1564  where
1565   -- The following decoding is based on evalString in the old machine.c
1566   unpack i
1567     | c == '\0' = []
1568     | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1569                   then '\\' : unpack (i+2)
1570                   else '\0' : unpack (i+2)
1571     | otherwise = c : unpack (i+1)
1572    where
1573     c = primIndexCharOffAddr a i
1574
1575
1576 -- Monadic I/O: --------------------------------------------------------------
1577
1578 type FilePath = String
1579
1580 --data IOError = ...
1581 --instance Eq IOError ...
1582 --instance Show IOError ...
1583
1584 data IOError = IOError String
1585 instance Show IOError where
1586    showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1587
1588 ioError :: IOError -> IO a
1589 ioError e@(IOError _) = primRaise (IOException e)
1590
1591 userError :: String -> IOError
1592 userError s = primRaise (ErrorCall s)
1593
1594 throw :: Exception -> a
1595 throw exception = primRaise exception
1596
1597 catchException :: IO a -> (Exception -> IO a) -> IO a
1598 catchException m k =  IO (\s -> unIO m s `primCatch` \ err -> unIO (k err) s)
1599
1600 catch           :: IO a -> (IOError -> IO a) -> IO a
1601 catch m k       =  catchException m handler
1602   where handler (IOException err) = k err
1603         handler other             = throw other
1604
1605 putChar :: Char -> IO ()
1606 putChar c = nh_stdout >>= \h -> nh_write h c
1607
1608 putStr :: String -> IO ()
1609 putStr s = nh_stdout >>= \h ->
1610            let loop []     = nh_flush h
1611                loop (c:cs) = nh_write h c >> loop cs
1612            in  loop s
1613
1614 putStrLn :: String -> IO ()
1615 putStrLn s = do { putStr s; putChar '\n' }
1616
1617 print :: Show a => a -> IO ()
1618 print = putStrLn . show
1619
1620 getChar :: IO Char
1621 getChar = nh_stdin  >>= \h ->
1622           nh_read h >>= \ci ->
1623           return (primIntToChar ci)
1624
1625 getLine :: IO String
1626 getLine    = do c <- getChar
1627                 if c=='\n' then return ""
1628                            else do cs <- getLine
1629                                    return (c:cs)
1630
1631 getContents :: IO String
1632 getContents = nh_stdin >>= \h -> readfromhandle h
1633
1634 interact  :: (String -> String) -> IO ()
1635 interact f = getContents >>= (putStr . f)
1636
1637 readFile :: FilePath -> IO String
1638 readFile fname
1639    = copy_String_to_cstring fname  >>= \ptr ->
1640      nh_open ptr 0                 >>= \h ->
1641      nh_free ptr                   >>
1642      nh_errno                      >>= \errno ->
1643      if   (isNullAddr h || errno /= 0)
1644      then (ioError.IOError) ("readFile: can't open file " ++ fname)
1645      else readfromhandle h
1646
1647 writeFile :: FilePath -> String -> IO ()
1648 writeFile fname contents
1649    = copy_String_to_cstring fname  >>= \ptr ->
1650      nh_open ptr 1                 >>= \h ->
1651      nh_free ptr                   >>
1652      nh_errno                      >>= \errno ->
1653      if   (isNullAddr h || errno /= 0)
1654      then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1655      else writetohandle fname h contents
1656
1657 appendFile :: FilePath -> String -> IO ()
1658 appendFile fname contents
1659    = copy_String_to_cstring fname  >>= \ptr ->
1660      nh_open ptr 2                 >>= \h ->
1661      nh_free ptr                   >>
1662      nh_errno                      >>= \errno ->
1663      if   (isNullAddr h || errno /= 0)
1664      then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1665      else writetohandle fname h contents
1666
1667
1668 -- raises an exception instead of an error
1669 readIO          :: Read a => String -> IO a
1670 readIO s         = case [x | (x,t) <- reads s, ("","") <- lex t] of
1671                         [x] -> return x
1672                         []  -> ioError (userError "PreludeIO.readIO: no parse")
1673                         _   -> ioError (userError
1674                                        "PreludeIO.readIO: ambiguous parse")
1675
1676 readLn          :: Read a => IO a
1677 readLn           = do l <- getLine
1678                       r <- readIO l
1679                       return r
1680
1681
1682 -- End of Hugs standard prelude ----------------------------------------------
1683 data Exception
1684   = IOException         IOError         -- IO exceptions (from 'ioError')
1685   | ArithException      ArithException  -- Arithmetic exceptions
1686   | ErrorCall           String          -- Calls to 'error'
1687   | NoMethodError       String          -- A non-existent method was invoked
1688   | PatternMatchFail    String          -- A pattern match failed
1689   | NonExhaustiveGuards String          -- A guard match failed
1690   | RecSelError         String          -- Selecting a non-existent field
1691   | RecConError         String          -- Field missing in record construction
1692   | RecUpdError         String          -- Record doesn't contain updated field
1693   | AssertionFailed     String          -- Assertions
1694   | DynException        Dynamic         -- Dynamic exceptions
1695   | AsyncException      AsyncException  -- Externally generated errors
1696   | PutFullMVar                         -- Put on a full MVar
1697   | NonTermination
1698
1699 data ArithException
1700   = Overflow
1701   | Underflow
1702   | LossOfPrecision
1703   | DivideByZero
1704   | Denormal
1705   deriving (Eq, Ord)
1706
1707 data AsyncException
1708   = StackOverflow
1709   | HeapOverflow
1710   | ThreadKilled
1711   deriving (Eq, Ord)
1712
1713 stackOverflow, heapOverflow :: Exception -- for the RTS
1714 stackOverflow = AsyncException StackOverflow
1715 heapOverflow  = AsyncException HeapOverflow
1716
1717 instance Show ArithException where
1718   showsPrec _ Overflow        = showString "arithmetic overflow"
1719   showsPrec _ Underflow       = showString "arithmetic underflow"
1720   showsPrec _ LossOfPrecision = showString "loss of precision"
1721   showsPrec _ DivideByZero    = showString "divide by zero"
1722   showsPrec _ Denormal        = showString "denormal"
1723
1724 instance Show AsyncException where
1725   showsPrec _ StackOverflow   = showString "stack overflow"
1726   showsPrec _ HeapOverflow    = showString "heap overflow"
1727   showsPrec _ ThreadKilled    = showString "thread killed"
1728
1729 instance Show Exception where
1730   showsPrec _ (IOException err)          = shows err
1731   showsPrec _ (ArithException err)       = shows err
1732   showsPrec _ (ErrorCall err)            = showString err
1733   showsPrec _ (NoMethodError err)        = showString err
1734   showsPrec _ (PatternMatchFail err)     = showString err
1735   showsPrec _ (NonExhaustiveGuards err)  = showString err
1736   showsPrec _ (RecSelError err)          = showString err
1737   showsPrec _ (RecConError err)          = showString err
1738   showsPrec _ (RecUpdError err)          = showString err
1739   showsPrec _ (AssertionFailed err)      = showString err
1740   showsPrec _ (AsyncException e)         = shows e
1741   showsPrec _ (DynException _err)        = showString "unknown exception"
1742   showsPrec _ (PutFullMVar)              = showString "putMVar: full MVar"
1743   showsPrec _ (NonTermination)           = showString "<<loop>>"
1744
1745 data Dynamic = Dynamic TypeRep Obj
1746
1747 data Obj = Obj   -- dummy type to hold the dynamically typed value.
1748 data TypeRep
1749  = App TyCon   [TypeRep]
1750  | Fun TypeRep TypeRep
1751    deriving ( Eq )
1752
1753 data TyCon = TyCon Int String
1754
1755 instance Eq TyCon where
1756   (TyCon t1 _) == (TyCon t2 _) = t1 == t2
1757
1758 data IOResult  = IOResult  deriving (Show)
1759
1760 type FILE_STAR = Addr   -- FILE *
1761
1762 foreign import "nHandle" "nh_stdin"    nh_stdin    :: IO FILE_STAR
1763 foreign import "nHandle" "nh_stdout"   nh_stdout   :: IO FILE_STAR
1764 foreign import "nHandle" "nh_stderr"   nh_stderr   :: IO FILE_STAR
1765 foreign import "nHandle" "nh_write"    nh_write    :: FILE_STAR -> Char -> IO ()
1766 foreign import "nHandle" "nh_read"     nh_read     :: FILE_STAR -> IO Int
1767 foreign import "nHandle" "nh_open"     nh_open     :: Addr -> Int -> IO FILE_STAR
1768 foreign import "nHandle" "nh_flush"    nh_flush    :: FILE_STAR -> IO ()
1769 foreign import "nHandle" "nh_close"    nh_close    :: FILE_STAR -> IO ()
1770 foreign import "nHandle" "nh_errno"    nh_errno    :: IO Int
1771
1772 foreign import "nHandle" "nh_malloc"   nh_malloc   :: Int -> IO Addr
1773 foreign import "nHandle" "nh_free"     nh_free     :: Addr -> IO ()
1774 foreign import "nHandle" "nh_store"    nh_store    :: Addr -> Char -> IO ()
1775 foreign import "nHandle" "nh_load"     nh_load     :: Addr -> IO Char
1776 foreign import "nHandle" "nh_getenv"   nh_getenv   :: Addr -> IO Addr
1777 foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int
1778 foreign import "nHandle" "nh_iseof"    nh_iseof    :: FILE_STAR -> IO Int
1779 foreign import "nHandle" "nh_system"   nh_system   :: Addr -> IO Int
1780 foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO ()
1781 foreign import "nHandle" "nh_getPID"   nh_getPID   :: IO Int
1782
1783 foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double
1784 foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double
1785
1786 copy_String_to_cstring :: String -> IO Addr
1787 copy_String_to_cstring s
1788    = nh_malloc (1 + length s) >>= \ptr0 ->
1789      let loop ptr []     = nh_store ptr (chr 0) >> return ptr0
1790          loop ptr (c:cs) = nh_store ptr c       >> loop (incAddr ptr) cs
1791      in
1792          if   isNullAddr ptr0
1793          then error "copy_String_to_cstring: malloc failed"
1794          else loop ptr0 s
1795
1796 copy_cstring_to_String :: Addr -> IO String
1797 copy_cstring_to_String ptr
1798    = nh_load ptr >>= \ci ->
1799      if   ci == '\0'
1800      then return []
1801      else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1802           return (ci : cs)
1803
1804 readfromhandle :: FILE_STAR -> IO String
1805 readfromhandle h
1806    = unsafeInterleaveIO (
1807      nh_read h >>= \ci ->
1808      if ci == -1 {-EOF-} then return "" else
1809      readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1810      )
1811
1812 writetohandle :: String -> FILE_STAR -> String -> IO ()
1813 writetohandle fname h []
1814    = nh_close h                  >>
1815      nh_errno                    >>= \errno ->
1816      if   errno == 0
1817      then return ()
1818      else error ( "writeFile/appendFile: error closing file " ++ fname)
1819 writetohandle fname h (c:cs)
1820    = nh_write h c >> writetohandle fname h cs
1821
1822 primGetRawArgs :: IO [String]
1823 primGetRawArgs
1824    = primGetArgc >>= \argc ->
1825      sequence (map get_one_arg [0 .. argc-1])
1826      where
1827         get_one_arg :: Int -> IO String
1828         get_one_arg argno
1829            = primGetArgv argno >>= \a ->
1830              copy_cstring_to_String a
1831
1832 primGetEnv :: String -> IO String
1833 primGetEnv v
1834    = copy_String_to_cstring v     >>= \ptr ->
1835      nh_getenv ptr                >>= \ptr2 ->
1836      nh_free ptr                  >>
1837      if   isNullAddr ptr2
1838      then ioError (IOError "getEnv failed")
1839      else
1840      copy_cstring_to_String ptr2  >>= \result ->
1841      return result
1842
1843
1844 ------------------------------------------------------------------------------
1845 -- ST ------------------------------------------------------------------------
1846 ------------------------------------------------------------------------------
1847
1848 newtype ST s a = ST (s -> (a,s))
1849 unST :: ST s a -> s -> (a,s)
1850 unST (ST a) = a
1851 mkST :: (s -> (a,s)) -> ST s a
1852 mkST = ST
1853 data RealWorld
1854
1855 runST :: (__forall s . ST s a) -> a
1856 runST m = fst (unST m alpha)
1857    where
1858       alpha = error "runST: entered the RealWorld"
1859
1860 instance Functor (ST s) where
1861    fmap f x  = x >>= (return . f)
1862
1863 instance Monad (ST s) where
1864    m >> k    = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1865    return x  = ST (\s -> (x,s))
1866    m >>= k   = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1867
1868 unsafeInterleaveST :: ST s a -> ST s a
1869 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1870
1871 ------------------------------------------------------------------------------
1872 -- IO ------------------------------------------------------------------------
1873 ------------------------------------------------------------------------------
1874
1875 newtype IO a = IO (RealWorld -> (a,RealWorld))
1876 unIO (IO a) = a
1877
1878 stToIO        :: ST RealWorld a -> IO a
1879 stToIO (ST fn) = IO fn
1880
1881 ioToST        :: IO a -> ST RealWorld a
1882 ioToST (IO fn) = ST fn
1883
1884 unsafePerformIO :: IO a -> a
1885 unsafePerformIO m = fst (unIO m theWorld)
1886    where
1887       theWorld :: RealWorld
1888       theWorld = error "unsafePerformIO: entered the RealWorld"
1889
1890 instance Functor IO where
1891    fmap f x  = x >>= (return . f)
1892
1893 instance Monad IO where
1894    m >> k    = IO (\s -> case unIO m s of { (a,s') -> unIO k s' })
1895    return x  = IO (\s -> (x,s))
1896    m >>= k   = IO (\s -> case unIO m s of { (a,s') -> unIO (k a) s' })
1897
1898 -- Library IO has a global variable which accumulates Handles
1899 -- as they are opened.  We keep here a second global variable
1900 -- into which a cleanup action may be specified.  When evaluation
1901 -- finishes, either normally or as a result of System.exitWith,
1902 -- this cleanup action is run, closing all known-about Handles.
1903 -- Doing it like this means the Prelude does not have to know
1904 -- anything about the grotty details of the Handle implementation.
1905 prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
1906 prelCleanupAfterRunAction = unsafePerformIO (newIORef Nothing)
1907
1908 -- used when Hugs invokes top level function
1909 hugsprimRunIO_toplevel :: IO a -> ()
1910 hugsprimRunIO_toplevel m
1911    = protect 5 (fst (unIO composite_action realWorld))
1912      where
1913         composite_action
1914            = do writeIORef prelCleanupAfterRunAction Nothing
1915                 m
1916                 cleanup_handles <- readIORef prelCleanupAfterRunAction
1917                 case cleanup_handles of
1918                    Nothing -> return ()
1919                    Just xx -> xx
1920
1921         realWorld = error "primRunIO: entered the RealWorld"
1922         protect :: Int -> () -> ()
1923         protect 0 comp
1924            = comp
1925         protect n comp
1926            = primCatch (protect (n-1) comp)
1927                        (\e -> fst (unIO (putStr (show e ++ "\n")) realWorld))
1928
1929 unsafeInterleaveIO :: IO a -> IO a
1930 unsafeInterleaveIO m = IO (\ s -> (fst (unIO m s), s))
1931
1932 ------------------------------------------------------------------------------
1933 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
1934 ------------------------------------------------------------------------------
1935
1936 data Addr
1937
1938 nullAddr     =  primIntToAddr 0
1939 incAddr a    =  primIntToAddr (1 + primAddrToInt a)
1940 isNullAddr a =  0 == primAddrToInt a
1941
1942 instance Eq Addr where
1943   (==)            = primEqAddr
1944   (/=)            = primNeAddr
1945
1946 instance Ord Addr where
1947   (<)             = primLtAddr
1948   (<=)            = primLeAddr
1949   (>=)            = primGeAddr
1950   (>)             = primGtAddr
1951
1952 data Word
1953
1954 instance Eq Word where
1955   (==)            = primEqWord
1956   (/=)            = primNeWord
1957
1958 instance Ord Word where
1959   (<)             = primLtWord
1960   (<=)            = primLeWord
1961   (>=)            = primGeWord
1962   (>)             = primGtWord
1963
1964 data StablePtr a
1965
1966 makeStablePtr   :: a -> IO (StablePtr a)
1967 makeStablePtr    = primMakeStablePtr
1968 deRefStablePtr  :: StablePtr a -> IO a
1969 deRefStablePtr   = primDeRefStablePtr
1970 freeStablePtr   :: StablePtr a -> IO ()
1971 freeStablePtr    = primFreeStablePtr
1972
1973
1974 data PrimArray              a -- immutable arrays with Int indices
1975 data PrimByteArray
1976
1977 data STRef                s a -- mutable variables
1978 data PrimMutableArray     s a -- mutable arrays with Int indices
1979 data PrimMutableByteArray s
1980
1981 newSTRef   :: a -> ST s (STRef s a)
1982 newSTRef    = primNewRef
1983 readSTRef  :: STRef s a -> ST s a
1984 readSTRef   = primReadRef
1985 writeSTRef :: STRef s a -> a -> ST s ()
1986 writeSTRef  = primWriteRef
1987
1988 newtype IORef a = IORef (STRef RealWorld a)
1989 newIORef   :: a -> IO (IORef a)
1990 newIORef   a = stToIO (primNewRef a >>= \ ref ->return (IORef ref))
1991 readIORef  :: IORef a -> IO a
1992 readIORef  (IORef ref) = stToIO (primReadRef ref)
1993 writeIORef :: IORef a -> a -> IO ()
1994 writeIORef  (IORef ref) a = stToIO (primWriteRef ref a)
1995
1996
1997 ------------------------------------------------------------------------------
1998 -- ThreadId, MVar, concurrency stuff -----------------------------------------
1999 ------------------------------------------------------------------------------
2000
2001 data MVar a
2002
2003 newEmptyMVar :: IO (MVar a)
2004 newEmptyMVar = primNewEmptyMVar
2005
2006 putMVar :: MVar a -> a -> IO ()
2007 putMVar = primPutMVar
2008
2009 takeMVar :: MVar a -> IO a
2010 takeMVar m
2011    = IO (\world -> primTakeMVar m cont world)
2012      where
2013         -- cont :: a -> RealWorld -> (a,RealWorld)
2014         -- where 'a' is as in the top-level signature
2015         cont x world = (x,world)
2016
2017         -- the type of the handwritten BCO (threesome) primTakeMVar is
2018         -- primTakeMVar :: MVar a
2019         --                 -> (a -> RealWorld -> (a,RealWorld))
2020         --                 -> RealWorld
2021         --                 -> (a,RealWorld)
2022         --
2023         -- primTakeMVar behaves like this:
2024         --
2025         -- primTakeMVar (MVar# m#) cont world
2026         --    = primTakeMVar_wrk m# cont world
2027         --
2028         -- primTakeMVar_wrk m# cont world
2029         --    = cont (takeMVar# m#) world
2030         --
2031         -- primTakeMVar_wrk has the special property that it is
2032         -- restartable by the scheduler, should the MVar be empty.
2033
2034 newMVar :: a -> IO (MVar a)
2035 newMVar value =
2036     newEmptyMVar        >>= \ mvar ->
2037     putMVar mvar value  >>
2038     return mvar
2039
2040 readMVar :: MVar a -> IO a
2041 readMVar mvar =
2042     takeMVar mvar       >>= \ value ->
2043     putMVar mvar value  >>
2044     return value
2045
2046 swapMVar :: MVar a -> a -> IO a
2047 swapMVar mvar new =
2048     takeMVar mvar       >>= \ old ->
2049     putMVar mvar new    >>
2050     return old
2051
2052 instance Eq (MVar a) where
2053     m1 == m2 = primSameMVar m1 m2
2054
2055
2056 data ThreadId
2057
2058 instance Eq ThreadId where
2059    tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
2060
2061 instance Ord ThreadId where
2062    compare tid1 tid2
2063       = let r = primCmpThreadIds tid1 tid2
2064         in  if r < 0 then LT else if r > 0 then GT else EQ
2065
2066
2067 forkIO :: IO a -> IO ThreadId
2068 -- Simple version; doesn't catch exceptions in computation
2069 -- forkIO computation
2070 --    = primForkIO (unsafePerformIO computation)
2071
2072 forkIO computation
2073    = primForkIO (
2074         primCatch
2075            (unIO computation realWorld `primSeq` ())
2076            (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
2077      )
2078      where
2079         realWorld = error "primForkIO: entered the RealWorld"
2080
2081 trace_quiet s x
2082    = (unsafePerformIO (putStr (s ++ "\n"))) `seq` x
2083
2084 -- showFloat ------------------------------------------------------------------
2085
2086 showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2087 showFFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2088 showGFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2089 showFloat      :: (RealFloat a) => a -> ShowS
2090
2091 showEFloat d x =  showString (formatRealFloat FFExponent d x)
2092 showFFloat d x =  showString (formatRealFloat FFFixed d x)
2093 showGFloat d x =  showString (formatRealFloat FFGeneric d x)
2094 showFloat      =  showGFloat Nothing
2095
2096 -- These are the format types.  This type is not exported.
2097
2098 data FFFormat = FFExponent | FFFixed | FFGeneric
2099
2100 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2101 formatRealFloat fmt decs x = s
2102   where base = 10
2103         s = if isNaN x then
2104                 "NaN"
2105             else if isInfinite x then
2106                 if x < 0 then "-Infinity" else "Infinity"
2107             else if x < 0 || isNegativeZero x then
2108                 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2109             else
2110                 doFmt fmt (floatToDigits (toInteger base) x)
2111         doFmt fmt (is, e) =
2112             let ds = map intToDigit is
2113             in  case fmt of
2114                 FFGeneric ->
2115                     doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2116                           (is, e)
2117                 FFExponent ->
2118                     case decs of
2119                     Nothing ->
2120                         case ds of
2121                          ['0'] -> "0.0e0"
2122                          [d]   -> d : ".0e" ++ show (e-1)
2123                          d:ds  -> d : '.' : ds ++ 'e':show (e-1)
2124                     Just dec ->
2125                         let dec' = max dec 1 in
2126                         case is of
2127                          [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2128                          _ ->
2129                           let (ei, is') = roundTo base (dec'+1) is
2130                               d:ds = map intToDigit
2131                                          (if ei > 0 then init is' else is')
2132                           in d:'.':ds  ++ "e" ++ show (e-1+ei)
2133                 FFFixed ->
2134                     case decs of
2135                     Nothing ->
2136                         let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2137                             f n s "" = f (n-1) (s++"0") ""
2138                             f n s (d:ds) = f (n-1) (s++[d]) ds
2139                             mk0 "" = "0"
2140                             mk0 s = s
2141                         in  f e "" ds
2142                     Just dec ->
2143                         let dec' = max dec 0 in
2144                         if e >= 0 then
2145                             let (ei, is') = roundTo base (dec' + e) is
2146                                 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2147                             in  (if null ls then "0" else ls) ++
2148                                 (if null rs then "" else '.' : rs)
2149                         else
2150                             let (ei, is') = roundTo base dec'
2151                                               (replicate (-e) 0 ++ is)
2152                                 d : ds = map intToDigit
2153                                             (if ei > 0 then is' else 0:is')
2154                             in  d : '.' : ds
2155
2156 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2157 roundTo base d is = case f d is of
2158                 (0, is) -> (0, is)
2159                 (1, is) -> (1, 1 : is)
2160   where b2 = base `div` 2
2161         f n [] = (0, replicate n 0)
2162         f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2163         f d (i:is) =
2164             let (c, ds) = f (d-1) is
2165                 i' = c + i
2166             in  if i' == base then (1, 0:ds) else (0, i':ds)
2167
2168 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2169 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2170 -- This version uses a much slower logarithm estimator.  It should be improved.
2171
2172 -- This function returns a list of digits (Ints in [0..base-1]) and an
2173 -- exponent.
2174
2175 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2176
2177 floatToDigits _ 0 = ([0], 0)
2178 floatToDigits base x =
2179     let (f0, e0) = decodeFloat x
2180         (minExp0, _) = floatRange x
2181         p = floatDigits x
2182         b = floatRadix x
2183         minExp = minExp0 - p            -- the real minimum exponent
2184         -- Haskell requires that f be adjusted so denormalized numbers
2185         -- will have an impossibly low exponent.  Adjust for this.
2186         (f, e) = let n = minExp - e0
2187                  in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2188
2189         (r, s, mUp, mDn) =
2190            if e >= 0 then
2191                let be = b^e in
2192                if f == b^(p-1) then
2193                    (f*be*b*2, 2*b, be*b, b)
2194                else
2195                    (f*be*2, 2, be, be)
2196            else
2197                if e > minExp && f == b^(p-1) then
2198                    (f*b*2, b^(-e+1)*2, b, 1)
2199                else
2200                    (f*2, b^(-e)*2, 1, 1)
2201         k =
2202             let k0 =
2203                     if b == 2 && base == 10 then
2204                          -- logBase 10 2 is slightly bigger than 3/10 so
2205                          -- the following will err on the low side.  Ignoring
2206                          -- the fraction will make it err even more.
2207                          -- Haskell promises that p-1 <= logBase b f < p.
2208                          (p - 1 + e0) * 3 `div` 10
2209                     else
2210                          ceiling ((log (fromInteger (f+1)) +
2211                                   fromInt e * log (fromInteger b)) /
2212                                    log (fromInteger base))
2213                 fixup n =
2214                     if n >= 0 then
2215                         if r + mUp <= expt base n * s then n else fixup (n+1)
2216                     else
2217                         if expt base (-n) * (r + mUp) <= s then n
2218                                                            else fixup (n+1)
2219             in  fixup k0
2220
2221         gen ds rn sN mUpN mDnN =
2222             let (dn, rn') = (rn * base) `divMod` sN
2223                 mUpN' = mUpN * base
2224                 mDnN' = mDnN * base
2225             in  case (rn' < mDnN', rn' + mUpN' > sN) of
2226                 (True,  False) -> dn : ds
2227                 (False, True)  -> dn+1 : ds
2228                 (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2229                 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2230         rds =
2231             if k >= 0 then
2232                 gen [] r (s * expt base k) mUp mDn
2233             else
2234                 let bk = expt base (-k)
2235                 in  gen [] (r * bk) s (mUp * bk) (mDn * bk)
2236     in  (map toInt (reverse rds), k)
2237
2238
2239 -- Exponentiation with a cache for the most common numbers.
2240 minExpt = 0::Int
2241 maxExpt = 1100::Int
2242 expt :: Integer -> Int -> Integer
2243 expt base n =
2244     if base == 2 && n >= minExpt && n <= maxExpt then
2245         expts !! (n-minExpt)
2246     else
2247         base^n
2248
2249 expts :: [Integer]
2250 expts = [2^n | n <- [minExpt .. maxExpt]]
2251