OS/2 Shareware BBS: 10 Tools/10-Tools.zip/hugs101o.zip/Progs/HUGS/hugs.prelude

Text File | 1995-03-02 | 64KB | 1,692 lines

-----------------------------------------------------------------------------
--        ___    ___   ___    ___   __________   __________           --
--       /  /   /  /  /  /   /  /  /  _______/  /  _______/   Version 1.01 --
--      /  /___/  /  /  /   /  /  /  / _____   /  /______           --
--     /  ____   /  /  /   /  /  /  / /_   /  /______   /     Copyright    --
--    /  /   /  /  /  /___/  /  /  /___/  /  _______/  /      Mark P Jones --
--   /__/   /__/  /_________/  /_________/  /_________/       1994, 1995   --
--                                       --
--   The Haskell User's Gofer System.   Derived from Gofer 2.30b.       --
--                                       --
--   This is the Hugs Standard Prelude, based very closely on the Standard --
--   Prelude for Haskell 1.2.                           --
--                                       --
--   Hugs is subject to conditions of use and distribution; see the file   --
--   "NOTICE" included with the main distribution for further details.     --
--                                                                         --
--   WARNING: This file is an integral part of the Hugs source code.       --
--   Changes to the definitions in this file without corresponding         --
--   modifications in other parts of the program may cause the interpreter --
--   to fail unexpectedly.  Under normal circumstances, you should not       --
--   attempt to modify this file in any way!  If you want to use a system  --
--   where the prelude file can be changed, try Gofer instead.           --
--                                       --
-----------------------------------------------------------------------------

-- Standard value bindings {Prelude} ----------------------------------------

infixr 9  .
infixl 9  !!, !, //
infixr 8  ^, ^^, **
          -- Fixities for the following operators are taken from the
          -- prelude listing in Appendix A of the Haskell report.
          -- Note that there are some discrepancies w.r.t. Section 5.7.
infixl 7  *, /, `quot`, `rem`, `div`, `mod`, :%, %
infix  6  :+
infixl 6  +, -
infix  5  \\
infixr 5  :, ++
infix  4  ==, /=, <, <=, >=, >, `elem`, `notElem`
infixr 3  &&
infixr 2  ||
infix  1  :=
infixr 0  $

-- Binary functions ---------------------------------------------------------

nullBin   :: Bin
nullBin    = noBinTypeInHugs

isNullBin :: Bin -> Bool
isNullBin  = noBinTypeInHugs

appendBin :: Bin -> Bin -> Bin
appendBin  = noBinTypeInHugs

noBinTypeInHugs = error "There is no Bin type in Hugs"

-- Boolean functions --------------------------------------------------------

(&&), (||)     :: Bool -> Bool -> Bool
False && x      = False
True  && x      = x
False || x      = x
True  || x      = True

not            :: Bool -> Bool
not True        = False
not False       = True

otherwise      :: Bool
otherwise       = True

-- Character functions ------------------------------------------------------

minChar, maxChar      :: Char
minChar                = '\0'
maxChar                = '\255'

primitive ord "primCharToInt" :: Char -> Int
primitive chr "primIntToChar" :: Int -> Char

isAscii, isControl, isPrint, isSpace            :: Char -> Bool
isUpper, isLower, isAlpha, isDigit, isAlphanum  :: Char -> Bool

isAscii c              =  ord c < 128
isControl c            =  c < ' ' ||  c == '\DEL'
isPrint c              =  c >= ' ' &&  c <= '~'
isSpace c              =  c == ' ' || c == '\t' || c == '\n' ||
                  c == '\r' || c == '\f' || c == '\v'
isUpper c              =  c >= 'A'   &&  c <= 'Z'
isLower c              =  c >= 'a'   &&  c <= 'z'
isAlpha c              =  isUpper c  ||  isLower c
isDigit c              =  c >= '0'   &&  c <= '9'
isAlphanum c           =  isAlpha c  ||  isDigit c

toUpper, toLower      :: Char -> Char
toUpper c | isLower c  = chr (ord c - ord 'a' + ord 'A')
          | otherwise  = c

toLower c | isUpper c  = chr (ord c - ord 'A' + ord 'a')
          | otherwise  = c

-- Numeric functions --------------------------------------------------------

primitive minInt "primMinInt", maxInt "primMaxInt" :: Int

subtract       :: Num a => a -> a -> a
subtract        = flip (-)

gcd            :: Integral a => a -> a -> a
gcd 0 0         = error "gcd{Prelude}: gcd 0 0 is undefined"
gcd x y         = gcd' (abs x) (abs y)
                  where gcd' x 0 = x
                        gcd' x y = gcd' y (x `rem` y)

lcm            :: (Integral a) => a -> a -> a
lcm _ 0         = 0
lcm 0 _         = 0
lcm x y         = abs ((x `quot` gcd x y) * y)

(^)            :: (Num a, Integral b) => a -> b -> a
x ^ 0           = 1
x ^ (n+1)       = f x n x
                  where f _ 0 y = y
                        f x n y = g x n where
                                  g x n | even n    = g (x*x) (n`quot`2)
                                        | otherwise = f x (n-1) (x*y)
_ ^ _           = error "(^){Prelude}: negative exponent"

(^^)           :: (Fractional a, Integral b) => a -> b -> a
x ^^ n          = if n >= 0 then x ^ n else recip (x^(-n))

fromIntegral   :: (Integral a, Num b) => a -> b
fromIntegral    = fromInteger . toInteger

fromRealFrac   :: (RealFrac a, Fractional b) => a -> b
fromRealFrac    = fromRational . toRational

atan2          :: (RealFloat a) => a -> a -> a
atan2 y x       = case (signum y, signum x) of
                    ( 0, 1) ->  0
                    ( 1, 0) ->  pi/2
                    ( 0,-1) ->  pi
                    (-1, 0) -> -pi/2
            ( _, 1) -> atan (y/x)
            ( _,-1) -> atan (y/x) + pi
            ( 0, 0) -> error "atan2{Prelude}: atan2 of origin"

-- Some standard functions --------------------------------------------------
-- component projections for pairs:
fst            :: (a,b) -> a
fst (x,_)       = x

snd            :: (a,b) -> b
snd (_,y)       = y

-- identity function
id             :: a -> a
id    x         = x

-- constant function
const          :: a -> b -> a
const k _       = k

-- function composition
(.)           :: (b -> c) -> (a -> b) -> (a -> c)
(f . g) x       = f (g x)

-- flip f takes its (first) two arguuments in the reverse order of f.
flip           :: (a -> b -> c) -> b -> a -> c
flip  f x y     = f y x

