From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- progs/prelude/Prelude.hs | 187 +++++++++ progs/prelude/Prelude.hu | 16 + progs/prelude/PreludeArray.hs | 201 +++++++++ progs/prelude/PreludeArrayPrims.hi | 37 ++ progs/prelude/PreludeArrayPrims.hu | 4 + progs/prelude/PreludeComplex.hs | 94 +++++ progs/prelude/PreludeCore.hs | 817 +++++++++++++++++++++++++++++++++++++ progs/prelude/PreludeIO.hs | 232 +++++++++++ progs/prelude/PreludeIOMonad.hs | 60 +++ progs/prelude/PreludeIOPrims.hi | 55 +++ progs/prelude/PreludeIOPrims.hu | 4 + progs/prelude/PreludeList.hs | 585 ++++++++++++++++++++++++++ progs/prelude/PreludeLocal.hs | 16 + progs/prelude/PreludeLocalIO.hs | 144 +++++++ progs/prelude/PreludePrims.hi | 252 ++++++++++++ progs/prelude/PreludePrims.hu | 4 + progs/prelude/PreludeRatio.hs | 98 +++++ progs/prelude/PreludeText.hs | 260 ++++++++++++ progs/prelude/PreludeTuple.hs | 213 ++++++++++ progs/prelude/PreludeTuplePrims.hi | 48 +++ progs/prelude/PreludeTuplePrims.hu | 4 + progs/prelude/README | 12 + 22 files changed, 3343 insertions(+) create mode 100644 progs/prelude/Prelude.hs create mode 100644 progs/prelude/Prelude.hu create mode 100644 progs/prelude/PreludeArray.hs create mode 100644 progs/prelude/PreludeArrayPrims.hi create mode 100644 progs/prelude/PreludeArrayPrims.hu create mode 100644 progs/prelude/PreludeComplex.hs create mode 100644 progs/prelude/PreludeCore.hs create mode 100644 progs/prelude/PreludeIO.hs create mode 100644 progs/prelude/PreludeIOMonad.hs create mode 100644 progs/prelude/PreludeIOPrims.hi create mode 100644 progs/prelude/PreludeIOPrims.hu create mode 100644 progs/prelude/PreludeList.hs create mode 100644 progs/prelude/PreludeLocal.hs create mode 100644 progs/prelude/PreludeLocalIO.hs create mode 100644 progs/prelude/PreludePrims.hi create mode 100644 progs/prelude/PreludePrims.hu create mode 100644 progs/prelude/PreludeRatio.hs create mode 100644 progs/prelude/PreludeText.hs create mode 100644 progs/prelude/PreludeTuple.hs create mode 100644 progs/prelude/PreludeTuplePrims.hi create mode 100644 progs/prelude/PreludeTuplePrims.hu create mode 100644 progs/prelude/README (limited to 'progs/prelude') diff --git a/progs/prelude/Prelude.hs b/progs/prelude/Prelude.hs new file mode 100644 index 0000000..bf20849 --- /dev/null +++ b/progs/prelude/Prelude.hs @@ -0,0 +1,187 @@ +-- Standard value bindings + +module Prelude ( + PreludeCore.., PreludeRatio.., PreludeComplex.., PreludeList.., + PreludeArray.., PreludeText.., PreludeIO.., + nullBin, isNullBin, appendBin, + (&&), (||), not, otherwise, + minChar, maxChar, ord, chr, + isAscii, isControl, isPrint, isSpace, + isUpper, isLower, isAlpha, isDigit, isAlphanum, + toUpper, toLower, + minInt, maxInt, subtract, gcd, lcm, (^), (^^), + fromIntegral, fromRealFrac, atan2, + fst, snd, id, const, (.), flip, ($), until, asTypeOf, error ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +import PreludePrims + +import PreludeCore +import PreludeList +import PreludeArray +import PreludeRatio +import PreludeComplex +import PreludeText +import PreludeIO + +infixr 9 . +infixr 8 ^, ^^ +infixr 3 && +infixr 2 || +infixr 0 $ + + +-- Binary functions + +nullBin :: Bin +nullBin = primNullBin + +isNullBin :: Bin -> Bool +isNullBin = primIsNullBin + +appendBin :: Bin -> Bin -> Bin +appendBin = primAppendBin + +-- Boolean functions + +(&&), (||) :: Bool -> Bool -> Bool +True && x = x +False && _ = False +True || _ = True +False || x = x + +not :: Bool -> Bool +not True = False +not False = True + +{-# (&&) :: Inline #-} +{-# (||) :: Inline #-} +{-# not :: Inline #-} + + +otherwise :: Bool +otherwise = True + +-- Character functions + +minChar, maxChar :: Char +minChar = '\0' +maxChar = '\255' + +ord :: Char -> Int +ord = primCharToInt + +chr :: Int -> Char +chr = primIntToChar + +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 + +minInt, maxInt :: Int +minInt = primMinInt +maxInt = primMaxInt + +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,y) = x + +snd :: (a,b) -> b +snd (x,y) = y + +-- identity function +id :: a -> a +id x = x + +-- constant function +const :: a -> b -> a +const x _ = x + +-- function composition +(.) :: (b -> c) -> (a -> b) -> a -> c +f . g = \ x -> f (g x) + +-- flip f takes its (first) two arguments in the reverse order of f. +flip :: (a -> b -> c) -> b -> a -> c +flip f x y = f y x + +-- right-associating infix application operator (useful in continuation- +-- passing style) +($) :: (a -> b) -> a -> b +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 diff --git a/progs/prelude/Prelude.hu b/progs/prelude/Prelude.hu new file mode 100644 index 0000000..1ee32ca --- /dev/null +++ b/progs/prelude/Prelude.hu @@ -0,0 +1,16 @@ +:output $PRELUDEBIN/Prelude +:stable +:prelude +PreludePrims.hu +PreludeArrayPrims.hu +PreludeTuplePrims.hu +PreludeIOPrims.hu +Prelude.hs +PreludeArray.hs +PreludeComplex.hs +PreludeCore.hs +PreludeIO.hs +PreludeList.hs +PreludeRatio.hs +PreludeText.hs +PreludeTuple.hs diff --git a/progs/prelude/PreludeArray.hs b/progs/prelude/PreludeArray.hs new file mode 100644 index 0000000..a501631 --- /dev/null +++ b/progs/prelude/PreludeArray.hs @@ -0,0 +1,201 @@ +module PreludeArray ( Array, Assoc((:=)), array, listArray, (!), bounds, + indices, elems, assocs, accumArray, (//), accum, amap, + ixmap + ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +-- This module uses some simple techniques with updatable vectors to +-- avoid vector copying in loops where single threading is obvious. +-- This is rather fragile and depends on the way the compiler handles +-- strictness. + +import PreludeBltinArray + +infixl 9 ! +infixl 9 // +infix 1 := + +data Assoc a b = a := b deriving (Eq, Ord, Ix, Text, Binary) +data (Ix a) => Array a b = MkArray (a,a) {-#STRICT#-} + (Vector (Box b)) {-#STRICT#-} + deriving () + +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 + +-- Arrays are a datatype containing a bounds pair and a vector of values. +-- Uninitialized array elements contain an error value. + +-- Primitive vectors now contain only unboxed values. This permits us to +-- treat array indexing as an atomic operation without forcing the element +-- being accessed. The boxing and unboxing of array elements happens +-- explicitly using these operations: + +data Box a = MkBox a +unBox (MkBox x) = x +{-# unBox :: Inline #-} + + +-- Array construction and update using index/value associations share +-- the same helper function. + +array b@(bmin, bmax) ivs = + let size = (index b bmax) + 1 + v = primMakeVector size uninitializedArrayError + in (MkArray b (updateArrayIvs b v ivs)) +{-# array :: Inline #-} + +a@(MkArray b v) // ivs = + let v' = primCopyVector v + in (MkArray b (updateArrayIvs b v' ivs)) +{-# (//) :: Inline #-} + +updateArrayIvs b v ivs = + let g (i := x) next = strict1 (primVectorUpdate v (index b i) (MkBox x)) + next + in foldr g v ivs +{-# updateArrayIvs :: Inline #-} + +uninitializedArrayError = + MkBox (error "(!){PreludeArray}: uninitialized array element.") + + +-- when mapping a list onto an array, be smart and don't do full index +-- computation + +listArray b@(bmin, bmax) vs = + let size = (index b bmax) + 1 + v = primMakeVector size uninitializedArrayError + in (MkArray b (updateArrayVs size v vs)) +{-# listArray :: Inline #-} + +updateArrayVs size v vs = + let g x next j = if (j == size) + then v + else strict1 (primVectorUpdate v j (MkBox x)) + (next (j + 1)) + in foldr g (\ _ -> v) vs 0 +{-# updateArrayVs :: Inline #-} + + +-- Array access + +a@(MkArray b v) ! i = unBox (primVectorSel v (index b i)) +{-# (!) :: Inline #-} + +bounds (MkArray b _) = b + +indices = range . bounds + + +-- Again, when mapping array elements into a list, be smart and don't do +-- the full index computation for every element. + +elems a@(MkArray b@(bmin, bmax) v) = + build (\ c n -> + let size = (index b bmax) + 1 + g j = if (j == size) + then n + else c (unBox (primVectorSel v j)) (g (j + 1)) + -- This strict1 is so size doesn't get inlined and recomputed + -- at every iteration. It should also force the array argument + -- to be strict. + in strict1 size (g 0)) +{-# elems :: Inline #-} + +assocs a@(MkArray b@(bmin, bmax) v) = + build (\ c n -> + let g i next j = let y = unBox (primVectorSel v j) + in c (i := y) (next (j + 1)) + in foldr g (\ _ -> n) (range b) 0) +{-# assocs :: Inline #-} + + +-- accum and accumArray share the same helper function. The difference is +-- that accum makes a copy of an existing array and accumArray creates +-- a new one with all elements initialized to the given value. + +accum f a@(MkArray b v) ivs = + let v' = primCopyVector v + in (MkArray b (accumArrayIvs f b v' ivs)) +{-# accum :: Inline #-} + +accumArray f z b@(bmin, bmax) ivs = + let size = (index b bmax) + 1 + v = primMakeVector size (MkBox z) + in (MkArray b (accumArrayIvs f b v ivs)) +{-# accumArray :: Inline #-} + + +-- This is a bit tricky. We need to force the access to the array element +-- before the update, but not force the thunk that is the value of the +-- array element unless f is strict. + +accumArrayIvs f b v ivs = + let g (i := x) next = + let j = index b i + y = primVectorSel v j + in strict1 + y + (strict1 (primVectorUpdate v j (MkBox (f (unBox y) x))) + next) + in foldr g v ivs +{-# accumArrayIvs :: Inline #-} + + +-- again, be smart and bypass full array indexing on array mapping + +amap f a@(MkArray b@(bmin, bmax) v) = + let size = (index b bmax) + 1 + v' = primMakeVector size uninitializedArrayError + g j = if (j == size) + then v' + else let y = primVectorSel v j + in strict1 (primVectorUpdate v' j (MkBox (f (unBox y)))) + (g (j + 1)) + in (MkArray b (g 0)) +{-# amap :: Inline #-} + + +-- can't bypass the index computation here since f needs it as an argument + +ixmap b f a = array b [i := a ! f i | i <- range b] +{-# ixmap :: Inline #-} + + +-- random other stuff + +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) ) + + readsPrec p = readParen (p > 9) + (\r -> [(array b as, u) | ("array",s) <- lex r, + (b,t) <- reads s, + (as,u) <- reads t ] + ++ + [(listArray b xs, u) | ("listArray",s) <- lex r, + (b,t) <- reads s, + (xs,u) <- reads t ]) diff --git a/progs/prelude/PreludeArrayPrims.hi b/progs/prelude/PreludeArrayPrims.hi new file mode 100644 index 0000000..a8529c0 --- /dev/null +++ b/progs/prelude/PreludeArrayPrims.hi @@ -0,0 +1,37 @@ +-- These primitives are used to implement arrays with constant time +-- access. There are destructive update routines for arrays for use +-- internally in functions such as array. These are impure but are +-- marked as pure to keep them out of the top level monad. This should +-- be redone using lambda-var someday. + +interface PreludeBltinArray where + + +data Vector a -- Used to represent vectors with delayed components +data Delay a -- An explicit represenation of a delayed object + + +-- Primitive vectors now always have strict components. This permits us +-- to treat array indexing as an atomic operation without the explicit +-- force on access. + +primVectorSel :: Vector a -> Int -> a +primVectorUpdate :: Vector a -> Int -> a -> a +primMakeVector :: Int -> a -> Vector a +primCopyVector :: Vector a -> Vector a + +-- These functions are used for explicit sequencing of destructive ops + +strict1 :: a -> b -> b +primForce :: Delay a -> a + +{-# +primVectorSel :: LispName("prim.vector-sel"), Complexity(1) +primVectorUpdate :: LispName("prim.vector-update"), Complexity(1) +primMakeVector :: LispName("prim.make-vector"), Complexity(4) +primCopyVector :: LispName("prim.copy-vector"), Complexity(5) +strict1 :: Strictness("S,N"), + LispName("prim.strict1") +primForce :: LispName("prim.force") +#-} + diff --git a/progs/prelude/PreludeArrayPrims.hu b/progs/prelude/PreludeArrayPrims.hu new file mode 100644 index 0000000..62ea8ac --- /dev/null +++ b/progs/prelude/PreludeArrayPrims.hu @@ -0,0 +1,4 @@ +:output $PRELUDEBIN/PreludeArrayPrims +:stable +:prelude +PreludeArrayPrims.hi diff --git a/progs/prelude/PreludeComplex.hs b/progs/prelude/PreludeComplex.hs new file mode 100644 index 0000000..2044129 --- /dev/null +++ b/progs/prelude/PreludeComplex.hs @@ -0,0 +1,94 @@ +-- Complex Numbers + +module PreludeComplex where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +infixl 6 :+ + +data (RealFloat a) => Complex a = a {-#STRICT#-} :+ a {-#STRICT #-} + 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 + +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 + +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) = cos y * sinh x :+ sin y * cosh x + cosh (x:+y) = cos y * cosh x :+ sin y * sinh x + tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx) + 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 diff --git a/progs/prelude/PreludeCore.hs b/progs/prelude/PreludeCore.hs new file mode 100644 index 0000000..f8a7be2 --- /dev/null +++ b/progs/prelude/PreludeCore.hs @@ -0,0 +1,817 @@ +-- Standard types, classes, and instances + +module PreludeCore ( + Eq((==), (/=)), + Ord((<), (<=), (>=), (>), max, min), + Num((+), (-), (*), negate, abs, signum, fromInteger), + Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger), + Fractional((/), recip, fromRational), + Floating(pi, exp, log, sqrt, (**), logBase, + sin, cos, tan, asin, acos, atan, + sinh, cosh, tanh, asinh, acosh, atanh), + Real(toRational), + RealFrac(properFraction, truncate, round, ceiling, floor), + RealFloat(floatRadix, floatDigits, floatRange, + encodeFloat, decodeFloat, exponent, significand, scaleFloat), + Ix(range, index, inRange), + Enum(enumFrom, enumFromThen, enumFromTo, enumFromThenTo), + Text(readsPrec, showsPrec, readList, showList), ReadS(..), ShowS(..), + Binary(readBin, showBin), +-- List type: [_]((:), []) +-- Tuple types: (_,_), (_,_,_), etc. +-- Trivial type: () + Bool(True, False), + Char, Int, Integer, Float, Double, Bin, + Ratio, Complex((:+)), Assoc((:=)), Array, + String(..), Rational(..) ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +import PreludePrims +import PreludeText +import PreludeRatio(Ratio, Rational(..)) +import PreludeComplex(Complex((:+))) +import PreludeArray(Assoc((:=)), Array) +import PreludeIO({-Request, Response,-} IOError, + Dialogue(..), SuccCont(..), StrCont(..), + StrListCont(..), BinCont(..), FailCont(..)) + +infixr 8 ** +infixl 7 *, /, `quot`, `rem`, `div`, `mod` +infixl 6 +, - +infix 4 ==, /=, <, <=, >=, > + + +infixr 5 : + +data Int = MkInt +data Integer = MkInteger +data Float = MkFloat +data Double = MkDouble +data Char = MkChar +data Bin = MkBin +data List a = a : (List a) | Nil deriving (Eq, Ord) +data Arrow a b = MkArrow a b +data UnitType = UnitConstructor deriving (Eq, Ord, Ix, Enum, Binary) + +-- Equality and Ordered classes + +class Eq a where + (==), (/=) :: a -> a -> Bool + + x /= y = not (x == y) + +class (Eq a) => Ord a where + (<), (<=), (>=), (>):: a -> a -> Bool + max, min :: a -> a -> a + + x < y = x <= y && x /= y + x >= y = y <= x + x > y = y < x + + -- The following default methods are appropriate for partial orders. + -- Note that the second guards in each function can be replaced + -- by "otherwise" and the error cases, eliminated for total orders. + max x y | x >= y = x + | y >= x = y + |otherwise = error "max{PreludeCore}: no ordering relation" + min x y | x <= y = x + | y <= x = y + |otherwise = error "min{PreludeCore}: no ordering relation" + + +-- Numeric classes + +class (Eq a, Text a) => Num a where + (+), (-), (*) :: a -> a -> a + negate :: a -> a + abs, signum :: a -> a + fromInteger :: Integer -> 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 + + 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 + + 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 + tanh x = sinh x / cosh x + +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, Text a) => Ix a where -- This is a Yale modification + 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,n'..] + enumFromTo :: a -> a -> [a] -- [n..m] + enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] + + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + +defaultEnumFromTo n m = takeWhile (<= m) (enumFrom n) +defaultEnumFromThenTo n n' m + = takeWhile (if n' >= n then (<= m) else (>= m)) + (enumFromThen n n') +{-# defaultEnumFromTo :: Inline #-} +{-# defaultEnumFromThenTo :: Inline #-} + +-- 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) = showString ", " . shows x . showl xs + + + +-- Binary class + +class Binary a where + readBin :: Bin -> (a,Bin) + showBin :: a -> Bin -> Bin + + +-- Trivial type + +-- data () = () deriving (Eq, Ord, Ix, Enum, Binary) + +instance Text () where + readsPrec p = readParen False + (\r -> [((),t) | ("(",s) <- lex r, + (")",t) <- lex s ] ) + showsPrec p () = showString "()" + + +-- Binary type + +instance Text Bin where + readsPrec p s = error "readsPrec{PreludeText}: Cannot read Bin." + showsPrec p b = showString "<>" + + +-- Boolean type + +data Bool = False | True deriving (Eq, Ord, Ix, Enum, Text, Binary) + + +-- Character type + +instance Eq Char where + (==) = primEqChar + (/=) = primNeqChar + +instance Ord Char where + (<) = primLsChar + (<=) = primLeChar + (>) = primGtChar + (>=) = primGeChar + +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 + {-# range :: Inline #-} + +instance Enum Char where + enumFrom = charEnumFrom + enumFromThen = charEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +charEnumFrom c = map chr [ord c .. ord maxChar] +charEnumFromThen c c' = map chr [ord c, ord c' .. ord lastChar] + where lastChar = if c' < c then minChar else maxChar +{-# charEnumFrom :: Inline #-} +{-# charEnumFromThen :: Inline #-} + +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) = showLitChar c . showl cs + +type String = [Char] + + +-- Standard Integral types + +instance Eq Int where + (==) = primEqInt + (/=) = primNeqInt + +instance Eq Integer where + (==) = primEqInteger + (/=) = primNeqInteger + +instance Ord Int where + (<) = primLsInt + (<=) = primLeInt + (>) = primGtInt + (>=) = primGeInt + max = primIntMax + min = primIntMin + +instance Ord Integer where + (<) = primLsInteger + (<=) = primLeInteger + (>) = primGtInteger + (>=) = primGeInteger + max = primIntegerMax + min = primIntegerMin + +instance Num Int where + (+) = primPlusInt + (-) = primMinusInt + negate = primNegInt + (*) = primMulInt + abs = primAbsInt + signum = signumReal + fromInteger = primIntegerToInt + +instance Num Integer where + (+) = primPlusInteger + (-) = primMinusInteger + negate = primNegInteger + (*) = primMulInteger + abs = primAbsInteger + signum = signumReal + fromInteger x = 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 + +instance Integral Int where + quotRem = primQuotRemInt + toInteger = primIntToInteger + +instance Integral Integer where + quotRem = primQuotRemInteger + toInteger x = x + +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 + {-# range :: Inline #-} + +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 + {-# range :: Inline #-} + +instance Enum Int where + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +instance Enum Integer where + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +numericEnumFrom :: (Real a) => a -> [a] +numericEnumFromThen :: (Real a) => a -> a -> [a] +numericEnumFrom = iterate (+1) +numericEnumFromThen n m = iterate (+(m-n)) n + +{-# numericEnumFrom :: Inline #-} +{-# numericEnumFromThen :: Inline #-} + + +instance Text Int where + readsPrec p = readSigned readDec + showsPrec = showSigned showInt + +instance Text Integer where + readsPrec p = readSigned readDec + showsPrec = showSigned showInt + + +-- Standard Floating types + +instance Eq Float where + (==) = primEqFloat + (/=) = primNeqFloat + +instance Eq Double where + (==) = primEqDouble + (/=) = primNeqDouble + +instance Ord Float where + (<) = primLsFloat + (<=) = primLeFloat + (>) = primGtFloat + (>=) = primGeFloat + max = primFloatMax + min = primFloatMin + +instance Ord Double where + (<) = primLsDouble + (<=) = primLeDouble + (>) = primGtDouble + (>=) = primGeDouble + max = primDoubleMax + min = primDoubleMax + +instance Num Float where + (+) = primPlusFloat + (-) = primMinusFloat + negate = primNegFloat + (*) = primMulFloat + abs = primAbsFloat + signum = signumReal + fromInteger n = encodeFloat n 0 + +instance Num Double where + (+) = primPlusDouble + (-) = primMinusDouble + negate = primNegDouble + (*) = primMulDouble + abs = primAbsDouble + signum = signumReal + fromInteger n = encodeFloat n 0 + +instance Real Float where + toRational = primFloatToRational + +instance Real Double where + toRational = primDoubleToRational + +-- realFloatToRational x = (m%1)*(b%1)^^n +-- where (m,n) = decodeFloat x +-- b = floatRadix x + +instance Fractional Float where + (/) = primDivFloat + fromRational = primRationalToFloat +-- fromRational = rationalToRealFloat + +instance Fractional Double where + (/) = primDivDouble + fromRational = primRationalToDouble +-- fromRational = rationalToRealFloat + +-- 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' + +instance Floating Float where + pi = primPiFloat + exp = primExpFloat + log = primLogFloat + sqrt = primSqrtFloat + sin = primSinFloat + cos = primCosFloat + tan = primTanFloat + asin = primAsinFloat + acos = primAcosFloat + atan = primAtanFloat + sinh = primSinhFloat + cosh = primCoshFloat + tanh = primTanhFloat + asinh = primAsinhFloat + acosh = primAcoshFloat + atanh = primAtanhFloat + +instance Floating Double where + pi = primPiDouble + exp = primExpDouble + log = primLogDouble + sqrt = primSqrtDouble + sin = primSinDouble + cos = primCosDouble + tan = primTanDouble + asin = primAsinDouble + acos = primAcosDouble + atan = primAtanDouble + sinh = primSinhDouble + cosh = primCoshDouble + tanh = primTanhDouble + asinh = primAsinhDouble + acosh = primAcoshDouble + atanh = primAtanhDouble + + +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)) + +instance RealFloat Float where + floatRadix _ = primFloatRadix + floatDigits _ = primFloatDigits + floatRange _ = (primFloatMinExp,primFloatMaxExp) + decodeFloat = primDecodeFloat + encodeFloat = primEncodeFloat + +instance RealFloat Double where + floatRadix _ = primDoubleRadix + floatDigits _ = primDoubleDigits + floatRange _ = (primDoubleMinExp,primDoubleMaxExp) + decodeFloat = primDecodeDouble + encodeFloat = primEncodeDouble + +instance Enum Float where + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +instance Enum Double where + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +instance Text Float where + readsPrec p = readSigned readFloat + showsPrec = showSigned showFloat + +instance Text Double where + readsPrec p = readSigned readFloat + showsPrec = showSigned showFloat + + +-- Lists + +-- data [a] = [] | a : [a] deriving (Eq, Ord, Binary) + +instance (Text a) => Text [a] where + readsPrec p = readList + showsPrec p = showList + + +-- Tuples + +-- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Binary) +{- +instance (Text a, Text b) => Text (a,b) where + readsPrec p = readParen False + (\r -> [((x,y), w) | ("(",s) <- lex r, + (x,t) <- reads s, + (",",u) <- lex t, + (y,v) <- reads u, + (")",w) <- lex v ] ) + + showsPrec p (x,y) = showChar '(' . shows x . showChar ',' . + shows y . showChar ')' +-- et cetera +-} + +-- Functions + +instance Text (a -> b) where + readsPrec p s = error "readsPrec{PreludeCore}: Cannot read functions." + showsPrec p f = showString "<>" + +-- Support for class Bin + +instance Binary Int where + showBin i b = primShowBinInt i b + readBin b = primReadBinInt b + +instance Binary Integer where + showBin i b = primShowBinInteger i b + readBin b = primReadBinInteger b + +instance Binary Float where + showBin f b = primShowBinFloat f b + readBin b = primReadBinFloat b + +instance Binary Double where + showBin d b = primShowBinDouble d b + readBin b = primReadBinDouble b + +instance Binary Char where + showBin c b = primShowBinInt (ord c) b + readBin b = (chr i,b') where + (i,b') = primReadBinSmallInt b primMaxChar + +instance (Binary a) => Binary [a] where + showBin l b = showBin (length l :: Int) (sb1 l b) where + sb1 [] b = b + sb1 (h:t) b = showBin h (sb1 t b) + readBin bin = rbl len bin' where + len :: Int + (len,bin') = readBin bin + rbl 0 b = ([],b) + rbl n b = (h:t,b'') where + (h,b') = readBin b + (t,b'') = rbl (n-1) b' + +instance (Ix a, Binary a, Binary b) => Binary (Array a b) where + showBin a = showBin (bounds a) . showBin (elems a) + readBin bin = (listArray b vs, bin'') + where (b,bin') = readBin bin + (vs,bin'') = readBin bin' + +{- +instance (Binary a, Binary b) => Binary (a,b) where + showBin (x,y) = (showBin x) . (showBin y) + readBin b = ((x,y),b'') where + (x,b') = readBin b + (y,b'') = readBin b' + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + showBin (x,y,z) = (showBin x) . (showBin y) . (showBin z) + readBin b = ((x,y,z),b3) where + (x,b1) = readBin b + (y,b2) = readBin b1 + (z,b3) = readBin b2 + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + showBin (a,b,c,d) = (showBin a) . (showBin b) . (showBin c) . (showBin d) + readBin b = ((a1,a2,a3,a4),b4) where + (a1,b1) = readBin b + (a2,b2) = readBin b1 + (a3,b3) = readBin b2 + (a4,b4) = readBin b3 +-} +-- Instances for tuples + +-- This whole section should be handled in the support code. For now, +-- only tuple instances expliticly provided here are available. +-- Currently provided: + +-- 2,3 tuples: all classes (Eq, Ord, Ix, Bin, Text) +-- 4 tuples: Eq, Bin, Text +-- 5, 6 tuples: Text (printing only) + +{- +rangeSize :: (Ix a) => (a,a) -> Int +rangeSize (l,u) = index (l,u) u + 1 + +instance (Eq a1, Eq a2) => Eq (a1,a2) where + (a1,a2) == (z1,z2) = a1==z1 && a2==z2 + +instance (Ord a1, Ord a2) => Ord (a1,a2) where + (a1,a2) <= (z1,z2) = a1<=z1 || a1==z1 && a2<=z2 + (a1,a2) < (z1,z2) = a1 Ix (a1,a2) where + range ((l1,l2),(u1,u2)) = [(i1,i2) | i1 <- range(l1,u1), + i2 <- range(l2,u2)] + index ((l1,l2),(u1,u2)) (i1,i2) = + index (l1,u1) i1 * rangeSize (l2,u2) + + index (l2,u2) i2 + inRange ((l1,l2),(u1,u2)) (i1,i2) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 + +{- Apprears in Joe's code. +instance (Text a1, Text a2) => Text (a1,a2) where + readsPrec p = readParen False + (\r0 -> [((a1,a2), w) | ("(",r1) <- lex r0, + (a1,r2) <- reads r1, + (",",r3) <- lex r2, + (a2,r4) <- reads r3, + (")",w) <- lex r4 ]) + + showsPrec p (a1,a2) = showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ')' +-} + +instance (Eq a1, Eq a2, Eq a3) => Eq (a1,a2,a3) where + (a1,a2,a3) == (z1,z2,z3) = a1==z1 && a2==z2 && a3==z3 + +instance (Ord a1, Ord a2, Ord a3) => Ord (a1,a2,a3) where + (a1,a2,a3) <= (z1,z2,z3) = a1<=z1 || a1==z1 && + (a2<=z2 || a2==z2 && + a3<=z3) + (a1,a2,a3) < (z1,z2,z3) = a1 Ix (a1,a2,a3) where + range ((l1,l2,l3),(u1,u2,u3)) = + [(i1,i2,i3) | i1 <- range(l1,u1), + i2 <- range(l2,u2), + i3 <- range(l3,u3)] + index ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + (index (l1,u1) i1 * rangeSize (l2,u2) + + index (l2,u2) i2 ) * rangeSize (l3,u3) + + index (l3,u3) i3 + inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && inRange (l3,u3) i3 + + +instance (Text a1, Text a2, Text a3) => Text (a1,a2,a3) where + readsPrec p = readParen False + (\r0 -> [((a1,a2,a3), w) | + ("(",r1) <- lex r0, + (a1,r2) <- reads r1, + (",",r3) <- lex r2, + (a2,r4) <- reads r3, + (",",r5) <- lex r4, + (a3,r6) <- reads r5, + (")",w) <- lex r6 ]) + showsPrec p (a1,a2,a3) = + showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ',' . + shows a3 . showChar ')' + +instance (Eq a1, Eq a2, Eq a3, Eq a4) => Eq (a1,a2,a3,a4) where + (a1,a2,a3,a4) == (z1,z2,z3,z4) = a1==z1 && a2==z2 && a3==z3 && a4 == z4 + +instance (Text a1, Text a2, Text a3, Text a4) => Text (a1,a2,a3,a4) where + readsPrec p = readParen False + (\r0 -> [((a1,a2,a3,a4), w) | + ("(",r1) <- lex r0, + (a1,r2) <- reads r1, + (",",r3) <- lex r2, + (a2,r4) <- reads r3, + (",",r5) <- lex r4, + (a3,r6) <- reads r5, + (",",r7) <- lex r6, + (a4,r8) <- reads r7, + (")",w) <- lex r8 ]) + showsPrec p (a1,a2,a3,a4) = + showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ',' . + shows a3 . showChar ',' . + shows a4 . showChar ')' + +instance (Text a1, Text a2, Text a3, Text a4, Text a5) => + Text (a1,a2,a3,a4,a5) where + readsPrec p = error "Read of 5 tuples not implemented" + showsPrec p (a1,a2,a3,a4,a5) = + showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ',' . + shows a3 . showChar ',' . + shows a4 . showChar ',' . + shows a5 . showChar ')' + +instance (Text a1, Text a2, Text a3, Text a4, Text a5, Text a6) => + Text (a1,a2,a3,a4,a5,a6) where + readsPrec p = error "Read of 6 tuples not implemented" + showsPrec p (a1,a2,a3,a4,a5,a6) = + showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ',' . + shows a3 . showChar ',' . + shows a4 . showChar ',' . + shows a5 . showChar ',' . + shows a6 . showChar ')' + + +-} diff --git a/progs/prelude/PreludeIO.hs b/progs/prelude/PreludeIO.hs new file mode 100644 index 0000000..6173d8c --- /dev/null +++ b/progs/prelude/PreludeIO.hs @@ -0,0 +1,232 @@ +-- I/O functions and definitions + +module PreludeIO(stdin,stdout,stderr,stdecho,{-Request(..),Response(..),-} + IOError(..),Dialogue(..),IO(..),SystemState,IOResult, + SuccCont(..),StrCont(..), + StrListCont(..),BinCont(..),FailCont(..), + readFile, writeFile, appendFile, readBinFile, + writeBinFile, appendBinFile, deleteFile, statusFile, + readChan, appendChan, readBinChan, appendBinChan, + statusChan, echo, getArgs, getProgName, getEnv, setEnv, + done, exit, abort, print, prints, interact, + thenIO,thenIO_,seqIO,returnIO, doneIO) + where + +import PreludeBltinIO +import PreludeBltinArray(strict1) + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +-- These datatypes are used by the monad. + +type IO a = SystemState -> IOResult a + +data SystemState = SystemState +data IOResult a = IOResult a + +-- Operations in the monad + +-- This definition is needed to allow proper tail recursion of the Lisp +-- code. The use of strict1 forces f1 s (since getState is strict) before +-- the call to f2. The optimizer removed getState and getRes from the +-- generated code. + +{-# thenIO :: Inline #-} +thenIO f1 f2 s = + let g = f1 s + s' = getState g in + strict1 s' (f2 (getRes g) s') + +{-# thenIO_ :: Inline #-} +x `thenIO_` y = x `thenIO` \_ -> y +x `seqIO` y = x `thenIO` \_ -> y + +-- The returnIO function is implemented directly as a primitive. +doneIO = returnIO () + + +-- File and channel names: + +stdin = "stdin" +stdout = "stdout" +stderr = "stderr" +stdecho = "stdecho" + + +-- Requests and responses: + +{- Not used since streams are no longer supported: +data Request = -- file system requests: + ReadFile String + | WriteFile String String + | AppendFile String String + | ReadBinFile String + | WriteBinFile String Bin + | AppendBinFile String Bin + | DeleteFile String + | StatusFile String + -- channel system requests: + | ReadChan String + | AppendChan String String + | ReadBinChan String + | AppendBinChan String Bin + | StatusChan String + -- environment requests: + | Echo Bool + | GetArgs + | GetProgName + | GetEnv String + | SetEnv String String + deriving Text + +data Response = Success + | Str String + | StrList [String] + | Bn Bin + | Failure IOError + deriving Text + +-} + +data IOError = WriteError String + | ReadError String + | SearchError String + | FormatError String + | OtherError String + deriving Text + +-- Continuation-based I/O: + +type Dialogue = IO () +type SuccCont = Dialogue +type StrCont = String -> Dialogue +type StrListCont = [String] -> Dialogue +type BinCont = Bin -> Dialogue +type FailCont = IOError -> Dialogue + +done :: Dialogue +readFile :: String -> FailCont -> StrCont -> Dialogue +writeFile :: String -> String -> FailCont -> SuccCont -> Dialogue +appendFile :: String -> String -> FailCont -> SuccCont -> Dialogue +readBinFile :: String -> FailCont -> BinCont -> Dialogue +writeBinFile :: String -> Bin -> FailCont -> SuccCont -> Dialogue +appendBinFile :: String -> Bin -> FailCont -> SuccCont -> Dialogue +deleteFile :: String -> FailCont -> SuccCont -> Dialogue +statusFile :: String -> FailCont -> StrCont -> Dialogue +readChan :: String -> FailCont -> StrCont -> Dialogue +appendChan :: String -> String -> FailCont -> SuccCont -> Dialogue +readBinChan :: String -> FailCont -> BinCont -> Dialogue +appendBinChan :: String -> Bin -> FailCont -> SuccCont -> Dialogue +statusChan :: String -> FailCont -> StrCont -> Dialogue +echo :: Bool -> FailCont -> SuccCont -> Dialogue +getArgs :: FailCont -> StrListCont -> Dialogue +getProgName :: FailCont -> StrCont -> Dialogue +getEnv :: String -> FailCont -> StrCont -> Dialogue +setEnv :: String -> String -> FailCont -> SuccCont -> Dialogue + +done = returnIO () + +readFile name fail succ = + primReadStringFile name `thenIO` objDispatch fail succ + +writeFile name contents fail succ = + primWriteStringFile name contents `thenIO` succDispatch fail succ + +appendFile name contents fail succ = + primAppendStringFile name contents `thenIO` succDispatch fail succ + +readBinFile name fail succ = + primReadBinFile name `thenIO` objDispatch fail succ + +writeBinFile name contents fail succ = + primWriteBinFile name contents `thenIO` succDispatch fail succ + +appendBinFile name contents fail succ = + primAppendBinFile name contents `thenIO` succDispatch fail succ + +deleteFile name fail succ = + primDeleteFile name `thenIO` succDispatch fail succ + +statusFile name fail succ = + primStatusFile name `thenIO` + (\status -> case status of Succ s -> succ s + Fail msg -> fail (SearchError msg)) + +readChan name fail succ = + if name == stdin then + primReadStdin `thenIO` succ + else + badChan fail name + +appendChan name contents fail succ = + if name == stdout then + primWriteStdout contents `thenIO` succDispatch fail succ + else + badChan fail name + +readBinChan name fail succ = + if name == stdin then + primReadBinStdin `thenIO` objDispatch fail succ + else + badChan fail name + +appendBinChan name contents fail succ = + if name == stdout then + primWriteBinStdout contents `thenIO` succDispatch fail succ + else + badChan fail name + +statusChan name fail succ = + if name == stdin || name == stdout then + succ "0 0" + else + fail (SearchError "Channel not defined") + +echo bool fail succ = + if bool then + succ + else + fail (OtherError "Echo cannot be turned off") + +getArgs fail succ = + succ [""] + +getProgName fail succ = + succ "haskell" + +getEnv name fail succ = + primGetEnv name `thenIO` objDispatch fail succ + +setEnv name val fail succ = + fail (OtherError "setEnv not implemented") + +objDispatch fail succ r = + case r of Succ s -> succ s + Fail msg -> fail (OtherError msg) + +succDispatch fail succ r = + case r of Succ _ -> succ + Fail msg -> fail (OtherError msg) + +badChan f name = f (OtherError ("Improper IO Channel: " ++ name)) + +abort :: FailCont +abort err = done + +exit :: FailCont +exit err = appendChan stderr (msg ++ "\n") 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) + diff --git a/progs/prelude/PreludeIOMonad.hs b/progs/prelude/PreludeIOMonad.hs new file mode 100644 index 0000000..9a45606 --- /dev/null +++ b/progs/prelude/PreludeIOMonad.hs @@ -0,0 +1,60 @@ +module IOMonad (State, IO(..)) where + +import IOMonadPrims + +{- I use data instead of type so that IO can be abstract. For efficiency, + IO can be annotated as a strict constructor. +-} + +type IO a = State -> (State, a) + +data State = State + +-- The rest of this file is unnecessary at the moment since +-- unitIO & bindIO are primitives and we're not using the rest of this + +{- Implemented as a primitives: +bindIO :: IO a -> (a -> IO b) -> IO b +bindIO (IO m) (IO k) = IO (\s0 -> let (s1, a) = m s0 in k a s1) -} + +unitIO :: a -> IO a +unitIO x = IO (\s -> (s, x)) + +-} + +{- Not currently used: +pureIO :: IO a -> a +pureIO (IO m) = let (s, x) = m State in x + +-- execIO executes a program of type IO (). +execIO :: IO () -> State +execIO (IO m) = let (s, x) = m State in s + +infixr 1 =: +infixr 1 ? + +-- assignment +(=:) :: a -> Var a -> IO () +x =: v = IO (\s -> (update v x s, ())) + +-- reader +(?) :: Var a -> (a -> IO b) -> IO b +v ? k = IO (\s -> (s, readVar v s)) `bindIO` k + +-- new +newvar :: IO (Var a) +newvar = IO allocVar + +instance Eq (Var a) where + x == y = eqVar x y +-} + + + + + + + + + + diff --git a/progs/prelude/PreludeIOPrims.hi b/progs/prelude/PreludeIOPrims.hi new file mode 100644 index 0000000..e4c2e74 --- /dev/null +++ b/progs/prelude/PreludeIOPrims.hi @@ -0,0 +1,55 @@ +-- These lisp functions implement the standard Haskell requests + +interface PreludeBltinIO where + +import PreludeCore(String,Bin) +import PreludeIO(SystemState,IOResult,IO) +data IOResponse a = Succ a | Fail String + +{-# Prelude #-} + +primReadStringFile :: String -> IO (IOResponse String) +primWriteStringFile :: String -> String -> IO (IOResponse ()) +primAppendStringFile :: String -> String -> IO (IOResponse ()) +primReadBinFile :: String -> IO (IOResponse Bin) +primWriteBinFile :: String -> Bin -> IO (IOResponse ()) +primAppendBinFile :: String -> Bin -> IO (IOResponse ()) +primDeleteFile :: String -> IO (IOResponse ()) +primStatusFile :: String -> IO (IOResponse String) +primReadStdin :: IO String +primWriteStdout :: String -> IO (IOResponse ()) +primReadBinStdin :: IO (IOResponse Bin) +primWriteBinStdout :: Bin -> IO (IOResponse ()) +primGetEnv :: String -> IO (IOResponse String) + +{-# +primReadStringFile :: LispName("prim.read-string-file") +primWriteStringFile :: LispName("prim.write-string-file"), NoConversion +primAppendStringFile :: LispName("prim.append-string-file"), NoConversion +primReadBinFile :: LispName("prim.read-bin-file") +primWriteBinFile :: LispName("prim.write-bin-file") +primAppendBinFile :: LispName("prim.append-bin-file") +primDeleteFile :: LispName("prim.delete-file") +primStatusFile :: LispName("prim.status-file") +primReadStdin :: LispName("prim.read-string-stdin"), NoConversion +primWriteStdout :: LispName("prim.write-string-stdout"), NoConversion +primReadBinStdin :: LispName("prim.read-bin-stdin") +primWriteBinStdout :: LispName("prim.write-bin-stdout") +primGetEnv :: LispName("prim.getenv") +#-} + +-- Monad prims + +returnIO :: a -> IO a +getState :: IOResult a -> SystemState +getRes :: IOResult a -> a + +{-# +returnIO :: LispName("prim.returnio"), + Strictness("N,S"), NoConversion, Complexity(3) +getState :: LispName("prim.getstate"), + Strictness("S"), NoConversion, Complexity(3) +getRes :: LispName("prim.getres"), + Strictness("S"), NoConversion +#-} + diff --git a/progs/prelude/PreludeIOPrims.hu b/progs/prelude/PreludeIOPrims.hu new file mode 100644 index 0000000..66393c5 --- /dev/null +++ b/progs/prelude/PreludeIOPrims.hu @@ -0,0 +1,4 @@ +:output $PRELUDEBIN/PreludeIOPrims +:stable +:prelude +PreludeIOPrims.hi diff --git a/progs/prelude/PreludeList.hs b/progs/prelude/PreludeList.hs new file mode 100644 index 0000000..3e445c3 --- /dev/null +++ b/progs/prelude/PreludeList.hs @@ -0,0 +1,585 @@ +-- Standard list functions + +-- build really shouldn't be exported, but what the heck. +-- some of the helper functions in this file shouldn't be +-- exported either! + +module PreludeList (PreludeList.., foldr, build) where + +import PreludePrims(build, foldr) + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +infixl 9 !! +infix 5 \\ +infixr 5 ++ +infix 4 `elem`, `notElem` + + +-- These are primitives used by the deforestation stuff in the optimizer. +-- the optimizer will turn references to foldr and build into +-- inlineFoldr and inlineBuild, respectively, but doesn't want to +-- necessarily inline all references immediately. + +inlineFoldr :: (a -> b -> b) -> b -> [a] -> b +inlineFoldr f z l = + let foldr' [] = z + foldr' (x:xs) = f x (foldr' xs) + in foldr' l +{-# inlineFoldr :: Inline #-} + + +inlineBuild :: ((a -> [a] -> [a]) -> [b] -> [c]) -> [c] +inlineBuild g = g (:) [] +{-# inlineBuild :: Inline #-} + + +-- head and tail extract the first element and remaining elements, +-- respectively, of a list, which must be non-empty. last and init +-- are the dual functions working from the end of a finite list, +-- rather than the beginning. + +head :: [a] -> a +head (x:_) = x +head [] = error "head{PreludeList}: head []" + +last :: [a] -> a +last [x] = x +last (_:xs) = last xs +last [] = error "last{PreludeList}: last []" + +tail :: [a] -> [a] +tail (_:xs) = xs +tail [] = error "tail{PreludeList}: tail []" + +init :: [a] -> [a] +init [x] = [] +init (x:xs) = x : init xs +init [] = error "init{PreludeList}: init []" + +-- null determines if a list is empty. +null :: [a] -> Bool +null [] = True +null (_:_) = False + + +-- list concatenation (right-associative) + +(++) :: [a] -> [a] -> [a] +xs ++ ys = build (\ c n -> foldr c (foldr c n ys) xs) +{-# (++) :: Inline #-} + + +-- the first occurrence of each element of ys in turn (if any) +-- has been removed from xs. Thus, (xs ++ ys) \\ xs == ys. +(\\) :: (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 l = foldr (\ x n -> 1 + n) 0 l +--genericLength [] = 0 +--genericLength (x:xs) = 1 + genericLength xs +{-# genericLength :: Inline #-} + + +length :: [a] -> Int +length l = foldr (\ x n -> 1 + n) 0 l +--length [] = 0 +--length (x:xs) = 1 + length xs +{-# length :: Inline #-} + +-- List index (subscript) operator, 0-origin +(!!) :: (Integral a) => [b] -> a -> b +l !! i = nth l (fromIntegral i) +{-# (!!) :: Inline #-} + +nth :: [b] -> Int -> b +nth l m = let f x g 0 = x + f x g i = g (i - 1) + fail _ = error "(!!){PreludeList}: index too large" + in foldr f fail l m +{-# nth :: Inline #-} +--nth _ n | n < 0 = error "(!!){PreludeList}: negative index" +--nth [] n = error "(!!){PreludeList}: index too large" +--nth (x:xs) n +-- | n == 0 = x +-- | otherwise = nth xs (n - 1) +--{-# nth :: Strictness("S,S") #-} + +-- map f xs applies f to each element of xs; i.e., map f xs == [f x | x <- xs]. +map :: (a -> b) -> [a] -> [b] +map f xs = build (\ c n -> foldr (\ a b -> c (f a) b) n xs) +--map f [] = [] +--map f (x:xs) = f x : map f xs +{-# map :: Inline #-} + + +-- filter, applied to a predicate and a list, returns the list of those +-- elements that satisfy the predicate; i.e., +-- filter p xs == [x | x <- xs, p x]. +filter :: (a -> Bool) -> [a] -> [a] +filter f xs = build (\ c n -> + foldr (\ a b -> if f a then c a b else b) + n xs) +--filter p = foldr (\x xs -> if p x then x:xs else xs) [] +{-# filter :: Inline #-} + + +-- 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; i.e., +-- partition p xs == (filter p xs, filter (not . p) xs). +partition :: (a -> Bool) -> [a] -> ([a],[a]) +partition p = foldr select ([],[]) + where select x (ts,fs) | p x = (x:ts,fs) + | otherwise = (ts,x:fs) +{-# partition :: Inline #-} + + +-- foldl, applied to a binary operator, a starting value (typically the +-- left-identity of the operator), and a list, reduces the list using +-- the binary operator, from left to right: +-- foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn +-- foldl1 is a variant that has no starting value argument, and thus must +-- be applied to non-empty lists. scanl is similar to foldl, but returns +-- a list of successive reduced values from the left: +-- scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- Note that last (scanl f z xs) == foldl f z xs. +-- scanl1 is similar, again without the starting element: +-- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] + +foldl :: (a -> b -> a) -> a -> [b] -> a +foldl f z xs = foldr (\ b g a -> g (f a b)) id xs z +--foldl f z [] = z +--foldl f z (x:xs) = foldl f (f z x) xs +{-# foldl :: Inline #-} + +foldl1 :: (a -> a -> a) -> [a] -> a +foldl1 f (x:xs) = foldl f x xs +foldl1 _ [] = error "foldl1{PreludeList}: empty list" +{-# foldl1 :: Inline #-} + +scanl :: (a -> b -> a) -> a -> [b] -> [a] +scanl f q xs = q : (case xs of + [] -> [] + x:xs -> scanl f (f q x) xs) +{-# scanl :: Inline #-} + +scanl1 :: (a -> a -> a) -> [a] -> [a] +scanl1 f (x:xs) = scanl f x xs +scanl1 _ [] = error "scanl1{PreludeList}: empty list" +{-# scanl1 :: Inline #-} + + +-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the +-- above functions. + +--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) +foldr1 _ [] = error "foldr1{PreludeList}: empty list" +{-# foldr1 :: Inline #-} + + +-- I'm not sure the build/foldr expansion wins. + +scanr :: (a -> b -> b) -> b -> [a] -> [b] +--scanr f q0 l = build (\ c n -> +-- let g x qs@(q:_) = c (f x q) qs +-- in foldr g (c q0 n) l) +scanr f q0 [] = [q0] +scanr f q0 (x:xs) = f x q : qs + where qs@(q:_) = scanr f q0 xs +{-# scanr :: Inline #-} + +scanr1 :: (a -> a -> a) -> [a] -> [a] +scanr1 f [x] = [x] +scanr1 f (x:xs) = f x q : qs + where qs@(q:_) = scanr1 f xs +scanr1 _ [] = error "scanr1{PreludeList}: empty list" +{-# scanr1 :: Inline #-} + + +-- iterate f x returns an infinite list of repeated applications of f to x: +-- iterate f x == [x, f x, f (f x), ...] +iterate :: (a -> a) -> a -> [a] +iterate f x = build (\ c n -> + let iterate' x' = c x' (iterate' (f x')) + in iterate' x) +--iterate f x = x : iterate f (f x) +{-# iterate :: Inline #-} + + +-- repeat x is an infinite list, with x the value of every element. +repeat :: a -> [a] +repeat x = build (\ c n -> let r = c x r in r) +--repeat x = xs where xs = x:xs +{-# repeat :: Inline #-} + +-- cycle ties a finite list into a circular one, or equivalently, +-- the infinite repetition of the original list. It is the identity +-- on infinite lists. + +cycle :: [a] -> [a] +cycle xs = xs' where xs' = xs ++ xs' + + +-- take n, applied to a list xs, returns the prefix of xs of length n, +-- or xs itself if n > length xs. drop n xs returns the suffix of xs +-- after the first n elements, or [] if n > length xs. splitAt n xs +-- is equivalent to (take n xs, drop n xs). + +take :: (Integral a) => a -> [b] -> [b] +take n l = takeInt (fromIntegral n) l +{-# take :: Inline #-} + +takeInt :: Int -> [b] -> [b] +takeInt m l = + build (\ c n -> + let f x g i | i <= 0 = n + | otherwise = c x (g (i - 1)) + in foldr f (\ _ -> n) l m) +--takeInt 0 _ = [] +--takeInt _ [] = [] +--takeInt n l | n > 0 = primTake n l +{-# takeInt :: Inline #-} + + + +-- Writing drop and friends in terms of build/foldr seems to lose +-- way big since they cause an extra traversal of the list tail +-- (except when the calls are being deforested). + +drop :: (Integral a) => a -> [b] -> [b] +drop n l = dropInt (fromIntegral n) l +{-# drop :: Inline #-} +{-# drop :: Strictness("S,S") #-} + + +dropInt :: Int -> [b] -> [b] +dropInt 0 xs = xs +dropInt _ [] = [] +dropInt (n+1) (_:xs) = dropInt n xs +{-# dropInt :: Inline #-} + +splitAt :: (Integral a) => a -> [b] -> ([b],[b]) +splitAt n l = splitAtInt (fromIntegral n) l +{-# splitAt :: Inline #-} + +splitAtInt :: Int -> [b] -> ([b],[b]) +splitAtInt 0 xs = ([],xs) +splitAtInt _ [] = ([],[]) +splitAtInt (n+1) (x:xs) = (x:xs',xs'') where (xs',xs'') = splitAtInt n xs +{-# splitAtInt :: Inline #-} + +-- takeWhile, applied to a predicate p and a list xs, returns the longest +-- prefix (possibly empty) of xs of elements that satisfy p. dropWhile p xs +-- returns the remaining suffix. Span p xs is equivalent to +-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p. + +takeWhile :: (a -> Bool) -> [a] -> [a] +takeWhile p l = build (\ c n -> foldr (\ a b -> if p a then c a b else n) n l) +--takeWhile p [] = [] +--takeWhile p (x:xs) +-- | p x = x : takeWhile p xs +-- | otherwise = [] +{-# takeWhile :: Inline #-} + + +dropWhile :: (a -> Bool) -> [a] -> [a] +dropWhile p [] = [] +dropWhile p xs@(x:xs') + | p x = dropWhile p xs' + | otherwise = xs +{-# dropWhile :: Inline #-} + +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) + +{-# span :: Inline #-} +{-# break :: Inline #-} + + +-- lines breaks a string up into a list of strings at newline characters. +-- The resulting strings do not contain newlines. Similary, words +-- breaks a string up into a list of words, which were delimited by +-- white space. unlines and unwords are the inverse operations. +-- unlines joins lines with terminating newlines, and unwords joins +-- words with separating spaces. + +lines :: String -> [String] +lines "" = [] +lines s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines 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 (++ "\n") +{-# unlines :: Inline #-} + + +unwords :: [String] -> String +unwords [] = "" +unwords ws = foldr1 (\w s -> w ++ ' ':s) ws + +-- nub (meaning "essence") removes duplicate elements from its list argument. +nub :: (Eq a) => [a] -> [a] +nub l = build (\ c n -> + let f x g [] = c x (g [x]) + f x g xs = if elem x xs + then (g xs) + else c x (g (x:xs)) + in foldr f (\ _ -> n) l []) +{-# nub :: Inline #-} +--nub [] = [] +--nub (x:xs) = x : nub (filter (/= x) xs) + +-- reverse xs returns the elements of xs in reverse order. xs must be finite. +reverse :: [a] -> [a] +reverse l = build (\ c n -> + let f x g tail = g (c x tail) + in foldr f id l n) +{-# reverse :: Inline #-} +--reverse x = reverse1 x [] where +-- reverse1 [] a = a +-- reverse1 (x:xs) a = reverse1 xs (x:a) + +-- and returns the conjunction of a Boolean list. For the result to be +-- True, the list must be finite; False, however, results from a False +-- value at a finite index of a finite or infinite list. or is the +-- disjunctive dual of and. +and, or :: [Bool] -> Bool +and = foldr (&&) True +or = foldr (||) False +{-# and :: Inline #-} +{-# or :: Inline #-} + +-- Applied to a predicate and a list, any determines if any element +-- of the list satisfies the predicate. Similarly, for all. +any, all :: (a -> Bool) -> [a] -> Bool +any p = or . map p +all p = and . map p +{-# any :: Inline #-} +{-# all :: Inline #-} + +-- elem is the list membership predicate, usually written in infix form, +-- e.g., x `elem` xs. notElem is the negation. +elem, notElem :: (Eq a) => a -> [a] -> Bool + +elem x ys = foldr (\ y t -> (x == y) || t) False ys +--x `elem` [] = False +--x `elem` (y:ys) = x == y || x `elem` ys +{-# elem :: Inline #-} +notElem x y = not (x `elem` y) + +-- sum and product compute the sum or product of a finite list of numbers. +sum, product :: (Num a) => [a] -> a +sum = foldl (+) 0 +product = foldl (*) 1 +{-# sum :: Inline #-} +{-# product :: Inline #-} + +-- sums and products give a list of running sums or products from +-- a list of numbers. For example, sums [1,2,3] == [0,1,3,6]. +sums, products :: (Num a) => [a] -> [a] +sums = scanl (+) 0 +products = scanl (*) 1 + +-- maximum and minimum return the maximum or minimum value from a list, +-- which must be non-empty, finite, and of an ordered type. +maximum, minimum :: (Ord a) => [a] -> a +maximum = foldl1 max +minimum = foldl1 min +{-# maximum :: Inline #-} +{-# minimum :: Inline #-} + +-- concat, applied to a list of lists, returns their flattened concatenation. +concat :: [[a]] -> [a] +concat xs = build (\ c n -> foldr (\ x y -> foldr c y x) n xs) +--concat [] = [] +--concat (l:ls) = l ++ concat ls +{-# concat :: Inline #-} + + +-- transpose, applied to a list of lists, returns that list with the +-- "rows" and "columns" interchanged. The input need not be rectangular +-- (a list of equal-length lists) to be completely transposable, but can +-- be "triangular": Each successive component list must be not longer +-- than the previous one; any elements outside of the "triangular" +-- transposable region are lost. The input can be infinite in either +-- dimension or both. +transpose :: [[a]] -> [[a]] +transpose = foldr + (\xs xss -> zipWith (:) xs (xss ++ repeat [])) + [] +{-# transpose :: Inline #-} + +-- zip takes two lists and returns a list of corresponding pairs. If one +-- input list is short, excess elements of the longer list are discarded. +-- zip3 takes three lists and returns a list of triples, etc. Versions +-- of zip producing up to septuplets are defined here. + +zip :: [a] -> [b] -> [(a,b)] +zip = zipWith (\a b -> (a,b)) +{-# zip :: Inline #-} + +zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] +zip3 = zipWith3 (\a b c -> (a,b,c)) +{-# zip3 :: Inline #-} + +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] +zip4 = zipWith4 (\a b c d -> (a,b,c,d)) +{-# zip4 :: Inline #-} + +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] +zip5 = zipWith5 (\a b c d e -> (a,b,c,d,e)) +{-# zip5 :: Inline #-} + +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)) +{-# zip6 :: Inline #-} + +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)) +{-# zip7 :: Inline #-} + +-- The zipWith family generalises the zip family by zipping with the +-- function given as the first argument, instead of a tupling function. +-- For example, zipWith (+) is applied to two lists to produce the list +-- of corresponding sums. + +zipWith :: (a->b->c) -> [a]->[b]->[c] +zipWith z as bs = + build (\ c' n' -> + let f' a g' (b:bs) = c' (z a b) (g' bs) + f' a g' _ = n' + in foldr f' (\ _ -> n') as bs) +--zipWith z (a:as) (b:bs) = z a b : zipWith z as bs +--zipWith _ _ _ = [] +{-# zipWith :: Inline #-} + +zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith3 z as bs cs = + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) = c' (z a b c) (g' bs cs) + f' a g' _ _ = n' + in foldr f' (\ _ _ -> n') as bs cs) +{-# zipWith3 :: Inline #-} +--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 as bs cs ds = + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) (d:ds) = c' (z a b c d) (g' bs cs ds) + f' a g' _ _ _ = n' + in foldr f' (\ _ _ _ -> n') as bs cs ds) +{-# zipWith4 :: Inline #-} +--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 as bs cs ds es= + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) (d:ds) (e:es) = + c' (z a b c d e) (g' bs cs ds es) + f' a g' _ _ _ _ = n' + in foldr f' (\ _ _ _ _ -> n') as bs cs ds es) +{-# zipWith5 :: Inline #-} +--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 as bs cs ds es fs = + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) (d:ds) (e:es) (f:fs) = + c' (z a b c d e f) (g' bs cs ds es fs) + f' a g' _ _ _ _ _ = n' + in foldr f' (\ _ _ _ _ _ -> n') as bs cs ds es fs) +{-# zipWith6 :: Inline #-} +--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 as bs cs ds es fs gs = + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) = + c' (z a b c d e f g) (g' bs cs ds es fs gs) + f' a g' _ _ _ _ _ _ = n' + in foldr f' (\ _ _ _ _ _ _ -> n') as bs cs ds es fs gs) +{-# zipWith7 :: Inline #-} +--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 transforms a list of pairs into a pair of lists. As with zip, +-- a family of such functions up to septuplets is provided. + +unzip :: [(a,b)] -> ([a],[b]) +unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[]) +{-# unzip :: Inline #-} + + +unzip3 :: [(a,b,c)] -> ([a],[b],[c]) +unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) + ([],[],[]) +{-# unzip3 :: Inline #-} + +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)) + ([],[],[],[]) +{-# unzip4 :: Inline #-} + +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)) + ([],[],[],[],[]) +{-# unzip5 :: Inline #-} + +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)) + ([],[],[],[],[],[]) +{-# unzip6 :: Inline #-} + +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)) + ([],[],[],[],[],[],[]) +{-# unzip7 :: Inline #-} + diff --git a/progs/prelude/PreludeLocal.hs b/progs/prelude/PreludeLocal.hs new file mode 100644 index 0000000..6e52bbf --- /dev/null +++ b/progs/prelude/PreludeLocal.hs @@ -0,0 +1,16 @@ +module PreludeLocal where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +infixr 5 : + +data Int = MkInt +data Integer = MkInteger +data Float = MkFloat +data Double = MkDouble +data Char = MkChar +data Bin = MkBin +data List a = a : (List a) | Nil +data Arrow a b = MkArrow a b + +data Triv = MkTriv diff --git a/progs/prelude/PreludeLocalIO.hs b/progs/prelude/PreludeLocalIO.hs new file mode 100644 index 0000000..2753071 --- /dev/null +++ b/progs/prelude/PreludeLocalIO.hs @@ -0,0 +1,144 @@ +module PreludeLocalIO where + +import PreludeIOPrims +import PreludeIOMonad + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +data IOResponse a = Succ a | Fail String deriving Text + +exec :: ([Response] -> [Request]) -> IO () +{- +-- Sunderesh's original definition +exec p = case (p bottom) of + [] -> unitIO () + (q:qs) -> processRequest q `bindIO` \r -> + exec (\rs -> tail (p (r:rs))) + +bottom :: a +bottom = error "Should never be evaluated" +-} +-- modified from the existing compiler. no quadratic behavior +-- needs +-- pure :: IO a -> a +-- other alternatives: +-- 1. use reference cells +-- 2. implement exec in Lisp + +exec p = os requests `bindIO` \x -> unitIO () where + requests = p responses + responses = pureIO (os requests) + +os :: [Request] -> IO [Response] +os [] = unitIO [] +os (q:qs) = processRequest q `bindIO` \r -> + os qs `bindIO` \rs -> + unitIO (r:rs) + +processRequest :: Request -> IO Response + +-- This needs to be rewritten in terms of the continuation based defs + +processRequest request = + case request of + +-- File system requests + ReadFile name -> + primReadStringFile name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + WriteFile name contents -> + primWriteStringFile name contents `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + AppendFile name contents -> + primAppendStringFile name contents `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + ReadBinFile name -> + primReadBinFile name `bindIO` \a -> + case a of + Succ s -> unitIO (Bn s) + Fail e -> unitIO (Failure e) + WriteBinFile name bin -> + primWriteBinFile name bin `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + AppendBinFile name bin -> + primAppendBinFile name bin `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + DeleteFile name -> + primDeleteFile name `bindIO` \a -> + case a of + MaybeNot -> Success + Maybe e -> unitIO (Failure e) + StatusFile name -> + primStatusFile name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + +-- Channel system requests + ReadChan name -> + primReadChan name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + AppendChan name string -> + primAppendChan name string `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + ReadBinChan name -> + primReadBinChan name `bindIO` \a -> + case a of + Succ s -> unitIO (Bn s) + Fail e -> unitIO (Failure e) + AppendBinChan name bin -> + primAppendBinChan name bin `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + StatusChan name -> + primStatusChan name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + +-- Environment requests + Echo status -> + primEcho status `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + GetArgs -> + primGetArgs `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + GetProgName -> + primProgArgs `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + GetEnv name -> + primGetEnv name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + SetEnv name string -> + primGetEnv name string `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + _ -> unitIO (Failure (OtherError "Unrecognized IO Feature")) + +-- Monadic Style IO +-- Channel system requests + diff --git a/progs/prelude/PreludePrims.hi b/progs/prelude/PreludePrims.hi new file mode 100644 index 0000000..737a448 --- /dev/null +++ b/progs/prelude/PreludePrims.hi @@ -0,0 +1,252 @@ +-- interface.scm -- define interface to primitives +-- +-- author : Sandra & John +-- date : 24 Apr 1992 +-- +-- This file declares the interface to the runtime system primitives. +-- The actual definitions for the Lisp functions all appear elsewhere; +-- they all have names like prim.xxx. (They can actually be macros +-- instead of functions since they're never referenced by name.) + +interface PreludePrims where + +{-# Prelude #-} + +import PreludeCore(Int,Integer,Float,Double,Char,Bool) +import PreludeRational(Rational) + +error :: String -> a +primCharToInt :: Char -> Int +primIntToChar :: Int -> Char +primEqChar, primNeqChar, primLeChar, primGtChar, primLsChar, primGeChar + :: Char -> Char -> Bool +primMaxChar :: Int +primEqFloat, primNeqFloat, primLeFloat, primGtFloat, primLsFloat, primGeFloat + :: Float -> Float -> Bool +primFloatMax, primFloatMin :: Float -> Float -> Float +primEqDouble, primNeqDouble, primLeDouble, primGtDouble, + primLsDouble, primGeDouble + :: Double -> Double -> Bool +primDoubleMax, primDoubleMin :: Double -> Double -> Double +primPlusFloat, primMinusFloat, primMulFloat, primDivFloat + :: Float -> Float -> Float +primPlusDouble, primMinusDouble, primMulDouble, primDivDouble + :: Double -> Double -> Double +primNegFloat, primAbsFloat :: Float -> Float +primNegDouble, primAbsDouble :: Double -> Double +primExpFloat, primLogFloat, primSqrtFloat, primSinFloat, primCosFloat, + primTanFloat, primAsinFloat, primAcosFloat, primAtanFloat, primSinhFloat, + primCoshFloat, primTanhFloat, primAsinhFloat, primAcoshFloat, primAtanhFloat + :: Float -> Float +primExpDouble, primLogDouble, primSqrtDouble, primSinDouble, primCosDouble, + primTanDouble, primAsinDouble, primAcosDouble, primAtanDouble, primSinhDouble, + primCoshDouble, primTanhDouble, primAsinhDouble, primAcoshDouble, primAtanhDouble + :: Double -> Double +primPiFloat :: Float +primPiDouble :: Double +primRationalToFloat :: Rational -> Float +primRationalToDouble :: Rational -> Double +primFloatToRational :: Float -> Rational +primDoubleToRational :: Double -> Rational +primFloatDigits :: Int +primFloatRadix :: Integer +primFloatMinExp :: Int +primFloatMaxExp :: Int +primFloatRange :: Float -> (Int, Int) +primDecodeFloat :: Float -> (Integer, Int) +primEncodeFloat :: Integer -> Int -> Float +primDoubleDigits :: Int +primDoubleRadix :: Integer +primDoubleMinExp :: Int +primDoubleMaxExp :: Int +primDoubleRange :: Double -> (Int, Int) +primDecodeDouble :: Double -> (Integer, Int) +primEncodeDouble :: Integer -> Int -> Double +primEqInt, primNeqInt, primLeInt, primGtInt, primLsInt, primGeInt + :: Int -> Int -> Bool +primIntMax, primIntMin :: Int -> Int -> Int +primEqInteger, primNeqInteger, primLeInteger, primGtInteger, + primLsInteger, primGeInteger + :: Integer -> Integer -> Bool +primIntegerMax, primIntegerMin :: Integer -> Integer -> Integer +primPlusInt, primMinusInt, primMulInt :: Int -> Int -> Int +primMinInt,primMaxInt :: Int +primNegInt, primAbsInt :: Int -> Int +primPlusInteger, primMinusInteger, primMulInteger :: Integer -> Integer -> Integer +primNegInteger, primAbsInteger :: Integer -> Integer +primQuotRemInt :: Int -> Int -> (Int, Int) +primQuotRemInteger :: Integer -> Integer -> (Integer, Integer) +primIntegerToInt :: Integer -> Int +primIntToInteger :: Int -> Integer +primNullBin :: Bin +primIsNullBin :: Bin -> Bool +primShowBinInt :: Int -> Bin -> Bin +primShowBinInteger :: Integer -> Bin -> Bin +primShowBinFloat :: Float -> Bin -> Bin +primShowBinDouble :: Double -> Bin -> Bin +primReadBinInt :: Bin -> (Int,Bin) +primReadBinInteger :: Bin -> (Integer,Bin) +primReadBinFloat :: Bin -> (Float,Bin) +primReadBinDouble :: Bin -> (Double,Bin) +primReadBinSmallInt :: Bin -> Int -> (Int,Bin) +primAppendBin :: Bin -> Bin -> Bin + +primStringEq :: [Char] -> [Char] -> Bool + +primAppend :: [a] -> [a] -> [a] +primTake :: Int -> [a] -> [a] + +foldr :: (a -> b -> b) -> b -> [a] -> b +build :: ((a -> [a] -> [a]) -> [b] -> [c]) -> [c] + + + +-- I've assigned complexities for arithmetic primitives as follows: +-- Int and Char comparisons and arithmetic are very cheap (complexity 1). +-- Double and Float comparsions are also cheap, but most implementations +-- need to box the results of floating-point arithmetic so I have given +-- them a complexity of 3. +-- Integer operations need to do an extra bignum check that has a fixed +-- overhead. I assume that actual bignums will be rare and give them +-- all a complexity of 2. + +{-# +error :: LispName("prim.abort") +primCharToInt :: LispName("prim.char-to-int"), Complexity(0),NoConversion +primIntToChar :: LispName("prim.int-to-char"), Complexity(0),NoConversion +primEqChar :: LispName("prim.eq-char"), Complexity(1), NoConversion +primNeqChar:: LispName("prim.not-eq-char"), Complexity(1), NoConversion +primLeChar :: LispName("prim.le-char"), Complexity(1), NoConversion +primGtChar :: LispName("prim.not-le-char"), Complexity(1), NoConversion +primLsChar :: LispName("prim.lt-char"), Complexity(1), NoConversion +primGeChar :: LispName("prim.not-lt-char"), Complexity(1), NoConversion +primMaxChar :: LispName("prim.max-char"), NoConversion +primEqFloat :: LispName("prim.eq-float"), Complexity(1) +primNeqFloat :: LispName("prim.not-eq-float"), Complexity(1) +primLeFloat :: LispName("prim.le-float"), Complexity(1) +primGtFloat :: LispName("prim.not-le-float"), Complexity(1) +primLsFloat :: LispName("prim.lt-float"), Complexity(1) +primGeFloat :: LispName("prim.not-lt-float"), Complexity(1) +primFloatMax :: LispName("prim.float-max"), Complexity(3) +primFloatMin :: LispName("prim.float-min"), Complexity(3) +primEqDouble :: LispName("prim.eq-double"), Complexity(1) +primNeqDouble :: LispName("prim.not-eq-double"), Complexity(1) +primLeDouble :: LispName("prim.le-double"), Complexity(1) +primGtDouble :: LispName("prim.not-le-double"), Complexity(1) +primLsDouble :: LispName("prim.lt-double"), Complexity(1) +primGeDouble :: LispName("prim.not-lt-double"), Complexity(1) +primDoubleMax :: LispName("prim.double-max"), Complexity(3) +primDoubleMin :: LispName("prim.double-min"), Complexity(3) +primPlusFloat :: LispName("prim.plus-float"), Complexity(3) +primMinusFloat :: LispName("prim.minus-float"), Complexity(3) +primMulFloat :: LispName("prim.mul-float"), Complexity(3) +primDivFloat :: LispName("prim.div-float"), Complexity(3) +primPlusDouble :: LispName("prim.plus-double"), Complexity(3) +primMinusDouble :: LispName("prim.minus-double"), Complexity(3) +primMulDouble :: LispName("prim.mul-double"), Complexity(3) +primDivDouble :: LispName("prim.div-double"), Complexity(3) +primNegFloat :: LispName("prim.neg-float"), Complexity(3) +primAbsFloat :: LispName("prim.abs-float"), Complexity(3) +primNegDouble :: LispName("prim.neg-double"), Complexity(3) +primAbsDouble :: LispName("prim.abs-double"), Complexity(3) +primExpFloat :: LispName("prim.exp-float") +primLogFloat :: LispName("prim.log-float") +primSqrtFloat :: LispName("prim.sqrt-float") +primSinFloat :: LispName("prim.sin-float") +primCosFloat :: LispName("prim.cos-float") +primTanFloat :: LispName("prim.tan-float") +primAsinFloat :: LispName("prim.asin-float") +primAcosFloat :: LispName("prim.acos-float") +primAtanFloat :: LispName("prim.atan-float") +primSinhFloat :: LispName("prim.sinh-float") +primCoshFloat :: LispName("prim.cosh-float") +primTanhFloat :: LispName("prim.tanh-float") +primAsinhFloat :: LispName("prim.asinh-float") +primAcoshFloat :: LispName("prim.acosh-float") +primAtanhFloat :: LispName("prim.atanh-float") +primExpDouble :: LispName("prim.exp-double") +primLogDouble :: LispName("prim.log-double") +primSqrtDouble :: LispName("prim.sqrt-double") +primSinDouble :: LispName("prim.sin-double") +primCosDouble :: LispName("prim.cos-double") +primTanDouble :: LispName("prim.tan-double") +primAsinDouble :: LispName("prim.asin-double") +primAcosDouble :: LispName("prim.acos-double") +primAtanDouble :: LispName("prim.atan-double") +primSinhDouble :: LispName("prim.sinh-double") +primCoshDouble :: LispName("prim.cosh-double") +primTanhDouble :: LispName("prim.tanh-double") +primAsinhDouble :: LispName("prim.asinh-double") +primAcoshDouble :: LispName("prim.acosh-double") +primAtanhDouble :: LispName("prim.atanh-double") +primPiFloat :: LispName("prim.pi-float") +primPiDouble :: LispName("prim.pi-double") +primRationalToFloat :: LispName("prim.rational-to-float"), Complexity(3) +primRationalToDouble :: LispName("prim.rational-to-double"), Complexity(3) +primFloatToRational :: LispName("prim.float-to-rational"), Complexity(3) +primDoubleToRational :: LispName("prim.double-to-rational"), Complexity(3) +primFloatDigits :: LispName("prim.float-digits") +primFloatRadix :: LispName("prim.float-radix") +primFloatMinExp :: LispName("prim.float-min-exp") +primFloatMaxExp :: LispName("prim.float-max-exp") +primFloatRange :: LispName("prim.float-range") +primDecodeFloat :: LispName("prim.decode-float") +primEncodeFloat :: LispName("prim.encode-float") +primDoubleDigits :: LispName("prim.double-digits") +primDoubleRadix :: LispName("prim.double-radix") +primDoubleMinExp :: LispName("prim.double-min-exp") +primDoubleMaxExp :: LispName("prim.double-max-exp") +primDoubleRange :: LispName("prim.double-range") +primDecodeDouble :: LispName("prim.decode-double") +primEncodeDouble :: LispName("prim.encode-double") +primEqInt :: LispName("prim.eq-int"), Complexity(1) +primNeqInt:: LispName("prim.not-eq-int"), Complexity(1) +primLeInt :: LispName("prim.le-int"), Complexity(1) +primGtInt :: LispName("prim.not-le-int"), Complexity(1) +primLsInt :: LispName("prim.lt-int"), Complexity(1) +primGeInt :: LispName("prim.not-lt-int"), Complexity(1) +primIntMax :: LispName("prim.int-max"), Complexity(1) +primIntMin :: LispName("prim.int-min"), Complexity(1) +primEqInteger :: LispName("prim.eq-integer"), Complexity(2) +primNeqInteger:: LispName("prim.not-eq-integer"), Complexity(2) +primLeInteger :: LispName("prim.le-integer"), Complexity(2) +primGtInteger :: LispName("prim.not-le-integer"), Complexity(2) +primLsInteger :: LispName("prim.lt-integer"), Complexity(2) +primGeInteger :: LispName("prim.not-lt-integer"), Complexity(2) +primIntegerMax :: LispName("prim.integer-max"), Complexity(2) +primIntegerMin :: LispName("prim.integer-min"), Complexity(2) +primPlusInt :: LispName("prim.plus-int"), Complexity(1) +primMinusInt :: LispName("prim.minus-int"), Complexity(1) +primMulInt :: LispName("prim.mul-int"), Complexity(1) +primMinInt :: LispName("prim.minint") +primMaxInt :: LispName("prim.maxint") +primNegInt :: LispName("prim.neg-int"), Complexity(1) +primAbsInt :: LispName("prim.abs-int"), Complexity(1) +primPlusInteger :: LispName("prim.plus-integer"), Complexity(2) +primMinusInteger :: LispName("prim.minus-integer"), Complexity(2) +primMulInteger :: LispName("prim.mul-integer"), Complexity(2) +primNegInteger :: LispName("prim.neg-integer"), Complexity(2) +primAbsInteger :: LispName("prim.abs-integer"), Complexity(2) +primQuotRemInt :: LispName("prim.div-rem-int") +primQuotRemInteger :: LispName("prim.div-rem-integer") +primIntegerToInt :: LispName("prim.integer-to-int"), Complexity(1) +primIntToInteger :: LispName("prim.int-to-integer"), Complexity(0) +primNullBin :: LispName("prim.nullbin") +primIsNullBin :: LispName("prim.is-null-bin"), Complexity(1) +primShowBinInt :: LispName("prim.show-bin-int"), Complexity(2) +primShowBinInteger :: LispName("prim.show-bin-integer"), Complexity(2) +primShowBinFloat :: LispName("prim.show-bin-float"), Complexity(2) +primShowBinDouble :: LispName("prim.show-bin-double"), Complexity(2) +primReadBinInt :: LispName("prim.read-bin-int") +primReadBinInteger :: LispName("prim.read-bin-integer") +primReadBinFloat :: LispName("prim.read-bin-float") +primReadBinDouble :: LispName("prim.read-bin-double") +primReadBinSmallInt :: LispName("prim.read-bin-small-int") +primAppendBin :: LispName("prim.append-bin") +primStringEq :: LispName("prim.string-eq"), Strictness("S,S"), NoConversion +primAppend :: LispName("prim.append"), Strictness("S,N"), NoConversion +primTake :: LispName("prim.take"), Strictness("S,S"), NoConversion +foldr :: LispName("prim.foldr"), Strictness("N,N,S"), NoConversion +build :: LispName("prim.build"), Strictness("S"), NoConversion + +#-} diff --git a/progs/prelude/PreludePrims.hu b/progs/prelude/PreludePrims.hu new file mode 100644 index 0000000..fd2cdcc --- /dev/null +++ b/progs/prelude/PreludePrims.hu @@ -0,0 +1,4 @@ +:output $PRELUDEBIN/PreludePrims +:stable +:prelude +PreludePrims.hi diff --git a/progs/prelude/PreludeRatio.hs b/progs/prelude/PreludeRatio.hs new file mode 100644 index 0000000..564558e --- /dev/null +++ b/progs/prelude/PreludeRatio.hs @@ -0,0 +1,98 @@ +-- Standard functions on rational numbers + +module PreludeRatio ( + Ratio, Rational(..), (%), numerator, denominator, approxRational ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +infixl 7 %, :% + +prec = 7 + +data (Integral a) => Ratio a = a {-# STRICT #-} :% a {-# STRICT #-} + deriving (Eq, Binary) + +type Rational = Ratio Integer + +(%) :: (Integral a) => a -> a -> Ratio a +numerator, denominator :: (Integral a) => Ratio a -> a +approxRational :: (RealFrac a) => a -> a -> Rational + + +reduce _ 0 = error "(%){PreludeRatio}: zero denominator" +reduce x y = (x `quot` d) :% (y `quot` d) + where d = gcd x y + + +x % y = reduce (x * signum y) (abs y) + +numerator (x:%y) = x + +denominator (x:%y) = y + + +instance (Integral a) => Ord (Ratio a) where + (x:%y) <= (x':%y') = x * y' <= x' * y + (x:%y) < (x':%y') = 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) = (-x) :% y + abs (x:%y) = abs x :% y + signum (x:%y) = signum x :% 1 + fromInteger x = fromInteger 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 + +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 = iterate ((+)1) + enumFromThen n m = iterate ((+)(m-n)) n + +instance (Integral a) => Text (Ratio a) where + readsPrec p = readParen (p > prec) + (\r -> [(x%y,u) | (x,s) <- reads r, + ("%",t) <- lex s, + (y,u) <- reads t ]) + + showsPrec p (x:%y) = showParen (p > prec) + (shows x . showString " % " . shows y) + + +-- approxRational, applied to two real fractional numbers x and epsilon, +-- returns the simplest rational number within epsilon of x. A rational +-- number n%d in reduced form is said to be simpler than another n'%d' if +-- abs n <= abs n' && d <= d'. Any real interval contains a unique +-- simplest rational; here, for simplicity, we assume a closed rational +-- interval. If such an interval includes at least one whole number, then +-- the simplest rational is the absolutely least whole number. Otherwise, +-- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d +-- and abs r' < d', and the simplest rational is q%1 + the reciprocal of +-- the simplest rational between d'%r' and d%r. + +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 diff --git a/progs/prelude/PreludeText.hs b/progs/prelude/PreludeText.hs new file mode 100644 index 0000000..9e4e353 --- /dev/null +++ b/progs/prelude/PreludeText.hs @@ -0,0 +1,260 @@ +module PreludeText ( + reads, shows, show, read, lex, + showChar, showString, readParen, showParen, readLitChar, showLitChar, + readSigned, showSigned, readDec, showInt, readFloat, showFloat ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +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') <- [match 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' + +match :: (Eq a) => [a] -> [a] -> ([a],[a]) +match (x:xs) (y:ys) | x == y = match xs ys +match 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') <- [match 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 + + +-- The functions readFloat and showFloat below use rational arithmetic +-- to insure correct conversion between the floating-point radix and +-- decimal. It is often possible to use a higher-precision floating- +-- point type to obtain the same results. + +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 + +-- The number of decimal digits m below is chosen to guarantee +-- read (show x) == x. See +-- Matula, D. W. A formalization of floating-point numeric base +-- conversion. IEEE Transactions on Computers C-19, 8 (1970 August), +-- 681-692. + +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 :: Integer + 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 diff --git a/progs/prelude/PreludeTuple.hs b/progs/prelude/PreludeTuple.hs new file mode 100644 index 0000000..4f2637a --- /dev/null +++ b/progs/prelude/PreludeTuple.hs @@ -0,0 +1,213 @@ +module PreludeTuple where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +import PreludeTuplePrims + +-- This module contains support routines which handle tuple instances. +-- These are based on a implementation level data type which represents +-- general tuples and a data type to hold the set of dictionaries which +-- are associated with the tuple. + +-- Each of these functions takes the tupledicts as the first argument. +-- Force all of these functions to take strict arguments because they'll +-- never be called with 0-length tuples anyway. + +-- The following primitives operate on tuples. + +-- tupleSize :: TupleDicts -> Int +-- tupleSel :: Tuple -> Int -> Int -> a +-- dictSel :: TupleDicts -> method -> Int -> a +-- listToTuple :: [a] -> Tuple + +-- Eq functions + +tupleEq :: TupleDicts -> Tuple -> Tuple -> Bool +{-# tupleEq :: Strictness("S,S,S") #-} +tupleEq dicts x y = tupleEq1 0 where + tupleEq1 i | i == size = True + | otherwise = + ((dictSel (cmpEq dicts i)) x' y') && tupleEq1 (i+1) + where + x' = tupleSel x i size + y' = tupleSel y i size + size = tupleSize dicts + +cmpEq x y = x == y + +tupleNeq dicts x y = not (tupleEq dicts x y) + +-- Ord functions + +tupleLe :: TupleDicts -> Tuple -> Tuple -> Bool +{-# tupleLe :: Strictness("S,S,S") #-} +tupleLe dicts x y = tupleLe1 0 where + tupleLe1 i | i == size = False + | (dictSel (cmpLs dicts i)) x' y' = True + | (dictSel (ordEq dicts i)) x' y' = tupleLe1 (i+1) + | otherwise = False + where + x' = tupleSel x i size + y' = tupleSel y i size + size = tupleSize dicts + +cmpLs x y = x < y + +ordEq :: Ord a => a -> a -> Bool +ordEq x y = x == y + +tupleLeq :: TupleDicts -> Tuple -> Tuple -> Bool +{-# tupleLeq :: Strictness("S,S,S") #-} +tupleLeq dicts x y = tupleLeq1 0 where + tupleLeq1 i | i == size = True + | (dictSel (cmpLs dicts i)) x' y' = True + | (dictSel (ordEq dicts i)) x' y' = tupleLeq1 (i+1) + | otherwise = False + where + x' = tupleSel x i size + y' = tupleSel y i size + size = tupleSize dicts + +tupleGe :: TupleDicts -> Tuple -> Tuple -> Bool +tupleGe d x y = tupleLe d y x + +tupleGeq :: TupleDicts -> Tuple -> Tuple -> Bool +tupleGeq d x y = tupleLeq d y x + +tupleMax,tupleMin :: TupleDicts -> Tuple -> Tuple -> Tuple +tupleMax d x y = if tupleGe d x y then x else y +tupleMin d x y = if tupleLe d x y then x else y + +-- Ix functions + +tupleRange :: TupleDicts -> (Tuple,Tuple) -> [Tuple] +{-# tupleRange :: Strictness("S,S") #-} + +tupleRange dicts (x,y) = map listToTuple (tupleRange' 0) where + tupleRange' i | i == size = [[]] + | otherwise = + [(i1 : i2) | i1 <- r, i2 <- tupleRange' (i+1)] + where + x' = tupleSel x i size + y' = tupleSel y i size + r = (dictSel (range' dicts i)) (x',y') + size = tupleSize dicts + +range' x = range x + +tupleIndex :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Int +{-# tupleIndex :: Strictness("S,S,S") #-} + +tupleIndex dicts (low,high) n = tupleIndex' (size-1) where + size = tupleSize dicts + tupleIndex' i | i == 0 = i' + | otherwise = i' + r' * (tupleIndex' (i-1)) + where + low' = tupleSel low i size + high' = tupleSel high i size + n' = tupleSel n i size + i' = (dictSel (index' dicts i)) (low',high') n' + r' = (dictSel (rangeSize dicts i)) (low',high') + +index' x = index x + +rangeSize :: (Ix a) => (a,a) -> Int +rangeSize (l,u) = index (l,u) u + 1 + +tupleInRange :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Bool +{-# tupleInRange :: Strictness("S,S,S") #-} +tupleInRange dicts (low,high) n = tupleInRange' 0 where + size = tupleSize dicts + tupleInRange' i | i == size = True + | otherwise = (dictSel (inRange' dicts i)) (low',high') n' + && tupleInRange' (i+1) + where + low' = tupleSel low i size + high' = tupleSel high i size + n' = tupleSel n i size + +inRange' x = inRange x + +-- Text functions + +tupleReadsPrec :: TupleDicts -> Int -> ReadS Tuple + +tupleReadsPrec dicts p = readParen False + (\s -> map ( \ (t,w) -> (listToTuple t,w)) + (tRP' s 0)) + where + size = tupleSize dicts + tRP' s i | i == 0 = [(t':t,w) | + ("(",s1) <- lex s, + (t',s2) <- nextItem s1, + (t,w) <- tRP' s2 (i+1)] + | i == size = [([],w) | (")",w) <- lex s] + | otherwise = + [(t':t,w) | + (",",s1) <- lex s, + (t',s2) <- nextItem s1, + (t,w) <- tRP' s2 (i+1)] + where + nextItem s = (dictSel (reads dicts i)) s + +tupleShowsPrec :: TupleDicts -> Int -> Tuple -> ShowS + +tupleShowsPrec dicts p tuple = + showChar '(' . tSP' 0 + where + size = tupleSize dicts + tSP' i | i == (size-1) = + showTup . showChar ')' + | otherwise = + showTup . showChar ',' . tSP' (i+1) + where + showTup = (dictSel (shows dicts i)) (tupleSel tuple i size) + +tupleReadList :: TupleDicts -> ReadS [Tuple] + +tupleReadList dicts = + readParen False (\r -> [pr | ("[",s) <- lex r, + pr <- readl s]) + where readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- tupleReads s, + (xs,u) <- readl' t] + readl' s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, + (x,u) <- tupleReads t, + (xs,v) <- readl' u] + tupleReads s = tupleReadsPrec dicts 0 s + +tupleShowList :: TupleDicts -> [Tuple] -> ShowS + +tupleShowList dicts [] = showString "[]" +tupleShowList dicts (x:xs) + = showChar '[' . showsTuple x . showl xs + where showl [] = showChar ']' + showl (x:xs) = showString ", " . showsTuple x + . showl xs + showsTuple x = tupleShowsPrec dicts 0 x + +-- Binary functions + +tupleShowBin :: TupleDicts -> Tuple -> Bin -> Bin + +tupleShowBin dicts t bin = tSB' 0 + where + size = tupleSize dicts + tSB' i | i == size = bin + tSB' i | otherwise = + (dictSel (showBin' dicts i)) (tupleSel t i size) (tSB' (i+1)) + +showBin' x = showBin x + +tupleReadBin :: TupleDicts -> Bin -> (Tuple,Bin) + +tupleReadBin dicts bin = (listToTuple t,b) where + size = tupleSize dicts + (t,b) = tRB' bin 0 + tRB' b i | i == size = ([],b) + | otherwise = (t':ts,b') where + (t',b'') = (dictSel (readBin' dicts i)) b + (ts,b') = tRB' b'' (i+1) + +readBin' x = readBin x diff --git a/progs/prelude/PreludeTuplePrims.hi b/progs/prelude/PreludeTuplePrims.hi new file mode 100644 index 0000000..6af0dfd --- /dev/null +++ b/progs/prelude/PreludeTuplePrims.hi @@ -0,0 +1,48 @@ + +-- This is the interface to the primitives used to implement arbitrary +-- sized tuples. + +interface PreludeTuplePrims where + +{-# Prelude #-} + +-- The type checker fiddles around with the call to dictSel to use the +-- dictionary to resolve the overloading of a subexpression. The call +-- dictSel (exp dict i) will typecheck exp and use the ith component of +-- the tupleDict dict to resolve the overloading. No check is made to ensure +-- that the type of the dictionary matches the overloaded class! Beware! + +import PreludeData(Int) + +data Tuple +data TupleDicts + + +tupleSize :: TupleDicts -> Int +tupleSel :: Tuple -> Int -> Int -> a +dictSel :: TupleDicts -> Int -> a +listToTuple :: [a] -> Tuple +-- These are not called by haskell code directly; these are introduced +-- during dictionary conversion by the type checker. +tupleEqDict :: a +tupleOrdDict :: a +tupleIxDict :: a +tupleTextDict :: a +tupleBinaryDict :: a + +{-# +tupleSize :: LispName("prim.tupleSize"), Complexity(1) +tupleSel :: LispName("prim.tupleSel") +dictSel :: LispName("prim.dict-sel") +listToTuple :: LispName("prim.list->tuple"), NoConversion +tupleEqDict :: LispName("prim.tupleEqDict") +tupleOrdDict :: LispName("prim.tupleOrdDict") +tupleIxDict :: LispName("prim.tupleIxDict") +tupleTextDict :: LispName("prim.tupleTextDict") +tupleBinaryDict :: LispName("prim.tupleBinaryDict") + +#-} + + + + diff --git a/progs/prelude/PreludeTuplePrims.hu b/progs/prelude/PreludeTuplePrims.hu new file mode 100644 index 0000000..eaa0385 --- /dev/null +++ b/progs/prelude/PreludeTuplePrims.hu @@ -0,0 +1,4 @@ +:output $PRELUDEBIN/PreludeTuplePrims +:stable +:prelude +PreludeTuplePrims.hi diff --git a/progs/prelude/README b/progs/prelude/README new file mode 100644 index 0000000..2decc21 --- /dev/null +++ b/progs/prelude/README @@ -0,0 +1,12 @@ + +This is the actual prelude used by the Yale system. This contains a many +small changes to the standard prelude, mostly optimizer annotations. +PreludeIO is totally different since we have flushed streams in favor +of the monad. Primitives are defined using the Haskell to Lisp interface. + +Arrays are implemented internally using destructive updates - no array +primitive involves more than one copy operation and lookup is constant +time. + +The data constructors for Complex and Rational are strict. + -- cgit v1.2.3