summaryrefslogtreecommitdiff
path: root/progs/prelude
diff options
context:
space:
mode:
Diffstat (limited to 'progs/prelude')
-rw-r--r--progs/prelude/Prelude.hs187
-rw-r--r--progs/prelude/Prelude.hu16
-rw-r--r--progs/prelude/PreludeArray.hs201
-rw-r--r--progs/prelude/PreludeArrayPrims.hi37
-rw-r--r--progs/prelude/PreludeArrayPrims.hu4
-rw-r--r--progs/prelude/PreludeComplex.hs94
-rw-r--r--progs/prelude/PreludeCore.hs817
-rw-r--r--progs/prelude/PreludeIO.hs232
-rw-r--r--progs/prelude/PreludeIOMonad.hs60
-rw-r--r--progs/prelude/PreludeIOPrims.hi55
-rw-r--r--progs/prelude/PreludeIOPrims.hu4
-rw-r--r--progs/prelude/PreludeList.hs585
-rw-r--r--progs/prelude/PreludeLocal.hs16
-rw-r--r--progs/prelude/PreludeLocalIO.hs144
-rw-r--r--progs/prelude/PreludePrims.hi252
-rw-r--r--progs/prelude/PreludePrims.hu4
-rw-r--r--progs/prelude/PreludeRatio.hs98
-rw-r--r--progs/prelude/PreludeText.hs260
-rw-r--r--progs/prelude/PreludeTuple.hs213
-rw-r--r--progs/prelude/PreludeTuplePrims.hi48
-rw-r--r--progs/prelude/PreludeTuplePrims.hu4
-rw-r--r--progs/prelude/README12
22 files changed, 3343 insertions, 0 deletions
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 "<<Bin>>"
+
+
+-- 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 "<<function>>"
+
+-- 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<z1 || a1==z1 && a2<z2
+
+instance (Ix a1, Ix a2) => 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<z1 || a1==z1 &&
+ (a2<z2 || a2==z2 &&
+ a3<z3)
+
+
+instance (Ix a1, Ix a2, Ix a3) => 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.
+
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-19 01:00:44 +0000