-- right associative infix application operator (useful in continuation-
-- passing style)
($)            :: (a -> b) -> a -> b     -- pronounced as `apply' elsewhere
f $ x           = f x

-- until p f  yields the result of applying f until p holds
until                  :: (a -> Bool) -> (a -> a) -> a -> a
until p f x | p x       = x
            | otherwise = until p f (f x)

-- asTypeOf is a type restricted version of const.  It is usually used
-- as an infix operator, and its typing forces its first argument
-- (which is usually overloaded) to have the same type as the second.
asTypeOf               :: a -> a -> a
asTypeOf                = const

-- error is applied to a string, returns any type, and is everywhere
-- undefined.  Operationally, the intent is that its application
-- terminates execution of the program and displays the argument
-- string in some appropriate way.
primitive error "primError" :: String -> a

-- strict is not defined in the Haskell prelude, but Hugs doesn't have a
-- strictness analyzer and it's occasionally useful to be able to exercise
-- some added degree over the order of evaluation.
primitive strict "primStrict" :: (a -> b) -> a -> b

-- Standard types, classes and instances {PreludeCore} ----------------------

-- Equality and Ordered classes ---------------------------------------------

class Eq a where
    (==), (/=) :: a -> a -> Bool
    x /= y      = not (x==y)

-- ordcmp is a new variation on an old idea;  ordcmp x y r  returns
-- True if x>y, False if x<y and r otherwise.  The conventional ordering
-- operators are defined in terms of ordcmp, but a default definition of
-- ordcmp is also provided just in case.  It is an error (but not detected
-- by the compiler) for the programmer to omit definitions both for <=
-- and for ordcmp.  It will also be assumed that the ordering is consistent
-- with the equality.
--        e.g. ordcmp (x:xs) (y:ys) = ordcmp x y . ordcmp xs ys
--
-- Unlike Haskell 1.2, we now assume that orderings are total.

class (Eq a) => Ord a where
    ordcmp               :: a -> a -> Bool -> Bool
    (<), (<=), (>=), (>) :: a -> a -> Bool
    max, min             :: a -> a -> a

--  ordcmp x y r          = ... define in terms of <= and == only and be
--                careful not to eval r until it is needed ...
    ordcmp x y r          = if x<=y then (x==y && r) else True

    x >  y                = ordcmp x y False
    x >= y                = ordcmp x y True
    x <  y                = ordcmp y x False
    x <= y                = ordcmp y x True

    max x y | x >= y      = x
            | otherwise   = y
    min x y | x <= y      = x
            | otherwise   = y

-- Numeric classes ----------------------------------------------------------

class (Eq a, Text a) => Num a where
    (+), (-), (*)  :: a -> a -> a
    negate         :: a -> a
    abs, signum    :: a -> a
    fromInteger    :: Integer -> a
    fromInt        :: Int -> a

    x - y           = x + negate y

class (Num a, Enum a) => Real a where
    toRational     :: a -> Rational

class (Real a, Ix a) => Integral a where
    quot, rem, div, mod :: a -> a -> a
    quotRem, divMod     :: a -> a -> (a,a)
    even, odd           :: a -> Bool
    toInteger           :: a -> Integer
    toInt               :: a -> Int

    n `quot` d           = q where (q,r) = quotRem n d
    n `rem` d            = r where (q,r) = quotRem n d
    n `div` d            = q where (q,r) = divMod n d
    n `mod` d            = r where (q,r) = divMod n d
    divMod n d           = if signum r == - signum d then (q-1, r+d) else qr
               where qr@(q,r) = quotRem n d
    even n               = n `rem` 2 == 0
    odd                  = not . even

class (Num a) => Fractional a where
    (/)          :: a -> a -> a
    recip        :: a -> a
    fromRational :: Rational -> a
    fromDouble   :: Double -> a

    recip x       = 1 / x

class (Fractional a) => Floating a where
    pi                  :: a
    exp, log, sqrt      :: a -> a
    (**), logBase       :: a -> a -> a
    sin, cos, tan       :: a -> a
    asin, acos, atan    :: a -> a
    sinh, cosh, tanh    :: a -> a
    asinh, acosh, atanh :: a -> a

    x ** y               = exp (log x * y)
    logBase x y          = log y / log x
    sqrt x               = x ** 0.5
    tan x                = sin x / cos x
    sinh x               = (exp x - exp (-x)) / 2
    cosh x               = (exp x + exp (-x)) / 2
    tanh x               = sinh x / cosh x
    asinh x              = log (x + sqrt (x*x + 1))
    acosh x              = log (x + sqrt (x*x - 1))
    atanh x              = (log (1 + x) - log (1 - x)) / 2

class (Real a, Fractional a) => RealFrac a where
    properFraction   :: (Integral b) => a -> (b,a)
    truncate, round  :: (Integral b) => a -> b
    ceiling, floor   :: (Integral b) => a -> b

    truncate x        = m where (m,_) = properFraction x

    round x           = let (n,r) = properFraction x
                            m     = if r < 0 then n - 1 else n + 1
                        in case signum (abs r - 0.5) of
                            -1 -> n
                            0  -> if even n then n else m
                            1  -> m

    ceiling x         = if r > 0 then n + 1 else n
                        where (n,r) = properFraction x

    floor x           = if r < 0 then n - 1 else n
                        where (n,r) = properFraction x

class (RealFrac a, Floating a) => RealFloat a where
    floatRadix       :: a -> Integer
    floatDigits      :: a -> Int
    floatRange       :: a -> (Int,Int)
    decodeFloat      :: a -> (Integer,Int)
    encodeFloat      :: Integer -> Int -> a
    exponent         :: a -> Int
    significand      :: a -> a
    scaleFloat       :: Int -> a -> a

    exponent x        = if m==0 then 0 else n + floatDigits x
                        where (m,n) = decodeFloat x
    significand x     = encodeFloat m (- floatDigits x)
                        where (m,_) = decodeFloat x
    scaleFloat k x    = encodeFloat m (n+k)
                        where (m,n) = decodeFloat x

-- Index and Enumeration classes --------------------------------------------

class (Ord a) => Ix a where
    range                :: (a,a) -> [a]
    index                :: (a,a) -> a -> Int
    inRange              :: (a,a) -> a -> Bool

class (Ord a) => Enum a where
    enumFrom             :: a -> [a]              -- [n..]
    enumFromThen         :: a -> a -> [a]         -- [n,m..]
    enumFromTo           :: a -> a -> [a]         -- [n..m]
    enumFromThenTo       :: a -> a -> a -> [a]    -- [n,n'..m]

    enumFromTo n m        = takeWhile (m>=) (enumFrom n)
    enumFromThenTo n n' m = takeWhile ((if n'>=n then (>=) else (<=)) m)
                                      (enumFromThen n n')

-- Text class ---------------------------------------------------------------

type  ReadS a = String -> [(a,String)]
type  ShowS   = String -> String

class Text a where
    readsPrec :: Int -> ReadS a
    showsPrec :: Int -> a -> ShowS
    readList  :: ReadS [a]
    showList  :: [a] -> ShowS

    readList        = readParen False (\r -> [pr | ("[",s) <- lex r,
                           pr      <- readl s ])
              where readl  s = [([],t)   | ("]",t) <- lex s] ++
                                       [(x:xs,u) | (x,t)   <- reads s,
                           (xs,u)  <- readl' t]
                    readl' s = [([],t)   | ("]",t) <- lex s] ++
                                       [(x:xs,v) | (",",t) <- lex s,
                           (x,u)   <- reads t,
                           (xs,v)  <- readl' u]

    showList []     = showString "[]"
    showList (x:xs) = showChar '[' . shows x . showl xs
                      where showl []     = showChar ']'
                            showl (x:xs) = showChar ',' . shows x . showl xs

-- Binary class -------------------------------------------------------------

-- Although Hugs does not provide any operations on the binary datatype, Bin,
-- we include the definition of the Binary class here for compatibility with
-- Haskell ... all of this may go in later versions of Haskell and Hugs.
class Binary a where
    readBin :: Bin -> (a,Bin)
    showBin :: a -> Bin -> Bin

    readBin  = noBinTypeInHugs
    showBin  = noBinTypeInHugs

-- Trivial type -------------------------------------------------------------

-- data () = () deriving (Eq, Ord, Ix, Enum, Text, Binary)

instance Eq () where
    () == ()  =  True

instance Ord () where
    ordcmp () () s = s

instance Ix () where
    range ((),())      = [()]
    index ((),()) ()   = 0
    inRange ((),()) () = True

instance Enum () where
    enumFrom ()        = [()]
    enumFromThen () () = [()]

instance Text () where
    readsPrec p    = readParen False
                            (\r -> [((),t) | ("(",s) <- lex r,
                                             (")",t) <- lex s ])
    showsPrec p () = showString "()"

instance Binary ()

-- Binary type --------------------------------------------------------------

instance Text Bin where
    readsPrec p s = error "readsPrec{PreludeText}: Cannot read Bin"
    showsPrec d b = showString "<<Bin>>>"

-- Boolean type -------------------------------------------------------------

data Bool = False | True deriving (Eq, Ord, Ix, Enum, Text, Binary)

-- Character type -----------------------------------------------------------

primitive primEqChar   "primEqChar",
      primLeChar   "primLeChar"  :: Char -> Char -> Bool

instance Eq Char  where (==) = primEqChar   -- c == d  =  ord c == ord d
instance Ord Char where (<=) = primLeChar   -- c <= d  =  ord c <= ord d

instance Ix Char where
    range (c,c')      = [c..c']
    index b@(c,c') ci
       | inRange b ci = ord ci - ord c
       | otherwise    = error "index{PreludeCore}: Index out of range"
    inRange (c,c') ci = ord c <= i && i <= ord c'
                        where i = ord ci

instance Enum Char where
    enumFrom c        = map chr [ord c .. ord maxChar]
    enumFromThen c c' = map chr [ord c, ord c' .. ord lastChar]
                        where lastChar = if c' < c then minChar else maxChar

instance Text Char where
    readsPrec p      = readParen False
                            (\r -> [(c,t) | ('\'':s,t) <- lex r,
                                            (c,_)      <- readLitChar s])
    showsPrec p '\'' = showString "'\\''"
    showsPrec p c    = showChar '\'' . showLitChar c . showChar '\''

    readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
                                               (l,_)      <- readl s ])
               where readl ('"':s)      = [("",s)]
                     readl ('\\':'&':s) = readl s
                     readl s            = [(c:cs,u) | (c ,t) <- readLitChar s,
                                                      (cs,u) <- readl t ]

    showList cs   = showChar '"' . showl cs
                    where showl ""       = showChar '"'
                          showl ('"':cs) = showString "\\\"" . showl cs
                          showl (c:cs)   = showChar c . showl cs
              -- Haskell has   showLitChar c . showl cs

type String = [Char]

-- Standard Integral types --------------------------------------------------

primitive primEqInt      "primEqInt"     :: Int -> Int -> Bool
primitive primCmpInt     "primCmpInt"    :: Int -> Int -> Bool -> Bool
primitive primEqInteger  "primEqInteger" :: Integer -> Integer -> Bool
primitive primCmpInteger "primCmpInteger":: Integer -> Integer -> Bool -> Bool

instance Eq  Int     where (==)   = primEqInt
instance Eq  Integer where (==)   = primEqInteger
instance Ord Int     where ordcmp = primCmpInt
instance Ord Integer where ordcmp = primCmpInteger

primitive primPlusInt      "primPlusInt",
      primMinusInt     "primMinusInt",
      primMulInt       "primMulInt"       :: Int -> Int -> Int
primitive primNegInt       "primNegInt"       :: Int -> Int
primitive primIntegerToInt "primIntegerToInt" :: Integer -> Int

instance Num Int where
    (+)           = primPlusInt
    (-)           = primMinusInt
    negate        = primNegInt
    (*)           = primMulInt
    abs           = absReal
    signum        = signumReal
    fromInteger   = primIntegerToInt
    fromInt x     = x

primitive primPlusInteger  "primPlusInteger",
      primMinusInteger "primMinusInteger",
      primMulInteger   "primMulInteger"   :: Integer -> Integer -> Integer
primitive primNegInteger   "primNegInteger"   :: Integer -> Integer
primitive primIntToInteger "primIntToInteger" :: Int -> Integer

instance Num Integer where
    (+)           = primPlusInteger
    (-)           = primMinusInteger
    negate        = primNegInteger
    (*)           = primMulInteger
    abs           = absReal
    signum        = signumReal
    fromInteger x = x
    fromInt       = primIntToInteger

absReal x    | x >= 0    = x
             | otherwise = -x

signumReal x | x == 0    =  0
             | x > 0     =  1
             | otherwise = -1

instance Real Int where
    toRational x = toInteger x % 1

instance Real Integer where
    toRational x = x % 1

primitive primDivInt  "primDivInt",
      primQuotInt "primQuotInt",
          primRemInt  "primRemInt",
          primModInt  "primModInt"    :: Int -> Int -> Int

instance Integral Int where
    div         = primDivInt
    quot        = primQuotInt
    rem         = primRemInt
    mod         = primModInt
    quotRem n d = (n `quot` d, n `rem` d)
    toInteger   = primIntToInteger
    toInt x     = x

primitive primQrmInteger  "primQrmInteger"
        :: Integer -> Integer -> (Integer,Integer)
primitive primEvenInteger  "primEvenInteger"  :: Integer -> Bool

instance Integral Integer where
    quotRem     = primQrmInteger
    even        = primEvenInteger
    toInteger x = x
    toInt       = primIntegerToInt

instance Ix Int where
    range (m,n)          = [m..n]
    index b@(m,n) i
           | inRange b i = i - m
           | otherwise   = error "index{PreludeCore}: Index out of range"
    inRange (m,n) i      = m <= i && i <= n

instance Ix Integer where
    range (m,n)          = [m..n]
    index b@(m,n) i
           | inRange b i = fromInteger (i - m)
           | otherwise   = error "index{PreludeCore}: Index out of range"
    inRange (m,n) i      = m <= i && i <= n

instance Enum Int where
    enumFrom     = numericEnumFrom
    enumFromThen = numericEnumFromThen

instance Enum Integer where
    enumFrom     = numericEnumFrom
    enumFromThen = numericEnumFromThen

numericEnumFrom        :: Real a => a -> [a]
numericEnumFromThen    :: Real a => a -> a -> [a]
numericEnumFrom         = iterate (1+)
numericEnumFromThen n m = iterate ((m-n)+) n

primitive primShowsInt "primShowsInt" :: Int -> Int -> ShowS

instance Text Int where
    readsPrec p = readSigned readDec
    showsPrec   = primShowsInt

primitive primShowsInteger "primShowsInteger" :: Int -> Integer -> ShowS

instance Text Integer where
    readsPrec p = readSigned readDec
    showsPrec   = primShowsInteger

-- Standard Floating types --------------------------------------------------

primitive primEqFloat    "primEqFloat",
          primLeFloat    "primLeFloat"    :: Float -> Float -> Bool
primitive primEqDouble   "primEqDouble",
          primLeDouble   "primLeDouble"   :: Double -> Double -> Bool

instance Eq  Float  where (==) = primEqFloat
instance Eq  Double where (==) = primEqDouble

instance Ord Float  where (<=) = primLeFloat
instance Ord Double where (<=) = primLeDouble

primitive primPlusFloat  "primPlusFloat",
          primMinusFloat "primMinusFloat",
          primMulFloat   "primMulFloat"   :: Float -> Float -> Float
primitive primNegFloat   "primNegFloat"   :: Float -> Float
primitive primIntToFloat "primIntToFloat" :: Int -> Float
primitive primIntegerToFloat "primIntegerToFloat" :: Integer -> Float

instance Num Float where
    (+)           = primPlusFloat
    (-)           = primMinusFloat
    negate        = primNegFloat
    (*)           = primMulFloat
    abs           = absReal
    signum        = signumReal
    fromInteger   = primIntegerToFloat
    fromInt       = primIntToFloat

primitive primPlusDouble  "primPlusDouble",
          primMinusDouble "primMinusDouble",
          primMulDouble   "primMulDouble"   :: Double -> Double -> Double
primitive primNegDouble   "primNegDouble"   :: Double -> Double
primitive primIntToDouble "primIntToDouble" :: Int -> Double
primitive primIntegerToDouble "primIntegerToDouble" :: Integer -> Double

instance Num Double where
    (+)         = primPlusDouble
    (-)         = primMinusDouble
    negate      = primNegDouble
    (*)         = primMulDouble
    abs         = absReal
    signum      = signumReal
    fromInteger = primIntegerToDouble
    fromInt     = primIntToDouble

instance Real Float where
    toRational = realFloatToRational

instance Real Double where
    toRational = realFloatToRational

realFloatToRational x = (m%1)*(b%1)^^n
                        where (m,n) = decodeFloat x
                              b     = floatRadix x

primitive primDivFloat      "primDivFloat"      :: Float -> Float -> Float
primitive primDoubleToFloat "primDoubleToFloat" :: Double -> Float

instance Fractional Float where
    (/)          = primDivFloat
    fromRational = rationalToRealFloat
    fromDouble   = primDoubleToFloat

primitive primDivDouble   "primDivDouble" :: Double -> Double -> Double

instance Fractional Double where
    (/)          = primDivDouble
    fromRational = rationalToRealFloat
    fromDouble x = x

rationalToRealFloat x = x'
 where x'    = f e
       f e   = if e' == e then y else f e'
               where y      = encodeFloat (round (x * (1%b)^^e)) e
                     (_,e') = decodeFloat y
       (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
                             / fromInteger (denominator x))
       b     = floatRadix x'

primitive primPiFloat   "primPiFloat" :: Float
primitive primSinFloat  "primSinFloat",  primAsinFloat  "primAsinFloat",
          primCosFloat  "primCosFloat",  primAcosFloat  "primAcosFloat",
      primTanFloat  "primTanFloat",  primAtanFloat  "primAtanFloat",
          primLogFloat  "primLogFloat",  primExpFloat   "primExpFloat",
      primSqrtFloat "primSqrtFloat" :: Float -> Float

instance Floating Float where
    pi    = primPiFloat
    exp   = primExpFloat
    log   = primLogFloat
    sqrt  = primSqrtFloat
    sin   = primSinFloat
    cos   = primCosFloat
    tan   = primTanFloat
    asin  = primAsinFloat
    acos  = primAcosFloat
    atan  = primAtanFloat

primitive primPiDouble   "primPiDouble" :: Double
primitive primSinDouble  "primSinDouble",  primAsinDouble  "primAsinDouble",
          primCosDouble  "primCosDouble",  primAcosDouble  "primAcosDouble",
      primTanDouble  "primTanDouble",  primAtanDouble  "primAtanDouble",
          primLogDouble  "primLogDouble",  primExpDouble   "primExpDouble",
      primSqrtDouble "primSqrtDouble" :: Double -> Double

instance Floating Double where
    pi    = primPiDouble
    exp   = primExpDouble
    log   = primLogDouble
    sqrt  = primSqrtDouble
    sin   = primSinDouble
    cos   = primCosDouble
    tan   = primTanDouble
    asin  = primAsinDouble
    acos  = primAcosDouble
    atan  = primAtanDouble

instance RealFrac Float where
    properFraction = floatProperFraction

instance RealFrac Double where
    properFraction = floatProperFraction

floatProperFraction x
   | n >= 0      = (fromInteger m * fromInteger b ^ n, 0)
   | otherwise   = (fromInteger w, encodeFloat r n)
                   where (m,n) = decodeFloat x
                         b     = floatRadix x
                         (w,r) = quotRem m (b^(-n))

primitive primFloatRadix  "primFloatRadix"  :: Float -> Integer
primitive primFloatDigits "primFloatDigits" :: Float -> Int
primitive primFloatRange  "primFloatRange"  :: Float -> (Int,Int)
primitive primFloatEncode "primFloatEncode" :: Integer -> Int -> Float
primitive primFloatDecode "primFloatDecode" :: Float -> (Integer, Int)

instance RealFloat Float where
    floatRadix  = primFloatRadix
    floatDigits = primFloatDigits
    floatRange  = primFloatRange
    encodeFloat = primFloatEncode
    decodeFloat = primFloatDecode

primitive primDoubleRadix  "primDoubleRadix"  :: Double -> Integer
primitive primDoubleDigits "primDoubleDigits" :: Double -> Int
primitive primDoubleRange  "primDoubleRange"  :: Double -> (Int,Int)
primitive primDoubleEncode "primDoubleEncode" :: Integer -> Int -> Double
primitive primDoubleDecode "primDoubleDecode" :: Double -> (Integer, Int)

instance RealFloat Double where
    floatRadix  = primDoubleRadix
    floatDigits = primDoubleDigits
    floatRange  = primDoubleRange
    encodeFloat = primDoubleEncode
    decodeFloat = primDoubleDecode

instance Enum Float where
    enumFrom     = numericEnumFrom
    enumFromThen = numericEnumFromThen

instance Enum Double where
    enumFrom     = numericEnumFrom
    enumFromThen = numericEnumFromThen

primitive primShowsFloat "primShowsFloat" :: Int -> Float -> ShowS

instance Text Float where
    readsPrec p = readSigned readFloat
    showsPrec   = primShowsFloat

primitive primShowsDouble "primShowsDouble" :: Int -> Double -> ShowS

instance Text Double where
    readsPrec p = readSigned readFloat
    showsPrec   = primShowsDouble

-- Lists --------------------------------------------------------------------

instance Eq a => Eq [a] where
    []     == []     =  True
    (x:xs) == (y:ys) =  x==y && xs==ys
    _      == _      =  False

instance Ord a => Ord [a] where
    []     <= _      =  True
    (_:_)  <= []     =  False
    (x:xs) <= (y:ys) =  x<y || (x==y && xs<=ys)

instance Text a => Text [a]  where
    readsPrec p = readList
    showsPrec p = showList

-- Tuples -------------------------------------------------------------------

-- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Text, Binary)
-- etc..

-- Functions ----------------------------------------------------------------

instance Text (a -> b) where
    readsPrec p s = error "readsPrec{PreludeCore}: Cannot read functions"
    showsPrec p f = showString "<<function>>"

-- Standard functions on rational numbers {PreludeRatio} --------------------

data Integral a => Ratio a = a :% a deriving (Eq, Binary)
type Rational              =  Ratio Integer

(%)                       :: Integral a => a -> a -> Ratio a
x % y                      = reduce (x * signum y) (abs y)

reduce                    :: Integral a => a -> a -> Ratio a
reduce x y | y== 0         = error "(%){PreludeRatio}: zero denominator"
           | otherwise     = (x `quot` d) :% (y `quot` d)
                             where d = gcd x y

numerator, denominator    :: Integral a => Ratio a -> a
numerator (x :% y)         = x
denominator (x :% y)       = y

instance Integral a => Ord (Ratio a) where
    ordcmp (x:%y) (x':%y') = ordcmp (x*y') (x'*y)

instance Integral a => Num (Ratio a) where
    (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
    (x:%y) * (x':%y') = reduce (x*x') (y*y')
    negate (x :% y)   = negate x :% y
    abs (x :% y)      = abs x :% y
    signum (x :% y)   = signum x :% 1
    fromInteger x     = fromInteger x :% 1
    fromInt x         = fromInt x :% 1

instance Integral a => Real (Ratio a) where
    toRational (x:%y) = toInteger x :% toInteger y

instance Integral a => Fractional (Ratio a) where
    (x:%y) / (x':%y')   = (x*y') % (y*x')
    recip (x:%y)        = if x < 0 then (-y) :% (-x) else y :% x
    fromRational (x:%y) = fromInteger x :% fromInteger y
    fromDouble x
            | n>=0      = (fromInteger m * fromInteger b ^ n) % 1
            | otherwise = fromInteger m % (fromInteger b ^ (-n))
                          where (m,n) = decodeFloat x
                                b     = floatRadix x

instance Integral a => RealFrac (Ratio a) where
    properFraction (x:%y) = (fromIntegral q, r:%y)
                where (q,r) = quotRem x y

instance Integral a => Enum (Ratio a) where
    enumFrom     = numericEnumFrom
    enumFromThen = numericEnumFromThen

instance Integral a => Text (Ratio a) where
    readsPrec p        = readParen (p > 7)
                                   (\r -> [(x%y,u) | (x,s)   <- reads r,
                                                     ("%",t) <- lex s,
                                                     (y,u)   <- reads t ])
    showsPrec p (x:%y) = showParen (p > 7)
                             (shows x . showString " % " . shows y)

approxRational      :: RealFrac a => a -> a -> Rational
approxRational x eps = simplest (x-eps) (x+eps)
 where simplest x y | y < x     = simplest y x
                    | x == y    = xr
                    | x > 0     = simplest' n d n' d'
                    | y < 0     = - simplest' (-n') d' (-n) d
                    | otherwise = 0 :% 1
                  where xr@(n:%d) = toRational x
                    (n':%d')  = toRational y
       simplest' n d n' d'        -- assumes 0 < n%d < n'%d'
            | r == 0    = q :% 1
            | q /= q'   = (q+1) :% 1
                    | otherwise = (q*n''+d'') :% n''
                  where (q,r)       = quotRem n d
                    (q',r')       = quotRem n' d'
                    (n'':%d'') = simplest' d' r' d r

-- Complex numbers {PreludeComplex} -----------------------------------------

data RealFloat a => Complex a = a :+ a deriving (Eq, Binary, Text)

instance RealFloat a => Num (Complex a) where
    (x:+y) + (x':+y')  = (x+x') :+ (y+y')
    (x:+y) - (x':+y')  = (x-x') :+ (y-y')
    (x:+y) * (x':+y')  = (x*x'-y*y') :+ (x*y'+y*x')
    negate (x:+y)      = negate x :+ negate y
    abs z              = magnitude z :+ 0
    signum 0           = 0
    signum z@(x:+y)    = x/r :+ y/r where r = magnitude z
    fromInteger n      = fromInteger n :+ 0
    fromInt n          = fromInt n :+ 0

instance RealFloat a => Fractional (Complex a) where
    (x:+y) / (x':+y')  = (x*x''+y*y'')/d :+ (y*x''-x*y'')/d
             where x'' = scaleFloat k x'
                   y'' = scaleFloat k y'
                   k   = - max (exponent x') (exponent y')
                   d   = x'*x'' + y'*y''
    fromRational a     = fromRational a :+ 0
    fromDouble a       = fromDouble a :+ 0

instance RealFloat a => Floating (Complex a) where
    pi            = pi :+ 0
    exp (x:+y)    = expx * cos y :+ expx * sin y
                    where expx = exp x
    log z         = log (magnitude z) :+ phase z
    sqrt 0        = 0
    sqrt z@(x:+y) = u :+ (if y < 0 then -v else v)
            where (u,v) = if x<0 then (v',u') else (u',v')
              v'    = abs y / (u'*2)
              u'    = sqrt ((magnitude z + abs x) / 2)
    sin (x:+y)    = sin x * cosh y :+ cos x * sinh y
    cos (x:+y)    = cos x * cosh y :+ (- sin x * sinh y)
    tan (x:+y)    = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))
            where sinx  = sin x
              cosx    = cos x
              sinhy = sinh y
              coshy = cosh y
    sinh (x:+y)   = sinh x * cos y :+ cosh x * sin y
    cosh (x:+y)   = cosh x * cos y :+ sinh x * sin y
    tanh (x:+y)   = (sinhx*cosy:+coshx*siny)/(coshx*cosy:+sinhx*siny)
            where siny  = sin y
              cosy    = cos y
              sinhx = sinh x
              coshx = cosh x
    asin z@(x:+y) = y' :+ (-x')
                    where (x':+y') = log ((-y:+x) + sqrt (1 - z*z))
    acos z@(x:+y) = y'':+(-x'')
            where (x'':+y'') = log (z + ((-y'):+x'))
              (x' :+ y') = sqrt (1 - z*z)
    atan z@(x:+y) = y' :+ (-x')
                    where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))
    asinh z       = log (z + sqrt (1+z*z))
    acosh z       = log (z + (z+1) * sqrt ((z-1)/(z+1)))
    atanh z       = log ((1+z) / sqrt (1 - z*z))

realPart, imagPart :: RealFloat a => Complex a -> a
realPart (x :+ y)   = x
imagPart (x :+ y)   = y

conjugate          :: RealFloat a => Complex a -> Complex a
conjugate (x :+ y)  = x :+ (-y)

mkPolar            :: RealFloat a => a -> a -> Complex a
mkPolar r theta     = r * cos theta :+ r * sin theta

cis                :: RealFloat a => a -> Complex a
cis theta           = cos theta :+ sin theta

polar              :: RealFloat a => Complex a -> (a, a)
polar z             = (magnitude z, phase z)

magnitude, phase   :: RealFloat a => Complex a -> a
magnitude (x :+ y)  = scaleFloat k
                       (sqrt ((scaleFloat mk x)^2 + (scaleFloat mk y)^2))
                      where k  = max (exponent x) (exponent y)
                            mk = -k
phase (x :+ y)      = atan2 y x

-- Standard list functions {PreludeList} ------------------------------------

head             :: [a] -> a
head (x:_)        = x

last             :: [a] -> a
last [x]          = x
last (_:xs)       = last xs

tail             :: [a] -> [a]
tail (_:xs)       = xs

init             :: [a] -> [a]
init [x]          = []
init (x:xs)       = x : init xs

-- null provides a simple and efficient way of determining whether a given
-- list is empty, without using (==) and hence avoiding an Eq a constraint.
null             :: [a] -> Bool
null []           = True
null (_:_)        = False

(++)             :: [a] -> [a] -> [a]    -- append lists.  Associative with
[]     ++ ys      = ys                   -- left and right identity [].
(x:xs) ++ ys      = x:(xs++ys)

-- (\\) is used to remove the first occurrence of each element in the second
-- list from the first list.  It is a kind of inverse of (++) in the sense
-- that  (xs ++ ys) \\ xs = ys for any finite list xs of proper values xs.
(\\)             :: Eq a => [a] -> [a] -> [a]
(\\)              = foldl del
                    where []     `del` _  = []
                          (x:xs) `del` y
                             | x == y     = xs
                             | otherwise  = x : xs `del` y

-- length returns the length of a finite list as an Int; it is an instance
-- of the more general genericLength, the result type of which may be
-- any kind of number

genericLength    :: Num a => [b] -> a
genericLength     = foldl' (\n _ -> n + 1) 0

length         :: [a] -> Int
length            = genericLength

-- List index (subscript) operator, 0-origin
(!!)             :: (Integral a) => [b] -> a -> b
(x:_)  !! 0       = x
(_:xs) !! (n+1)   = xs !! n

-- map f xs applies the function f to each element of the list xs returning
-- the corresponding list of results.  filter p xs returns the sublist of xs
-- containing those elements which satisfy the predicate p.

map              :: (a -> b) -> [a] -> [b]
map f []          = []
map f (x:xs)      = f x : map f xs

filter           :: (a -> Bool) -> [a] -> [a]
filter p          = foldr (\x xs -> if p x then x:xs else xs) []

-- partition takes a predicate and a list and returns a pair of lists:
-- those elements of the argument list that do and do not satisfy the
-- predicate, respectively.
partition        :: (a -> Bool) -> [a] -> ([a],[a])
partition p       = foldr select ([],[])
                    where select x (ts,fs) | p x       = (x:ts,fs)
                                           | otherwise = (ts,x:fs)

-- Fold primitives:  The foldl and scanl functions, variants foldl1 and
-- scanl1 for non-empty lists, and strict variants foldl' scanl' describe
-- common patterns of recursion over lists.  Informally:
--
--  foldl f a [x1, x2, ..., xn]  = f (...(f (f a x1) x2)...) xn
--                               = (...((a `f` x1) `f` x2)...) `f` xn
-- etc...
--
-- The functions foldr, scanr and variants foldr1, scanr1 are duals of these
-- functions:
-- e.g.  foldr f a xs = foldl (flip f) a (reverse xs)  for finite lists xs.

foldl            :: (a -> b -> a) -> a -> [b] -> a
foldl f z []      = z
foldl f z (x:xs)  = foldl f (f z x) xs

foldl'           :: (a -> b -> a) -> a -> [b] -> a
foldl' f a []     =  a
foldl' f a (x:xs) =  strict (foldl' f) (f a x) xs

foldl1           :: (a -> a -> a) -> [a] -> a
foldl1 f (x:xs)   = foldl f x xs

scanl            :: (a -> b -> a) -> a -> [b] -> [a]
scanl f q xs      = q : (case xs of
                         []   -> []
                         x:xs -> scanl f (f q x) xs)

scanl1           :: (a -> a -> a) -> [a] -> [a]
scanl1 f (x:xs)   = scanl f x xs

foldr            :: (a -> b -> b) -> b -> [a] -> b
foldr f z []      = z
foldr f z (x:xs)  = f x (foldr f z xs)

foldr1           :: (a -> a -> a) -> [a] -> a
foldr1 f [x]      = x
foldr1 f (x:xs)   = f x (foldr1 f xs)

scanr            :: (a -> b -> b) -> b -> [a] -> [b]
scanr f q0 []     = [q0]
scanr f q0 (x:xs) = f x q : qs
                    where qs@(q:_) = scanr f q0 xs

scanr1           :: (a -> a -> a) -> [a] -> [a]
scanr1 f [x]      = [x]
scanr1 f (x:xs)   = f x q : qs
                    where qs@(q:_) = scanr1 f xs

iterate          :: (a -> a) -> a -> [a] -- generate the infinite list
iterate f x       = x : iterate f (f x)  -- [x, f x, f (f x), ...

repeat           :: a -> [a]             -- generate the infinite list
repeat x          = xs where xs = x:xs   -- [x, x, x, x, ...

cycle            :: [a] -> [a]           -- generate the infinite list
cycle xs          = xs' where xs'=xs++xs'-- xs ++ xs ++ xs ++ ...

-- List breaking functions:
--
--   take n xs       returns the first n elements of xs
--   drop n xs       returns the remaining elements of xs
--   splitAt n xs    = (take n xs, drop n xs)
--
--   takeWhile p xs  returns the longest initial segment of xs whose
--                   elements satisfy p
--   dropWhile p xs  returns the remaining portion of the list
--   span p xs       = (takeWhile p xs, dropWhile p xs)
--
--   takeUntil p xs  returns the list of elements upto and including the
--                   first element of xs which satisfies p

take                :: Integral a => a -> [b] -> [b]
take 0     _         = []
take _     []        = []
take (n+1) (x:xs)    = x : take n xs

drop                :: Integral a => a -> [b] -> [b]
drop 0     xs        = xs
drop _     []        = []
drop (n+1) (_:xs)    = drop n xs

splitAt             :: Integral a => a -> [b] -> ([b], [b])
splitAt 0     xs     = ([],xs)
splitAt _     []     = ([],[])
splitAt (n+1) (x:xs) = (x:xs',xs'') where (xs',xs'') = splitAt n xs

takeWhile           :: (a -> Bool) -> [a] -> [a]
takeWhile p []       = []
takeWhile p (x:xs)
         | p x       = x : takeWhile p xs
         | otherwise = []

dropWhile           :: (a -> Bool) -> [a] -> [a]
dropWhile p []       = []
dropWhile p xs@(x:xs')
         | p x       = dropWhile p xs'
         | otherwise = xs

span, break         :: (a -> Bool) -> [a] -> ([a],[a])
span p []            = ([],[])
span p xs@(x:xs')
         | p x       = let (ys,zs) = span p xs' in (x:ys,zs)
         | otherwise = ([],xs)
break p              = span (not . p)

-- Text processing:
--   lines s     returns the list of lines in the string s.
--   words s     returns the list of words in the string s.
--   unlines ls  joins the list of lines ls into a single string
--               with lines separated by newline characters.
--   unwords ws  joins the list of words ws into a single string
--               with words separated by spaces.

lines     :: String -> [String]
lines ""   = []
lines s    = l : (if null s' then [] else lines (tail s'))
             where (l, s') = break ('\n'==) s

words     :: String -> [String]
words s    = case dropWhile isSpace s of
                  "" -> []
                  s' -> w : words s''
                        where (w,s'') = break isSpace s'

unlines   :: [String] -> String
unlines    = concat . map (\l -> l ++ "\n")

unwords   :: [String] -> String
unwords [] = []
unwords ws = foldr1 (\w s -> w ++ ' ':s) ws

nub              :: Eq a => [a] -> [a]   -- remove duplicates from list
nub []            = []
nub (x:xs)        = x : nub (filter (x/=) xs)

reverse          :: [a] -> [a]           -- reverse elements of list
reverse           = foldl (flip (:)) []

and, or        :: [Bool] -> Bool
and             = foldr (&&) True     -- returns conjunction of boolean list
or              = foldr (||) False     -- returns disjunction of boolean list

any, all       :: (a -> Bool) -> [a] -> Bool
any p           = or  . map p
all p           = and . map p

elem, notElem    :: Eq a => a -> [a] -> Bool
elem              = any . (==)           -- test for membership in list
notElem           = all . (/=)           -- test for non-membership

sum, product     :: Num a => [a] -> a
sum               = foldl' (+) 0
product           = foldl' (*) 1

sums, products     :: Num a => [a] -> [a]
sums              = scanl (+) 0
products          = scanl (*) 1

maximum, minimum :: Ord a => [a] -> a
maximum           = foldl1 max          -- max element in non-empty list
minimum           = foldl1 min          -- min element in non-empty list

concat           :: [[a]] -> [a]        -- concatenate list of lists
concat            = foldr (++) []

transpose        :: [[a]] -> [[a]]      -- transpose list of lists
transpose         = foldr
                      (\xs xss -> zipWith (:) xs (xss ++ repeat []))
                      []

-- zip and zipWith families of functions:

zip  :: [a] -> [b] -> [(a,b)]
zip   = zipWith  (\a b -> (a,b))

zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
zip3  = zipWith3 (\a b c -> (a,b,c))

zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
zip4  = zipWith4 (\a b c d -> (a,b,c,d))

zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
zip5  = zipWith5 (\a b c d e -> (a,b,c,d,e))

zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a,b,c,d,e,f)]
zip6  = zipWith6 (\a b c d e f -> (a,b,c,d,e,f))

zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a,b,c,d,e,f,g)]
zip7  = zipWith7 (\a b c d e f g -> (a,b,c,d,e,f,g))

zipWith                  :: (a->b->c) -> [a]->[b]->[c]
zipWith z (a:as) (b:bs)   = z a b : zipWith z as bs
zipWith _ _      _        = []

zipWith3                 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
zipWith3 z (a:as) (b:bs) (c:cs)
                          = z a b c : zipWith3 z as bs cs
zipWith3 _ _ _ _          = []

zipWith4                 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
                          = z a b c d : zipWith4 z as bs cs ds
zipWith4 _ _ _ _ _        = []

zipWith5                 :: (a->b->c->d->e->f) -> [a]->[b]->[c]->[d]->[e]->[f]
zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
                          = z a b c d e : zipWith5 z as bs cs ds es
zipWith5 _ _ _ _ _ _      = []

zipWith6                 :: (a->b->c->d->e->f->g)
                            -> [a]->[b]->[c]->[d]->[e]->[f]->[g]
zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
                          = z a b c d e f : zipWith6 z as bs cs ds es fs
zipWith6 _ _ _ _ _ _ _    = []

zipWith7                 :: (a->b->c->d->e->f->g->h)
                             -> [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
                          = z a b c d e f g : zipWith7 z as bs cs ds es fs gs
zipWith7 _ _ _ _ _ _ _ _  = []

unzip                    :: [(a,b)] -> ([a],[b])
unzip                     = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])

unzip3                   :: [(a,b,c)] -> ([a],[b],[c])
unzip3                    = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
                                  ([],[],[])

unzip4                   :: [(a,b,c,d)] -> ([a],[b],[c],[d])
unzip4                    = foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->
                                       (a:as,b:bs,c:cs,d:ds))
                                  ([],[],[],[])

unzip5                   :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])
unzip5                    = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->
                                       (a:as,b:bs,c:cs,d:ds,e:es))
                                  ([],[],[],[],[])

unzip6                   :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])
unzip6                    = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->
                                       (a:as,b:bs,c:cs,d:ds,e:es,f:fs))
                                  ([],[],[],[],[],[])

unzip7                   :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])
unzip7                    = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->
                                       (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))
                                  ([],[],[],[],[],[],[])

-- Standard array functions {PreludeArray} ----------------------------------

data Assoc a b =  a := b deriving (Eq, Ord, Ix, Text, Binary)

array      :: Ix a => (a,a) -> [Assoc a b] -> Array a b
listArray  :: Ix a => (a,a) -> [b] -> Array a b
(!)       :: Ix a => Array a b -> a -> b
bounds     :: Ix a => Array a b -> (a,a)
indices       :: Ix a => Array a b -> [a]
elems      :: Ix a => Array a b -> [b]
assocs       :: Ix a => Array a b -> [Assoc a b]
accumArray :: Ix a => (b -> c -> b) -> b -> (a,a) -> [Assoc a c] -> Array a b
(//)       :: Ix a => Array a b -> [Assoc a b] -> Array a b
accum      :: Ix a => (b -> c -> b) -> Array a b -> [Assoc a c] -> Array a b
amap       :: Ix a => (b -> c) -> Array a b -> Array a c
ixmap       :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c

primitive primArray "primArray"
    :: (a -> Int) -> (a,a) -> [Assoc a b] -> Array a b
primitive primUpdate "primUpdate"
    :: (a -> Int) -> Array a b -> [Assoc a b] -> Array a b
primitive primAccum "primAccum"
    :: (a -> Int) -> (b -> c -> b) -> Array a b -> [Assoc a c] -> Array a b
primitive primAccumArray "primAccumArray"
    :: (a -> Int) -> (b -> c -> b) -> b -> (a,a) -> [Assoc a c] -> Array a b
primitive primBounds    "primBounds"    :: Array a b -> (a,a)
primitive primElems     "primElems"     :: Array a b -> [b]
primitive primSubscript "primSubscript" :: (a -> Int) -> Array a b -> a -> b
primitive primAmap      "primAmap"    :: (b -> c) -> Array a b -> Array a c

array bounds assocs = primArray (index bounds) bounds assocs
listArray b vs        = array b (zipWith (:=) (range b) vs)
(!) a               = primSubscript (index (bounds a)) a
bounds              = primBounds
indices            = range . bounds
elems               = primElems
assocs a            = zipWith (:=) (indices a) (elems a)
accumArray f z b    = primAccumArray (index b) f z b
a // as             = primUpdate (index (bounds a)) a as
accum f a           = primAccum (index (bounds a)) f a
amap                = primAmap
ixmap b f a         = array b [ i := (a ! f i) | i <- range b ]

instance (Ix a, Eq b) => Eq (Array a b) where
    a == a'   =   assocs a == assocs a'

instance (Ix a, Ord b) => Ord (Array a b) where
    a <= a'   =   assocs a <= assocs a'

instance (Ix a, Text a, Text b) => Text (Array a b) where
    showsPrec p a = showParen (p > 9) (
                       showString "array " .
                       shows (bounds a)    .
                       showChar ' '        .
                       shows (assocs a))

instance (Ix a, Binary a, Binary b) => Binary (Array a b)

rangeSize        :: (Ix a) => (a,a) -> Int
rangeSize r@(l,u) = index r u + 1

-- PreludeText ----------------------------------------------------------------

reads        :: Text a => ReadS a
reads         = readsPrec 0

shows        :: Text a => a -> ShowS
shows         = showsPrec 0

read         :: Text a => String -> a
read s        =  case [x | (x,t) <- reads s, ("","") <- lex t] of
                      [x] -> x
                      []  -> error "read{PreludeText}: no parse"
                      _   -> error "read{PreludeText}: ambiguous parse"

show         :: Text a => a -> String
show x        = shows x ""

showChar     :: Char -> ShowS
showChar      = (:)

showString   :: String -> ShowS
showString    = (++)

showParen    :: Bool -> ShowS -> ShowS
showParen b p = if b then showChar '(' . p . showChar ')' else p

readParen    :: Bool -> ReadS a -> ReadS a
readParen b g = if b then mandatory else optional
                where optional r  = g r ++ mandatory r
                      mandatory r = [(x,u) | ("(",s) <- lex r,
                                             (x,t)   <- optional s,
                                             (")",u) <- lex t    ]

lex                     :: ReadS String
lex ""                  = [("","")]
lex (c:s) | isSpace c   = lex (dropWhile isSpace s)
lex ('-':'-':s)         = case dropWhile (/= '\n') s of
                                 '\n':t -> lex t
                                 _      -> [] -- unterminated end-of-line
                                              -- comment

lex ('{':'-':s)         = lexNest lex s
                          where
                          lexNest f ('-':'}':s) = f s
                          lexNest f ('{':'-':s) = lexNest (lexNest f) s
                          lexNest f (c:s)             = lexNest f s
                          lexNest _ ""          = [] -- unterminated
                                                     -- nested comment

lex ('<':'-':s)         = [("<-",s)]
lex ('\'':s)            = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
                                               ch /= "'"                ]
lex ('"':s)             = [('"':str, t)      | (str,t) <- lexString s]
                          where
                          lexString ('"':s) = [("\"",s)]
                          lexString s = [(ch++str, u)
                                                | (ch,t)  <- lexStrItem s,
                                                  (str,u) <- lexString t  ]

                          lexStrItem ('\\':'&':s) = [("\\&",s)]
                          lexStrItem ('\\':c:s) | isSpace c
                              = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
                          lexStrItem s            = lexLitChar s

lex (c:s) | isSingle c  = [([c],s)]
          | isSym1 c    = [(c:sym,t)         | (sym,t) <- [span isSym s]]
          | isAlpha c   = [(c:nam,t)         | (nam,t) <- [span isIdChar s]]
          | isDigit c   = [(c:ds++fe,t)      | (ds,s)  <- [span isDigit s],
                                               (fe,t)  <- lexFracExp s     ]
          | otherwise   = []    -- bad character
                where
                isSingle c  =  c `elem` ",;()[]{}_"
                isSym1 c    =  c `elem` "-~" || isSym c
                isSym c     =  c `elem` "!@#$%&*+./<=>?\\^|:"
                isIdChar c  =  isAlphanum c || c `elem` "_'"

                lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
                                                      (e,u)  <- lexExp t    ]
                lexFracExp s       = [("",s)]

                lexExp (e:s) | e `elem` "eE"
                         = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
                                                   (ds,u) <- lexDigits t] ++
                           [(e:ds,t)   | (ds,t) <- lexDigits s]
                lexExp s = [("",s)]

lexDigits               :: ReadS String
lexDigits               =  nonnull isDigit

nonnull                 :: (Char -> Bool) -> ReadS String
nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]

lexLitChar              :: ReadS String
lexLitChar ('\\':s)     =  [('\\':esc, t) | (esc,t) <- lexEsc s]
        where
        lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]
        lexEsc ('^':c:s) | c >= '@' && c <= '_'  = [(['^',c],s)]
        lexEsc s@(d:_)   | isDigit d             = lexDigits s
        lexEsc ('o':s)  =  [('o':os, t) | (os,t) <- nonnull isOctDigit s]
        lexEsc ('x':s)  =  [('x':xs, t) | (xs,t) <- nonnull isHexDigit s]
        lexEsc s@(c:_)   | isUpper c
                        =  case [(mne,s') | mne <- "DEL" : elems asciiTab,
                                            ([],s') <- [lexmatch mne s]      ]
                           of (pr:_) -> [pr]
                              []     -> []
        lexEsc _        =  []
lexLitChar (c:s)        =  [([c],s)]
lexLitChar ""           =  []

isOctDigit c  =  c >= '0' && c <= '7'
isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'
                           || c >= 'a' && c <= 'f'

lexmatch                   :: (Eq a) => [a] -> [a] -> ([a],[a])
lexmatch (x:xs) (y:ys) | x == y  =  lexmatch xs ys
lexmatch xs     ys               =  (xs,ys)

asciiTab = listArray ('\NUL', ' ')
           ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
            "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
            "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
            "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
            "SP"]

readLitChar             :: ReadS Char
readLitChar ('\\':s)    =  readEsc s
 where
       readEsc ('a':s)  = [('\a',s)]
       readEsc ('b':s)  = [('\b',s)]
       readEsc ('f':s)  = [('\f',s)]
       readEsc ('n':s)  = [('\n',s)]
       readEsc ('r':s)  = [('\r',s)]
       readEsc ('t':s)  = [('\t',s)]
       readEsc ('v':s)  = [('\v',s)]
       readEsc ('\\':s) = [('\\',s)]
       readEsc ('"':s)  = [('"',s)]
       readEsc ('\'':s) = [('\'',s)]
       readEsc ('^':c:s) | c >= '@' && c <= '_'
                        = [(chr (ord c - ord '@'), s)]
       readEsc s@(d:_) | isDigit d
                        = [(chr n, t) | (n,t) <- readDec s]
       readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]
       readEsc ('x':s)  = [(chr n, t) | (n,t) <- readHex s]
       readEsc s@(c:_) | isUpper c
                        = let table = ('\DEL':= "DEL") : assocs asciiTab
                          in case [(c,s') | (c := mne) <- table,
                                            ([],s') <- [lexmatch mne s]]
                             of (pr:_) -> [pr]
                                []     -> []
       readEsc _        = []
readLitChar (c:s)       =  [(c,s)]

showLitChar               :: Char -> ShowS
showLitChar c | c > '\DEL' = showChar '\\' . protectEsc isDigit (shows (ord c))
showLitChar '\DEL'         = showString "\\DEL"
showLitChar '\\'           = showString "\\\\"
showLitChar c | c >= ' '   = showChar c
showLitChar '\a'           = showString "\\a"
showLitChar '\b'           = showString "\\b"
showLitChar '\f'           = showString "\\f"
showLitChar '\n'           = showString "\\n"
showLitChar '\r'           = showString "\\r"
showLitChar '\t'           = showString "\\t"
showLitChar '\v'           = showString "\\v"
showLitChar '\SO'          = protectEsc ('H'==) (showString "\\SO")
showLitChar c              = showString ('\\' : asciiTab!c)

protectEsc p f             = f . cont
 where cont s@(c:_) | p c  = "\\&" ++ s
       cont s              = s

readDec, readOct, readHex :: Integral a => ReadS a
readDec = readInt 10 isDigit (\d -> ord d - ord '0')
readOct = readInt  8 isOctDigit (\d -> ord d - ord '0')
readHex = readInt 16 isHexDigit hex
            where hex d = ord d - (if isDigit d then ord '0'
                                   else ord (if isUpper d then 'A' else 'a')
                                        - 10)

readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
readInt radix isDig digToInt s =
    [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
        | (ds,r) <- nonnull isDig s ]

showInt    :: Integral a => a -> ShowS
showInt n r = let (n',d) = quotRem n 10
                  r'     = chr (ord '0' + fromIntegral d) : r
              in  if n' == 0 then r' else showInt n' r'

readSigned:: Real a => ReadS a -> ReadS a
readSigned readPos = readParen False read'
                     where read' r  = read'' r ++
                                      [(-x,t) | ("-",s) <- lex r,
                                                (x,t)   <- read'' s]
                           read'' r = [(n,s)  | (str,s) <- lex r,
                                                (n,"")  <- readPos str]

showSigned    :: Real a => (a -> ShowS) -> Int -> a -> ShowS
showSigned showPos p x = if x < 0 then showParen (p > 6)
                                                 (showChar '-' . showPos (-x))
                                  else showPos x

readFloat     :: RealFloat a => ReadS a
readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
                               (k,t)   <- readExp s]
                 where readFix r = [(read (ds++ds'), length ds', t)
                    | (ds,'.':s) <- lexDigits r,
                      (ds',t)    <- lexDigits s ]

               readExp (e:s) | e `elem` "eE" = readExp' s
               readExp s                     = [(0,s)]

               readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
               readExp' ('+':s) = readDec s
               readExp' s       = readDec s

showFloat     :: RealFloat a => a -> ShowS
showFloat x    = if x==0 then showString ("0." ++ take (m-1) (repeat '0'))
                         else if e >= m-1 || e < 0 then showSci else showFix
 where showFix     = showString whole . showChar '.' . showString frac
           where (whole,frac) = splitAt (e+1) (show sig)
       showSci     = showChar d . showChar '.' . showString frac
            . showChar 'e' . shows e
           where (d:frac) = show sig
       (m,sig,e) = if b == 10 then (w, s, n+w-1) else (m',sig',e')
       m'        = ceiling
            (fromIntegral w * log (fromInteger b) / log 10 :: Double)
           + 1
       (sig',e') = if      sig1 >= 10^m'     then (round (t/10), e1+1)
           else if sig1 <  10^(m'-1) then (round (t*10), e1-1)
                         else (sig1, e1)
       sig1     = round t
       t     = s%1 * (b%1)^^n * 10^^(m'-e1-1)
       e1     = floor (logBase 10 x)
       (s,n)     = decodeFloat x
       b     = floatRadix x
       w     = floatDigits x

-- I/O functions and definitions {PreludeIO} ----------------------------------

stdin         =  "stdin"
stdout        =  "stdout"
stderr        =  "stderr"
stdecho       =  "stdecho"

data Request  =  -- file system requests:
                ReadFile      String
              | WriteFile     String String
              | AppendFile    String String
                 -- channel system requests:
              | ReadChan      String
              | AppendChan    String String
                 -- environment requests:
              | Echo          Bool
          | GetArgs
          | GetProgName
          | GetEnv        String

data Response = Success
              | Str     String
              | Failure IOError
          | StrList [String]

data IOError  = WriteError   String
              | ReadError    String
              | SearchError  String
              | FormatError  String
              | OtherError   String

type Dialogue    =  [Response] -> [Request]

type SuccCont    =                Dialogue
type StrCont     =  String     -> Dialogue
type StrListCont =  [String]   -> Dialogue
type FailCont    =  IOError    -> Dialogue

done            ::                                                Dialogue
readFile        :: String ->           FailCont -> StrCont     -> Dialogue
writeFile       :: String -> String -> FailCont -> SuccCont    -> Dialogue
appendFile      :: String -> String -> FailCont -> SuccCont    -> Dialogue
readChan        :: String ->           FailCont -> StrCont     -> Dialogue
appendChan      :: String -> String -> FailCont -> SuccCont    -> Dialogue
echo            :: Bool ->             FailCont -> SuccCont    -> Dialogue
getArgs         ::                     FailCont -> StrListCont -> Dialogue
getProgName     ::               FailCont -> StrCont     -> Dialogue
getEnv        :: String ->           FailCont -> StrCont     -> Dialogue

done resps    =  []
readFile name fail succ resps =
     (ReadFile name) : strDispatch fail succ resps
writeFile name contents fail succ resps =
    (WriteFile name contents) : succDispatch fail succ resps
appendFile name contents fail succ resps =
    (AppendFile name contents) : succDispatch fail succ resps
readChan name fail succ resps =
    (ReadChan name) : strDispatch fail succ resps
appendChan name contents fail succ resps =
    (AppendChan name contents) : succDispatch fail succ resps
echo bool fail succ resps =
    (Echo bool) : succDispatch fail succ resps
getArgs fail succ resps =
    GetArgs : strListDispatch fail succ resps
getProgName fail succ resps =
    GetProgName : strDispatch fail succ resps
getEnv name fail succ resps =
    (GetEnv name) : strDispatch fail succ resps

strDispatch fail succ (resp:resps) =
            case resp of Str val     -> succ val resps
                         Failure msg -> fail msg resps

succDispatch fail succ (resp:resps) =
            case resp of Success     -> succ resps
                         Failure msg -> fail msg resps

strListDispatch fail succ (resp:resps) =
        case resp of StrList val -> succ val resps
             Failure msg -> fail msg resps

abort           :: FailCont
abort err        = done

exit            :: FailCont
exit err         = appendChan stderr msg abort done
                   where msg = case err of ReadError s   -> s
                                           WriteError s  -> s
                                           SearchError s -> s
                                           FormatError s -> s
                                           OtherError s  -> s

print           :: Text a => a -> Dialogue
print x          = appendChan stdout (show x) exit done

prints          :: Text a => a -> String -> Dialogue
prints x s       = appendChan stdout (shows x s) exit done

interact    :: (String -> String) -> Dialogue
interact f     = readChan stdin exit
                (\x -> appendChan stdout (f x) exit done)

-- Hooks for primitives: -----------------------------------------------------
-- Do not mess with these!

data HugsMaybe a  = HugsJust a | HugsNothing

primPmInt        :: Num a => Int -> a -> Bool
primPmInt n x     = fromInt n == x

primPmInteger    :: Num a => Integer -> a -> Bool
primPmInteger n x = fromInteger n == x

primPmFlt        :: Fractional a => Double -> a -> Bool
primPmFlt n x     = fromDouble n == x

primPmNpk        :: Integral a => Int -> a -> HugsMaybe a
primPmNpk n x     = if n'<=x then HugsJust (x-n') else HugsNothing
            where n' = fromInt n

primPmSub        :: Integral a => Int -> a -> a
primPmSub n x     = x - fromInt n

-- End of Hugs standard prelude ----------------------------------------------