ghc/lib/hugs/PrimPrel.hs

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