ghc/lib/hugs/Prelude.hs

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