ghc/interpreter/lib/Prelude.hs

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