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     --divMod        = primDivModInteger
 692     toInteger     = id
 693     toInt         = primIntegerToInt
 694
 695 instance Ix Int where
 696     range (m,n)          = [m..n]
 697     index b@(m,n) i
 698            | inRange b i = i - m
 699            | otherwise   = error "index: Index out of range"
 700     inRange (m,n) i      = m <= i && i <= n
 701
 702 instance Ix Integer where
 703     range (m,n)          = [m..n]
 704     index b@(m,n) i
 705            | inRange b i = fromInteger (i - m)
 706            | otherwise   = error "index: Index out of range"
 707     inRange (m,n) i      = m <= i && i <= n
 708
 709 instance Enum Int where
 710     toEnum               = id
 711     fromEnum             = id
 712     enumFrom       = numericEnumFrom
 713     enumFromTo     = numericEnumFromTo
 714     enumFromThen   = numericEnumFromThen
 715     enumFromThenTo = numericEnumFromThenTo
 716
 717 instance Enum Integer where
 718     toEnum         = primIntToInteger
 719     fromEnum       = primIntegerToInt
 720     enumFrom       = numericEnumFrom
 721     enumFromTo     = numericEnumFromTo
 722     enumFromThen   = numericEnumFromThen
 723     enumFromThenTo = numericEnumFromThenTo
 724
 725 numericEnumFrom        :: Real a => a -> [a]
 726 numericEnumFromThen    :: Real a => a -> a -> [a]
 727 numericEnumFromTo      :: Real a => a -> a -> [a]
 728 numericEnumFromThenTo  :: Real a => a -> a -> a -> [a]
 729 numericEnumFrom n            = n : (numericEnumFrom $! (n+1))
 730 numericEnumFromThen n m      = iterate ((m-n)+) n
 731 numericEnumFromTo n m        = takeWhile (<= m) (numericEnumFrom n)
 732 numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
 733                                where p | n' >= n   = (<= m)
 734                                        | otherwise = (>= m)
 735
 736 instance Read Int where
 737     readsPrec p = readSigned readDec
 738
 739 instance  Show Int  where
 740     showsPrec p n
 741       | n == minBound = showSigned showInt p (toInteger n)
 742       | otherwise     = showSigned showInt p n
 743
 744 instance Read Integer where
 745     readsPrec p = readSigned readDec
 746
 747 instance Show Integer where
 748     showsPrec   = showSigned showInt
 749
 750
 751 -- Standard Floating types --------------------------------------------------
 752
 753 data Float     -- builtin datatype of single precision floating point numbers
 754 data Double    -- builtin datatype of double precision floating point numbers
 755
 756 instance Eq  Float  where
 757     (==)          = primEqFloat
 758     (/=)          = primNeFloat
 759
 760 instance Ord Float  where
 761     (<)           = primLtFloat
 762     (<=)          = primLeFloat
 763     (>=)          = primGeFloat
 764     (>)           = primGtFloat
 765
 766 instance Num Float where
 767     (+)           = primPlusFloat
 768     (-)           = primMinusFloat
 769     negate        = primNegateFloat
 770     (*)           = primTimesFloat
 771     abs           = absReal
 772     signum        = signumReal
 773     fromInteger   = primIntegerToFloat
 774     fromInt       = primIntToFloat
 775
 776
 777
 778 instance Eq  Double  where
 779     (==)         = primEqDouble
 780     (/=)         = primNeDouble
 781
 782 instance Ord Double  where
 783     (<)          = primLtDouble
 784     (<=)         = primLeDouble
 785     (>=)         = primGeDouble
 786     (>)          = primGtDouble
 787
 788 instance Num Double where
 789     (+)          = primPlusDouble
 790     (-)          = primMinusDouble
 791     negate       = primNegateDouble
 792     (*)          = primTimesDouble
 793     abs          = absReal
 794     signum       = signumReal
 795     fromInteger  = primIntegerToDouble
 796     fromInt      = primIntToDouble
 797
 798
 799
 800 instance Real Float where
 801     toRational = floatToRational
 802
 803 instance Real Double where
 804     toRational = doubleToRational
 805
 806 -- Calls to these functions are optimised when passed as arguments to
 807 -- fromRational.
 808 floatToRational  :: Float  -> Rational
 809 doubleToRational :: Double -> Rational
 810 floatToRational  x = realFloatToRational x
 811 doubleToRational x = realFloatToRational x
 812
 813 realFloatToRational x = (m%1)*(b%1)^^n
 814                         where (m,n) = decodeFloat x
 815                               b     = floatRadix x
 816
 817 instance Fractional Float where
 818     (/)           = primDivideFloat
 819     fromRational  = rationalToRealFloat
 820
 821 instance Fractional Double where
 822     (/)          = primDivideDouble
 823     fromRational = rationalToRealFloat
 824
 825 rationalToRealFloat x = x'
 826  where x'    = f e
 827        f e   = if e' == e then y else f e'
 828                where y      = encodeFloat (round (x * (1%b)^^e)) e
 829                      (_,e') = decodeFloat y
 830        (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
 831                              / fromInteger (denominator x))
 832        b     = floatRadix x'
 833
 834 instance Floating Float where
 835     pi    = 3.14159265358979323846
 836     exp   = primExpFloat
 837     log   = primLogFloat
 838     sqrt  = primSqrtFloat
 839     sin   = primSinFloat
 840     cos   = primCosFloat
 841     tan   = primTanFloat
 842     asin  = primAsinFloat
 843     acos  = primAcosFloat
 844     atan  = primAtanFloat
 845
 846 instance Floating Double where
 847     pi    = 3.14159265358979323846
 848     exp   = primExpDouble
 849     log   = primLogDouble
 850     sqrt  = primSqrtDouble
 851     sin   = primSinDouble
 852     cos   = primCosDouble
 853     tan   = primTanDouble
 854     asin  = primAsinDouble
 855     acos  = primAcosDouble
 856     atan  = primAtanDouble
 857
 858 instance RealFrac Float where
 859     properFraction = floatProperFraction
 860
 861 instance RealFrac Double where
 862     properFraction = floatProperFraction
 863
 864 floatProperFraction x
 865    | n >= 0      = (fromInteger m * fromInteger b ^ n, 0)
 866    | otherwise   = (fromInteger w, encodeFloat r n)
 867                    where (m,n) = decodeFloat x
 868                          b     = floatRadix x
 869                          (w,r) = quotRem m (b^(-n))
 870
 871 instance RealFloat Float where
 872     floatRadix  _ = toInteger primRadixFloat
 873     floatDigits _ = primDigitsFloat
 874     floatRange  _ = (primMinExpFloat,primMaxExpFloat)
 875     encodeFloat   = primEncodeFloatZ
 876     decodeFloat   = primDecodeFloatZ
 877     isNaN         = primIsNaNFloat
 878     isInfinite    = primIsInfiniteFloat
 879     isDenormalized= primIsDenormalizedFloat
 880     isNegativeZero= primIsNegativeZeroFloat
 881     isIEEE        = const primIsIEEEFloat
 882
 883 instance RealFloat Double where
 884     floatRadix  _ = toInteger primRadixDouble
 885     floatDigits _ = primDigitsDouble
 886     floatRange  _ = (primMinExpDouble,primMaxExpDouble)
 887     encodeFloat   = primEncodeDoubleZ
 888     decodeFloat   = primDecodeDoubleZ
 889     isNaN         = primIsNaNDouble
 890     isInfinite    = primIsInfiniteDouble
 891     isDenormalized= primIsDenormalizedDouble
 892     isNegativeZero= primIsNegativeZeroDouble
 893     isIEEE        = const primIsIEEEDouble
 894
 895 instance Enum Float where
 896     toEnum                = primIntToFloat
 897     fromEnum              = truncate
 898     enumFrom              = numericEnumFrom
 899     enumFromThen          = numericEnumFromThen
 900     enumFromTo n m        = numericEnumFromTo n (m+1/2)
 901     enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
 902
 903 instance Enum Double where
 904     toEnum                = primIntToDouble
 905     fromEnum              = truncate
 906     enumFrom              = numericEnumFrom
 907     enumFromThen          = numericEnumFromThen
 908     enumFromTo n m        = numericEnumFromTo n (m+1/2)
 909     enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
 910
 911 instance Read Float where
 912     readsPrec p = readSigned readFloat
 913
 914 instance Show Float where
 915     showsPrec p = showSigned showFloat p
 916
 917 instance Read Double where
 918     readsPrec p = readSigned readFloat
 919
 920 instance Show Double where
 921     showsPrec p = showSigned showFloat p
 922
 923
 924 -- Some standard functions --------------------------------------------------
 925
 926 fst            :: (a,b) -> a
 927 fst (x,_)       = x
 928
 929 snd            :: (a,b) -> b
 930 snd (_,y)       = y
 931
 932 curry          :: ((a,b) -> c) -> (a -> b -> c)
 933 curry f x y     = f (x,y)
 934
 935 uncurry        :: (a -> b -> c) -> ((a,b) -> c)
 936 uncurry f p     = f (fst p) (snd p)
 937
 938 id             :: a -> a
 939 id    x         = x
 940
 941 const          :: a -> b -> a
 942 const k _       = k
 943
 944 (.)            :: (b -> c) -> (a -> b) -> (a -> c)
 945 (f . g) x       = f (g x)
 946
 947 flip           :: (a -> b -> c) -> b -> a -> c
 948 flip f x y      = f y x
 949
 950 ($)            :: (a -> b) -> a -> b
 951 f $ x           = f x
 952
 953 until          :: (a -> Bool) -> (a -> a) -> a -> a
 954 until p f x     = if p x then x else until p f (f x)
 955
 956 asTypeOf       :: a -> a -> a
 957 asTypeOf        = const
 958
 959 error          :: String -> a
 960 error msg      =  primRaise (ErrorCall msg)
 961
 962 undefined         :: a
 963 undefined | False = undefined
 964
 965 -- Standard functions on rational numbers {PreludeRatio} --------------------
 966
 967 data Integral a => Ratio a = a :% a deriving (Eq)
 968 type Rational              = Ratio Integer
 969
 970 (%)                       :: Integral a => a -> a -> Ratio a
 971 x % y                      = reduce (x * signum y) (abs y)
 972
 973 reduce                    :: Integral a => a -> a -> Ratio a
 974 reduce x y | y == 0        = error "Ratio.%: zero denominator"
 975            | otherwise     = (x `quot` d) :% (y `quot` d)
 976                              where d = gcd x y
 977
 978 numerator, denominator    :: Integral a => Ratio a -> a
 979 numerator (x :% y)         = x
 980 denominator (x :% y)       = y
 981
 982 instance Integral a => Ord (Ratio a) where
 983     compare (x:%y) (x':%y') = compare (x*y') (x'*y)
 984
 985 instance Integral a => Num (Ratio a) where
 986     (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
 987     (x:%y) * (x':%y') = reduce (x*x') (y*y')
 988     negate (x :% y)   = negate x :% y
 989     abs (x :% y)      = abs x :% y
 990     signum (x :% y)   = signum x :% 1
 991     fromInteger x     = fromInteger x :% 1
 992     fromInt           = intToRatio
 993
 994 -- Hugs optimises code of the form fromRational (intToRatio x)
 995 intToRatio :: Integral a => Int -> Ratio a
 996 intToRatio x = fromInt x :% 1
 997
 998 instance Integral a => Real (Ratio a) where
 999     toRational (x:%y) = toInteger x :% toInteger y
1000
1001 instance Integral a => Fractional (Ratio a) where
1002     (x:%y) / (x':%y')   = (x*y') % (y*x')
1003     recip (x:%y)        = if x < 0 then (-y) :% (-x) else y :% x
1004     fromRational (x:%y) = fromInteger x :% fromInteger y
1005
1006 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1007 doubleToRatio :: Integral a => Double -> Ratio a
1008 doubleToRatio x
1009             | n>=0      = (fromInteger m * fromInteger b ^ n) % 1
1010             | otherwise = fromInteger m % (fromInteger b ^ (-n))
1011                           where (m,n) = decodeFloat x
1012                                 b     = floatRadix x
1013
1014 instance Integral a => RealFrac (Ratio a) where
1015     properFraction (x:%y) = (fromIntegral q, r:%y)
1016                             where (q,r) = quotRem x y
1017
1018 instance Integral a => Enum (Ratio a) where
1019     toEnum       = fromInt
1020     fromEnum     = truncate
1021     enumFrom     = numericEnumFrom
1022     enumFromThen = numericEnumFromThen
1023
1024 instance (Read a, Integral a) => Read (Ratio a) where
1025     readsPrec p = readParen (p > 7)
1026                             (\r -> [(x%y,u) | (x,s)   <- reads r,
1027                                               ("%",t) <- lex s,
1028                                               (y,u)   <- reads t ])
1029
1030 instance Integral a => Show (Ratio a) where
1031     showsPrec p (x:%y) = showParen (p > 7)
1032                              (shows x . showString " % " . shows y)
1033
1034 approxRational      :: RealFrac a => a -> a -> Rational
1035 approxRational x eps = simplest (x-eps) (x+eps)
1036  where simplest x y | y < x     = simplest y x
1037                     | x == y    = xr
1038                     | x > 0     = simplest' n d n' d'
1039                     | y < 0     = - simplest' (-n') d' (-n) d
1040                     | otherwise = 0 :% 1
1041                                   where xr@(n:%d) = toRational x
1042                                         (n':%d')  = toRational y
1043        simplest' n d n' d'        -- assumes 0 < n%d < n'%d'
1044                     | r == 0    = q :% 1
1045                     | q /= q'   = (q+1) :% 1
1046                     | otherwise = (q*n''+d'') :% n''
1047                                   where (q,r)      = quotRem n d
1048                                         (q',r')    = quotRem n' d'
1049                                         (n'':%d'') = simplest' d' r' d r
1050
1051 -- Standard list functions {PreludeList} ------------------------------------
1052
1053 head             :: [a] -> a
1054 head (x:_)        = x
1055
1056 last             :: [a] -> a
1057 last [x]          = x
1058 last (_:xs)       = last xs
1059
1060 tail             :: [a] -> [a]
1061 tail (_:xs)       = xs
1062
1063 init             :: [a] -> [a]
1064 init [x]          = []
1065 init (x:xs)       = x : init xs
1066
1067 null             :: [a] -> Bool
1068 null []           = True
1069 null (_:_)        = False
1070
1071 (++)             :: [a] -> [a] -> [a]
1072 []     ++ ys      = ys
1073 (x:xs) ++ ys      = x : (xs ++ ys)
1074
1075 map              :: (a -> b) -> [a] -> [b]
1076 --map f xs          = [ f x | x <- xs ]
1077 map f []     = []
1078 map f (x:xs) = f x : map f xs
1079
1080
1081 filter           :: (a -> Bool) -> [a] -> [a]
1082 --filter p xs       = [ x | x <- xs, p x ]
1083 filter p [] = []
1084 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1085
1086
1087 concat           :: [[a]] -> [a]
1088 --concat            = foldr (++) []
1089 concat []       = []
1090 concat (xs:xss) = xs ++ concat xss
1091
1092 length           :: [a] -> Int
1093 --length            = foldl' (\n _ -> n + 1) 0
1094 length []     = 0
1095 length (x:xs) = let n = length xs in primSeq n (1+n)
1096
1097 (!!)             :: [b] -> Int -> b
1098 (x:_)  !! 0       = x
1099 (_:xs) !! n | n>0 = xs !! (n-1)
1100 (_:_)  !! _       = error "Prelude.!!: negative index"
1101 []     !! _       = error "Prelude.!!: index too large"
1102
1103 foldl            :: (a -> b -> a) -> a -> [b] -> a
1104 foldl f z []      = z
1105 foldl f z (x:xs)  = foldl f (f z x) xs
1106
1107 foldl'           :: (a -> b -> a) -> a -> [b] -> a
1108 foldl' f a []     = a
1109 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1110
1111 foldl1           :: (a -> a -> a) -> [a] -> a
1112 foldl1 f (x:xs)   = foldl f x xs
1113
1114 scanl            :: (a -> b -> a) -> a -> [b] -> [a]
1115 scanl f q xs      = q : (case xs of
1116                          []   -> []
1117                          x:xs -> scanl f (f q x) xs)
1118
1119 scanl1           :: (a -> a -> a) -> [a] -> [a]
1120 scanl1 f (x:xs)   = scanl f x xs
1121
1122 foldr            :: (a -> b -> b) -> b -> [a] -> b
1123 foldr f z []      = z
1124 foldr f z (x:xs)  = f x (foldr f z xs)
1125
1126 foldr1           :: (a -> a -> a) -> [a] -> a
1127 foldr1 f [x]      = x
1128 foldr1 f (x:xs)   = f x (foldr1 f xs)
1129
1130 scanr            :: (a -> b -> b) -> b -> [a] -> [b]
1131 scanr f q0 []     = [q0]
1132 scanr f q0 (x:xs) = f x q : qs
1133                     where qs@(q:_) = scanr f q0 xs
1134
1135 scanr1           :: (a -> a -> a) -> [a] -> [a]
1136 scanr1 f [x]      = [x]
1137 scanr1 f (x:xs)   = f x q : qs
1138                     where qs@(q:_) = scanr1 f xs
1139
1140 iterate          :: (a -> a) -> a -> [a]
1141 iterate f x       = x : iterate f (f x)
1142
1143 repeat           :: a -> [a]
1144 repeat x          = xs where xs = x:xs
1145
1146 replicate        :: Int -> a -> [a]
1147 replicate n x     = take n (repeat x)
1148
1149 cycle            :: [a] -> [a]
1150 cycle []          = error "Prelude.cycle: empty list"
1151 cycle xs          = xs' where xs'=xs++xs'
1152
1153 take                :: Int -> [a] -> [a]
1154 take 0 _             = []
1155 take _ []            = []
1156 take n (x:xs) | n>0  = x : take (n-1) xs
1157 take _ _             = error "Prelude.take: negative argument"
1158
1159 drop                :: Int -> [a] -> [a]
1160 drop 0 xs            = xs
1161 drop _ []            = []
1162 drop n (_:xs) | n>0  = drop (n-1) xs
1163 drop _ _             = error "Prelude.drop: negative argument"
1164
1165 splitAt               :: Int -> [a] -> ([a], [a])
1166 splitAt 0 xs           = ([],xs)
1167 splitAt _ []           = ([],[])
1168 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1169 splitAt _ _            = error "Prelude.splitAt: negative argument"
1170
1171 takeWhile           :: (a -> Bool) -> [a] -> [a]
1172 takeWhile p []       = []
1173 takeWhile p (x:xs)
1174          | p x       = x : takeWhile p xs
1175          | otherwise = []
1176
1177 dropWhile           :: (a -> Bool) -> [a] -> [a]
1178 dropWhile p []       = []
1179 dropWhile p xs@(x:xs')
1180          | p x       = dropWhile p xs'
1181          | otherwise = xs
1182
1183 span, break         :: (a -> Bool) -> [a] -> ([a],[a])
1184 span p []            = ([],[])
1185 span p xs@(x:xs')
1186          | p x       = (x:ys, zs)
1187          | otherwise = ([],xs)
1188                        where (ys,zs) = span p xs'
1189 break p              = span (not . p)
1190
1191 lines     :: String -> [String]
1192 lines ""   = []
1193 lines s    = let (l,s') = break ('\n'==) s
1194              in l : case s' of []      -> []
1195                                (_:s'') -> lines s''
1196
1197 words     :: String -> [String]
1198 words s    = case dropWhile isSpace s of
1199                   "" -> []
1200                   s' -> w : words s''
1201                         where (w,s'') = break isSpace s'
1202
1203 unlines   :: [String] -> String
1204 unlines    = concatMap (\l -> l ++ "\n")
1205
1206 unwords   :: [String] -> String
1207 unwords [] = []
1208 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1209
1210 reverse   :: [a] -> [a]
1211 --reverse    = foldl (flip (:)) []
1212 reverse xs = ri [] xs
1213              where ri acc []     = acc
1214                    ri acc (x:xs) = ri (x:acc) xs
1215
1216 and, or   :: [Bool] -> Bool
1217 --and        = foldr (&&) True
1218 --or         = foldr (||) False
1219 and []     = True
1220 and (x:xs) = if x then and xs else x
1221 or  []     = False
1222 or  (x:xs) = if x then x else or xs
1223
1224 any, all  :: (a -> Bool) -> [a] -> Bool
1225 --any p      = or  . map p
1226 --all p      = and . map p
1227 any p []     = False
1228 any p (x:xs) = if p x then True else any p xs
1229 all p []     = True
1230 all p (x:xs) = if p x then all p xs else False
1231
1232 elem, notElem    :: Eq a => a -> [a] -> Bool
1233 --elem              = any . (==)
1234 --notElem           = all . (/=)
1235 elem x []        = False
1236 elem x (y:ys)    = if x==y then True else elem x ys
1237 notElem x []     = True
1238 notElem x (y:ys) = if x==y then False else notElem x ys
1239
1240 lookup           :: Eq a => a -> [(a,b)] -> Maybe b
1241 lookup k []       = Nothing
1242 lookup k ((x,y):xys)
1243       | k==x      = Just y
1244       | otherwise = lookup k xys
1245
1246 sum, product     :: Num a => [a] -> a
1247 sum               = foldl' (+) 0
1248 product           = foldl' (*) 1
1249
1250 maximum, minimum :: Ord a => [a] -> a
1251 maximum           = foldl1 max
1252 minimum           = foldl1 min
1253
1254 concatMap        :: (a -> [b]) -> [a] -> [b]
1255 concatMap f       = concat . map f
1256
1257 zip              :: [a] -> [b] -> [(a,b)]
1258 zip               = zipWith  (\a b -> (a,b))
1259
1260 zip3             :: [a] -> [b] -> [c] -> [(a,b,c)]
1261 zip3              = zipWith3 (\a b c -> (a,b,c))
1262
1263 zipWith                  :: (a->b->c) -> [a]->[b]->[c]
1264 zipWith z (a:as) (b:bs)   = z a b : zipWith z as bs
1265 zipWith _ _      _        = []
1266
1267 zipWith3                 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1268 zipWith3 z (a:as) (b:bs) (c:cs)
1269                           = z a b c : zipWith3 z as bs cs
1270 zipWith3 _ _ _ _          = []
1271
1272 unzip                    :: [(a,b)] -> ([a],[b])
1273 unzip                     = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1274
1275 unzip3                   :: [(a,b,c)] -> ([a],[b],[c])
1276 unzip3                    = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1277                                   ([],[],[])
1278
1279 -- PreludeText ----------------------------------------------------------------
1280
1281 reads        :: Read a => ReadS a
1282 reads         = readsPrec 0
1283
1284 shows        :: Show a => a -> ShowS
1285 shows         = showsPrec 0
1286
1287 read         :: Read a => String -> a
1288 read s        =  case [x | (x,t) <- reads s, ("","") <- lex t] of
1289                       [x] -> x
1290                       []  -> error "Prelude.read: no parse"
1291                       _   -> error "Prelude.read: ambiguous parse"
1292
1293 showChar     :: Char -> ShowS
1294 showChar      = (:)
1295
1296 showString   :: String -> ShowS
1297 showString    = (++)
1298
1299 showParen    :: Bool -> ShowS -> ShowS
1300 showParen b p = if b then showChar '(' . p . showChar ')' else p
1301
1302 hugsprimShowField    :: Show a => String -> a -> ShowS
1303 hugsprimShowField m v = showString m . showChar '=' . shows v
1304
1305 readParen    :: Bool -> ReadS a -> ReadS a
1306 readParen b g = if b then mandatory else optional
1307                 where optional r  = g r ++ mandatory r
1308                       mandatory r = [(x,u) | ("(",s) <- lex r,
1309                                              (x,t)   <- optional s,
1310                                              (")",u) <- lex t    ]
1311
1312
1313 hugsprimReadField    :: Read a => String -> ReadS a
1314 hugsprimReadField m s0 = [ r | (t,  s1) <- lex s0, t == m,
1315                                ("=",s2) <- lex s1,
1316                                r        <- reads s2 ]
1317
1318 lex                    :: ReadS String
1319 lex ""                  = [("","")]
1320 lex (c:s) | isSpace c   = lex (dropWhile isSpace s)
1321 lex ('\'':s)            = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
1322                                                ch /= "'"                ]
1323 lex ('"':s)             = [('"':str, t)      | (str,t) <- lexString s]
1324                           where
1325                           lexString ('"':s) = [("\"",s)]
1326                           lexString s = [(ch++str, u)
1327                                                 | (ch,t)  <- lexStrItem s,
1328                                                   (str,u) <- lexString t  ]
1329
1330                           lexStrItem ('\\':'&':s) = [("\\&",s)]
1331                           lexStrItem ('\\':c:s) | isSpace c
1332                               = [("",t) | '\\':t <- [dropWhile isSpace s]]
1333                           lexStrItem s            = lexLitChar s
1334
1335 lex (c:s) | isSingle c  = [([c],s)]
1336           | isSym c     = [(c:sym,t)         | (sym,t) <- [span isSym s]]
1337           | isAlpha c   = [(c:nam,t)         | (nam,t) <- [span isIdChar s]]
1338           | isDigit c   = [(c:ds++fe,t)      | (ds,s)  <- [span isDigit s],
1339                                                (fe,t)  <- lexFracExp s     ]
1340           | otherwise   = []    -- bad character
1341                 where
1342                 isSingle c  =  c `elem` ",;()[]{}_`"
1343                 isSym c     =  c `elem` "!@#$%&*+./<=>?\\^|:-~"
1344                 isIdChar c  =  isAlphaNum c || c `elem` "_'"
1345
1346                 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1347                                                       (e,u)  <- lexExp t    ]
1348                 lexFracExp s       = [("",s)]
1349
1350                 lexExp (e:s) | e `elem` "eE"
1351                          = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
1352                                                    (ds,u) <- lexDigits t] ++
1353                            [(e:ds,t)   | (ds,t) <- lexDigits s]
1354                 lexExp s = [("",s)]
1355
1356 lexDigits               :: ReadS String
1357 lexDigits               =  nonnull isDigit
1358
1359 nonnull                 :: (Char -> Bool) -> ReadS String
1360 nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
1361
1362 lexLitChar              :: ReadS String
1363 lexLitChar ('\\':s)     =  [('\\':esc, t) | (esc,t) <- lexEsc s]
1364         where
1365         lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]    -- "
1366         lexEsc ('^':c:s) | c >= '@' && c <= '_'    = [(['^',c],s)]
1367         lexEsc s@(d:_)   | isDigit d               = lexDigits s
1368         lexEsc s@(c:_)   | isUpper c
1369                           = let table = ('\DEL',"DEL") : asciiTab
1370                             in case [(mne,s') | (c, mne) <- table,
1371                                                 ([],s') <- [lexmatch mne s]]
1372                                of (pr:_) -> [pr]
1373                                   []     -> []
1374         lexEsc _                                   = []
1375 lexLitChar (c:s)        =  [([c],s)]
1376 lexLitChar ""           =  []
1377
1378 isOctDigit c  =  c >= '0' && c <= '7'
1379 isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'
1380                            || c >= 'a' && c <= 'f'
1381
1382 lexmatch                   :: (Eq a) => [a] -> [a] -> ([a],[a])
1383 lexmatch (x:xs) (y:ys) | x == y  =  lexmatch xs ys
1384 lexmatch xs     ys               =  (xs,ys)
1385
1386 asciiTab = zip ['\NUL'..' ']
1387            ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1388             "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
1389             "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1390             "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
1391             "SP"]
1392
1393 readLitChar            :: ReadS Char
1394 readLitChar ('\\':s)    = readEsc s
1395  where
1396        readEsc ('a':s)  = [('\a',s)]
1397        readEsc ('b':s)  = [('\b',s)]
1398        readEsc ('f':s)  = [('\f',s)]
1399        readEsc ('n':s)  = [('\n',s)]
1400        readEsc ('r':s)  = [('\r',s)]
1401        readEsc ('t':s)  = [('\t',s)]
1402        readEsc ('v':s)  = [('\v',s)]
1403        readEsc ('\\':s) = [('\\',s)]
1404        readEsc ('"':s)  = [('"',s)]
1405        readEsc ('\'':s) = [('\'',s)]
1406        readEsc ('^':c:s) | c >= '@' && c <= '_'
1407                         = [(toEnum (fromEnum c - fromEnum '@'), s)]
1408        readEsc s@(d:_) | isDigit d
1409                         = [(toEnum n, t) | (n,t) <- readDec s]
1410        readEsc ('o':s)  = [(toEnum n, t) | (n,t) <- readOct s]
1411        readEsc ('x':s)  = [(toEnum n, t) | (n,t) <- readHex s]
1412        readEsc s@(c:_) | isUpper c
1413                         = let table = ('\DEL',"DEL") : asciiTab
1414                           in case [(c,s') | (c, mne) <- table,
1415                                             ([],s') <- [lexmatch mne s]]
1416                              of (pr:_) -> [pr]
1417                                 []     -> []
1418        readEsc _        = []
1419 readLitChar (c:s)       = [(c,s)]
1420
1421 showLitChar               :: Char -> ShowS
1422 showLitChar c | c > '\DEL' = showChar '\\' .
1423                              protectEsc isDigit (shows (fromEnum c))
1424 showLitChar '\DEL'         = showString "\\DEL"
1425 showLitChar '\\'           = showString "\\\\"
1426 showLitChar c | c >= ' '   = showChar c
1427 showLitChar '\a'           = showString "\\a"
1428 showLitChar '\b'           = showString "\\b"
1429 showLitChar '\f'           = showString "\\f"
1430 showLitChar '\n'           = showString "\\n"
1431 showLitChar '\r'           = showString "\\r"
1432 showLitChar '\t'           = showString "\\t"
1433 showLitChar '\v'           = showString "\\v"
1434 showLitChar '\SO'          = protectEsc ('H'==) (showString "\\SO")
1435 showLitChar c              = showString ('\\' : snd (asciiTab!!fromEnum c))
1436
1437 protectEsc p f             = f . cont
1438  where cont s@(c:_) | p c  = "\\&" ++ s
1439        cont s              = s
1440
1441 -- Unsigned readers for various bases
1442 readDec, readOct, readHex :: Integral a => ReadS a
1443 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1444 readOct = readInt  8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1445 readHex = readInt 16 isHexDigit hex
1446           where hex d = fromEnum d -
1447                         (if isDigit d
1448                            then fromEnum '0'
1449                            else fromEnum (if isUpper d then 'A' else 'a') - 10)
1450
1451 -- readInt reads a string of digits using an arbitrary base.
1452 -- Leading minus signs must be handled elsewhere.
1453
1454 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1455 readInt radix isDig digToInt s =
1456     [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1457         | (ds,r) <- nonnull isDig s ]
1458
1459 -- showInt is used for positive numbers only
1460 showInt    :: Integral a => a -> ShowS
1461 showInt n r
1462    | n < 0
1463    = error "Numeric.showInt: can't show negative numbers"
1464    | otherwise
1465 {-
1466    = let (n',d) = quotRem n 10
1467          r'     = toEnum (fromEnum '0' + fromIntegral d) : r
1468      in  if n' == 0 then r' else showInt n' r'
1469 -}
1470    = case quotRem n 10 of { (n',d) ->
1471      let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1472      in  if n' == 0 then r' else showInt n' r'
1473      }
1474
1475
1476 readSigned:: Real a => ReadS a -> ReadS a
1477 readSigned readPos = readParen False read'
1478                      where read' r  = read'' r ++
1479                                       [(-x,t) | ("-",s) <- lex r,
1480                                                 (x,t)   <- read'' s]
1481                            read'' r = [(n,s)  | (str,s) <- lex r,
1482                                                 (n,"")  <- readPos str]
1483
1484 showSigned    :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1485 showSigned showPos p x = if x < 0 then showParen (p > 6)
1486                                                  (showChar '-' . showPos (-x))
1487                                   else showPos x
1488
1489 readFloat     :: RealFloat a => ReadS a
1490 readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1491                                                        (k,t)   <- readExp s]
1492                  where readFix r = [(read (ds++ds'), length ds', t)
1493                                         | (ds, s) <- lexDigits r
1494                                         , (ds',t) <- lexFrac s   ]
1495
1496                        lexFrac ('.':s) = lexDigits s
1497                        lexFrac s       = [("",s)]
1498
1499                        readExp (e:s) | e `elem` "eE" = readExp' s
1500                        readExp s                     = [(0,s)]
1501
1502                        readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1503                        readExp' ('+':s) = readDec s
1504                        readExp' s       = readDec s
1505
1506
1507 -- Hooks for primitives: -----------------------------------------------------
1508 -- Do not mess with these!
1509
1510 hugsprimCompAux      :: Ord a => a -> a -> Ordering -> Ordering
1511 hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1512
1513 hugsprimEqChar       :: Char -> Char -> Bool
1514 hugsprimEqChar c1 c2  = primEqChar c1 c2
1515
1516 hugsprimPmInt        :: Num a => Int -> a -> Bool
1517 hugsprimPmInt n x     = fromInt n == x
1518
1519 hugsprimPmInteger    :: Num a => Integer -> a -> Bool
1520 hugsprimPmInteger n x = fromInteger n == x
1521
1522 hugsprimPmDouble     :: Fractional a => Double -> a -> Bool
1523 hugsprimPmDouble n x  = fromDouble n == x
1524
1525 -- ToDo: make the message more informative.
1526 hugsprimPmFail       :: a
1527 hugsprimPmFail        = error "Pattern Match Failure"
1528
1529 -- used in desugaring Foreign functions
1530 -- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
1531 -- bit of code of type   RealWorld -> (a,RealWorld)   into a proper IO value.
1532 -- What follows is the version for standalone mode.  ghc/lib/std/PrelHugs.lhs
1533 -- contains a version used in combined mode.  That version takes care of
1534 -- switching between the GHC and Hugs IO representations, which are different.
1535 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1536 hugsprimMkIO = IO
1537
1538 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1539 hugsprimCreateAdjThunk fun typestr callconv
1540    = do sp <- makeStablePtr fun
1541         p  <- copy_String_to_cstring typestr  -- is never freed
1542         a  <- primCreateAdjThunkARCH sp p callconv
1543         return a
1544
1545 -- The following primitives are only needed if (n+k) patterns are enabled:
1546 hugsprimPmSub           :: Integral a => Int -> a -> a
1547 hugsprimPmSub n x        = x - fromInt n
1548
1549 hugsprimPmFromInteger   :: Integral a => Integer -> a
1550 hugsprimPmFromInteger    = fromIntegral
1551
1552 hugsprimPmSubtract      :: Integral a => a -> a -> a
1553 hugsprimPmSubtract x y   = x - y
1554
1555 hugsprimPmLe            :: Integral a => a -> a -> Bool
1556 hugsprimPmLe x y         = x <= y
1557
1558 -- Unpack strings generated by the Hugs code generator.
1559 -- Strings can contain \0 provided they're coded right.
1560 --
1561 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1562
1563 hugsprimUnpackString :: Addr -> String
1564 hugsprimUnpackString a = unpack 0
1565  where
1566   -- The following decoding is based on evalString in the old machine.c
1567   unpack i
1568     | c == '\0' = []
1569     | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1570                   then '\\' : unpack (i+2)
1571                   else '\0' : unpack (i+2)
1572     | otherwise = c : unpack (i+1)
1573    where
1574     c = primIndexCharOffAddr a i
1575
1576
1577 -- Monadic I/O: --------------------------------------------------------------
1578
1579 type FilePath = String
1580
1581 --data IOError = ...
1582 --instance Eq IOError ...
1583 --instance Show IOError ...
1584
1585 data IOError = IOError String
1586 instance Show IOError where
1587    showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1588
1589 ioError :: IOError -> IO a
1590 ioError (IOError s) = primRaise (IOExcept s)
1591
1592 userError :: String -> IOError
1593 userError s = primRaise (ErrorCall s)
1594
1595 catch :: IO a -> (IOError -> IO a) -> IO a
1596 catch m k
1597   = IO (\s -> unIO m s `primCatch` \ err -> unIO (k (e2ioe err)) s)
1598     where
1599        e2ioe (IOExcept s) = IOError s
1600        e2ioe other        = IOError (show other)
1601
1602 putChar :: Char -> IO ()
1603 putChar c = nh_stdout >>= \h -> nh_write h c
1604
1605 putStr :: String -> IO ()
1606 putStr s = nh_stdout >>= \h ->
1607            let loop []     = nh_flush h
1608                loop (c:cs) = nh_write h c >> loop cs
1609            in  loop s
1610
1611 putStrLn :: String -> IO ()
1612 putStrLn s = do { putStr s; putChar '\n' }
1613
1614 print :: Show a => a -> IO ()
1615 print = putStrLn . show
1616
1617 getChar :: IO Char
1618 getChar = nh_stdin  >>= \h ->
1619           nh_read h >>= \ci ->
1620           return (primIntToChar ci)
1621
1622 getLine :: IO String
1623 getLine    = do c <- getChar
1624                 if c=='\n' then return ""
1625                            else do cs <- getLine
1626                                    return (c:cs)
1627
1628 getContents :: IO String
1629 getContents = nh_stdin >>= \h -> readfromhandle h
1630
1631 interact  :: (String -> String) -> IO ()
1632 interact f = getContents >>= (putStr . f)
1633
1634 readFile :: FilePath -> IO String
1635 readFile fname
1636    = copy_String_to_cstring fname  >>= \ptr ->
1637      nh_open ptr 0                 >>= \h ->
1638      nh_free ptr                   >>
1639      nh_errno                      >>= \errno ->
1640      if   (isNullAddr h || errno /= 0)
1641      then (ioError.IOError) ("readFile: can't open file " ++ fname)
1642      else readfromhandle h
1643
1644 writeFile :: FilePath -> String -> IO ()
1645 writeFile fname contents
1646    = copy_String_to_cstring fname  >>= \ptr ->
1647      nh_open ptr 1                 >>= \h ->
1648      nh_free ptr                   >>
1649      nh_errno                      >>= \errno ->
1650      if   (isNullAddr h || errno /= 0)
1651      then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1652      else writetohandle fname h contents
1653
1654 appendFile :: FilePath -> String -> IO ()
1655 appendFile fname contents
1656    = copy_String_to_cstring fname  >>= \ptr ->
1657      nh_open ptr 2                 >>= \h ->
1658      nh_free ptr                   >>
1659      nh_errno                      >>= \errno ->
1660      if   (isNullAddr h || errno /= 0)
1661      then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1662      else writetohandle fname h contents
1663
1664
1665 -- raises an exception instead of an error
1666 readIO          :: Read a => String -> IO a
1667 readIO s         = case [x | (x,t) <- reads s, ("","") <- lex t] of
1668                         [x] -> return x
1669                         []  -> ioError (userError "PreludeIO.readIO: no parse")
1670                         _   -> ioError (userError
1671                                        "PreludeIO.readIO: ambiguous parse")
1672
1673 readLn          :: Read a => IO a
1674 readLn           = do l <- getLine
1675                       r <- readIO l
1676                       return r
1677
1678
1679 -- End of Hugs standard prelude ----------------------------------------------
1680
1681 data Exception
1682    = ErrorCall String
1683    | IOExcept  String
1684
1685 instance Show Exception where
1686    showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1687    showsPrec _ (IOExcept s)  = showString ("I/O error: " ++ s)
1688
1689 data IOResult  = IOResult  deriving (Show)
1690
1691 type FILE_STAR = Addr   -- FILE *
1692
1693 foreign import "nHandle" "nh_stdin"    nh_stdin    :: IO FILE_STAR
1694 foreign import "nHandle" "nh_stdout"   nh_stdout   :: IO FILE_STAR
1695 foreign import "nHandle" "nh_stderr"   nh_stderr   :: IO FILE_STAR
1696 foreign import "nHandle" "nh_write"    nh_write    :: FILE_STAR -> Char -> IO ()
1697 foreign import "nHandle" "nh_read"     nh_read     :: FILE_STAR -> IO Int
1698 foreign import "nHandle" "nh_open"     nh_open     :: Addr -> Int -> IO FILE_STAR
1699 foreign import "nHandle" "nh_flush"    nh_flush    :: FILE_STAR -> IO ()
1700 foreign import "nHandle" "nh_close"    nh_close    :: FILE_STAR -> IO ()
1701 foreign import "nHandle" "nh_errno"    nh_errno    :: IO Int
1702
1703 foreign import "nHandle" "nh_malloc"   nh_malloc   :: Int -> IO Addr
1704 foreign import "nHandle" "nh_free"     nh_free     :: Addr -> IO ()
1705 foreign import "nHandle" "nh_store"    nh_store    :: Addr -> Char -> IO ()
1706 foreign import "nHandle" "nh_load"     nh_load     :: Addr -> IO Char
1707 foreign import "nHandle" "nh_getenv"   nh_getenv   :: Addr -> IO Addr
1708 foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int
1709 foreign import "nHandle" "nh_iseof"    nh_iseof    :: FILE_STAR -> IO Int
1710 foreign import "nHandle" "nh_system"   nh_system   :: Addr -> IO Int
1711 foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO ()
1712 foreign import "nHandle" "nh_getPID"   nh_getPID   :: IO Int
1713
1714 foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double
1715 foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double
1716
1717 copy_String_to_cstring :: String -> IO Addr
1718 copy_String_to_cstring s
1719    = nh_malloc (1 + length s) >>= \ptr0 ->
1720      let loop ptr []     = nh_store ptr (chr 0) >> return ptr0
1721          loop ptr (c:cs) = nh_store ptr c       >> loop (incAddr ptr) cs
1722      in
1723          if   isNullAddr ptr0
1724          then error "copy_String_to_cstring: malloc failed"
1725          else loop ptr0 s
1726
1727 copy_cstring_to_String :: Addr -> IO String
1728 copy_cstring_to_String ptr
1729    = nh_load ptr >>= \ci ->
1730      if   ci == '\0'
1731      then return []
1732      else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1733           return (ci : cs)
1734
1735 readfromhandle :: FILE_STAR -> IO String
1736 readfromhandle h
1737    = unsafeInterleaveIO (
1738      nh_read h >>= \ci ->
1739      if ci == -1 {-EOF-} then return "" else
1740      readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1741      )
1742
1743 writetohandle :: String -> FILE_STAR -> String -> IO ()
1744 writetohandle fname h []
1745    = nh_close h                  >>
1746      nh_errno                    >>= \errno ->
1747      if   errno == 0
1748      then return ()
1749      else error ( "writeFile/appendFile: error closing file " ++ fname)
1750 writetohandle fname h (c:cs)
1751    = nh_write h c >> writetohandle fname h cs
1752
1753 primGetRawArgs :: IO [String]
1754 primGetRawArgs
1755    = primGetArgc >>= \argc ->
1756      sequence (map get_one_arg [0 .. argc-1])
1757      where
1758         get_one_arg :: Int -> IO String
1759         get_one_arg argno
1760            = primGetArgv argno >>= \a ->
1761              copy_cstring_to_String a
1762
1763 primGetEnv :: String -> IO String
1764 primGetEnv v
1765    = copy_String_to_cstring v     >>= \ptr ->
1766      nh_getenv ptr                >>= \ptr2 ->
1767      nh_free ptr                  >>
1768      if   isNullAddr ptr2
1769      then ioError (IOError "getEnv failed")
1770      else
1771      copy_cstring_to_String ptr2  >>= \result ->
1772      return result
1773
1774
1775 ------------------------------------------------------------------------------
1776 -- ST ------------------------------------------------------------------------
1777 ------------------------------------------------------------------------------
1778
1779 newtype ST s a = ST (s -> (a,s))
1780 unST (ST a) = a
1781 data RealWorld
1782
1783 runST :: (__forall s . ST s a) -> a
1784 runST m = fst (unST m alpha)
1785    where
1786       alpha = error "runST: entered the RealWorld"
1787
1788 fixST :: (a -> ST s a) -> ST s a
1789 fixST m = ST (\ s ->
1790                 let
1791                    (r,s) = unST (m r) s
1792                 in
1793                    (r,s))
1794
1795 instance Functor (ST s) where
1796    fmap f x  = x >>= (return . f)
1797
1798 instance Monad (ST s) where
1799    m >> k    = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1800    return x  = ST (\s -> (x,s))
1801    m >>= k   = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1802
1803 unsafeInterleaveST :: ST s a -> ST s a
1804 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1805
1806 ------------------------------------------------------------------------------
1807 -- IO ------------------------------------------------------------------------
1808 ------------------------------------------------------------------------------
1809
1810 newtype IO a = IO (RealWorld -> (a,RealWorld))
1811 unIO (IO a) = a
1812
1813 stToIO        :: ST RealWorld a -> IO a
1814 stToIO (ST fn) = IO fn
1815
1816 ioToST        :: IO a -> ST RealWorld a
1817 ioToST (IO fn) = ST fn
1818
1819 unsafePerformIO :: IO a -> a
1820 unsafePerformIO m = fst (unIO m theWorld)
1821    where
1822       theWorld :: RealWorld
1823       theWorld = error "unsafePerformIO: entered the RealWorld"
1824
1825 instance Functor IO where
1826    fmap f x  = x >>= (return . f)
1827
1828 instance Monad IO where
1829    m >> k    = IO (\s -> case unIO m s of { (a,s') -> unIO k s' })
1830    return x  = IO (\s -> (x,s))
1831    m >>= k   = IO (\s -> case unIO m s of { (a,s') -> unIO (k a) s' })
1832
1833 -- Library IO has a global variable which accumulates Handles
1834 -- as they are opened.  We keep here a second global variable
1835 -- into which a cleanup action may be specified.  When evaluation
1836 -- finishes, either normally or as a result of System.exitWith,
1837 -- this cleanup action is run, closing all known-about Handles.
1838 -- Doing it like this means the Prelude does not have to know
1839 -- anything about the grotty details of the Handle implementation.
1840 prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
1841 prelCleanupAfterRunAction = unsafePerformIO (newIORef Nothing)
1842
1843 -- used when Hugs invokes top level function
1844 hugsprimRunIO_toplevel :: IO a -> ()
1845 hugsprimRunIO_toplevel m
1846    = protect 5 (fst (unIO composite_action realWorld))
1847      where
1848         composite_action
1849            = do writeIORef prelCleanupAfterRunAction Nothing
1850                 m
1851                 cleanup_handles <- readIORef prelCleanupAfterRunAction
1852                 case cleanup_handles of
1853                    Nothing -> return ()
1854                    Just xx -> xx
1855
1856         realWorld = error "primRunIO: entered the RealWorld"
1857         protect :: Int -> () -> ()
1858         protect 0 comp
1859            = comp
1860         protect n comp
1861            = primCatch (protect (n-1) comp)
1862                        (\e -> fst (unIO (putStr (show e ++ "\n")) realWorld))
1863
1864 unsafeInterleaveIO :: IO a -> IO a
1865 unsafeInterleaveIO m = IO (\ s -> (fst (unIO m s), s))
1866
1867 ------------------------------------------------------------------------------
1868 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
1869 ------------------------------------------------------------------------------
1870
1871 data Addr
1872
1873 nullAddr     =  primIntToAddr 0
1874 incAddr a    =  primIntToAddr (1 + primAddrToInt a)
1875 isNullAddr a =  0 == primAddrToInt a
1876
1877 instance Eq Addr where
1878   (==)            = primEqAddr
1879   (/=)            = primNeAddr
1880
1881 instance Ord Addr where
1882   (<)             = primLtAddr
1883   (<=)            = primLeAddr
1884   (>=)            = primGeAddr
1885   (>)             = primGtAddr
1886
1887 data Word
1888
1889 instance Eq Word where
1890   (==)            = primEqWord
1891   (/=)            = primNeWord
1892
1893 instance Ord Word where
1894   (<)             = primLtWord
1895   (<=)            = primLeWord
1896   (>=)            = primGeWord
1897   (>)             = primGtWord
1898
1899 data StablePtr a
1900
1901 makeStablePtr   :: a -> IO (StablePtr a)
1902 makeStablePtr    = primMakeStablePtr
1903 deRefStablePtr  :: StablePtr a -> IO a
1904 deRefStablePtr   = primDeRefStablePtr
1905 freeStablePtr   :: StablePtr a -> IO ()
1906 freeStablePtr    = primFreeStablePtr
1907
1908
1909 data PrimArray              a -- immutable arrays with Int indices
1910 data PrimByteArray
1911
1912 data STRef                s a -- mutable variables
1913 data PrimMutableArray     s a -- mutable arrays with Int indices
1914 data PrimMutableByteArray s
1915
1916 newSTRef   :: a -> ST s (STRef s a)
1917 newSTRef    = primNewRef
1918 readSTRef  :: STRef s a -> ST s a
1919 readSTRef   = primReadRef
1920 writeSTRef :: STRef s a -> a -> ST s ()
1921 writeSTRef  = primWriteRef
1922
1923 newtype IORef a = IORef (STRef RealWorld a)
1924 newIORef   :: a -> IO (IORef a)
1925 newIORef   a = stToIO (primNewRef a >>= \ ref ->return (IORef ref))
1926 readIORef  :: IORef a -> IO a
1927 readIORef  (IORef ref) = stToIO (primReadRef ref)
1928 writeIORef :: IORef a -> a -> IO ()
1929 writeIORef  (IORef ref) a = stToIO (primWriteRef ref a)
1930
1931
1932 ------------------------------------------------------------------------------
1933 -- ThreadId, MVar, concurrency stuff -----------------------------------------
1934 ------------------------------------------------------------------------------
1935
1936 data MVar a
1937
1938 newEmptyMVar :: IO (MVar a)
1939 newEmptyMVar = primNewEmptyMVar
1940
1941 putMVar :: MVar a -> a -> IO ()
1942 putMVar = primPutMVar
1943
1944 takeMVar :: MVar a -> IO a
1945 takeMVar m
1946    = IO (\world -> primTakeMVar m cont world)
1947      where
1948         -- cont :: a -> RealWorld -> (a,RealWorld)
1949         -- where 'a' is as in the top-level signature
1950         cont x world = (x,world)
1951
1952         -- the type of the handwritten BCO (threesome) primTakeMVar is
1953         -- primTakeMVar :: MVar a
1954         --                 -> (a -> RealWorld -> (a,RealWorld))
1955         --                 -> RealWorld
1956         --                 -> (a,RealWorld)
1957         --
1958         -- primTakeMVar behaves like this:
1959         --
1960         -- primTakeMVar (MVar# m#) cont world
1961         --    = primTakeMVar_wrk m# cont world
1962         --
1963         -- primTakeMVar_wrk m# cont world
1964         --    = cont (takeMVar# m#) world
1965         --
1966         -- primTakeMVar_wrk has the special property that it is
1967         -- restartable by the scheduler, should the MVar be empty.
1968
1969 newMVar :: a -> IO (MVar a)
1970 newMVar value =
1971     newEmptyMVar        >>= \ mvar ->
1972     putMVar mvar value  >>
1973     return mvar
1974
1975 readMVar :: MVar a -> IO a
1976 readMVar mvar =
1977     takeMVar mvar       >>= \ value ->
1978     putMVar mvar value  >>
1979     return value
1980
1981 swapMVar :: MVar a -> a -> IO a
1982 swapMVar mvar new =
1983     takeMVar mvar       >>= \ old ->
1984     putMVar mvar new    >>
1985     return old
1986
1987 instance Eq (MVar a) where
1988     m1 == m2 = primSameMVar m1 m2
1989
1990
1991 data ThreadId
1992
1993 instance Eq ThreadId where
1994    tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
1995
1996 instance Ord ThreadId where
1997    compare tid1 tid2
1998       = let r = primCmpThreadIds tid1 tid2
1999         in  if r < 0 then LT else if r > 0 then GT else EQ
2000
2001
2002 forkIO :: IO a -> IO ThreadId
2003 -- Simple version; doesn't catch exceptions in computation
2004 -- forkIO computation
2005 --    = primForkIO (unsafePerformIO computation)
2006
2007 forkIO computation
2008    = primForkIO (
2009         primCatch
2010            (unIO computation realWorld `primSeq` ())
2011            (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
2012      )
2013      where
2014         realWorld = error "primForkIO: entered the RealWorld"
2015
2016 trace_quiet s x
2017    = (unsafePerformIO (putStr (s ++ "\n"))) `seq` x
2018
2019 -- showFloat ------------------------------------------------------------------
2020
2021 showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2022 showFFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2023 showGFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2024 showFloat      :: (RealFloat a) => a -> ShowS
2025
2026 showEFloat d x =  showString (formatRealFloat FFExponent d x)
2027 showFFloat d x =  showString (formatRealFloat FFFixed d x)
2028 showGFloat d x =  showString (formatRealFloat FFGeneric d x)
2029 showFloat      =  showGFloat Nothing
2030
2031 -- These are the format types.  This type is not exported.
2032
2033 data FFFormat = FFExponent | FFFixed | FFGeneric
2034
2035 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2036 formatRealFloat fmt decs x = s
2037   where base = 10
2038         s = if isNaN x then
2039                 "NaN"
2040             else if isInfinite x then
2041                 if x < 0 then "-Infinity" else "Infinity"
2042             else if x < 0 || isNegativeZero x then
2043                 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2044             else
2045                 doFmt fmt (floatToDigits (toInteger base) x)
2046         doFmt fmt (is, e) =
2047             let ds = map intToDigit is
2048             in  case fmt of
2049                 FFGeneric ->
2050                     doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2051                           (is, e)
2052                 FFExponent ->
2053                     case decs of
2054                     Nothing ->
2055                         case ds of
2056                          ['0'] -> "0.0e0"
2057                          [d]   -> d : ".0e" ++ show (e-1)
2058                          d:ds  -> d : '.' : ds ++ 'e':show (e-1)
2059                     Just dec ->
2060                         let dec' = max dec 1 in
2061                         case is of
2062                          [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2063                          _ ->
2064                           let (ei, is') = roundTo base (dec'+1) is
2065                               d:ds = map intToDigit
2066                                          (if ei > 0 then init is' else is')
2067                           in d:'.':ds  ++ "e" ++ show (e-1+ei)
2068                 FFFixed ->
2069                     case decs of
2070                     Nothing ->
2071                         let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2072                             f n s "" = f (n-1) (s++"0") ""
2073                             f n s (d:ds) = f (n-1) (s++[d]) ds
2074                             mk0 "" = "0"
2075                             mk0 s = s
2076                         in  f e "" ds
2077                     Just dec ->
2078                         let dec' = max dec 0 in
2079                         if e >= 0 then
2080                             let (ei, is') = roundTo base (dec' + e) is
2081                                 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2082                             in  (if null ls then "0" else ls) ++
2083                                 (if null rs then "" else '.' : rs)
2084                         else
2085                             let (ei, is') = roundTo base dec'
2086                                               (replicate (-e) 0 ++ is)
2087                                 d : ds = map intToDigit
2088                                             (if ei > 0 then is' else 0:is')
2089                             in  d : '.' : ds
2090
2091 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2092 roundTo base d is = case f d is of
2093                 (0, is) -> (0, is)
2094                 (1, is) -> (1, 1 : is)
2095   where b2 = base `div` 2
2096         f n [] = (0, replicate n 0)
2097         f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2098         f d (i:is) =
2099             let (c, ds) = f (d-1) is
2100                 i' = c + i
2101             in  if i' == base then (1, 0:ds) else (0, i':ds)
2102
2103 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2104 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2105 -- This version uses a much slower logarithm estimator.  It should be improved.
2106
2107 -- This function returns a list of digits (Ints in [0..base-1]) and an
2108 -- exponent.
2109
2110 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2111
2112 floatToDigits _ 0 = ([0], 0)
2113 floatToDigits base x =
2114     let (f0, e0) = decodeFloat x
2115         (minExp0, _) = floatRange x
2116         p = floatDigits x
2117         b = floatRadix x
2118         minExp = minExp0 - p            -- the real minimum exponent
2119         -- Haskell requires that f be adjusted so denormalized numbers
2120         -- will have an impossibly low exponent.  Adjust for this.
2121         (f, e) = let n = minExp - e0
2122                  in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2123
2124         (r, s, mUp, mDn) =
2125            if e >= 0 then
2126                let be = b^e in
2127                if f == b^(p-1) then
2128                    (f*be*b*2, 2*b, be*b, b)
2129                else
2130                    (f*be*2, 2, be, be)
2131            else
2132                if e > minExp && f == b^(p-1) then
2133                    (f*b*2, b^(-e+1)*2, b, 1)
2134                else
2135                    (f*2, b^(-e)*2, 1, 1)
2136         k =
2137             let k0 =
2138                     if b == 2 && base == 10 then
2139                          -- logBase 10 2 is slightly bigger than 3/10 so
2140                          -- the following will err on the low side.  Ignoring
2141                          -- the fraction will make it err even more.
2142                          -- Haskell promises that p-1 <= logBase b f < p.
2143                          (p - 1 + e0) * 3 `div` 10
2144                     else
2145                          ceiling ((log (fromInteger (f+1)) +
2146                                   fromInt e * log (fromInteger b)) /
2147                                    log (fromInteger base))
2148                 fixup n =
2149                     if n >= 0 then
2150                         if r + mUp <= expt base n * s then n else fixup (n+1)
2151                     else
2152                         if expt base (-n) * (r + mUp) <= s then n
2153                                                            else fixup (n+1)
2154             in  fixup k0
2155
2156         gen ds rn sN mUpN mDnN =
2157             let (dn, rn') = (rn * base) `divMod` sN
2158                 mUpN' = mUpN * base
2159                 mDnN' = mDnN * base
2160             in  case (rn' < mDnN', rn' + mUpN' > sN) of
2161                 (True,  False) -> dn : ds
2162                 (False, True)  -> dn+1 : ds
2163                 (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2164                 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2165         rds =
2166             if k >= 0 then
2167                 gen [] r (s * expt base k) mUp mDn
2168             else
2169                 let bk = expt base (-k)
2170                 in  gen [] (r * bk) s (mUp * bk) (mDn * bk)
2171     in  (map toInt (reverse rds), k)
2172
2173
2174 -- Exponentiation with a cache for the most common numbers.
2175 minExpt = 0::Int
2176 maxExpt = 1100::Int
2177 expt :: Integer -> Int -> Integer
2178 expt base n =
2179     if base == 2 && n >= minExpt && n <= maxExpt then
2180         expts !! (n-minExpt)
2181     else
2182         base^n
2183
2184 expts :: [Integer]
2185 expts = [2^n | n <- [minExpt .. maxExpt]]
2186