ghc/interpreter/lib/Prelude.hs

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