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