ghc/lib/hugs/Prelude.hs

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