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
1810 --primRunST :: (forall s. ST s a) -> a
1811 primRunST :: ST RealWorld a -> a
1812 primRunST m = fst (unST m theWorld)
1813    where
1814       theWorld :: RealWorld
1815       theWorld = error "primRunST: entered the RealWorld"
1816
1817 unST (ST a) = a
1818
1819 instance Functor (ST s) where
1820    fmap f x  = x >>= (return . f)
1821
1822 instance Monad (ST s) where
1823    m >> k    = ST (\s -> case unST m s of { (a,s') -> unST k s' })
1824    return x  = ST (\s -> (x,s))
1825    m >>= k   = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
1826
1827
1828 -- Library IO has a global variable which accumulates Handles
1829 -- as they are opened.  We keep here a second global variable
1830 -- into which a cleanup action may be specified.  When evaluation
1831 -- finishes, either normally or as a result of System.exitWith,
1832 -- this cleanup action is run, closing all known-about Handles.
1833 -- Doing it like this means the Prelude does not have to know
1834 -- anything about the grotty details of the Handle implementation.
1835 prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
1836 prelCleanupAfterRunAction = primRunST (newIORef Nothing)
1837
1838 -- used when Hugs invokes top level function
1839 primRunIO_hugs_toplevel :: IO () -> ()
1840 primRunIO_hugs_toplevel m
1841    = protect 5 (fst (unST composite_action realWorld))
1842      where
1843         composite_action
1844            = do writeIORef prelCleanupAfterRunAction Nothing
1845                 m
1846                 cleanup_handles <- readIORef prelCleanupAfterRunAction
1847                 case cleanup_handles of
1848                    Nothing -> return ()
1849                    Just xx -> xx
1850
1851         realWorld = error "primRunIO: entered the RealWorld"
1852         protect :: Int -> () -> ()
1853         protect 0 comp
1854            = comp
1855         protect n comp
1856            = primCatch (protect (n-1) comp)
1857                        (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
1858
1859 trace, trace_quiet :: String -> a -> a
1860 trace s x
1861    = trace_quiet ("trace: " ++ s) x
1862 trace_quiet s x
1863    = (primRunST (putStr (s ++ "\n"))) `seq` x
1864
1865 unsafeInterleaveST :: ST s a -> ST s a
1866 unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
1867
1868 unsafeInterleaveIO :: IO a -> IO a
1869 unsafeInterleaveIO = unsafeInterleaveST
1870
1871
1872 ------------------------------------------------------------------------------
1873 -- Word, Addr, StablePtr, Prim*Array -----------------------------------------
1874 ------------------------------------------------------------------------------
1875
1876 data Addr
1877
1878 nullAddr     =  primIntToAddr 0
1879 incAddr a    =  primIntToAddr (1 + primAddrToInt a)
1880 isNullAddr a =  0 == primAddrToInt a
1881
1882 instance Eq Addr where
1883   (==)            = primEqAddr
1884   (/=)            = primNeAddr
1885
1886 instance Ord Addr where
1887   (<)             = primLtAddr
1888   (<=)            = primLeAddr
1889   (>=)            = primGeAddr
1890   (>)             = primGtAddr
1891
1892 data Word
1893
1894 instance Eq Word where
1895   (==)            = primEqWord
1896   (/=)            = primNeWord
1897
1898 instance Ord Word where
1899   (<)             = primLtWord
1900   (<=)            = primLeWord
1901   (>=)            = primGeWord
1902   (>)             = primGtWord
1903
1904 data StablePtr a
1905
1906 makeStablePtr   :: a -> IO (StablePtr a)
1907 makeStablePtr    = primMakeStablePtr
1908 deRefStablePtr  :: StablePtr a -> IO a
1909 deRefStablePtr   = primDeRefStablePtr
1910 freeStablePtr   :: StablePtr a -> IO ()
1911 freeStablePtr    = primFreeStablePtr
1912
1913
1914 data PrimArray              a -- immutable arrays with Int indices
1915 data PrimByteArray
1916
1917 data STRef                s a -- mutable variables
1918 data PrimMutableArray     s a -- mutable arrays with Int indices
1919 data PrimMutableByteArray s
1920
1921 newSTRef   :: a -> ST s (STRef s a)
1922 newSTRef    = primNewRef
1923 readSTRef  :: STRef s a -> ST s a
1924 readSTRef   = primReadRef
1925 writeSTRef :: STRef s a -> a -> ST s ()
1926 writeSTRef  = primWriteRef
1927
1928 type IORef a = STRef RealWorld a
1929 newIORef   :: a -> IO (IORef a)
1930 newIORef    = primNewRef
1931 readIORef  :: IORef a -> IO a
1932 readIORef   = primReadRef
1933 writeIORef :: IORef a -> a -> IO ()
1934 writeIORef  = primWriteRef
1935
1936
1937 ------------------------------------------------------------------------------
1938 -- ThreadId, MVar, concurrency stuff -----------------------------------------
1939 ------------------------------------------------------------------------------
1940
1941 data MVar a
1942
1943 newEmptyMVar :: IO (MVar a)
1944 newEmptyMVar = primNewEmptyMVar
1945
1946 putMVar :: MVar a -> a -> IO ()
1947 putMVar = primPutMVar
1948
1949 takeMVar :: MVar a -> IO a
1950 takeMVar m
1951    = ST (\world -> primTakeMVar m cont world)
1952      where
1953         -- cont :: a -> RealWorld -> (a,RealWorld)
1954         -- where 'a' is as in the top-level signature
1955         cont x world = (x,world)
1956
1957         -- the type of the handwritten BCO (threesome) primTakeMVar is
1958         -- primTakeMVar :: MVar a
1959         --                 -> (a -> RealWorld -> (a,RealWorld))
1960         --                 -> RealWorld
1961         --                 -> (a,RealWorld)
1962         --
1963         -- primTakeMVar behaves like this:
1964         --
1965         -- primTakeMVar (MVar# m#) cont world
1966         --    = primTakeMVar_wrk m# cont world
1967         --
1968         -- primTakeMVar_wrk m# cont world
1969         --    = cont (takeMVar# m#) world
1970         --
1971         -- primTakeMVar_wrk has the special property that it is
1972         -- restartable by the scheduler, should the MVar be empty.
1973
1974 newMVar :: a -> IO (MVar a)
1975 newMVar value =
1976     newEmptyMVar        >>= \ mvar ->
1977     putMVar mvar value  >>
1978     return mvar
1979
1980 readMVar :: MVar a -> IO a
1981 readMVar mvar =
1982     takeMVar mvar       >>= \ value ->
1983     putMVar mvar value  >>
1984     return value
1985
1986 swapMVar :: MVar a -> a -> IO a
1987 swapMVar mvar new =
1988     takeMVar mvar       >>= \ old ->
1989     putMVar mvar new    >>
1990     return old
1991
1992 instance Eq (MVar a) where
1993     m1 == m2 = primSameMVar m1 m2
1994
1995
1996 data ThreadId
1997
1998 instance Eq ThreadId where
1999    tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
2000
2001 instance Ord ThreadId where
2002    compare tid1 tid2
2003       = let r = primCmpThreadIds tid1 tid2
2004         in  if r < 0 then LT else if r > 0 then GT else EQ
2005
2006
2007 forkIO :: IO a -> IO ThreadId
2008 -- Simple version; doesn't catch exceptions in computation
2009 -- forkIO computation
2010 --    = primForkIO (primRunST computation)
2011
2012 forkIO computation
2013    = primForkIO (
2014         primCatch
2015            (unST computation realWorld `primSeq` ())
2016            (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
2017      )
2018      where
2019         realWorld = error "primForkIO: entered the RealWorld"
2020
2021
2022 -- showFloat ------------------------------------------------------------------
2023
2024 showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2025 showFFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2026 showGFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
2027 showFloat      :: (RealFloat a) => a -> ShowS
2028
2029 showEFloat d x =  showString (formatRealFloat FFExponent d x)
2030 showFFloat d x =  showString (formatRealFloat FFFixed d x)
2031 showGFloat d x =  showString (formatRealFloat FFGeneric d x)
2032 showFloat      =  showGFloat Nothing
2033
2034 -- These are the format types.  This type is not exported.
2035
2036 data FFFormat = FFExponent | FFFixed | FFGeneric
2037
2038 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
2039 formatRealFloat fmt decs x = s
2040   where base = 10
2041         s = if isNaN x then
2042                 "NaN"
2043             else if isInfinite x then
2044                 if x < 0 then "-Infinity" else "Infinity"
2045             else if x < 0 || isNegativeZero x then
2046                 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
2047             else
2048                 doFmt fmt (floatToDigits (toInteger base) x)
2049         doFmt fmt (is, e) =
2050             let ds = map intToDigit is
2051             in  case fmt of
2052                 FFGeneric ->
2053                     doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
2054                           (is, e)
2055                 FFExponent ->
2056                     case decs of
2057                     Nothing ->
2058                         case ds of
2059                          ['0'] -> "0.0e0"
2060                          [d]   -> d : ".0e" ++ show (e-1)
2061                          d:ds  -> d : '.' : ds ++ 'e':show (e-1)
2062                     Just dec ->
2063                         let dec' = max dec 1 in
2064                         case is of
2065                          [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
2066                          _ ->
2067                           let (ei, is') = roundTo base (dec'+1) is
2068                               d:ds = map intToDigit
2069                                          (if ei > 0 then init is' else is')
2070                           in d:'.':ds  ++ "e" ++ show (e-1+ei)
2071                 FFFixed ->
2072                     case decs of
2073                     Nothing ->
2074                         let f 0 s ds = mk0 s ++ "." ++ mk0 ds
2075                             f n s "" = f (n-1) (s++"0") ""
2076                             f n s (d:ds) = f (n-1) (s++[d]) ds
2077                             mk0 "" = "0"
2078                             mk0 s = s
2079                         in  f e "" ds
2080                     Just dec ->
2081                         let dec' = max dec 0 in
2082                         if e >= 0 then
2083                             let (ei, is') = roundTo base (dec' + e) is
2084                                 (ls, rs) = splitAt (e+ei) (map intToDigit is')
2085                             in  (if null ls then "0" else ls) ++
2086                                 (if null rs then "" else '.' : rs)
2087                         else
2088                             let (ei, is') = roundTo base dec'
2089                                               (replicate (-e) 0 ++ is)
2090                                 d : ds = map intToDigit
2091                                             (if ei > 0 then is' else 0:is')
2092                             in  d : '.' : ds
2093
2094 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
2095 roundTo base d is = case f d is of
2096                 (0, is) -> (0, is)
2097                 (1, is) -> (1, 1 : is)
2098   where b2 = base `div` 2
2099         f n [] = (0, replicate n 0)
2100         f 0 (i:_) = (if i >= b2 then 1 else 0, [])
2101         f d (i:is) =
2102             let (c, ds) = f (d-1) is
2103                 i' = c + i
2104             in  if i' == base then (1, 0:ds) else (0, i':ds)
2105
2106 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
2107 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
2108 -- This version uses a much slower logarithm estimator.  It should be improved.
2109
2110 -- This function returns a list of digits (Ints in [0..base-1]) and an
2111 -- exponent.
2112
2113 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
2114
2115 floatToDigits _ 0 = ([0], 0)
2116 floatToDigits base x =
2117     let (f0, e0) = decodeFloat x
2118         (minExp0, _) = floatRange x
2119         p = floatDigits x
2120         b = floatRadix x
2121         minExp = minExp0 - p            -- the real minimum exponent
2122         -- Haskell requires that f be adjusted so denormalized numbers
2123         -- will have an impossibly low exponent.  Adjust for this.
2124         (f, e) = let n = minExp - e0
2125                  in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
2126
2127         (r, s, mUp, mDn) =
2128            if e >= 0 then
2129                let be = b^e in
2130                if f == b^(p-1) then
2131                    (f*be*b*2, 2*b, be*b, b)
2132                else
2133                    (f*be*2, 2, be, be)
2134            else
2135                if e > minExp && f == b^(p-1) then
2136                    (f*b*2, b^(-e+1)*2, b, 1)
2137                else
2138                    (f*2, b^(-e)*2, 1, 1)
2139         k =
2140             let k0 =
2141                     if b == 2 && base == 10 then
2142                          -- logBase 10 2 is slightly bigger than 3/10 so
2143                          -- the following will err on the low side.  Ignoring
2144                          -- the fraction will make it err even more.
2145                          -- Haskell promises that p-1 <= logBase b f < p.
2146                          (p - 1 + e0) * 3 `div` 10
2147                     else
2148                          ceiling ((log (fromInteger (f+1)) +
2149                                   fromInt e * log (fromInteger b)) /
2150                                    log (fromInteger base))
2151                 fixup n =
2152                     if n >= 0 then
2153                         if r + mUp <= expt base n * s then n else fixup (n+1)
2154                     else
2155                         if expt base (-n) * (r + mUp) <= s then n
2156                                                            else fixup (n+1)
2157             in  fixup k0
2158
2159         gen ds rn sN mUpN mDnN =
2160             let (dn, rn') = (rn * base) `divMod` sN
2161                 mUpN' = mUpN * base
2162                 mDnN' = mDnN * base
2163             in  case (rn' < mDnN', rn' + mUpN' > sN) of
2164                 (True,  False) -> dn : ds
2165                 (False, True)  -> dn+1 : ds
2166                 (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds
2167                 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
2168         rds =
2169             if k >= 0 then
2170                 gen [] r (s * expt base k) mUp mDn
2171             else
2172                 let bk = expt base (-k)
2173                 in  gen [] (r * bk) s (mUp * bk) (mDn * bk)
2174     in  (map toInt (reverse rds), k)
2175
2176
2177 -- Exponentiation with a cache for the most common numbers.
2178 minExpt = 0::Int
2179 maxExpt = 1100::Int
2180 expt :: Integer -> Int -> Integer
2181 expt base n =
2182     if base == 2 && n >= minExpt && n <= maxExpt then
2183         expts !! (n-minExpt)
2184     else
2185         base^n
2186
2187 expts :: [Integer]
2188 expts = [2^n | n <- [minExpt .. maxExpt]]
2189