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