ghc/lib/hugs/PrimPrel.hs

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