ghc/lib/hugs/Prelude.hs

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