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