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