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