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