home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
hugs101.zip
/
hugs101sc.zip
/
hugsdist
/
hugs.prelude
< prev
next >
Wrap
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 ----------------------------------------------