home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.uni-stuttgart.de/pub/systems/acorn/
/
Acorn.tar
/
Acorn
/
acornet
/
dev
/
gofer.spk
/
!Gofer
/
preludes
/
simple
< prev
next >
Wrap
Text File
|
1993-02-18
|
20KB
|
612 lines
-- __________ __________ __________ __________ ________
-- / _______/ / ____ / / _______/ / _______/ / ____ \
-- / / _____ / / / / / /______ / /______ / /___/ /
-- / / /_ / / / / / / _______/ / _______/ / __ __/
-- / /___/ / / /___/ / / / / /______ / / \ \
-- /_________/ /_________/ /__/ /_________/ /__/ \__\
--
-- Functional programming environment, Version 2.28
-- Copyright Mark P Jones 1991-1993.
--
-- Simplified prelude, without any type classes and overloaded values
-- Based on the Haskell standard prelude version 1.2.
--
-- This prelude file shows one approach to using Gofer without the
-- use of overloaded implementations of show, <=, == etc.
--
-- Needless to say, some (most) of the Gofer demonstration programs
-- cannot be used in connection with this prelude ... but a wide
-- family of programs can be used without needing to worry about
-- type classes at all.
--
help = "press :? for a list of commands"
quit = help ++ ", :q to quit"
-- Operator precedence table: ---------------------------------------------
infixl 9 !!
infixr 9 .
infixr 8 ^
infixl 7 *
infix 7 /, `div`, `quot`, `rem`, `mod`
infixl 6 +, -
infix 5 \\
infixr 5 ++, :
infix 4 ==, /=, <, <=, >=, >
infix 4 `elem`, `notElem`
infixr 3 &&
infixr 2 ||
infixr 0 $
-- Standard combinators: --------------------------------------------------
primitive strict "primStrict" :: (a -> b) -> a -> b
const :: a -> b -> a
const k x = k
id :: a -> a
id x = x
curry :: ((a,b) -> c) -> a -> b -> c
curry f a b = f (a,b)
uncurry :: (a -> b -> c) -> (a,b) -> c
uncurry f (a,b) = f a b
fst :: (a,b) -> a
fst (x,_) = x
snd :: (a,b) -> b
snd (_,y) = y
fst3 :: (a,b,c) -> a
fst3 (x,_,_) = x
snd3 :: (a,b,c) -> b
snd3 (_,x,_) = x
thd3 :: (a,b,c) -> c
thd3 (_,_,x) = x
(.) :: (b -> c) -> (a -> b) -> (a -> c)
(f . g) x = f (g x)
flip :: (a -> b -> c) -> b -> a -> c
flip f x y = f y x
($) :: (a -> b) -> a -> b -- pronounced as `apply' elsewhere
f $ x = f x
-- Boolean functions: -----------------------------------------------------
(&&), (||) :: Bool -> Bool -> Bool
False && x = False
True && x = x
False || x = x
True || x = True
not :: Bool -> Bool
not True = False
not False = True
and, or :: [Bool] -> Bool
and = foldr (&&) True
or = foldr (||) False
any, all :: (a -> Bool) -> [a] -> Bool
any p = or . map p
all p = and . map p
otherwise :: Bool
otherwise = True
-- Essentials and builtin primitives: ------------------------------------
primitive (==) "primGenericEq",
(/=) "primGenericNe",
(<=) "primGenericLe",
(<) "primGenericLt",
(>=) "primGenericGe",
(>) "primGenericGt" :: a -> a -> Bool
max x y | x >= y = x
| otherwise = y
min x y | x <= y = x
| otherwise = y
enumFrom n = iterate (1+) n -- [n..]
enumFromThen n m = iterate ((m-n)+) n -- [n,m..]
enumFromTo n m = takeWhile (m>=) (enumFrom n) -- [n..m]
enumFromThenTo n o m = takeWhile
((if o>=n then (>=) else (<=)) m) -- [n,o..m]
(enumFromThen n o)
primitive (+) "primPlusInt",
(-) "primMinusInt",
(/) "primDivInt",
div "primDivInt",
quot "primQuotInt",
rem "primRemInt",
mod "primModInt",
(*) "primMulInt" :: Int -> Int -> Int
primitive negate "primNegInt" :: Int -> Int
primitive primPrint "primPrint" :: Int -> a -> String -> String
show :: a -> String
show x = primPrint 0 x []
-- Character functions: ---------------------------------------------------
primitive ord "primCharToInt" :: Char -> Int
primitive chr "primIntToChar" :: Int -> Char
isAscii, isControl, isPrint, isSpace :: Char -> Bool
isUpper, isLower, isAlpha, isDigit, isAlphanum :: Char -> Bool
isAscii c = ord c < 128
isControl c = c < ' ' || c == '\DEL'
isPrint c = c >= ' ' && c <= '~'
isSpace c = c == ' ' || c == '\t' || c == '\n' || c == '\r' ||
c == '\f' || c == '\v'
isUpper c = c >= 'A' && c <= 'Z'
isLower c = c >= 'a' && c <= 'z'
isAlpha c = isUpper c || isLower c
isDigit c = c >= '0' && c <= '9'
isAlphanum c = isAlpha c || isDigit c
toUpper, toLower :: Char -> Char
toUpper c | isLower c = chr (ord c - ord 'a' + ord 'A')
| otherwise = c
toLower c | isUpper c = chr (ord c - ord 'A' + ord 'a')
| otherwise = c
minChar, maxChar :: Char
minChar = chr 0
maxChar = chr 255
-- Standard numerical functions: -----------------------------------------
subtract :: Int -> Int -> Int
subtract = flip (-)
even, odd :: Int -> Bool
even x = x `rem` 2 == 0
odd = not . even
gcd :: Int -> Int -> Int
gcd x y = gcd' (abs x) (abs y)
where gcd' x 0 = x
gcd' x y = gcd' y (x `rem` y)
lcm :: Int -> Int -> Int
lcm _ 0 = 0
lcm 0 _ = 0
lcm x y = abs ((x `quot` gcd x y) * y)
(^) :: Int -> Int -> Int
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)
abs :: Int -> Int
abs x | x >= 0 = x
| x < 0 = - x
signum :: Int -> Int
signum x | x == 0 = 0
| x > 0 = 1
| x < 0 = -1
sum, product :: [Int] -> Int
sum = foldl' (+) 0
product = foldl' (*) 1
sums, products :: [Int] -> [Int]
sums = scanl (+) 0
products = scanl (*) 1
-- Standard list processing functions: -----------------------------------
head :: [a] -> a
head (x:_) = x
last :: [a] -> a
last [x] = x
last (_:xs) = last xs
tail :: [a] -> [a]
tail (_:xs) = xs
init :: [a] -> [a]
init [x] = []
init (x:xs) = x : init xs
(++) :: [a] -> [a] -> [a] -- append lists. Associative with
[] ++ ys = ys -- left and right identity [].
(x:xs) ++ ys = x:(xs++ys)
length :: [a] -> Int -- calculate length of list
length = foldl' (\n _ -> n+1) 0
(!!) :: [a] -> Int -> a -- xs!!n selects the nth element of
(x:_) !! 0 = x -- the list xs (first element xs!!0)
(_:xs) !! (n+1) = xs !! n -- for any n < length xs.
iterate :: (a -> a) -> a -> [a] -- generate the infinite list
iterate f x = x : iterate f (f x) -- [x, f x, f (f x), ...
repeat :: a -> [a] -- generate the infinite list
repeat x = xs where xs = x:xs -- [x, x, x, x, ...
cycle :: [a] -> [a] -- generate the infinite list
cycle xs = xs' where xs'=xs++xs'-- xs ++ xs ++ xs ++ ...
copy :: Int -> a -> [a] -- make list of n copies of x
copy n x = take n xs where xs = x:xs
nub :: [a] -> [a] -- remove duplicates from list
nub [] = []
nub (x:xs) = x : nub (filter (x/=) xs)
reverse :: [a] -> [a] -- reverse elements of list
reverse = foldl (flip (:)) []
elem, notElem :: a -> [a] -> Bool
elem = any . (==) -- test for membership in list
notElem = all . (/=) -- test for non-membership
maximum, minimum :: [a] -> a
maximum = foldl1 max -- max element in non-empty list
minimum = foldl1 min -- min element in non-empty list
concat :: [[a]] -> [a] -- concatenate list of lists
concat = foldr (++) []
transpose :: [[a]] -> [[a]] -- transpose list of lists
transpose = foldr
(\xs xss -> zipWith (:) xs (xss ++ repeat []))
[]
-- null provides a simple and efficient way of determining whether a given
-- list is empty, without using (==) and hence avoiding a constraint of the
-- form Eq [a] in the full standard prelude.
null :: [a] -> Bool
null [] = True
null (_:_) = False
-- (\\) is used to remove the first occurrence of each element in the
-- second list from the first list. It is a kind of inverse of (++) in
-- the sense that (xs ++ ys) \\ xs = ys for any finite list xs of
-- proper values xs.
(\\) :: [a] -> [a] -> [a]
(\\) = foldl del
where [] `del` _ = []
(x:xs) `del` y
| x == y = xs
| otherwise = x : xs `del` y
-- map f xs applies the function f to each element of the list xs returning
-- the corresponding list of results. filter p xs returns the sublist of
-- xs containing those elements which satisfy the predicate p.
map :: (a -> b) -> [a] -> [b]
map f [] = []
map f (x:xs) = f x : map f xs
filter :: (a -> Bool) -> [a] -> [a]
filter _ [] = []
filter p (x:xs)
| p x = x : xs'
| otherwise = xs'
where xs' = filter p xs
-- Fold primitives: The foldl and scanl functions, variants foldl1 and
-- scanl1 for non-empty lists, and strict variants foldl' scanl' describe
-- common patterns of recursion over lists. Informally:
--
-- foldl f a [x1, x2, ..., xn] = f (...(f (f a x1) x2)...) xn
-- = (...((a `f` x1) `f` x2)...) `f` xn
-- etc...
--
-- The functions foldr, scanr and variants foldr1, scanr1 are duals of
-- these functions:
-- e.g. foldr f a xs = foldl (flip f) a (reverse xs) for finite lists xs.
foldl :: (a -> b -> a) -> a -> [b] -> a
foldl f z [] = z
foldl f z (x:xs) = foldl f (f z x) xs
foldl1 :: (a -> a -> a) -> [a] -> a
foldl1 f (x:xs) = foldl f x xs
foldl' :: (a -> b -> a) -> a -> [b] -> a
foldl' f a [] = a
foldl' f a (x:xs) = strict (foldl' f) (f a x) xs
scanl :: (a -> b -> a) -> a -> [b] -> [a]
scanl f q xs = q : (case xs of
[] -> []
x:xs -> scanl f (f q x) xs)
scanl1 :: (a -> a -> a) -> [a] -> [a]
scanl1 f (x:xs) = scanl f x xs
scanl' :: (a -> b -> a) -> a -> [b] -> [a]
scanl' f q xs = q : (case xs of
[] -> []
x:xs -> strict (scanl' f) (f q x) xs)
foldr :: (a -> b -> b) -> b -> [a] -> b
foldr f z [] = z
foldr f z (x:xs) = f x (foldr f z xs)
foldr1 :: (a -> a -> a) -> [a] -> a
foldr1 f [x] = x
foldr1 f (x:xs) = f x (foldr1 f xs)
scanr :: (a -> b -> b) -> b -> [a] -> [b]
scanr f q0 [] = [q0]
scanr f q0 (x:xs) = f x q : qs
where qs@(q:_) = scanr f q0 xs
scanr1 :: (a -> a -> a) -> [a] -> [a]
scanr1 f [x] = [x]
scanr1 f (x:xs) = f x q : qs
where qs@(q:_) = scanr1 f xs
-- List breaking functions:
--
-- take n xs returns the first n elements of xs
-- drop n xs returns the remaining elements of xs
-- splitAt n xs = (take n xs, drop n xs)
--
-- takeWhile p xs returns the longest initial segment of xs whose
-- elements satisfy p
-- dropWhile p xs returns the remaining portion of the list
-- span p xs = (takeWhile p xs, dropWhile p xs)
--
-- takeUntil p xs returns the list of elements upto and including the
-- first element of xs which satisfies p
take :: Int -> [a] -> [a]
take 0 _ = []
take _ [] = []
take (n+1) (x:xs) = x : take n xs
drop :: Int -> [a] -> [a]
drop 0 xs = xs
drop _ [] = []
drop (n+1) (_:xs) = drop n xs
splitAt :: Int -> [a] -> ([a], [a])
splitAt 0 xs = ([],xs)
splitAt _ [] = ([],[])
splitAt (n+1) (x:xs) = (x:xs',xs'') where (xs',xs'') = splitAt n xs
takeWhile :: (a -> Bool) -> [a] -> [a]
takeWhile p [] = []
takeWhile p (x:xs)
| p x = x : takeWhile p xs
| otherwise = []
takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil p [] = []
takeUntil p (x:xs)
| p x = [x]
| otherwise = x : takeUntil p xs
dropWhile :: (a -> Bool) -> [a] -> [a]
dropWhile p [] = []
dropWhile p xs@(x:xs')
| p x = dropWhile p xs'
| otherwise = xs
span, break :: (a -> Bool) -> [a] -> ([a],[a])
span p [] = ([],[])
span p xs@(x:xs')
| p x = let (ys,zs) = span p xs' in (x:ys,zs)
| otherwise = ([],xs)
break p = span (not . p)
-- Text processing:
-- lines s returns the list of lines in the string s.
-- words s returns the list of words in the string s.
-- unlines ls joins the list of lines ls into a single string
-- with lines separated by newline characters.
-- unwords ws joins the list of words ws into a single string
-- with words separated by spaces.
lines :: String -> [String]
lines "" = []
lines s = l : (if null s' then [] else lines (tail s'))
where (l, s') = break ('\n'==) s
words :: String -> [String]
words s = case dropWhile isSpace s of
"" -> []
s' -> w : words s''
where (w,s'') = break isSpace s'
unlines :: [String] -> String
unlines = concat . map (\l -> l ++ "\n")
unwords :: [String] -> String
unwords [] = []
unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
-- Merging and sorting lists:
merge :: [a] -> [a] -> [a]
merge [] ys = ys
merge xs [] = xs
merge (x:xs) (y:ys)
| x <= y = x : merge xs (y:ys)
| otherwise = y : merge (x:xs) ys
sort :: [a] -> [a]
sort = foldr insert []
insert :: a -> [a] -> [a]
insert x [] = [x]
insert x (y:ys)
| x <= y = x:y:ys
| otherwise = y:insert x ys
qsort :: [a] -> [a]
qsort [] = []
qsort (x:xs) = qsort [ u | u<-xs, u<x ] ++
[ x ] ++
qsort [ u | u<-xs, u>=x ]
-- zip and zipWith families of functions:
zip :: [a] -> [b] -> [(a,b)]
zip = zipWith (\a b -> (a,b))
zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
zip3 = zipWith3 (\a b c -> (a,b,c))
zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
zip4 = zipWith4 (\a b c d -> (a,b,c,d))
zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
zip5 = zipWith5 (\a b c d e -> (a,b,c,d,e))
zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a,b,c,d,e,f)]
zip6 = zipWith6 (\a b c d e f -> (a,b,c,d,e,f))
zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a,b,c,d,e,f,g)]
zip7 = zipWith7 (\a b c d e f g -> (a,b,c,d,e,f,g))
zipWith :: (a->b->c) -> [a]->[b]->[c]
zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
zipWith _ _ _ = []
zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
zipWith3 z (a:as) (b:bs) (c:cs)
= z a b c : zipWith3 z as bs cs
zipWith3 _ _ _ _ = []
zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
= z a b c d : zipWith4 z as bs cs ds
zipWith4 _ _ _ _ _ = []
zipWith5 :: (a->b->c->d->e->f) -> [a]->[b]->[c]->[d]->[e]->[f]
zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
= z a b c d e : zipWith5 z as bs cs ds es
zipWith5 _ _ _ _ _ _ = []
zipWith6 :: (a->b->c->d->e->f->g)
-> [a]->[b]->[c]->[d]->[e]->[f]->[g]
zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
= z a b c d e f : zipWith6 z as bs cs ds es fs
zipWith6 _ _ _ _ _ _ _ = []
zipWith7 :: (a->b->c->d->e->f->g->h)
-> [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
= z a b c d e f g : zipWith7 z as bs cs ds es fs gs
zipWith7 _ _ _ _ _ _ _ _ = []
unzip :: [(a,b)] -> ([a],[b])
unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
-- Formatted output: -----------------------------------------------------
cjustify, ljustify, rjustify :: Int -> String -> String
cjustify n s = space halfm ++ s ++ space (m - halfm)
where m = n - length s
halfm = m `div` 2
ljustify n s = s ++ space (n - length s)
rjustify n s = space (n - length s) ++ s
space :: Int -> String
space n = copy n ' '
layn :: [String] -> String
layn = lay 1 where lay _ [] = []
lay n (x:xs) = rjustify 4 (show n) ++ ") "
++ x ++ "\n" ++ lay (n+1) xs
-- Miscellaneous: --------------------------------------------------------
until :: (a -> Bool) -> (a -> a) -> a -> a
until p f x | p x = x
| otherwise = until p f (f x)
until' :: (a -> Bool) -> (a -> a) -> a -> [a]
until' p f = takeUntil p . iterate f
primitive error "primError" :: String -> a
undefined :: a
undefined | False = undefined
asTypeOf :: a -> a -> a
x `asTypeOf` _ = x
-- I/O functions and definitions: ----------------------------------------
-- This is the minimum required for bootstrapping and execution of
-- interactive programs.
{- The Dialogue, Request, Response and IOError datatypes are now builtin:
data Request = -- file system requests:
ReadFile String
| WriteFile String String
| AppendFile String String
-- channel system requests:
| ReadChan String
| AppendChan String String
-- environment requests:
| Echo Bool
| GetArgs
| GetProgName
| GetEnv String
data Response = Success
| Str String
| Failure IOError
data IOError = WriteError String
| ReadError String
| SearchError String
| FormatError String
| OtherError String
-- Continuation-based I/O:
type Dialogue = [Response] -> [Request]
-}
run :: (String -> String) -> Dialogue
run f ~(Success : ~(Str kbd : _))
= [Echo False, ReadChan "stdin", AppendChan "stdout" (f kbd)]
primitive primFopen "primFopen" :: String -> a -> (String -> a) -> a
openfile :: String -> String
openfile f = primFopen f (error ("can't open file "++f)) id
-- End of Gofer simplified prelude: ---------------------------------------