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), fromDouble,
  88     Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
  89              asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
  90     RealFrac(properFraction, truncate, round, ceiling, floor),
  91     RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
  92               encodeFloat, exponent, significand, scaleFloat, isNaN,
  93               isInfinite, isDenormalized, isIEEE, isNegativeZero),
  94     Monad((>>=), (>>), return, fail),
  95     Functor(fmap),
  96     mapM, mapM_, sequence, sequence_, (=<<),
  97     maybe, either,
  98     (&&), (||), not, otherwise,
  99     subtract, even, odd, gcd, lcm, (^), (^^),
 100     fromIntegral, realToFrac, atan2,
 101     fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
 102     asTypeOf, error, undefined,
 103     seq, ($!)
 104
 105     , MVar, newEmptyMVar, newMVar, putMVar, takeMVar, readMVar, swapMVar
 106     , ThreadId, forkIO
 107     ,trace
 108
 109     , STRef, newSTRef, readSTRef, writeSTRef
 110     , IORef, newIORef, readIORef, writeIORef
 111
 112     -- This lot really shouldn't be exported, but are needed to
 113     -- implement various libs.
 114     ,hugsprimCompAux,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     nh_filesize, nh_iseof, nh_system, nh_exitwith, nh_getPID,
 121     nh_getCPUtime, nh_getCPUprec, prelCleanupAfterRunAction,
 122
 123     Word,
 124     primGtWord, primGeWord, primEqWord, primNeWord,
 125     primLtWord, primLeWord, primMinWord, primMaxWord,
 126     primPlusWord, primMinusWord, primTimesWord, primQuotWord,
 127     primRemWord, primQuotRemWord, primNegateWord, primAndWord,
 128     primOrWord, primXorWord, primNotWord, primShiftLWord,
 129     primShiftRAWord, primShiftRLWord, primIntToWord, primWordToInt,
 130
 131     primAndInt, primOrInt, primXorInt, primNotInt,
 132     primShiftLInt, primShiftRAInt,  primShiftRLInt,
 133
 134     primAddrToInt, primIntToAddr,
 135
 136     primDoubleToFloat, primFloatToDouble,
 137
 138   ) where
 139
 140 -- Standard value bindings {Prelude} ----------------------------------------
 141
 142 infixr 9  .
 143 infixl 9  !!
 144 infixr 8  ^, ^^, **
 145 infixl 7  *, /, `quot`, `rem`, `div`, `mod`, :%, %
 146 infixl 6  +, -
 147 --infixr 5  :    -- this fixity declaration is hard-wired into Hugs
 148 infixr 5  ++
 149 infix  4  ==, /=, <, <=, >=, >, `elem`, `notElem`
 150 infixr 3  &&
 151 infixr 2  ||
 152 infixl 1  >>, >>=
 153 infixr 1  =<<
 154 infixr 0  $, $!, `seq`
 155
 156 -- Equality and Ordered classes ---------------------------------------------
 157
 158 class Eq a where
 159     (==), (/=) :: a -> a -> Bool
 160
 161     -- Minimal complete definition: (==) or (/=)
 162     x == y      = not (x/=y)
 163     x /= y      = not (x==y)
 164
 165 class (Eq a) => Ord a where
 166     compare                :: a -> a -> Ordering
 167     (<), (<=), (>=), (>)   :: a -> a -> Bool
 168     max, min               :: a -> a -> a
 169
 170     -- Minimal complete definition: (<=) or compare
 171     -- using compare can be more efficient for complex types
 172     compare x y | x==y      = EQ
 173                 | x<=y      = LT
 174                 | otherwise = GT
 175
 176     x <= y                  = compare x y /= GT
 177     x <  y                  = compare x y == LT
 178     x >= y                  = compare x y /= LT
 179     x >  y                  = compare x y == GT
 180
 181     max x y   | x >= y      = x
 182               | otherwise   = y
 183     min x y   | x <= y      = x
 184               | otherwise   = y
 185
 186 class Bounded a where
 187     minBound, maxBound :: a
 188     -- Minimal complete definition: All
 189
 190 -- Numeric classes ----------------------------------------------------------
 191
 192 class (Eq a, Show a) => Num a where
 193     (+), (-), (*)  :: a -> a -> a
 194     negate         :: a -> a
 195     abs, signum    :: a -> a
 196     fromInteger    :: Integer -> a
 197     fromInt        :: Int -> a
 198
 199     -- Minimal complete definition: All, except negate or (-)
 200     x - y           = x + negate y
 201     fromInt         = fromIntegral
 202     negate x        = 0 - x
 203
 204 class (Num a, Ord a) => Real a where
 205     toRational     :: a -> Rational
 206
 207 class (Real a, Enum a) => Integral a where
 208     quot, rem, div, mod :: a -> a -> a
 209     quotRem, divMod     :: a -> a -> (a,a)
 210     even, odd           :: a -> Bool
 211     toInteger           :: a -> Integer
 212     toInt               :: a -> Int
 213
 214     -- Minimal complete definition: quotRem and toInteger
 215     n `quot` d           = q where (q,r) = quotRem n d
 216     n `rem` d            = r where (q,r) = quotRem n d
 217     n `div` d            = q where (q,r) = divMod n d
 218     n `mod` d            = r where (q,r) = divMod n d
 219     divMod n d           = if signum r == - signum d then (q-1, r+d) else qr
 220                            where qr@(q,r) = quotRem n d
 221     even n               = n `rem` 2 == 0
 222     odd                  = not . even
 223     toInt                = toInt . toInteger
 224
 225 class (Num a) => Fractional a where
 226     (/)          :: a -> a -> a
 227     recip        :: a -> a
 228     fromRational :: Rational -> a
 229
 230     -- Minimal complete definition: fromRational and ((/) or recip)
 231     recip x       = 1 / x
 232     x / y         = x * recip y
 233
 234 fromDouble :: Fractional a => Double -> a
 235 fromDouble n = fromRational (toRational n)
 236
 237 class (Fractional a) => Floating a where
 238     pi                  :: a
 239     exp, log, sqrt      :: a -> a
 240     (**), logBase       :: a -> a -> a
 241     sin, cos, tan       :: a -> a
 242     asin, acos, atan    :: a -> a
 243     sinh, cosh, tanh    :: a -> a
 244     asinh, acosh, atanh :: a -> a
 245
 246     -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
 247     --                              asinh, acosh, atanh
 248     x ** y               = exp (log x * y)
 249     logBase x y          = log y / log x
 250     sqrt x               = x ** 0.5
 251     tan x                = sin x / cos x
 252     sinh x               = (exp x - exp (-x)) / 2
 253     cosh x               = (exp x + exp (-x)) / 2
 254     tanh x               = sinh x / cosh x
 255     asinh x              = log (x + sqrt (x*x + 1))
 256     acosh x              = log (x + sqrt (x*x - 1))
 257     atanh x              = (log (1 + x) - log (1 - x)) / 2
 258
 259 class (Real a, Fractional a) => RealFrac a where
 260     properFraction   :: (Integral b) => a -> (b,a)
 261     truncate, round  :: (Integral b) => a -> b
 262     ceiling, floor   :: (Integral b) => a -> b
 263
 264     -- Minimal complete definition: properFraction
 265     truncate x        = m where (m,_) = properFraction x
 266
 267     round x           = let (n,r) = properFraction x
 268                             m     = if r < 0 then n - 1 else n + 1
 269                         in case signum (abs r - 0.5) of
 270                             -1 -> n
 271                             0  -> if even n then n else m
 272                             1  -> m
 273
 274     ceiling x         = if r > 0 then n + 1 else n
 275                         where (n,r) = properFraction x
 276
 277     floor x           = if r < 0 then n - 1 else n
 278                         where (n,r) = properFraction x
 279
 280 class (RealFrac a, Floating a) => RealFloat a where
 281     floatRadix       :: a -> Integer
 282     floatDigits      :: a -> Int
 283     floatRange       :: a -> (Int,Int)
 284     decodeFloat      :: a -> (Integer,Int)
 285     encodeFloat      :: Integer -> Int -> a
 286     exponent         :: a -> Int
 287     significand      :: a -> a
 288     scaleFloat       :: Int -> a -> a
 289     isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
 290                      :: a -> Bool
 291     atan2            :: a -> a -> a
 292
 293     -- Minimal complete definition: All, except exponent, signficand,
 294     --                              scaleFloat, atan2
 295     exponent x        = if m==0 then 0 else n + floatDigits x
 296                         where (m,n) = decodeFloat x
 297     significand x     = encodeFloat m (- floatDigits x)
 298                         where (m,_) = decodeFloat x
 299     scaleFloat k x    = encodeFloat m (n+k)
 300                         where (m,n) = decodeFloat x
 301     atan2 y x
 302       | x>0           = atan (y/x)
 303       | x==0 && y>0   = pi/2
 304       | x<0 && y>0    = pi + atan (y/x)
 305       | (x<=0 && y<0) ||
 306         (x<0 && isNegativeZero y) ||
 307         (isNegativeZero x && isNegativeZero y)
 308                       = - atan2 (-y) x
 309       | y==0 && (x<0 || isNegativeZero x)
 310                       = pi    -- must be after the previous test on zero y
 311       | x==0 && y==0  = y     -- must be after the other double zero tests
 312       | otherwise     = x + y -- x or y is a NaN, return a NaN (via +)
 313
 314 -- Numeric functions --------------------------------------------------------
 315
 316 subtract       :: Num a => a -> a -> a
 317 subtract        = flip (-)
 318
 319 gcd            :: Integral a => a -> a -> a
 320 gcd 0 0         = error "Prelude.gcd: gcd 0 0 is undefined"
 321 gcd x y         = gcd' (abs x) (abs y)
 322                   where gcd' x 0 = x
 323                         gcd' x y = gcd' y (x `rem` y)
 324
 325 lcm            :: (Integral a) => a -> a -> a
 326 lcm _ 0         = 0
 327 lcm 0 _         = 0
 328 lcm x y         = abs ((x `quot` gcd x y) * y)
 329
 330 (^)            :: (Num a, Integral b) => a -> b -> a
 331 x ^ 0           = 1
 332 x ^ n  | n > 0  = f x (n-1) x
 333                   where f _ 0 y = y
 334                         f x n y = g x n where
 335                                   g x n | even n    = g (x*x) (n`quot`2)
 336                                         | otherwise = f x (n-1) (x*y)
 337 _ ^ _           = error "Prelude.^: negative exponent"
 338
 339 (^^)           :: (Fractional a, Integral b) => a -> b -> a
 340 x ^^ n          = if n >= 0 then x ^ n else recip (x^(-n))
 341
 342 fromIntegral   :: (Integral a, Num b) => a -> b
 343 fromIntegral    = fromInteger . toInteger
 344
 345 realToFrac     :: (Real a, Fractional b) => a -> b
 346 realToFrac      = fromRational . toRational
 347
 348 -- Index and Enumeration classes --------------------------------------------
 349
 350 class (Ord a) => Ix a where
 351     range                :: (a,a) -> [a]
 352     index                :: (a,a) -> a -> Int
 353     inRange              :: (a,a) -> a -> Bool
 354     rangeSize            :: (a,a) -> Int
 355
 356     rangeSize r@(l,u)
 357              | l > u      = 0
 358              | otherwise  = index r u + 1
 359
 360 class Enum a where
 361     succ, pred           :: a -> a
 362     toEnum               :: Int -> a
 363     fromEnum             :: a -> Int
 364     enumFrom             :: a -> [a]              -- [n..]
 365     enumFromThen         :: a -> a -> [a]         -- [n,m..]
 366     enumFromTo           :: a -> a -> [a]         -- [n..m]
 367     enumFromThenTo       :: a -> a -> a -> [a]    -- [n,n'..m]
 368
 369     -- Minimal complete definition: toEnum, fromEnum
 370     succ                  = toEnum . (1+)       . fromEnum
 371     pred                  = toEnum . subtract 1 . fromEnum
 372     enumFrom x            = map toEnum [ fromEnum x .. ]
 373     enumFromTo x y        = map toEnum [ fromEnum x .. fromEnum y ]
 374     enumFromThen 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) = hugsprimCompAux 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
 854 instance Fractional Double where
 855     (/)          = primDivideDouble
 856     fromRational = rationalToRealFloat
 857
 858 rationalToRealFloat x = x'
 859  where x'    = f e
 860        f e   = if e' == e then y else f e'
 861                where y      = encodeFloat (round (x * (1%b)^^e)) e
 862                      (_,e') = decodeFloat y
 863        (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
 864                              / fromInteger (denominator x))
 865        b     = floatRadix x'
 866
 867 instance Floating Float where
 868     pi    = 3.14159265358979323846
 869     exp   = primExpFloat
 870     log   = primLogFloat
 871     sqrt  = primSqrtFloat
 872     sin   = primSinFloat
 873     cos   = primCosFloat
 874     tan   = primTanFloat
 875     asin  = primAsinFloat
 876     acos  = primAcosFloat
 877     atan  = primAtanFloat
 878
 879 instance Floating Double where
 880     pi    = 3.14159265358979323846
 881     exp   = primExpDouble
 882     log   = primLogDouble
 883     sqrt  = primSqrtDouble
 884     sin   = primSinDouble
 885     cos   = primCosDouble
 886     tan   = primTanDouble
 887     asin  = primAsinDouble
 888     acos  = primAcosDouble
 889     atan  = primAtanDouble
 890
 891 instance RealFrac Float where
 892     properFraction = floatProperFraction
 893
 894 instance RealFrac Double where
 895     properFraction = floatProperFraction
 896
 897 floatProperFraction x
 898    | n >= 0      = (fromInteger m * fromInteger b ^ n, 0)
 899    | otherwise   = (fromInteger w, encodeFloat r n)
 900                    where (m,n) = decodeFloat x
 901                          b     = floatRadix x
 902                          (w,r) = quotRem m (b^(-n))
 903
 904 instance RealFloat Float where
 905     floatRadix  _ = toInteger primRadixFloat
 906     floatDigits _ = primDigitsFloat
 907     floatRange  _ = (primMinExpFloat,primMaxExpFloat)
 908     encodeFloat   = primEncodeFloatZ
 909     decodeFloat   = primDecodeFloatZ
 910     isNaN         = primIsNaNFloat
 911     isInfinite    = primIsInfiniteFloat
 912     isDenormalized= primIsDenormalizedFloat
 913     isNegativeZero= primIsNegativeZeroFloat
 914     isIEEE        = const primIsIEEEFloat
 915
 916 instance RealFloat Double where
 917     floatRadix  _ = toInteger primRadixDouble
 918     floatDigits _ = primDigitsDouble
 919     floatRange  _ = (primMinExpDouble,primMaxExpDouble)
 920     encodeFloat   = primEncodeDoubleZ
 921     decodeFloat   = primDecodeDoubleZ
 922     isNaN         = primIsNaNDouble
 923     isInfinite    = primIsInfiniteDouble
 924     isDenormalized= primIsDenormalizedDouble
 925     isNegativeZero= primIsNegativeZeroDouble
 926     isIEEE        = const primIsIEEEDouble
 927
 928 instance Enum Float where
 929     toEnum                = primIntToFloat
 930     fromEnum              = truncate
 931     enumFrom              = numericEnumFrom
 932     enumFromThen          = numericEnumFromThen
 933     enumFromTo n m        = numericEnumFromTo n (m+1/2)
 934     enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
 935
 936 instance Enum Double where
 937     toEnum                = primIntToDouble
 938     fromEnum              = truncate
 939     enumFrom              = numericEnumFrom
 940     enumFromThen          = numericEnumFromThen
 941     enumFromTo n m        = numericEnumFromTo n (m+1/2)
 942     enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
 943
 944 instance Read Float where
 945     readsPrec p = readSigned readFloat
 946
 947 instance Show Float where
 948     showsPrec p = showSigned showFloat p
 949
 950 instance Read Double where
 951     readsPrec p = readSigned readFloat
 952
 953 instance Show Double where
 954     showsPrec p = showSigned showFloat p
 955
 956
 957 -- Some standard functions --------------------------------------------------
 958
 959 fst            :: (a,b) -> a
 960 fst (x,_)       = x
 961
 962 snd            :: (a,b) -> b
 963 snd (_,y)       = y
 964
 965 curry          :: ((a,b) -> c) -> (a -> b -> c)
 966 curry f x y     = f (x,y)
 967
 968 uncurry        :: (a -> b -> c) -> ((a,b) -> c)
 969 uncurry f p     = f (fst p) (snd p)
 970
 971 id             :: a -> a
 972 id    x         = x
 973
 974 const          :: a -> b -> a
 975 const k _       = k
 976
 977 (.)            :: (b -> c) -> (a -> b) -> (a -> c)
 978 (f . g) x       = f (g x)
 979
 980 flip           :: (a -> b -> c) -> b -> a -> c
 981 flip f x y      = f y x
 982
 983 ($)            :: (a -> b) -> a -> b
 984 f $ x           = f x
 985
 986 until          :: (a -> Bool) -> (a -> a) -> a -> a
 987 until p f x     = if p x then x else until p f (f x)
 988
 989 asTypeOf       :: a -> a -> a
 990 asTypeOf        = const
 991
 992 error          :: String -> a
 993 error msg      =  primRaise (ErrorCall msg)
 994
 995 undefined         :: a
 996 undefined | False = undefined
 997
 998 -- Standard functions on rational numbers {PreludeRatio} --------------------
 999
1000 data Integral a => Ratio a = a :% a deriving (Eq)
1001 type Rational              = Ratio Integer
1002
1003 (%)                       :: Integral a => a -> a -> Ratio a
1004 x % y                      = reduce (x * signum y) (abs y)
1005
1006 reduce                    :: Integral a => a -> a -> Ratio a
1007 reduce x y | y == 0        = error "Ratio.%: zero denominator"
1008            | otherwise     = (x `quot` d) :% (y `quot` d)
1009                              where d = gcd x y
1010
1011 numerator, denominator    :: Integral a => Ratio a -> a
1012 numerator (x :% y)         = x
1013 denominator (x :% y)       = y
1014
1015 instance Integral a => Ord (Ratio a) where
1016     compare (x:%y) (x':%y') = compare (x*y') (x'*y)
1017
1018 instance Integral a => Num (Ratio a) where
1019     (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
1020     (x:%y) * (x':%y') = reduce (x*x') (y*y')
1021     negate (x :% y)   = negate x :% y
1022     abs (x :% y)      = abs x :% y
1023     signum (x :% y)   = signum x :% 1
1024     fromInteger x     = fromInteger x :% 1
1025     fromInt           = intToRatio
1026
1027 -- Hugs optimises code of the form fromRational (intToRatio x)
1028 intToRatio :: Integral a => Int -> Ratio a
1029 intToRatio x = fromInt x :% 1
1030
1031 instance Integral a => Real (Ratio a) where
1032     toRational (x:%y) = toInteger x :% toInteger y
1033
1034 instance Integral a => Fractional (Ratio a) where
1035     (x:%y) / (x':%y')   = (x*y') % (y*x')
1036     recip (x:%y)        = if x < 0 then (-y) :% (-x) else y :% x
1037     fromRational (x:%y) = fromInteger x :% fromInteger y
1038
1039 -- Hugs optimises code of the form fromRational (doubleToRatio x)
1040 doubleToRatio :: Integral a => Double -> Ratio a
1041 doubleToRatio x
1042             | n>=0      = (fromInteger m * fromInteger b ^ n) % 1
1043             | otherwise = fromInteger m % (fromInteger b ^ (-n))
1044                           where (m,n) = decodeFloat x
1045                                 b     = floatRadix x
1046
1047 instance Integral a => RealFrac (Ratio a) where
1048     properFraction (x:%y) = (fromIntegral q, r:%y)
1049                             where (q,r) = quotRem x y
1050
1051 instance Integral a => Enum (Ratio a) where
1052     toEnum       = fromInt
1053     fromEnum     = truncate
1054     enumFrom     = numericEnumFrom
1055     enumFromThen = numericEnumFromThen
1056
1057 instance (Read a, Integral a) => Read (Ratio a) where
1058     readsPrec p = readParen (p > 7)
1059                             (\r -> [(x%y,u) | (x,s)   <- reads r,
1060                                               ("%",t) <- lex s,
1061                                               (y,u)   <- reads t ])
1062
1063 instance Integral a => Show (Ratio a) where
1064     showsPrec p (x:%y) = showParen (p > 7)
1065                              (shows x . showString " % " . shows y)
1066
1067 approxRational      :: RealFrac a => a -> a -> Rational
1068 approxRational x eps = simplest (x-eps) (x+eps)
1069  where simplest x y | y < x     = simplest y x
1070                     | x == y    = xr
1071                     | x > 0     = simplest' n d n' d'
1072                     | y < 0     = - simplest' (-n') d' (-n) d
1073                     | otherwise = 0 :% 1
1074                                   where xr@(n:%d) = toRational x
1075                                         (n':%d')  = toRational y
1076        simplest' n d n' d'        -- assumes 0 < n%d < n'%d'
1077                     | r == 0    = q :% 1
1078                     | q /= q'   = (q+1) :% 1
1079                     | otherwise = (q*n''+d'') :% n''
1080                                   where (q,r)      = quotRem n d
1081                                         (q',r')    = quotRem n' d'
1082                                         (n'':%d'') = simplest' d' r' d r
1083
1084 -- Standard list functions {PreludeList} ------------------------------------
1085
1086 head             :: [a] -> a
1087 head (x:_)        = x
1088
1089 last             :: [a] -> a
1090 last [x]          = x
1091 last (_:xs)       = last xs
1092
1093 tail             :: [a] -> [a]
1094 tail (_:xs)       = xs
1095
1096 init             :: [a] -> [a]
1097 init [x]          = []
1098 init (x:xs)       = x : init xs
1099
1100 null             :: [a] -> Bool
1101 null []           = True
1102 null (_:_)        = False
1103
1104 (++)             :: [a] -> [a] -> [a]
1105 []     ++ ys      = ys
1106 (x:xs) ++ ys      = x : (xs ++ ys)
1107
1108 map              :: (a -> b) -> [a] -> [b]
1109 --map f xs          = [ f x | x <- xs ]
1110 map f []     = []
1111 map f (x:xs) = f x : map f xs
1112
1113
1114 filter           :: (a -> Bool) -> [a] -> [a]
1115 --filter p xs       = [ x | x <- xs, p x ]
1116 filter p [] = []
1117 filter p (x:xs) = if p x then x : filter p xs else filter p xs
1118
1119
1120 concat           :: [[a]] -> [a]
1121 --concat            = foldr (++) []
1122 concat []       = []
1123 concat (xs:xss) = xs ++ concat xss
1124
1125 length           :: [a] -> Int
1126 --length            = foldl' (\n _ -> n + 1) 0
1127 length []     = 0
1128 length (x:xs) = let n = length xs in primSeq n (1+n)
1129
1130 (!!)             :: [b] -> Int -> b
1131 (x:_)  !! 0       = x
1132 (_:xs) !! n | n>0 = xs !! (n-1)
1133 (_:_)  !! _       = error "Prelude.!!: negative index"
1134 []     !! _       = error "Prelude.!!: index too large"
1135
1136 foldl            :: (a -> b -> a) -> a -> [b] -> a
1137 foldl f z []      = z
1138 foldl f z (x:xs)  = foldl f (f z x) xs
1139
1140 foldl'           :: (a -> b -> a) -> a -> [b] -> a
1141 foldl' f a []     = a
1142 foldl' f a (x:xs) = (foldl' f $! f a x) xs
1143
1144 foldl1           :: (a -> a -> a) -> [a] -> a
1145 foldl1 f (x:xs)   = foldl f x xs
1146
1147 scanl            :: (a -> b -> a) -> a -> [b] -> [a]
1148 scanl f q xs      = q : (case xs of
1149                          []   -> []
1150                          x:xs -> scanl f (f q x) xs)
1151
1152 scanl1           :: (a -> a -> a) -> [a] -> [a]
1153 scanl1 f (x:xs)   = scanl f x xs
1154
1155 foldr            :: (a -> b -> b) -> b -> [a] -> b
1156 foldr f z []      = z
1157 foldr f z (x:xs)  = f x (foldr f z xs)
1158
1159 foldr1           :: (a -> a -> a) -> [a] -> a
1160 foldr1 f [x]      = x
1161 foldr1 f (x:xs)   = f x (foldr1 f xs)
1162
1163 scanr            :: (a -> b -> b) -> b -> [a] -> [b]
1164 scanr f q0 []     = [q0]
1165 scanr f q0 (x:xs) = f x q : qs
1166                     where qs@(q:_) = scanr f q0 xs
1167
1168 scanr1           :: (a -> a -> a) -> [a] -> [a]
1169 scanr1 f [x]      = [x]
1170 scanr1 f (x:xs)   = f x q : qs
1171                     where qs@(q:_) = scanr1 f xs
1172
1173 iterate          :: (a -> a) -> a -> [a]
1174 iterate f x       = x : iterate f (f x)
1175
1176 repeat           :: a -> [a]
1177 repeat x          = xs where xs = x:xs
1178
1179 replicate        :: Int -> a -> [a]
1180 replicate n x     = take n (repeat x)
1181
1182 cycle            :: [a] -> [a]
1183 cycle []          = error "Prelude.cycle: empty list"
1184 cycle xs          = xs' where xs'=xs++xs'
1185
1186 take                :: Int -> [a] -> [a]
1187 take 0 _             = []
1188 take _ []            = []
1189 take n (x:xs) | n>0  = x : take (n-1) xs
1190 take _ _             = error "Prelude.take: negative argument"
1191
1192 drop                :: Int -> [a] -> [a]
1193 drop 0 xs            = xs
1194 drop _ []            = []
1195 drop n (_:xs) | n>0  = drop (n-1) xs
1196 drop _ _             = error "Prelude.drop: negative argument"
1197
1198 splitAt               :: Int -> [a] -> ([a], [a])
1199 splitAt 0 xs           = ([],xs)
1200 splitAt _ []           = ([],[])
1201 splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
1202 splitAt _ _            = error "Prelude.splitAt: negative argument"
1203
1204 takeWhile           :: (a -> Bool) -> [a] -> [a]
1205 takeWhile p []       = []
1206 takeWhile p (x:xs)
1207          | p x       = x : takeWhile p xs
1208          | otherwise = []
1209
1210 dropWhile           :: (a -> Bool) -> [a] -> [a]
1211 dropWhile p []       = []
1212 dropWhile p xs@(x:xs')
1213          | p x       = dropWhile p xs'
1214          | otherwise = xs
1215
1216 span, break         :: (a -> Bool) -> [a] -> ([a],[a])
1217 span p []            = ([],[])
1218 span p xs@(x:xs')
1219          | p x       = (x:ys, zs)
1220          | otherwise = ([],xs)
1221                        where (ys,zs) = span p xs'
1222 break p              = span (not . p)
1223
1224 lines     :: String -> [String]
1225 lines ""   = []
1226 lines s    = let (l,s') = break ('\n'==) s
1227              in l : case s' of []      -> []
1228                                (_:s'') -> lines s''
1229
1230 words     :: String -> [String]
1231 words s    = case dropWhile isSpace s of
1232                   "" -> []
1233                   s' -> w : words s''
1234                         where (w,s'') = break isSpace s'
1235
1236 unlines   :: [String] -> String
1237 unlines    = concatMap (\l -> l ++ "\n")
1238
1239 unwords   :: [String] -> String
1240 unwords [] = []
1241 unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
1242
1243 reverse   :: [a] -> [a]
1244 --reverse    = foldl (flip (:)) []
1245 reverse xs = ri [] xs
1246              where ri acc []     = acc
1247                    ri acc (x:xs) = ri (x:acc) xs
1248
1249 and, or   :: [Bool] -> Bool
1250 --and        = foldr (&&) True
1251 --or         = foldr (||) False
1252 and []     = True
1253 and (x:xs) = if x then and xs else x
1254 or  []     = False
1255 or  (x:xs) = if x then x else or xs
1256
1257 any, all  :: (a -> Bool) -> [a] -> Bool
1258 --any p      = or  . map p
1259 --all p      = and . map p
1260 any p []     = False
1261 any p (x:xs) = if p x then True else any p xs
1262 all p []     = True
1263 all p (x:xs) = if p x then all p xs else False
1264
1265 elem, notElem    :: Eq a => a -> [a] -> Bool
1266 --elem              = any . (==)
1267 --notElem           = all . (/=)
1268 elem x []        = False
1269 elem x (y:ys)    = if x==y then True else elem x ys
1270 notElem x []     = True
1271 notElem x (y:ys) = if x==y then False else notElem x ys
1272
1273 lookup           :: Eq a => a -> [(a,b)] -> Maybe b
1274 lookup k []       = Nothing
1275 lookup k ((x,y):xys)
1276       | k==x      = Just y
1277       | otherwise = lookup k xys
1278
1279 sum, product     :: Num a => [a] -> a
1280 sum               = foldl' (+) 0
1281 product           = foldl' (*) 1
1282
1283 maximum, minimum :: Ord a => [a] -> a
1284 maximum           = foldl1 max
1285 minimum           = foldl1 min
1286
1287 concatMap        :: (a -> [b]) -> [a] -> [b]
1288 concatMap f       = concat . map f
1289
1290 zip              :: [a] -> [b] -> [(a,b)]
1291 zip               = zipWith  (\a b -> (a,b))
1292
1293 zip3             :: [a] -> [b] -> [c] -> [(a,b,c)]
1294 zip3              = zipWith3 (\a b c -> (a,b,c))
1295
1296 zipWith                  :: (a->b->c) -> [a]->[b]->[c]
1297 zipWith z (a:as) (b:bs)   = z a b : zipWith z as bs
1298 zipWith _ _      _        = []
1299
1300 zipWith3                 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
1301 zipWith3 z (a:as) (b:bs) (c:cs)
1302                           = z a b c : zipWith3 z as bs cs
1303 zipWith3 _ _ _ _          = []
1304
1305 unzip                    :: [(a,b)] -> ([a],[b])
1306 unzip                     = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
1307
1308 unzip3                   :: [(a,b,c)] -> ([a],[b],[c])
1309 unzip3                    = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
1310                                   ([],[],[])
1311
1312 -- PreludeText ----------------------------------------------------------------
1313
1314 reads        :: Read a => ReadS a
1315 reads         = readsPrec 0
1316
1317 shows        :: Show a => a -> ShowS
1318 shows         = showsPrec 0
1319
1320 read         :: Read a => String -> a
1321 read s        =  case [x | (x,t) <- reads s, ("","") <- lex t] of
1322                       [x] -> x
1323                       []  -> error "Prelude.read: no parse"
1324                       _   -> error "Prelude.read: ambiguous parse"
1325
1326 showChar     :: Char -> ShowS
1327 showChar      = (:)
1328
1329 showString   :: String -> ShowS
1330 showString    = (++)
1331
1332 showParen    :: Bool -> ShowS -> ShowS
1333 showParen b p = if b then showChar '(' . p . showChar ')' else p
1334
1335 hugsprimShowField    :: Show a => String -> a -> ShowS
1336 hugsprimShowField m v = showString m . showChar '=' . shows v
1337
1338 readParen    :: Bool -> ReadS a -> ReadS a
1339 readParen b g = if b then mandatory else optional
1340                 where optional r  = g r ++ mandatory r
1341                       mandatory r = [(x,u) | ("(",s) <- lex r,
1342                                              (x,t)   <- optional s,
1343                                              (")",u) <- lex t    ]
1344
1345
1346 hugsprimReadField    :: Read a => String -> ReadS a
1347 hugsprimReadField m s0 = [ r | (t,  s1) <- lex s0, t == m,
1348                                ("=",s2) <- lex s1,
1349                                r        <- reads s2 ]
1350
1351 lex                    :: ReadS String
1352 lex ""                  = [("","")]
1353 lex (c:s) | isSpace c   = lex (dropWhile isSpace s)
1354 lex ('\'':s)            = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
1355                                                ch /= "'"                ]
1356 lex ('"':s)             = [('"':str, t)      | (str,t) <- lexString s]
1357                           where
1358                           lexString ('"':s) = [("\"",s)]
1359                           lexString s = [(ch++str, u)
1360                                                 | (ch,t)  <- lexStrItem s,
1361                                                   (str,u) <- lexString t  ]
1362
1363                           lexStrItem ('\\':'&':s) = [("\\&",s)]
1364                           lexStrItem ('\\':c:s) | isSpace c
1365                               = [("",t) | '\\':t <- [dropWhile isSpace s]]
1366                           lexStrItem s            = lexLitChar s
1367
1368 lex (c:s) | isSingle c  = [([c],s)]
1369           | isSym c     = [(c:sym,t)         | (sym,t) <- [span isSym s]]
1370           | isAlpha c   = [(c:nam,t)         | (nam,t) <- [span isIdChar s]]
1371           | isDigit c   = [(c:ds++fe,t)      | (ds,s)  <- [span isDigit s],
1372                                                (fe,t)  <- lexFracExp s     ]
1373           | otherwise   = []    -- bad character
1374                 where
1375                 isSingle c  =  c `elem` ",;()[]{}_`"
1376                 isSym c     =  c `elem` "!@#$%&*+./<=>?\\^|:-~"
1377                 isIdChar c  =  isAlphaNum c || c `elem` "_'"
1378
1379                 lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
1380                                                       (e,u)  <- lexExp t    ]
1381                 lexFracExp s       = [("",s)]
1382
1383                 lexExp (e:s) | e `elem` "eE"
1384                          = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
1385                                                    (ds,u) <- lexDigits t] ++
1386                            [(e:ds,t)   | (ds,t) <- lexDigits s]
1387                 lexExp s = [("",s)]
1388
1389 lexDigits               :: ReadS String
1390 lexDigits               =  nonnull isDigit
1391
1392 nonnull                 :: (Char -> Bool) -> ReadS String
1393 nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
1394
1395 lexLitChar              :: ReadS String
1396 lexLitChar ('\\':s)     =  [('\\':esc, t) | (esc,t) <- lexEsc s]
1397         where
1398         lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]    -- "
1399         lexEsc ('^':c:s) | c >= '@' && c <= '_'    = [(['^',c],s)]
1400         lexEsc s@(d:_)   | isDigit d               = lexDigits s
1401         lexEsc s@(c:_)   | isUpper c
1402                           = let table = ('\DEL',"DEL") : asciiTab
1403                             in case [(mne,s') | (c, mne) <- table,
1404                                                 ([],s') <- [lexmatch mne s]]
1405                                of (pr:_) -> [pr]
1406                                   []     -> []
1407         lexEsc _                                   = []
1408 lexLitChar (c:s)        =  [([c],s)]
1409 lexLitChar ""           =  []
1410
1411 isOctDigit c  =  c >= '0' && c <= '7'
1412 isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'
1413                            || c >= 'a' && c <= 'f'
1414
1415 lexmatch                   :: (Eq a) => [a] -> [a] -> ([a],[a])
1416 lexmatch (x:xs) (y:ys) | x == y  =  lexmatch xs ys
1417 lexmatch xs     ys               =  (xs,ys)
1418
1419 asciiTab = zip ['\NUL'..' ']
1420            ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
1421             "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
1422             "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
1423             "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
1424             "SP"]
1425
1426 readLitChar            :: ReadS Char
1427 readLitChar ('\\':s)    = readEsc s
1428  where
1429        readEsc ('a':s)  = [('\a',s)]
1430        readEsc ('b':s)  = [('\b',s)]
1431        readEsc ('f':s)  = [('\f',s)]
1432        readEsc ('n':s)  = [('\n',s)]
1433        readEsc ('r':s)  = [('\r',s)]
1434        readEsc ('t':s)  = [('\t',s)]
1435        readEsc ('v':s)  = [('\v',s)]
1436        readEsc ('\\':s) = [('\\',s)]
1437        readEsc ('"':s)  = [('"',s)]
1438        readEsc ('\'':s) = [('\'',s)]
1439        readEsc ('^':c:s) | c >= '@' && c <= '_'
1440                         = [(toEnum (fromEnum c - fromEnum '@'), s)]
1441        readEsc s@(d:_) | isDigit d
1442                         = [(toEnum n, t) | (n,t) <- readDec s]
1443        readEsc ('o':s)  = [(toEnum n, t) | (n,t) <- readOct s]
1444        readEsc ('x':s)  = [(toEnum n, t) | (n,t) <- readHex s]
1445        readEsc s@(c:_) | isUpper c
1446                         = let table = ('\DEL',"DEL") : asciiTab
1447                           in case [(c,s') | (c, mne) <- table,
1448                                             ([],s') <- [lexmatch mne s]]
1449                              of (pr:_) -> [pr]
1450                                 []     -> []
1451        readEsc _        = []
1452 readLitChar (c:s)       = [(c,s)]
1453
1454 showLitChar               :: Char -> ShowS
1455 showLitChar c | c > '\DEL' = showChar '\\' .
1456                              protectEsc isDigit (shows (fromEnum c))
1457 showLitChar '\DEL'         = showString "\\DEL"
1458 showLitChar '\\'           = showString "\\\\"
1459 showLitChar c | c >= ' '   = showChar c
1460 showLitChar '\a'           = showString "\\a"
1461 showLitChar '\b'           = showString "\\b"
1462 showLitChar '\f'           = showString "\\f"
1463 showLitChar '\n'           = showString "\\n"
1464 showLitChar '\r'           = showString "\\r"
1465 showLitChar '\t'           = showString "\\t"
1466 showLitChar '\v'           = showString "\\v"
1467 showLitChar '\SO'          = protectEsc ('H'==) (showString "\\SO")
1468 showLitChar c              = showString ('\\' : snd (asciiTab!!fromEnum c))
1469
1470 protectEsc p f             = f . cont
1471  where cont s@(c:_) | p c  = "\\&" ++ s
1472        cont s              = s
1473
1474 -- Unsigned readers for various bases
1475 readDec, readOct, readHex :: Integral a => ReadS a
1476 readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
1477 readOct = readInt  8 isOctDigit (\d -> fromEnum d - fromEnum '0')
1478 readHex = readInt 16 isHexDigit hex
1479           where hex d = fromEnum d -
1480                         (if isDigit d
1481                            then fromEnum '0'
1482                            else fromEnum (if isUpper d then 'A' else 'a') - 10)
1483
1484 -- readInt reads a string of digits using an arbitrary base.
1485 -- Leading minus signs must be handled elsewhere.
1486
1487 readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
1488 readInt radix isDig digToInt s =
1489     [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
1490         | (ds,r) <- nonnull isDig s ]
1491
1492 -- showInt is used for positive numbers only
1493 showInt    :: Integral a => a -> ShowS
1494 showInt n r
1495    | n < 0
1496    = error "Numeric.showInt: can't show negative numbers"
1497    | otherwise
1498 {-
1499    = let (n',d) = quotRem n 10
1500          r'     = toEnum (fromEnum '0' + fromIntegral d) : r
1501      in  if n' == 0 then r' else showInt n' r'
1502 -}
1503    = case quotRem n 10 of { (n',d) ->
1504      let r' = toEnum (fromEnum '0' + fromIntegral d) : r
1505      in  if n' == 0 then r' else showInt n' r'
1506      }
1507
1508
1509 readSigned:: Real a => ReadS a -> ReadS a
1510 readSigned readPos = readParen False read'
1511                      where read' r  = read'' r ++
1512                                       [(-x,t) | ("-",s) <- lex r,
1513                                                 (x,t)   <- read'' s]
1514                            read'' r = [(n,s)  | (str,s) <- lex r,
1515                                                 (n,"")  <- readPos str]
1516
1517 showSigned    :: Real a => (a -> ShowS) -> Int -> a -> ShowS
1518 showSigned showPos p x = if x < 0 then showParen (p > 6)
1519                                                  (showChar '-' . showPos (-x))
1520                                   else showPos x
1521
1522 readFloat     :: RealFloat a => ReadS a
1523 readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
1524                                                        (k,t)   <- readExp s]
1525                  where readFix r = [(read (ds++ds'), length ds', t)
1526                                         | (ds, s) <- lexDigits r
1527                                         , (ds',t) <- lexFrac s   ]
1528
1529                        lexFrac ('.':s) = lexDigits s
1530                        lexFrac s       = [("",s)]
1531
1532                        readExp (e:s) | e `elem` "eE" = readExp' s
1533                        readExp s                     = [(0,s)]
1534
1535                        readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
1536                        readExp' ('+':s) = readDec s
1537                        readExp' s       = readDec s
1538
1539
1540 -- Hooks for primitives: -----------------------------------------------------
1541 -- Do not mess with these!
1542
1543 hugsprimCompAux      :: Ord a => a -> a -> Ordering -> Ordering
1544 hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
1545
1546 hugsprimEqChar       :: Char -> Char -> Bool
1547 hugsprimEqChar c1 c2  = primEqChar c1 c2
1548
1549 hugsprimPmInt        :: Num a => Int -> a -> Bool
1550 hugsprimPmInt n x     = fromInt n == x
1551
1552 hugsprimPmInteger    :: Num a => Integer -> a -> Bool
1553 hugsprimPmInteger n x = fromInteger n == x
1554
1555 hugsprimPmDouble     :: Fractional a => Double -> a -> Bool
1556 hugsprimPmDouble n x  = fromDouble n == x
1557
1558 -- ToDo: make the message more informative.
1559 hugsprimPmFail       :: a
1560 hugsprimPmFail        = error "Pattern Match Failure"
1561
1562 -- used in desugaring Foreign functions
1563 -- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
1564 -- bit of code of type   RealWorld -> (a,RealWorld)   into a proper IO value.
1565 -- What follows is the version for standalone mode.  ghc/lib/std/PrelHugs.lhs
1566 -- contains a version used in combined mode.  That version takes care of
1567 -- switching between the GHC and Hugs IO representations, which are different.
1568 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1569 hugsprimMkIO = ST
1570
1571 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1572 hugsprimCreateAdjThunk fun typestr callconv
1573    = do sp <- makeStablePtr fun
1574         p  <- copy_String_to_cstring typestr  -- is never freed
1575         a  <- primCreateAdjThunkARCH sp p callconv
1576         return a
1577
1578 -- The following primitives are only needed if (n+k) patterns are enabled:
1579 hugsprimPmSub           :: Integral a => Int -> a -> a
1580 hugsprimPmSub n x        = x - fromInt n
1581
1582 hugsprimPmFromInteger   :: Integral a => Integer -> a
1583 hugsprimPmFromInteger    = fromIntegral
1584
1585 hugsprimPmSubtract      :: Integral a => a -> a -> a
1586 hugsprimPmSubtract x y   = x - y
1587
1588 hugsprimPmLe            :: Integral a => a -> a -> Bool
1589 hugsprimPmLe x y         = x <= y
1590
1591 -- Unpack strings generated by the Hugs code generator.
1592 -- Strings can contain \0 provided they're coded right.
1593 --
1594 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1595
1596 hugsprimUnpackString :: Addr -> String
1597 hugsprimUnpackString a = unpack 0
1598  where
1599   -- The following decoding is based on evalString in the old machine.c
1600   unpack i
1601     | c == '\0' = []
1602     | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1603                   then '\\' : unpack (i+2)
1604                   else '\0' : unpack (i+2)
1605     | otherwise = c : unpack (i+1)
1606    where
1607     c = primIndexCharOffAddr a i
1608
1609
1610 -- Monadic I/O: --------------------------------------------------------------
1611
1612 type FilePath = String
1613
1614 --data IOError = ...
1615 --instance Eq IOError ...
1616 --instance Show IOError ...
1617
1618 data IOError = IOError String
1619 instance Show IOError where
1620    showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1621
1622 ioError :: IOError -> IO a
1623 ioError (IOError s) = primRaise (IOExcept s)
1624
1625 userError :: String -> IOError
1626 userError s = primRaise (ErrorCall s)
1627
1628 catch :: IO a -> (IOError -> IO a) -> IO a
1629 catch m k
1630   = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
1631     where
1632        e2ioe (IOExcept s) = IOError s
1633        e2ioe other        = IOError (show other)
1634
1635 putChar :: Char -> IO ()
1636 putChar c = nh_stdout >>= \h -> nh_write h c
1637
1638 putStr :: String -> IO ()
1639 putStr s = nh_stdout >>= \h ->
1640            let loop []     = nh_flush h
1641                loop (c:cs) = nh_write h c >> loop cs
1642            in  loop s
1643
1644 putStrLn :: String -> IO ()
1645 putStrLn s = do { putStr s; putChar '\n' }
1646
1647 print :: Show a => a -> IO ()
1648 print = putStrLn . show
1649
1650 getChar :: IO Char
1651 getChar = unsafeInterleaveIO (
1652           nh_stdin  >>= \h ->
1653           nh_read h >>= \ci ->
1654           return (primIntToChar ci)
1655           )
1656
1657 getLine :: IO String
1658 getLine    = do c <- getChar
1659                 if c=='\n' then return ""
1660                            else do cs <- getLine
1661                                    return (c:cs)
1662
1663 getContents :: IO String
1664 getContents = nh_stdin >>= \h -> readfromhandle h
1665
1666 interact  :: (String -> String) -> IO ()
1667 interact f = getContents >>= (putStr . f)
1668
1669 readFile :: FilePath -> IO String
1670 readFile fname
1671    = copy_String_to_cstring fname  >>= \ptr ->
1672      nh_open ptr 0                 >>= \h ->
1673      nh_free ptr                   >>
1674      nh_errno                      >>= \errno ->
1675      if   (isNullAddr h || errno /= 0)
1676      then (ioError.IOError) ("readFile: can't open file " ++ fname)
1677      else readfromhandle h
1678
1679 writeFile :: FilePath -> String -> IO ()
1680 writeFile fname contents
1681    = copy_String_to_cstring fname  >>= \ptr ->
1682      nh_open ptr 1                 >>= \h ->
1683      nh_free ptr                   >>
1684      nh_errno                      >>= \errno ->
1685      if   (isNullAddr h || errno /= 0)
1686      then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1687      else writetohandle fname h contents
1688
1689 appendFile :: FilePath -> String -> IO ()
1690 appendFile fname contents
1691    = copy_String_to_cstring fname  >>= \ptr ->
1692      nh_open ptr 2                 >>= \h ->
1693      nh_free ptr                   >>
1694      nh_errno                      >>= \errno ->
1695      if   (isNullAddr h || errno /= 0)
1696      then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1697      else writetohandle fname h contents
1698
1699
1700 -- raises an exception instead of an error
1701 readIO          :: Read a => String -> IO a
1702 readIO s         = case [x | (x,t) <- reads s, ("","") <- lex t] of
1703                         [x] -> return x
1704                         []  -> ioError (userError "PreludeIO.readIO: no parse")
1705                         _   -> ioError (userError
1706                                        "PreludeIO.readIO: ambiguous parse")
1707
1708 readLn          :: Read a => IO a
1709 readLn           = do l <- getLine
1710                       r <- readIO l
1711                       return r
1712
1713
1714 -- End of Hugs standard prelude ----------------------------------------------
1715
1716 data Exception
1717    = ErrorCall String
1718    | IOExcept  String
1719
1720 instance Show Exception where
1721    showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1722    showsPrec _ (IOExcept s)  = showString ("I/O error: " ++ s)
1723
1724 data IOResult  = IOResult  deriving (Show)
1725
1726 type FILE_STAR = Addr   -- FILE *
1727
1728 foreign import "nHandle" "nh_stdin"    nh_stdin    :: IO FILE_STAR
1729 foreign import "nHandle" "nh_stdout"   nh_stdout   :: IO FILE_STAR
1730 foreign import "nHandle" "nh_stderr"   nh_stderr   :: IO FILE_STAR
1731 foreign import "nHandle" "nh_write"    nh_write    :: FILE_STAR -> Char -> IO ()
1732 foreign import "nHandle" "nh_read"     nh_read     :: FILE_STAR -> IO Int
1733 foreign import "nHandle" "nh_open"     nh_open     :: Addr -> Int -> IO FILE_STAR
1734 foreign import "nHandle" "nh_flush"    nh_flush    :: FILE_STAR -> IO ()
1735 foreign import "nHandle" "nh_close"    nh_close    :: FILE_STAR -> IO ()
1736 foreign import "nHandle" "nh_errno"    nh_errno    :: IO Int
1737
1738 foreign import "nHandle" "nh_malloc"   nh_malloc   :: Int -> IO Addr
1739 foreign import "nHandle" "nh_free"     nh_free     :: Addr -> IO ()
1740 foreign import "nHandle" "nh_store"    nh_store    :: Addr -> Char -> IO ()
1741 foreign import "nHandle" "nh_load"     nh_load     :: Addr -> IO Char
1742 foreign import "nHandle" "nh_getenv"   nh_getenv   :: Addr -> IO Addr
1743 foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int
1744 foreign import "nHandle" "nh_iseof"    nh_iseof    :: FILE_STAR -> IO Int
1745 foreign import "nHandle" "nh_system"   nh_system   :: Addr -> IO Int
1746 foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO ()
1747 foreign import "nHandle" "nh_getPID"   nh_getPID   :: IO Int
1748
1749 foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double
1750 foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double
1751
1752 copy_String_to_cstring :: String -> IO Addr
1753 copy_String_to_cstring s
1754    = nh_malloc (1 + length s) >>= \ptr0 ->
1755      let loop ptr []     = nh_store ptr (chr 0) >> return ptr0
1756          loop ptr (c:cs) = nh_store ptr c       >> loop (incAddr ptr) cs
1757      in
1758          if   isNullAddr ptr0
1759          then error "copy_String_to_cstring: malloc failed"
1760          else loop ptr0 s
1761
1762 copy_cstring_to_String :: Addr -> IO String
1763 copy_cstring_to_String ptr
1764    = nh_load ptr >>= \ci ->
1765      if   ci == '\0'
1766      then return []
1767      else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1768           return (ci : cs)
1769
1770 readfromhandle :: FILE_STAR -> IO String
1771 readfromhandle h
1772    = unsafeInterleaveIO (
1773      nh_read h >>= \ci ->
1774      if ci == -1 {-EOF-} then return "" else
1775      readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1776      )
1777
1778 writetohandle :: String -> FILE_STAR -> String -> IO ()
1779 writetohandle fname h []
1780    = nh_close h                  >>
1781      nh_errno                    >>= \errno ->
1782      if   errno == 0
1783      then return ()
1784      else error ( "writeFile/appendFile: error closing file " ++ fname)
1785 writetohandle fname h (c:cs)
1786    = nh_write h c >> writetohandle fname h cs
1787
1788 primGetRawArgs :: IO [String]
1789 primGetRawArgs
1790    = primGetArgc >>= \argc ->
1791      sequence (map get_one_arg [0 .. argc-1])
1792      where
1793         get_one_arg :: Int -> IO String
1794         get_one_arg argno
1795            = primGetArgv argno >>= \a ->
1796              copy_cstring_to_String a
1797
1798 primGetEnv :: String -> IO String
1799 primGetEnv v
1800    = copy_String_to_cstring v     >>= \ptr ->
1801      nh_getenv ptr                >>= \ptr2 ->
1802      nh_free ptr                  >>
1803      if   isNullAddr ptr2
1804      then return []
1805      else
1806      copy_cstring_to_String ptr2  >>= \result ->
1807      return result
1808
1809
1810 ------------------------------------------------------------------------------
1811 -- ST, IO --------------------------------------------------------------------
1812 ------------------------------------------------------------------------------
1813
1814 newtype ST s a = ST (s -> (a,s))
1815
1816 data RealWorld
1817 type IO a = ST RealWorld a
1818
1819 --primRunST :: (forall s. ST s a) -> a
1820 primRunST :: ST RealWorld a -> a
1821 primRunST m = fst (unST m theWorld)
1822    where
1823       theWorld :: RealWorld
1824       theWorld = error "primRunST: entered the RealWorld"
1825
1826 unST (ST a) = a
1827
1828 instance Functor (ST s) where
1829    fmap f x  = x >>= (return . f)
1830
1831 instance Monad (ST s) where
1832    m >> k    = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1833    return x  = ST (\s -> (x,s))
1834    m >>= k   = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1835
1836
1837 -- Library IO has a global variable which accumulates Handles
1838 -- as they are opened.  We keep here a second global variable
1839 -- into which a cleanup action may be specified.  When evaluation
1840 -- finishes, either normally or as a result of System.exitWith,
1841 -- this cleanup action is run, closing all known-about Handles.
1842 -- Doing it like this means the Prelude does not have to know
1843 -- anything about the grotty details of the Handle implementation.
1844 prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
1845 prelCleanupAfterRunAction = primRunST (newIORef Nothing)
1846
1847 -- used when Hugs invokes top level function
1848 hugsprimRunIO_toplevel :: IO a -> ()
1849 hugsprimRunIO_toplevel m
1850    = protect 5 (fst (unST composite_action realWorld))
1851      where
1852         composite_action
1853            = do writeIORef prelCleanupAfterRunAction Nothing
1854                 m
1855                 cleanup_handles <- readIORef prelCleanupAfterRunAction
1856                 case cleanup_handles of
1857                    Nothing -> return ()
1858                    Just xx -> xx
1859
1860         realWorld = error "primRunIO: entered the RealWorld"
1861         protect :: Int -> () -> ()
1862         protect 0 comp
1863            = comp
1864         protect n comp
1865            = primCatch (protect (n-1) comp)
1866                        (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1867
1868 trace, trace_quiet :: String -> a -> a
1869 trace s x
1870    = trace_quiet ("trace: " ++ s) x
1871 trace_quiet s x
1872    = (primRunST (putStr (s ++ "\n"))) `seq` x
1873
1874 unsafeInterleaveST :: ST s a -> ST s a
1875 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1876
1877 unsafeInterleaveIO :: IO a -> IO a
1878 unsafeInterleaveIO = unsafeInterleaveST
1879
1880
1881 ------------------------------------------------------------------------------
1882 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
1883 ------------------------------------------------------------------------------
1884
1885 data Addr
1886
1887 nullAddr     =  primIntToAddr 0
1888 incAddr a    =  primIntToAddr (1 + primAddrToInt a)
1889 isNullAddr a =  0 == primAddrToInt a
1890
1891 instance Eq Addr where
1892   (==)            = primEqAddr
1893   (/=)            = primNeAddr
1894
1895 instance Ord Addr where
1896   (<)             = primLtAddr
1897   (<=)            = primLeAddr
1898   (>=)            = primGeAddr
1899   (>)             = primGtAddr
1900
1901 data Word
1902
1903 instance Eq Word where
1904   (==)            = primEqWord
1905   (/=)            = primNeWord
1906
1907 instance Ord Word where
1908   (<)             = primLtWord
1909   (<=)            = primLeWord
1910   (>=)            = primGeWord
1911   (>)             = primGtWord
1912
1913 data StablePtr a
1914
1915 makeStablePtr   :: a -> IO (StablePtr a)
1916 makeStablePtr    = primMakeStablePtr
1917 deRefStablePtr  :: StablePtr a -> IO a
1918 deRefStablePtr   = primDeRefStablePtr
1919 freeStablePtr   :: StablePtr a -> IO ()
1920 freeStablePtr    = primFreeStablePtr
1921
1922
1923 data PrimArray              a -- immutable arrays with Int indices
1924 data PrimByteArray
1925
1926 data STRef                s a -- mutable variables
1927 data PrimMutableArray     s a -- mutable arrays with Int indices
1928 data PrimMutableByteArray s
1929
1930 newSTRef   :: a -> ST s (STRef s a)
1931 newSTRef    = primNewRef
1932 readSTRef  :: STRef s a -> ST s a
1933 readSTRef   = primReadRef
1934 writeSTRef :: STRef s a -> a -> ST s ()
1935 writeSTRef  = primWriteRef
1936
1937 type IORef a = STRef RealWorld a
1938 newIORef   :: a -> IO (IORef a)
1939 newIORef    = primNewRef
1940 readIORef  :: IORef a -> IO a
1941 readIORef   = primReadRef
1942 writeIORef :: IORef a -> a -> IO ()
1943 writeIORef  = primWriteRef
1944
1945
1946 ------------------------------------------------------------------------------
1947 -- ThreadId, MVar, concurrency stuff -----------------------------------------
1948 ------------------------------------------------------------------------------
1949
1950 data MVar a
1951
1952 newEmptyMVar :: IO (MVar a)
1953 newEmptyMVar = primNewEmptyMVar
1954
1955 putMVar :: MVar a -> a -> IO ()
1956 putMVar = primPutMVar
1957
1958 takeMVar :: MVar a -> IO a
1959 takeMVar m
1960    = ST (\world -> primTakeMVar m cont world)
1961      where
1962         -- cont :: a -> RealWorld -> (a,RealWorld)
1963         -- where 'a' is as in the top-level signature
1964         cont x world = (x,world)
1965
1966         -- the type of the handwritten BCO (threesome) primTakeMVar is
1967         -- primTakeMVar :: MVar a
1968         --                 -> (a -> RealWorld -> (a,RealWorld))
1969         --                 -> RealWorld
1970         --                 -> (a,RealWorld)
1971         --
1972         -- primTakeMVar behaves like this:
1973         --
1974         -- primTakeMVar (MVar# m#) cont world
1975         --    = primTakeMVar_wrk m# cont world
1976         --
1977         -- primTakeMVar_wrk m# cont world
1978         --    = cont (takeMVar# m#) world
1979         --
1980         -- primTakeMVar_wrk has the special property that it is
1981         -- restartable by the scheduler, should the MVar be empty.
1982
1983 newMVar :: a -> IO (MVar a)
1984 newMVar value =
1985     newEmptyMVar        >>= \ mvar ->
1986     putMVar mvar value  >>
1987     return mvar
1988
1989 readMVar :: MVar a -> IO a
1990 readMVar mvar =
1991     takeMVar mvar       >>= \ value ->
1992     putMVar mvar value  >>
1993     return value
1994
1995 swapMVar :: MVar a -> a -> IO a
1996 swapMVar mvar new =
1997     takeMVar mvar       >>= \ old ->
1998     putMVar mvar new    >>
1999     return old
2000
2001 instance Eq (MVar a) where
2002     m1 == m2 = primSameMVar m1 m2
2003
2004
2005 data ThreadId
2006
2007 instance Eq ThreadId where
2008    tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
2009
2010 instance Ord ThreadId where
2011    compare tid1 tid2
2012       = let r = primCmpThreadIds tid1 tid2
2013         in  if r < 0 then LT else if r > 0 then GT else EQ
2014
2015
2016 forkIO :: IO a -> IO ThreadId
2017 -- Simple version; doesn't catch exceptions in computation
2018 -- forkIO computation
2019 --    = primForkIO (primRunST computation)
2020
2021 forkIO computation
2022    = primForkIO (
2023         primCatch
2024            (unST computation realWorld `primSeq` ())
2025            (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
2026      )
2027      where
2028         realWorld = error "primForkIO: entered the RealWorld"
2029
2030
2031 -- showFloat ------------------------------------------------------------------
2032
2033 showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2034 showFFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2035 showGFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2036 showFloat      :: (RealFloat a) => a -> ShowS
2037
2038 showEFloat d x =  showString (formatRealFloat FFExponent d x)
2039 showFFloat d x =  showString (formatRealFloat FFFixed d x)
2040 showGFloat d x =  showString (formatRealFloat FFGeneric d x)
2041 showFloat      =  showGFloat Nothing
2042
2043 -- These are the format types.  This type is not exported.
2044
2045 data FFFormat = FFExponent | FFFixed | FFGeneric
2046
2047 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2048 formatRealFloat fmt decs x = s
2049   where base = 10
2050         s = if isNaN x then
2051                 "NaN"
2052             else if isInfinite x then
2053                 if x < 0 then "-Infinity" else "Infinity"
2054             else if x < 0 || isNegativeZero x then
2055                 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2056             else
2057                 doFmt fmt (floatToDigits (toInteger base) x)
2058         doFmt fmt (is, e) =
2059             let ds = map intToDigit is
2060             in  case fmt of
2061                 FFGeneric ->
2062                     doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2063                           (is, e)
2064                 FFExponent ->
2065                     case decs of
2066                     Nothing ->
2067                         case ds of
2068                          ['0'] -> "0.0e0"
2069                          [d]   -> d : ".0e" ++ show (e-1)
2070                          d:ds  -> d : '.' : ds ++ 'e':show (e-1)
2071                     Just dec ->
2072                         let dec' = max dec 1 in
2073                         case is of
2074                          [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2075                          _ ->
2076                           let (ei, is') = roundTo base (dec'+1) is
2077                               d:ds = map intToDigit
2078                                          (if ei > 0 then init is' else is')
2079                           in d:'.':ds  ++ "e" ++ show (e-1+ei)
2080                 FFFixed ->
2081                     case decs of
2082                     Nothing ->
2083                         let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2084                             f n s "" = f (n-1) (s++"0") ""
2085                             f n s (d:ds) = f (n-1) (s++[d]) ds
2086                             mk0 "" = "0"
2087                             mk0 s = s
2088                         in  f e "" ds
2089                     Just dec ->
2090                         let dec' = max dec 0 in
2091                         if e >= 0 then
2092                             let (ei, is') = roundTo base (dec' + e) is
2093                                 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2094                             in  (if null ls then "0" else ls) ++
2095                                 (if null rs then "" else '.' : rs)
2096                         else
2097                             let (ei, is') = roundTo base dec'
2098                                               (replicate (-e) 0 ++ is)
2099                                 d : ds = map intToDigit
2100                                             (if ei > 0 then is' else 0:is')
2101                             in  d : '.' : ds
2102
2103 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2104 roundTo base d is = case f d is of
2105                 (0, is) -> (0, is)
2106                 (1, is) -> (1, 1 : is)
2107   where b2 = base `div` 2
2108         f n [] = (0, replicate n 0)
2109         f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2110         f d (i:is) =
2111             let (c, ds) = f (d-1) is
2112                 i' = c + i
2113             in  if i' == base then (1, 0:ds) else (0, i':ds)
2114
2115 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2116 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2117 -- This version uses a much slower logarithm estimator.  It should be improved.
2118
2119 -- This function returns a list of digits (Ints in [0..base-1]) and an
2120 -- exponent.
2121
2122 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2123
2124 floatToDigits _ 0 = ([0], 0)
2125 floatToDigits base x =
2126     let (f0, e0) = decodeFloat x
2127         (minExp0, _) = floatRange x
2128         p = floatDigits x
2129         b = floatRadix x
2130         minExp = minExp0 - p            -- the real minimum exponent
2131         -- Haskell requires that f be adjusted so denormalized numbers
2132         -- will have an impossibly low exponent.  Adjust for this.
2133         (f, e) = let n = minExp - e0
2134                  in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2135
2136         (r, s, mUp, mDn) =
2137            if e >= 0 then
2138                let be = b^e in
2139                if f == b^(p-1) then
2140                    (f*be*b*2, 2*b, be*b, b)
2141                else
2142                    (f*be*2, 2, be, be)
2143            else
2144                if e > minExp && f == b^(p-1) then
2145                    (f*b*2, b^(-e+1)*2, b, 1)
2146                else
2147                    (f*2, b^(-e)*2, 1, 1)
2148         k =
2149             let k0 =
2150                     if b == 2 && base == 10 then
2151                          -- logBase 10 2 is slightly bigger than 3/10 so
2152                          -- the following will err on the low side.  Ignoring
2153                          -- the fraction will make it err even more.
2154                          -- Haskell promises that p-1 <= logBase b f < p.
2155                          (p - 1 + e0) * 3 `div` 10
2156                     else
2157                          ceiling ((log (fromInteger (f+1)) +
2158                                   fromInt e * log (fromInteger b)) /
2159                                    log (fromInteger base))
2160                 fixup n =
2161                     if n >= 0 then
2162                         if r + mUp <= expt base n * s then n else fixup (n+1)
2163                     else
2164                         if expt base (-n) * (r + mUp) <= s then n
2165                                                            else fixup (n+1)
2166             in  fixup k0
2167
2168         gen ds rn sN mUpN mDnN =
2169             let (dn, rn') = (rn * base) `divMod` sN
2170                 mUpN' = mUpN * base
2171                 mDnN' = mDnN * base
2172             in  case (rn' < mDnN', rn' + mUpN' > sN) of
2173                 (True,  False) -> dn : ds
2174                 (False, True)  -> dn+1 : ds
2175                 (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2176                 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2177         rds =
2178             if k >= 0 then
2179                 gen [] r (s * expt base k) mUp mDn
2180             else
2181                 let bk = expt base (-k)
2182                 in  gen [] (r * bk) s (mUp * bk) (mDn * bk)
2183     in  (map toInt (reverse rds), k)
2184
2185
2186 -- Exponentiation with a cache for the most common numbers.
2187 minExpt = 0::Int
2188 maxExpt = 1100::Int
2189 expt :: Integer -> Int -> Integer
2190 expt base n =
2191     if base == 2 && n >= minExpt && n <= maxExpt then
2192         expts !! (n-minExpt)
2193     else
2194         base^n
2195
2196 expts :: [Integer]
2197 expts = [2^n | n <- [minExpt .. maxExpt]]
2198