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