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