ghc/lib/hugs/Prelude.hs

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