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