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