pustd.pre

--         __________   __________   __________   __________   ________
--        /  _______/  /  ____   /  /  _______/  /  _______/  /  ____  \
--       /  / _____   /  /   /  /  /  /______   /  /______   /  /___/  /
--      /  / /_   /  /  /   /  /  /  _______/  /  _______/  /  __   __/
--     /  /___/  /  /  /___/  /  /  /         /  /______   /  /  \  \ 
--    /_________/  /_________/  /__/         /_________/  /__/    \__\
--
--    Functional programming environment, Version 2.28
--    Copyright Mark P Jones 1991-1993.
--    PU Additions
--    Copyright Rusi Mody 1995-2015.
--
--    Standard prelude for use of overloaded values using type classes.
--    Based on the Haskell standard prelude version 1.2.

help = "press :? for a list of commands"

-- 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 ||

-- Standard combinators: ----------------------------------------------------

primitive strict "primStrict" : (a -> b) -> a -> b
primitive (.) "primApply" : (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

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

flip           : (a -> b -> c) -> b -> a -> c
flip.f.x.y	= f.y.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	= map.p ; or
all.p	= map.p ; and

otherwise      : Bool
otherwise       = True

-- 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 type 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

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

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

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

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

class (Eq.a, Text.a) => Num.a where         -- simplified numeric class
    (+), (-), (*), (/) : a -> a -> a
    negate             : a -> a
    fromInteger	       : Int -> a

-- Type class instances: ----------------------------------------------------

primitive primEqInt    "primEqInt",
	  primLeInt    "primLeInt"   : Int -> Int -> Bool
primitive primPlusInt  "primPlusInt",
	  primMinusInt "primMinusInt",
	  primDivInt   "primDivInt",
	  primMulInt   "primMulInt"  : Int -> Int -> Int
primitive primNegInt   "primNegInt"  : Int -> Int

instance Eq.()  where () == () = True
instance Ord.() where () <= () = True

instance Eq.Int  where (==) = primEqInt

instance Ord.Int where (<=) = primLeInt

instance Ix.Int where
    range.(m,n)		= [m...n]
    index.(m,n).i	= i - m
    inRange.(m,n).i	= m <= i && i <= n

instance Enum.Int where
    enumFrom.n		= iterate.(1 +).n
    enumFromThen.n.m	= iterate.((m - n) +).n

instance Num.Int where
    (+)           = primPlusInt
    (-)           = primMinusInt
    (*)           = primMulInt
    (/)           = primDivInt
    negate        = primNegInt
    fromInteger.x = x

{- PC version off -}
primitive primEqFloat    "primEqFloat",
          primLeFloat    "primLeFloat"    : Float -> Float -> Bool
primitive primPlusFloat  "primPlusFloat", 
          primMinusFloat "primMinusFloat", 
          primDivFloat   "primDivFloat",
          primMulFloat   "primMulFloat"   : Float -> Float -> Float 
primitive primNegFloat   "primNegFloat"   : Float -> Float
primitive primIntToFloat "primIntToFloat" : Int -> Float

instance Eq.Float where (==) = primEqFloat

instance Ord.Float where (<=) = primLeFloat

instance Enum.Float where
    enumFrom.n		= iterate.(1.0 +).n
    enumFromThen.n.m	= iterate.((m - n) +).n

instance Num.Float where
    (+)         = primPlusFloat
    (-)         = primMinusFloat
    (*)         = primMulFloat
    (/)         = primDivFloat 
    negate      = primNegFloat
    fromInteger = primIntToFloat

primitive sin "primSinFloat",  asin  "primAsinFloat",
          cos "primCosFloat",  acos  "primAcosFloat",
	  tan "primTanFloat",  atan  "primAtanFloat",
          log "primLogFloat",  log10 "primLog10Float",
	  exp "primExpFloat",  sqrt  "primSqrtFloat" : Float -> Float
primitive atan2    "primAtan2Float" : Float -> Float -> Float
primitive truncate "primFloatToInt" : Float -> Int

pi : Float
pi  = 3.1415926535

{- PC version on -}

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

instance Eq.Char  where (==) = primEqChar   -- c == d  =  ord c == ord d

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

instance Ix.Char where
    range.(c,c')      = [c...c']
    index.(c,c').ci   = ord.ci - ord.c
    inRange.(c,c').ci = ord.c <= i && i <= ord.c' where i = ord.ci

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

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

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

instance (Eq.a, Eq.b) => Eq.(a,b) where
    (x,y) == (u,v)  =  x==u && y==v

instance (Ord.a, Ord.b) => Ord.(a,b) where
    (x,y) <= (u,v)  = x<u  ||  (x==u && y<=v)

instance Eq.Bool where
    True  == True   =  True
    False == False  =  True
    _     == _      =  False

instance Ord.Bool where
    False <= x      = True
    True  <= x      = x

-- Standard numerical functions: --------------------------------------------

primitive div    "primDivInt",
	  quot   "primQuotInt",
          rem    "primRemInt",
          mod    "primModInt"    : Int -> Int -> Int

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

even, odd : Int -> Bool
even.x	= x `rem` 2 == 0
odd	= even ; not

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)

(^)       : Num.a => a -> Int -> a
x ^ 0	= fromInteger.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 : (Num.a, Ord.a) => a -> a
abs.x | x>=fromInteger.0 = x
      | otherwise        = -x

signum			: (Num.a, Ord.a) => a -> Int
signum.x
      | x==fromInteger.0 = 0
      | x> fromInteger.0 = 1
      | otherwise        = -1

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

sums, products	: Num.a => [a] -> [a]
sums		= scanl.(+).(fromInteger.0)
products	= scanl.(*).(fromInteger.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
(x::xs) ++ ys	= x :: (xs ++ ys)

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

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              : Eq.a => [a] -> [a]   -- remove duplicates from list
nub.[]		= []
nub.(x::xs)	= x :: nub.(filter.(x /=).xs)

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

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

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

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

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

-- 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].

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.

(\\)             : Eq.a => [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.(p ; not)

-- 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	= map.(\l -> l ++ "\n") ; concat

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

-- Merging and sorting lists:

merge               : Ord.a => [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                : Ord.a => [a] -> [a]
sort	= foldr.insert.[]

insert              : Ord.a => a -> [a] -> [a]
insert.x.[]	= [x]
insert.x.(y::ys)
   | x <= y	= x::y::ys
   | otherwise	= y::insert.x.ys

qsort               : Ord.a => [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: --------------------------------------------------------

primitive primPrint "primPrint"  : Int -> a -> String -> String

show'       : a -> String
show'.x	= primPrint.0.x.[]

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              = iterate.f ; takeUntil.p

primitive error "primError" : String -> a

undefined              : a
undefined | False       = undefined

asTypeOf               : a -> a -> a
x `asTypeOf` _          = x

-- A trimmed down version of the Haskell Text class: ------------------------

type  ShowS   = String -> String

class Text.a where 
    showsPrec      : Int -> a -> ShowS
    showList       : [a] -> ShowS

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

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

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

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

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

instance Text.() where
    showsPrec.d.()	= showString."()"

instance Text.Bool where
    showsPrec.d.True	= showString."True"
    showsPrec.d.False	= showString."False"

primitive primShowsInt "primShowsInt" : Int -> Int -> String -> String
instance Text.Int where showsPrec = primShowsInt

{- PC version off -}
primitive primShowsFloat "primShowsFloat" : Int -> Float -> String -> String
instance Text.Float where showsPrec = primShowsFloat
{- PC version on -}

instance Text.Char where
    showsPrec.p.c = showString.[q, c, q] where q = '\''
    showList.cs	= showl.cs ; showChar.'"'
	where   showl.""	= showChar.'"'
		showl.('"'::cs)	= showl.cs ; showString."\\\""
		showl.(c :: cs)	= showl.cs ; showChar.c
		-- Haskell has   showLitChar c . showl cs

instance Text.a => Text.[a]  where
    showsPrec.p	= showList

instance (Text.a, Text.b) => Text.(a,b) where
    showsPrec.p.(x,y) = showChar.')' ; shows.y ; showChar.',' ; shows.x ;
		    showChar.'(' ; showsPrec.p.(x,y)

-- I/O functions and definitions: -------------------------------------------

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

{- 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
	      | StrList.[String]

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


type Dialogue    =  [Response] -> [Request]
-}

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

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

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

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

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

abort           : FailCont
abort.err	= done

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

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

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

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

run		: (String -> String) -> Dialogue
run.f	= echo.False.exit.(interact.f)

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 standard prelude: --------------------------------------------