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 (primCharToInt c)
1616
1617 putStr :: String -> IO ()
1618 putStr s = --mapM_ putChar s -- correct, but slow
1619            nh_stdout >>= \h ->
1620            let loop []     = return ()
1621                loop (c:cs) = nh_write h (primCharToInt c) >> loop cs
1622            in  loop s
1623
1624 putStrLn :: String -> IO ()
1625 putStrLn s = do { putStr s; putChar '\n' }
1626
1627 print :: Show a => a -> IO ()
1628 print = putStrLn . show
1629
1630 getChar :: IO Char
1631 getChar = unsafeInterleaveIO (
1632           nh_stdin  >>= \h ->
1633           nh_read h >>= \ci ->
1634           return (primIntToChar ci)
1635           )
1636
1637 getLine :: IO String
1638 getLine    = do c <- getChar
1639                 if c=='\n' then return ""
1640                            else do cs <- getLine
1641                                    return (c:cs)
1642
1643 getContents :: IO String
1644 getContents = nh_stdin >>= \h -> readfromhandle h
1645
1646 interact  :: (String -> String) -> IO ()
1647 interact f = getContents >>= (putStr . f)
1648
1649 readFile :: FilePath -> IO String
1650 readFile fname
1651    = copy_String_to_cstring fname  >>= \ptr ->
1652      nh_open ptr 0                 >>= \h ->
1653      nh_free ptr                   >>
1654      nh_errno                      >>= \errno ->
1655      if   (h == 0 || errno /= 0)
1656      then (ioError.IOError) ("readFile: can't open file " ++ fname)
1657      else readfromhandle h
1658
1659 writeFile :: FilePath -> String -> IO ()
1660 writeFile fname contents
1661    = copy_String_to_cstring fname  >>= \ptr ->
1662      nh_open ptr 1                 >>= \h ->
1663      nh_free ptr                   >>
1664      nh_errno                      >>= \errno ->
1665      if   (h == 0 || errno /= 0)
1666      then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1667      else writetohandle fname h contents
1668
1669 appendFile :: FilePath -> String -> IO ()
1670 appendFile fname contents
1671    = copy_String_to_cstring fname  >>= \ptr ->
1672      nh_open ptr 2                 >>= \h ->
1673      nh_free ptr                   >>
1674      nh_errno                      >>= \errno ->
1675      if   (h == 0 || errno /= 0)
1676      then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1677      else writetohandle fname h contents
1678
1679
1680 -- raises an exception instead of an error
1681 readIO          :: Read a => String -> IO a
1682 readIO s         = case [x | (x,t) <- reads s, ("","") <- lex t] of
1683                         [x] -> return x
1684                         []  -> ioError (userError "PreludeIO.readIO: no parse")
1685                         _   -> ioError (userError
1686                                        "PreludeIO.readIO: ambiguous parse")
1687
1688 readLn          :: Read a => IO a
1689 readLn           = do l <- getLine
1690                       r <- readIO l
1691                       return r
1692
1693
1694 -- End of Hugs standard prelude ----------------------------------------------
1695
1696 data Exception
1697    = ErrorCall String
1698    | IOExcept  String
1699
1700 instance Show Exception where
1701    showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1702    showsPrec _ (IOExcept s)  = showString ("I/O error: " ++ s)
1703
1704 data IOResult  = IOResult  deriving (Show)
1705
1706 type FILE_STAR = Int   -- FILE *
1707
1708 foreign import "nHandle" "nh_stdin"  nh_stdin  :: IO FILE_STAR
1709 foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
1710 foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
1711 foreign import "nHandle" "nh_write"  nh_write  :: FILE_STAR -> Int -> IO ()
1712 foreign import "nHandle" "nh_read"   nh_read   :: FILE_STAR -> IO Int
1713 foreign import "nHandle" "nh_open"   nh_open   :: Addr -> Int -> IO FILE_STAR
1714 foreign import "nHandle" "nh_flush"  nh_flush  :: FILE_STAR -> IO ()
1715 foreign import "nHandle" "nh_close"  nh_close  :: FILE_STAR -> IO ()
1716 foreign import "nHandle" "nh_errno"  nh_errno  :: IO Int
1717
1718 foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
1719 foreign import "nHandle" "nh_free"   nh_free   :: Addr -> IO ()
1720 foreign import "nHandle" "nh_store"  nh_store  :: Addr -> Int -> IO ()
1721 foreign import "nHandle" "nh_load"   nh_load   :: Addr -> IO Int
1722
1723 --foreign import "nHandle" "nh_argc"   nh_argc   :: IO Int
1724 --foreign import "nHandle" "nh_argvb"  nh_argvb  :: Int -> Int -> IO Int
1725 foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
1726
1727 copy_String_to_cstring :: String -> IO Addr
1728 copy_String_to_cstring s
1729    = nh_malloc (1 + length s) >>= \ptr0 ->
1730      let loop ptr []     = nh_store ptr 0 >> return ptr0
1731          loop ptr (c:cs) = nh_store ptr (primCharToInt c) >> loop (incAddr ptr) cs
1732      in
1733          if   isNullAddr ptr0
1734          then error "copy_String_to_cstring: malloc failed"
1735          else loop ptr0 s
1736
1737 copy_cstring_to_String :: Addr -> IO String
1738 copy_cstring_to_String ptr
1739    = nh_load ptr >>= \ci ->
1740      if   ci == 0
1741      then return []
1742      else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1743           return ((primIntToChar ci) : cs)
1744
1745 readfromhandle :: FILE_STAR -> IO String
1746 readfromhandle h
1747    = unsafeInterleaveIO (
1748      nh_read h >>= \ci ->
1749      if ci == -1 {-EOF-} then return "" else
1750      readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1751      )
1752
1753 writetohandle :: String -> FILE_STAR -> String -> IO ()
1754 writetohandle fname h []
1755    = nh_close h                  >>
1756      nh_errno                    >>= \errno ->
1757      if   errno == 0
1758      then return ()
1759      else error ( "writeFile/appendFile: error closing file " ++ fname)
1760 writetohandle fname h (c:cs)
1761    = nh_write h (primCharToInt c) >>
1762      writetohandle fname h cs
1763
1764 primGetRawArgs :: IO [String]
1765 primGetRawArgs
1766    = primGetArgc >>= \argc ->
1767      accumulate (map get_one_arg [0 .. argc-1])
1768      where
1769         get_one_arg :: Int -> IO String
1770         get_one_arg argno
1771            = primGetArgv argno >>= \a ->
1772              copy_cstring_to_String a
1773
1774 primGetEnv :: String -> IO String
1775 primGetEnv v
1776    = copy_String_to_cstring v     >>= \ptr ->
1777      nh_getenv ptr                >>= \ptr2 ->
1778      nh_free ptr                  >>
1779      if   isNullAddr ptr2
1780      then return []
1781      else
1782      copy_cstring_to_String ptr2  >>= \result ->
1783      return result
1784
1785
1786 ------------------------------------------------------------------------------
1787 -- ST, IO --------------------------------------------------------------------
1788 ------------------------------------------------------------------------------
1789
1790 newtype ST s a = ST (s -> (a,s))
1791
1792 data RealWorld
1793 type IO a = ST RealWorld a
1794
1795
1796 --primRunST :: (forall s. ST s a) -> a
1797 primRunST :: ST RealWorld a -> a
1798 primRunST m = fst (unST m theWorld)
1799    where
1800       theWorld :: RealWorld
1801       theWorld = error "primRunST: entered the RealWorld"
1802
1803 unST (ST a) = a
1804
1805 instance Functor (ST s) where
1806    fmap f x  = x >>= (return . f)
1807
1808 instance Monad (ST s) where
1809    m >> k    = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1810    return x  = ST (\s -> (x,s))
1811    m >>= k   = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1812
1813
1814 -- used when Hugs invokes top level function
1815 primRunIO :: IO () -> ()
1816 primRunIO m
1817    = protect (fst (unST m realWorld))
1818      where
1819         realWorld = error "primRunIO: entered the RealWorld"
1820         protect :: () -> ()
1821         protect comp
1822            = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1823
1824 trace :: String -> a -> a
1825 trace s x
1826    = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x
1827
1828 unsafeInterleaveST :: ST s a -> ST s a
1829 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1830
1831 unsafeInterleaveIO :: IO a -> IO a
1832 unsafeInterleaveIO = unsafeInterleaveST
1833
1834
1835 ------------------------------------------------------------------------------
1836 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
1837 ------------------------------------------------------------------------------
1838
1839 data Addr
1840
1841 nullAddr     =  primIntToAddr 0
1842 incAddr a    =  primIntToAddr (1 + primAddrToInt a)
1843 isNullAddr a =  0 == primAddrToInt a
1844
1845 instance Eq Addr where
1846   (==)            = primEqAddr
1847   (/=)            = primNeAddr
1848
1849 instance Ord Addr where
1850   (<)             = primLtAddr
1851   (<=)            = primLeAddr
1852   (>=)            = primGeAddr
1853   (>)             = primGtAddr
1854
1855
1856 data Word
1857
1858 instance Eq Word where
1859   (==)            = primEqWord
1860   (/=)            = primNeWord
1861
1862 instance Ord Word where
1863   (<)             = primLtWord
1864   (<=)            = primLeWord
1865   (>=)            = primGeWord
1866   (>)             = primGtWord
1867
1868
1869 data StablePtr a
1870
1871 makeStablePtr   :: a -> IO (StablePtr a)
1872 makeStablePtr    = primMakeStablePtr
1873 deRefStablePtr  :: StablePtr a -> IO a
1874 deRefStablePtr   = primDeRefStablePtr
1875 freeStablePtr   :: StablePtr a -> IO ()
1876 freeStablePtr    = primFreeStablePtr
1877
1878
1879 data PrimArray              a -- immutable arrays with Int indices
1880 data PrimByteArray
1881
1882 data Ref                  s a -- mutable variables
1883 data PrimMutableArray     s a -- mutable arrays with Int indices
1884 data PrimMutableByteArray s
1885
1886
1887
1888 -- showFloat ------------------------------------------------------------------
1889
1890 showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
1891 showFFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
1892 showGFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
1893 showFloat      :: (RealFloat a) => a -> ShowS
1894
1895 showEFloat d x =  showString (formatRealFloat FFExponent d x)
1896 showFFloat d x =  showString (formatRealFloat FFFixed d x)
1897 showGFloat d x =  showString (formatRealFloat FFGeneric d x)
1898 showFloat      =  showGFloat Nothing
1899
1900 -- These are the format types.  This type is not exported.
1901
1902 data FFFormat = FFExponent | FFFixed | FFGeneric
1903
1904 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
1905 formatRealFloat fmt decs x = s
1906   where base = 10
1907         s = if isNaN x then
1908                 "NaN"
1909             else if isInfinite x then
1910                 if x < 0 then "-Infinity" else "Infinity"
1911             else if x < 0 || isNegativeZero x then
1912                 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
1913             else
1914                 doFmt fmt (floatToDigits (toInteger base) x)
1915         doFmt fmt (is, e) =
1916             let ds = map intToDigit is
1917             in  case fmt of
1918                 FFGeneric ->
1919                     doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
1920                           (is, e)
1921                 FFExponent ->
1922                     case decs of
1923                     Nothing ->
1924                         case ds of
1925                          ['0'] -> "0.0e0"
1926                          [d]   -> d : ".0e" ++ show (e-1)
1927                          d:ds  -> d : '.' : ds ++ 'e':show (e-1)
1928                     Just dec ->
1929                         let dec' = max dec 1 in
1930                         case is of
1931                          [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
1932                          _ ->
1933                           let (ei, is') = roundTo base (dec'+1) is
1934                               d:ds = map intToDigit
1935                                          (if ei > 0 then init is' else is')
1936                           in d:'.':ds  ++ "e" ++ show (e-1+ei)
1937                 FFFixed ->
1938                     case decs of
1939                     Nothing ->
1940                         let f 0 s ds = mk0 s ++ "." ++ mk0 ds
1941                             f n s "" = f (n-1) (s++"0") ""
1942                             f n s (d:ds) = f (n-1) (s++[d]) ds
1943                             mk0 "" = "0"
1944                             mk0 s = s
1945                         in  f e "" ds
1946                     Just dec ->
1947                         let dec' = max dec 0 in
1948                         if e >= 0 then
1949                             let (ei, is') = roundTo base (dec' + e) is
1950                                 (ls, rs) = splitAt (e+ei) (map intToDigit is')
1951                             in  (if null ls then "0" else ls) ++
1952                                 (if null rs then "" else '.' : rs)
1953                         else
1954                             let (ei, is') = roundTo base dec'
1955                                               (replicate (-e) 0 ++ is)
1956                                 d : ds = map intToDigit
1957                                             (if ei > 0 then is' else 0:is')
1958                             in  d : '.' : ds
1959
1960 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
1961 roundTo base d is = case f d is of
1962                 (0, is) -> (0, is)
1963                 (1, is) -> (1, 1 : is)
1964   where b2 = base `div` 2
1965         f n [] = (0, replicate n 0)
1966         f 0 (i:_) = (if i >= b2 then 1 else 0, [])
1967         f d (i:is) =
1968             let (c, ds) = f (d-1) is
1969                 i' = c + i
1970             in  if i' == base then (1, 0:ds) else (0, i':ds)
1971
1972 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
1973 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
1974 -- This version uses a much slower logarithm estimator.  It should be improved.
1975
1976 -- This function returns a list of digits (Ints in [0..base-1]) and an
1977 -- exponent.
1978
1979 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
1980
1981 floatToDigits _ 0 = ([0], 0)
1982 floatToDigits base x =
1983     let (f0, e0) = decodeFloat x
1984         (minExp0, _) = floatRange x
1985         p = floatDigits x
1986         b = floatRadix x
1987         minExp = minExp0 - p            -- the real minimum exponent
1988         -- Haskell requires that f be adjusted so denormalized numbers
1989         -- will have an impossibly low exponent.  Adjust for this.
1990         (f, e) = let n = minExp - e0
1991                  in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
1992
1993         (r, s, mUp, mDn) =
1994            if e >= 0 then
1995                let be = b^e in
1996                if f == b^(p-1) then
1997                    (f*be*b*2, 2*b, be*b, b)
1998                else
1999                    (f*be*2, 2, be, be)
2000            else
2001                if e > minExp && f == b^(p-1) then
2002                    (f*b*2, b^(-e+1)*2, b, 1)
2003                else
2004                    (f*2, b^(-e)*2, 1, 1)
2005         k =
2006             let k0 =
2007                     if b == 2 && base == 10 then
2008                          -- logBase 10 2 is slightly bigger than 3/10 so
2009                          -- the following will err on the low side.  Ignoring
2010                          -- the fraction will make it err even more.
2011                          -- Haskell promises that p-1 <= logBase b f < p.
2012                          (p - 1 + e0) * 3 `div` 10
2013                     else
2014                          ceiling ((log (fromInteger (f+1)) +
2015                                   fromInt e * log (fromInteger b)) /
2016                                    log (fromInteger base))
2017                 fixup n =
2018                     if n >= 0 then
2019                         if r + mUp <= expt base n * s then n else fixup (n+1)
2020                     else
2021                         if expt base (-n) * (r + mUp) <= s then n
2022                                                            else fixup (n+1)
2023             in  fixup k0
2024
2025         gen ds rn sN mUpN mDnN =
2026             let (dn, rn') = (rn * base) `divMod` sN
2027                 mUpN' = mUpN * base
2028                 mDnN' = mDnN * base
2029             in  case (rn' < mDnN', rn' + mUpN' > sN) of
2030                 (True,  False) -> dn : ds
2031                 (False, True)  -> dn+1 : ds
2032                 (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2033                 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2034         rds =
2035             if k >= 0 then
2036                 gen [] r (s * expt base k) mUp mDn
2037             else
2038                 let bk = expt base (-k)
2039                 in  gen [] (r * bk) s (mUp * bk) (mDn * bk)
2040     in  (map toInt (reverse rds), k)
2041
2042
2043 -- Exponentiation with a cache for the most common numbers.
2044 minExpt = 0::Int
2045 maxExpt = 1100::Int
2046 expt :: Integer -> Int -> Integer
2047 expt base n =
2048     if base == 2 && n >= minExpt && n <= maxExpt then
2049         expts !! (n-minExpt)
2050     else
2051         base^n
2052
2053 expts :: [Integer]
2054 expts = [2^n | n <- [minExpt .. maxExpt]]
2055