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 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
1564 hugsprimMkIO = ST
1565
1566 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
1567 hugsprimCreateAdjThunk fun typestr callconv
1568    = do sp <- makeStablePtr fun
1569         p  <- copy_String_to_cstring typestr  -- is never freed
1570         a  <- primCreateAdjThunkARCH sp p callconv
1571         return a
1572
1573 -- The following primitives are only needed if (n+k) patterns are enabled:
1574 hugsprimPmSub           :: Integral a => Int -> a -> a
1575 hugsprimPmSub n x        = x - fromInt n
1576
1577 hugsprimPmFromInteger   :: Integral a => Integer -> a
1578 hugsprimPmFromInteger    = fromIntegral
1579
1580 hugsprimPmSubtract      :: Integral a => a -> a -> a
1581 hugsprimPmSubtract x y   = x - y
1582
1583 hugsprimPmLe            :: Integral a => a -> a -> Bool
1584 hugsprimPmLe x y         = x <= y
1585
1586 -- Unpack strings generated by the Hugs code generator.
1587 -- Strings can contain \0 provided they're coded right.
1588 --
1589 -- ToDo: change this (and Hugs code generator) to use ByteArrays
1590
1591 hugsprimUnpackString :: Addr -> String
1592 hugsprimUnpackString a = unpack 0
1593  where
1594   -- The following decoding is based on evalString in the old machine.c
1595   unpack i
1596     | c == '\0' = []
1597     | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
1598                   then '\\' : unpack (i+2)
1599                   else '\0' : unpack (i+2)
1600     | otherwise = c : unpack (i+1)
1601    where
1602     c = primIndexCharOffAddr a i
1603
1604
1605 -- Monadic I/O: --------------------------------------------------------------
1606
1607 type FilePath = String
1608
1609 --data IOError = ...
1610 --instance Eq IOError ...
1611 --instance Show IOError ...
1612
1613 data IOError = IOError String
1614 instance Show IOError where
1615    showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
1616
1617 ioError :: IOError -> IO a
1618 ioError (IOError s) = primRaise (IOExcept s)
1619
1620 userError :: String -> IOError
1621 userError s = primRaise (ErrorCall s)
1622
1623 catch :: IO a -> (IOError -> IO a) -> IO a
1624 catch m k
1625   = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
1626     where
1627        e2ioe (IOExcept s) = IOError s
1628        e2ioe other        = IOError (show other)
1629
1630 putChar :: Char -> IO ()
1631 putChar c = nh_stdout >>= \h -> nh_write h c
1632
1633 putStr :: String -> IO ()
1634 putStr s = nh_stdout >>= \h ->
1635            let loop []     = nh_flush h
1636                loop (c:cs) = nh_write h c >> loop cs
1637            in  loop s
1638
1639 putStrLn :: String -> IO ()
1640 putStrLn s = do { putStr s; putChar '\n' }
1641
1642 print :: Show a => a -> IO ()
1643 print = putStrLn . show
1644
1645 getChar :: IO Char
1646 getChar = unsafeInterleaveIO (
1647           nh_stdin  >>= \h ->
1648           nh_read h >>= \ci ->
1649           return (primIntToChar ci)
1650           )
1651
1652 getLine :: IO String
1653 getLine    = do c <- getChar
1654                 if c=='\n' then return ""
1655                            else do cs <- getLine
1656                                    return (c:cs)
1657
1658 getContents :: IO String
1659 getContents = nh_stdin >>= \h -> readfromhandle h
1660
1661 interact  :: (String -> String) -> IO ()
1662 interact f = getContents >>= (putStr . f)
1663
1664 readFile :: FilePath -> IO String
1665 readFile fname
1666    = copy_String_to_cstring fname  >>= \ptr ->
1667      nh_open ptr 0                 >>= \h ->
1668      nh_free ptr                   >>
1669      nh_errno                      >>= \errno ->
1670      if   (isNullAddr h || errno /= 0)
1671      then (ioError.IOError) ("readFile: can't open file " ++ fname)
1672      else readfromhandle h
1673
1674 writeFile :: FilePath -> String -> IO ()
1675 writeFile fname contents
1676    = copy_String_to_cstring fname  >>= \ptr ->
1677      nh_open ptr 1                 >>= \h ->
1678      nh_free ptr                   >>
1679      nh_errno                      >>= \errno ->
1680      if   (isNullAddr h || errno /= 0)
1681      then (ioError.IOError) ("writeFile: can't create file " ++ fname)
1682      else writetohandle fname h contents
1683
1684 appendFile :: FilePath -> String -> IO ()
1685 appendFile fname contents
1686    = copy_String_to_cstring fname  >>= \ptr ->
1687      nh_open ptr 2                 >>= \h ->
1688      nh_free ptr                   >>
1689      nh_errno                      >>= \errno ->
1690      if   (isNullAddr h || errno /= 0)
1691      then (ioError.IOError) ("appendFile: can't open file " ++ fname)
1692      else writetohandle fname h contents
1693
1694
1695 -- raises an exception instead of an error
1696 readIO          :: Read a => String -> IO a
1697 readIO s         = case [x | (x,t) <- reads s, ("","") <- lex t] of
1698                         [x] -> return x
1699                         []  -> ioError (userError "PreludeIO.readIO: no parse")
1700                         _   -> ioError (userError
1701                                        "PreludeIO.readIO: ambiguous parse")
1702
1703 readLn          :: Read a => IO a
1704 readLn           = do l <- getLine
1705                       r <- readIO l
1706                       return r
1707
1708
1709 -- End of Hugs standard prelude ----------------------------------------------
1710
1711 data Exception
1712    = ErrorCall String
1713    | IOExcept  String
1714
1715 instance Show Exception where
1716    showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
1717    showsPrec _ (IOExcept s)  = showString ("I/O error: " ++ s)
1718
1719 data IOResult  = IOResult  deriving (Show)
1720
1721 type FILE_STAR = Addr   -- FILE *
1722
1723 foreign import "nHandle" "nh_stdin"    nh_stdin    :: IO FILE_STAR
1724 foreign import "nHandle" "nh_stdout"   nh_stdout   :: IO FILE_STAR
1725 foreign import "nHandle" "nh_stderr"   nh_stderr   :: IO FILE_STAR
1726 foreign import "nHandle" "nh_write"    nh_write    :: FILE_STAR -> Char -> IO ()
1727 foreign import "nHandle" "nh_read"     nh_read     :: FILE_STAR -> IO Int
1728 foreign import "nHandle" "nh_open"     nh_open     :: Addr -> Int -> IO FILE_STAR
1729 foreign import "nHandle" "nh_flush"    nh_flush    :: FILE_STAR -> IO ()
1730 foreign import "nHandle" "nh_close"    nh_close    :: FILE_STAR -> IO ()
1731 foreign import "nHandle" "nh_errno"    nh_errno    :: IO Int
1732
1733 foreign import "nHandle" "nh_malloc"   nh_malloc   :: Int -> IO Addr
1734 foreign import "nHandle" "nh_free"     nh_free     :: Addr -> IO ()
1735 foreign import "nHandle" "nh_store"    nh_store    :: Addr -> Char -> IO ()
1736 foreign import "nHandle" "nh_load"     nh_load     :: Addr -> IO Char
1737 foreign import "nHandle" "nh_getenv"   nh_getenv   :: Addr -> IO Addr
1738 foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int
1739 foreign import "nHandle" "nh_iseof"    nh_iseof    :: FILE_STAR -> IO Int
1740 foreign import "nHandle" "nh_system"   nh_system   :: Addr -> IO Int
1741 foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO ()
1742 foreign import "nHandle" "nh_getPID"   nh_getPID   :: IO Int
1743
1744 foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double
1745 foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double
1746
1747 copy_String_to_cstring :: String -> IO Addr
1748 copy_String_to_cstring s
1749    = nh_malloc (1 + length s) >>= \ptr0 ->
1750      let loop ptr []     = nh_store ptr (chr 0) >> return ptr0
1751          loop ptr (c:cs) = nh_store ptr c       >> loop (incAddr ptr) cs
1752      in
1753          if   isNullAddr ptr0
1754          then error "copy_String_to_cstring: malloc failed"
1755          else loop ptr0 s
1756
1757 copy_cstring_to_String :: Addr -> IO String
1758 copy_cstring_to_String ptr
1759    = nh_load ptr >>= \ci ->
1760      if   ci == '\0'
1761      then return []
1762      else copy_cstring_to_String (incAddr ptr) >>= \cs ->
1763           return (ci : cs)
1764
1765 readfromhandle :: FILE_STAR -> IO String
1766 readfromhandle h
1767    = unsafeInterleaveIO (
1768      nh_read h >>= \ci ->
1769      if ci == -1 {-EOF-} then return "" else
1770      readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
1771      )
1772
1773 writetohandle :: String -> FILE_STAR -> String -> IO ()
1774 writetohandle fname h []
1775    = nh_close h                  >>
1776      nh_errno                    >>= \errno ->
1777      if   errno == 0
1778      then return ()
1779      else error ( "writeFile/appendFile: error closing file " ++ fname)
1780 writetohandle fname h (c:cs)
1781    = nh_write h c >> writetohandle fname h cs
1782
1783 primGetRawArgs :: IO [String]
1784 primGetRawArgs
1785    = primGetArgc >>= \argc ->
1786      sequence (map get_one_arg [0 .. argc-1])
1787      where
1788         get_one_arg :: Int -> IO String
1789         get_one_arg argno
1790            = primGetArgv argno >>= \a ->
1791              copy_cstring_to_String a
1792
1793 primGetEnv :: String -> IO String
1794 primGetEnv v
1795    = copy_String_to_cstring v     >>= \ptr ->
1796      nh_getenv ptr                >>= \ptr2 ->
1797      nh_free ptr                  >>
1798      if   isNullAddr ptr2
1799      then return []
1800      else
1801      copy_cstring_to_String ptr2  >>= \result ->
1802      return result
1803
1804
1805 ------------------------------------------------------------------------------
1806 -- ST, IO --------------------------------------------------------------------
1807 ------------------------------------------------------------------------------
1808
1809 newtype ST s a = ST (s -> (a,s))
1810
1811 data RealWorld
1812 type IO a = ST RealWorld a
1813
1814 --primRunST :: (forall s. ST s a) -> a
1815 primRunST :: ST RealWorld a -> a
1816 primRunST m = fst (unST m theWorld)
1817    where
1818       theWorld :: RealWorld
1819       theWorld = error "primRunST: entered the RealWorld"
1820
1821 unST (ST a) = a
1822
1823 instance Functor (ST s) where
1824    fmap f x  = x >>= (return . f)
1825
1826 instance Monad (ST s) where
1827    m >> k    = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1828    return x  = ST (\s -> (x,s))
1829    m >>= k   = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1830
1831
1832 -- Library IO has a global variable which accumulates Handles
1833 -- as they are opened.  We keep here a second global variable
1834 -- into which a cleanup action may be specified.  When evaluation
1835 -- finishes, either normally or as a result of System.exitWith,
1836 -- this cleanup action is run, closing all known-about Handles.
1837 -- Doing it like this means the Prelude does not have to know
1838 -- anything about the grotty details of the Handle implementation.
1839 prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
1840 prelCleanupAfterRunAction = primRunST (newIORef Nothing)
1841
1842 -- used when Hugs invokes top level function
1843 hugsprimRunIO_toplevel :: IO a -> ()
1844 hugsprimRunIO_toplevel m
1845    = protect 5 (fst (unST composite_action realWorld))
1846      where
1847         composite_action
1848            = do writeIORef prelCleanupAfterRunAction Nothing
1849                 m
1850                 cleanup_handles <- readIORef prelCleanupAfterRunAction
1851                 case cleanup_handles of
1852                    Nothing -> return ()
1853                    Just xx -> xx
1854
1855         realWorld = error "primRunIO: entered the RealWorld"
1856         protect :: Int -> () -> ()
1857         protect 0 comp
1858            = comp
1859         protect n comp
1860            = primCatch (protect (n-1) comp)
1861                        (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1862
1863 trace, trace_quiet :: String -> a -> a
1864 trace s x
1865    = trace_quiet ("trace: " ++ s) x
1866 trace_quiet s x
1867    = (primRunST (putStr (s ++ "\n"))) `seq` x
1868
1869 unsafeInterleaveST :: ST s a -> ST s a
1870 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1871
1872 unsafeInterleaveIO :: IO a -> IO a
1873 unsafeInterleaveIO = unsafeInterleaveST
1874
1875
1876 ------------------------------------------------------------------------------
1877 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
1878 ------------------------------------------------------------------------------
1879
1880 data Addr
1881
1882 nullAddr     =  primIntToAddr 0
1883 incAddr a    =  primIntToAddr (1 + primAddrToInt a)
1884 isNullAddr a =  0 == primAddrToInt a
1885
1886 instance Eq Addr where
1887   (==)            = primEqAddr
1888   (/=)            = primNeAddr
1889
1890 instance Ord Addr where
1891   (<)             = primLtAddr
1892   (<=)            = primLeAddr
1893   (>=)            = primGeAddr
1894   (>)             = primGtAddr
1895
1896 data Word
1897
1898 instance Eq Word where
1899   (==)            = primEqWord
1900   (/=)            = primNeWord
1901
1902 instance Ord Word where
1903   (<)             = primLtWord
1904   (<=)            = primLeWord
1905   (>=)            = primGeWord
1906   (>)             = primGtWord
1907
1908 data StablePtr a
1909
1910 makeStablePtr   :: a -> IO (StablePtr a)
1911 makeStablePtr    = primMakeStablePtr
1912 deRefStablePtr  :: StablePtr a -> IO a
1913 deRefStablePtr   = primDeRefStablePtr
1914 freeStablePtr   :: StablePtr a -> IO ()
1915 freeStablePtr    = primFreeStablePtr
1916
1917
1918 data PrimArray              a -- immutable arrays with Int indices
1919 data PrimByteArray
1920
1921 data STRef                s a -- mutable variables
1922 data PrimMutableArray     s a -- mutable arrays with Int indices
1923 data PrimMutableByteArray s
1924
1925 newSTRef   :: a -> ST s (STRef s a)
1926 newSTRef    = primNewRef
1927 readSTRef  :: STRef s a -> ST s a
1928 readSTRef   = primReadRef
1929 writeSTRef :: STRef s a -> a -> ST s ()
1930 writeSTRef  = primWriteRef
1931
1932 type IORef a = STRef RealWorld a
1933 newIORef   :: a -> IO (IORef a)
1934 newIORef    = primNewRef
1935 readIORef  :: IORef a -> IO a
1936 readIORef   = primReadRef
1937 writeIORef :: IORef a -> a -> IO ()
1938 writeIORef  = primWriteRef
1939
1940
1941 ------------------------------------------------------------------------------
1942 -- ThreadId, MVar, concurrency stuff -----------------------------------------
1943 ------------------------------------------------------------------------------
1944
1945 data MVar a
1946
1947 newEmptyMVar :: IO (MVar a)
1948 newEmptyMVar = primNewEmptyMVar
1949
1950 putMVar :: MVar a -> a -> IO ()
1951 putMVar = primPutMVar
1952
1953 takeMVar :: MVar a -> IO a
1954 takeMVar m
1955    = ST (\world -> primTakeMVar m cont world)
1956      where
1957         -- cont :: a -> RealWorld -> (a,RealWorld)
1958         -- where 'a' is as in the top-level signature
1959         cont x world = (x,world)
1960
1961         -- the type of the handwritten BCO (threesome) primTakeMVar is
1962         -- primTakeMVar :: MVar a
1963         --                 -> (a -> RealWorld -> (a,RealWorld))
1964         --                 -> RealWorld
1965         --                 -> (a,RealWorld)
1966         --
1967         -- primTakeMVar behaves like this:
1968         --
1969         -- primTakeMVar (MVar# m#) cont world
1970         --    = primTakeMVar_wrk m# cont world
1971         --
1972         -- primTakeMVar_wrk m# cont world
1973         --    = cont (takeMVar# m#) world
1974         --
1975         -- primTakeMVar_wrk has the special property that it is
1976         -- restartable by the scheduler, should the MVar be empty.
1977
1978 newMVar :: a -> IO (MVar a)
1979 newMVar value =
1980     newEmptyMVar        >>= \ mvar ->
1981     putMVar mvar value  >>
1982     return mvar
1983
1984 readMVar :: MVar a -> IO a
1985 readMVar mvar =
1986     takeMVar mvar       >>= \ value ->
1987     putMVar mvar value  >>
1988     return value
1989
1990 swapMVar :: MVar a -> a -> IO a
1991 swapMVar mvar new =
1992     takeMVar mvar       >>= \ old ->
1993     putMVar mvar new    >>
1994     return old
1995
1996 instance Eq (MVar a) where
1997     m1 == m2 = primSameMVar m1 m2
1998
1999
2000 data ThreadId
2001
2002 instance Eq ThreadId where
2003    tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
2004
2005 instance Ord ThreadId where
2006    compare tid1 tid2
2007       = let r = primCmpThreadIds tid1 tid2
2008         in  if r < 0 then LT else if r > 0 then GT else EQ
2009
2010
2011 forkIO :: IO a -> IO ThreadId
2012 -- Simple version; doesn't catch exceptions in computation
2013 -- forkIO computation
2014 --    = primForkIO (primRunST computation)
2015
2016 forkIO computation
2017    = primForkIO (
2018         primCatch
2019            (unST computation realWorld `primSeq` ())
2020            (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
2021      )
2022      where
2023         realWorld = error "primForkIO: entered the RealWorld"
2024
2025
2026 -- showFloat ------------------------------------------------------------------
2027
2028 showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2029 showFFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2030 showGFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2031 showFloat      :: (RealFloat a) => a -> ShowS
2032
2033 showEFloat d x =  showString (formatRealFloat FFExponent d x)
2034 showFFloat d x =  showString (formatRealFloat FFFixed d x)
2035 showGFloat d x =  showString (formatRealFloat FFGeneric d x)
2036 showFloat      =  showGFloat Nothing
2037
2038 -- These are the format types.  This type is not exported.
2039
2040 data FFFormat = FFExponent | FFFixed | FFGeneric
2041
2042 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2043 formatRealFloat fmt decs x = s
2044   where base = 10
2045         s = if isNaN x then
2046                 "NaN"
2047             else if isInfinite x then
2048                 if x < 0 then "-Infinity" else "Infinity"
2049             else if x < 0 || isNegativeZero x then
2050                 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2051             else
2052                 doFmt fmt (floatToDigits (toInteger base) x)
2053         doFmt fmt (is, e) =
2054             let ds = map intToDigit is
2055             in  case fmt of
2056                 FFGeneric ->
2057                     doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2058                           (is, e)
2059                 FFExponent ->
2060                     case decs of
2061                     Nothing ->
2062                         case ds of
2063                          ['0'] -> "0.0e0"
2064                          [d]   -> d : ".0e" ++ show (e-1)
2065                          d:ds  -> d : '.' : ds ++ 'e':show (e-1)
2066                     Just dec ->
2067                         let dec' = max dec 1 in
2068                         case is of
2069                          [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2070                          _ ->
2071                           let (ei, is') = roundTo base (dec'+1) is
2072                               d:ds = map intToDigit
2073                                          (if ei > 0 then init is' else is')
2074                           in d:'.':ds  ++ "e" ++ show (e-1+ei)
2075                 FFFixed ->
2076                     case decs of
2077                     Nothing ->
2078                         let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2079                             f n s "" = f (n-1) (s++"0") ""
2080                             f n s (d:ds) = f (n-1) (s++[d]) ds
2081                             mk0 "" = "0"
2082                             mk0 s = s
2083                         in  f e "" ds
2084                     Just dec ->
2085                         let dec' = max dec 0 in
2086                         if e >= 0 then
2087                             let (ei, is') = roundTo base (dec' + e) is
2088                                 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2089                             in  (if null ls then "0" else ls) ++
2090                                 (if null rs then "" else '.' : rs)
2091                         else
2092                             let (ei, is') = roundTo base dec'
2093                                               (replicate (-e) 0 ++ is)
2094                                 d : ds = map intToDigit
2095                                             (if ei > 0 then is' else 0:is')
2096                             in  d : '.' : ds
2097
2098 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2099 roundTo base d is = case f d is of
2100                 (0, is) -> (0, is)
2101                 (1, is) -> (1, 1 : is)
2102   where b2 = base `div` 2
2103         f n [] = (0, replicate n 0)
2104         f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2105         f d (i:is) =
2106             let (c, ds) = f (d-1) is
2107                 i' = c + i
2108             in  if i' == base then (1, 0:ds) else (0, i':ds)
2109
2110 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2111 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2112 -- This version uses a much slower logarithm estimator.  It should be improved.
2113
2114 -- This function returns a list of digits (Ints in [0..base-1]) and an
2115 -- exponent.
2116
2117 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2118
2119 floatToDigits _ 0 = ([0], 0)
2120 floatToDigits base x =
2121     let (f0, e0) = decodeFloat x
2122         (minExp0, _) = floatRange x
2123         p = floatDigits x
2124         b = floatRadix x
2125         minExp = minExp0 - p            -- the real minimum exponent
2126         -- Haskell requires that f be adjusted so denormalized numbers
2127         -- will have an impossibly low exponent.  Adjust for this.
2128         (f, e) = let n = minExp - e0
2129                  in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2130
2131         (r, s, mUp, mDn) =
2132            if e >= 0 then
2133                let be = b^e in
2134                if f == b^(p-1) then
2135                    (f*be*b*2, 2*b, be*b, b)
2136                else
2137                    (f*be*2, 2, be, be)
2138            else
2139                if e > minExp && f == b^(p-1) then
2140                    (f*b*2, b^(-e+1)*2, b, 1)
2141                else
2142                    (f*2, b^(-e)*2, 1, 1)
2143         k =
2144             let k0 =
2145                     if b == 2 && base == 10 then
2146                          -- logBase 10 2 is slightly bigger than 3/10 so
2147                          -- the following will err on the low side.  Ignoring
2148                          -- the fraction will make it err even more.
2149                          -- Haskell promises that p-1 <= logBase b f < p.
2150                          (p - 1 + e0) * 3 `div` 10
2151                     else
2152                          ceiling ((log (fromInteger (f+1)) +
2153                                   fromInt e * log (fromInteger b)) /
2154                                    log (fromInteger base))
2155                 fixup n =
2156                     if n >= 0 then
2157                         if r + mUp <= expt base n * s then n else fixup (n+1)
2158                     else
2159                         if expt base (-n) * (r + mUp) <= s then n
2160                                                            else fixup (n+1)
2161             in  fixup k0
2162
2163         gen ds rn sN mUpN mDnN =
2164             let (dn, rn') = (rn * base) `divMod` sN
2165                 mUpN' = mUpN * base
2166                 mDnN' = mDnN * base
2167             in  case (rn' < mDnN', rn' + mUpN' > sN) of
2168                 (True,  False) -> dn : ds
2169                 (False, True)  -> dn+1 : ds
2170                 (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2171                 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2172         rds =
2173             if k >= 0 then
2174                 gen [] r (s * expt base k) mUp mDn
2175             else
2176                 let bk = expt base (-k)
2177                 in  gen [] (r * bk) s (mUp * bk) (mDn * bk)
2178     in  (map toInt (reverse rds), k)
2179
2180
2181 -- Exponentiation with a cache for the most common numbers.
2182 minExpt = 0::Int
2183 maxExpt = 1100::Int
2184 expt :: Integer -> Int -> Integer
2185 expt base n =
2186     if base == 2 && n >= minExpt && n <= maxExpt then
2187         expts !! (n-minExpt)
2188     else
2189         base^n
2190
2191 expts :: [Integer]
2192 expts = [2^n | n <- [minExpt .. maxExpt]]
2193