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