{-# OPTIONS_GHC -XNoImplicitPrelude #-}
{-# LANGUAGE MagicHash #-}

{-

the -XNoImplicitPrelude flag also causes the following pieces of
built-in syntax to refer to whatever is in scope, not the Prelude versions:

  * An integer literal 368 means "fromInteger (368::Integer)", rather than "Prelude.fromInteger
      (368::Integer)".
  * Fractional literals are handed in just the same way, except that the translation is fromRational
    (3.68::Rational).
  * The equality test in an overloaded numeric pattern uses whatever (==) is in scope.
  * The subtraction operation, and the greater-than-or-equal test, in n+k patterns use whatever (-)
    and (>=) are in scope.
  * Negation (e.g. "- (f x)") means "negate (f x)", both in numeric patterns, and expressions.
  * "Do" notation is translated using whatever functions (>>=), (>>), and fail, are in scope (not the
    Prelude versions). List comprehensions, mdo (Section 8.3.6, “The recursive do-notation ”), and
    parallel array comprehensions, are unaffected.

it's fine for fromInteger to have any of the types:

fromInteger :: Integer -> Integer
fromInteger :: forall a. Foo a => Integer -> a
fromInteger :: Num a => a -> Integer
fromInteger :: Integer -> Bool -> Bool

-}

-- |
-- Module      : Prelude.Gofer
-- Copyright Mark P Jones 1991-1994.
-- Copyright Don Stewart, 2009
--
-- Functional programming environment, Version 2.30
-- Standard prelude for use of overloaded values using type classes.
-- Based on the Haskell standard prelude version 1.2.
--
module Prelude.Gofer (

        -- $intro

        -- Standard types
        -- Float, Int, Char, Bool,
        -- ()
        -- , (,)(..)
        -- , (,,)(..)
        -- , (,,,)(..)
        -- , (,,,,)(..)
        -- , (,,,,,)(..)
        -- , (,,,,,,)(..)

        -- * Standard combinators
        strict,
        const,
        id,
        curry,
        uncurry,
        fst,
        snd,
        fst3,
        snd3,
        thd3,
        (.),
        flip,
        ($),

        -- * Boolean functions
        (&&), (||),
        not,
        and, or,
        any, all,
        otherwise,

        -- * Character functions
        ord, chr,
        isAscii, isControl, isPrint, isSpace,
        isUpper, isLower, isAlpha, isDigit, isAlphanum,
        minChar, maxChar,

        -- * Standard type classes
        (==), (/=),

        (<), (<=), (>), (>=),
        max, min,

        range,
        index,
        inRange,

        enumFrom,
        enumFromThen,
        enumFromTo,
        enumFromThenTo,

        (+), (-), (*), (/),
        negate,
        fromInteger_ ,

        sin,
        asin,
        cos,
        acos,
        tan,
        atan,
        log,
        exp,
        sqrt,
        atan2,
        truncate,
        pi,

        -- * Standard numerical functions
        div,
        quot,
        rem,
        mod,
        subtract,
        even, odd,
        gcd,
        lcm,
        (^),
        abs,
        signum,
        sum, product,
        sums, products,

        -- * Standard list processing functions
        head,
        last,
        tail,
        init,
        (++),
        genericLength,
        length,
        (!!),
        iterate,
        repeat,
        cycle,
        copy,
        nub,
        reverse,
        elem, notElem,
        maximum, minimum,
        concat,
        transpose,
        null,
        (\\),
        map,
        filter,
        foldl,
        foldl1,
        foldl',
        scanl,
        scanl1,
        scanl',
        foldr,
        foldr1,
        scanr,
        scanr1,

        -- * List breaking functions
        take,
        drop,
        splitAt,
        takeWhile,
        takeUntil,
        dropWhile,
        span, break,

        -- * Text processing:
        lines,
        words,
        unlines,
        unwords,

        -- * Merging and sorting lists:
        merge,
        sort,
        insert,
        qsort,

        -- * zip and zipWith families of functions:
        zip,
        zip3,
        zip4,
        zip5,
        zip6,
        zip7,
        zipWith,
        zipWith3,
        zipWith4,
        zipWith5,
        zipWith6,
        zipWith7,
        unzip,

        -- * Formatted output
        cjustify, ljustify, rjustify,
        space,
        layn,

        -- * Miscellaneous
        until,
        until',
        error,
        undefined,
        asTypeOf,

        -- * A trimmed down version of the Haskell Text class
        ShowS,
        showsPrec,
        showList,
        shows,
        show,
        showChar,
        showString,

        -- * I\/O functions and definitions
        stdin,
        stdout,
        stderr,
        stdecho,
        Request(..), Response(..), IOError(..),
        Dialogue, SuccCont, StrCont, StrListCont, FailCont,

        done,
        readFile,
        writeFile,
        appendFile,
        readChan,
        appendChan,
        echo,
        getArgs,
        getProgName,
        getEnv,
        strDispatch,
        succDispatch,
        strListDispatch,
        abort,
        exit,
        print,
        prints,
        interact,
        run,
        openfile,

        help

    ) where

-- Basic types
import GHC.Base (Float(..), Int(..), Bool(..), String, Char(..))

-- Some primitives
import qualified GHC.Base as GHC (ord, chr, seq, error)

-- 
-- The Int type
import qualified GHC.Base as GHC ( eqInt,leInt,plusInt,minusInt,timesInt
                 , negateInt, divInt, modInt, remInt,quotInt)

-- 
-- The Float type
import GHC.Prim (eqFloat#, leFloat#, eqChar#, leChar# )
import GHC.Float ( plusFloat, showSignedFloat
                 , minusFloat, divideFloat, timesFloat, negateFloat, int2Float
                 , sinFloat, asinFloat, cosFloat, acosFloat, tanFloat, atanFloat
                 , logFloat, logBase, expFloat, sqrtFloat, atanFloat, float2Int)

--
-- For IO
import qualified System.IO.Unsafe as GHC (unsafePerformIO)
import qualified System.IO        as GHC (readFile)

--
-- For Text
import qualified GHC.Show  as GHC (showSignedInt, shows)
import qualified GHC.Float as GHC (showSignedFloat)

--
-- Need for desugaring comprehensions, enumerations and numeric literals
import qualified GHC.Real as GHC (fromRational)
import qualified GHC.Num  as GHC (fromInteger)
import GHC.Base (fail, (>>), (>>=))

--
-- $intro
--
-- >       __________   __________   __________   __________   ________
-- >      /  _______/  /  ____   /  /  _______/  /  _______/  /  ____  \
-- >     /  / _____   /  /   /  /  /  /______   /  /______   /  /___/  /
-- >    /  / /_   /  /  /   /  /  /  _______/  /  _______/  /  __   __/
-- >   /  /___/  /  /  /___/  /  /  /         /  /______   /  /  \  \ 
-- >  /_________/  /_________/  /__/         /_________/  /__/    \__\
--
--    Functional programming environment, Version 2.30
--    Copyright Mark P Jones 1991-1994.
--
--    Standard prelude for use of overloaded values using type classes.
--    Based on the Haskell standard prelude version 1.2.

------------------------------------------------------------------------
-- For desugaring

fromRational = GHC.fromRational
fromInteger  = GHC.fromInteger  -- required to be on Integer arguments

------------------------------------------------------------------------

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 ||
infixr 0 $

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

-- | primitive strict primStrict :: (a -> b) -> a -> b
strict f x = x `seq` f x

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

-- Character functions: -----------------------------------------------------

-- primitive ord "primCharToInt" :: Char -> Int
-- primitive chr "primIntToChar" :: Int -> Char

ord :: Char -> Int
ord = GHC.ord

chr :: Int -> Char
chr = GHC.chr

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   -- N.B. used for desugaring

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

primEqInt       = GHC.eqInt
primLeInt       = GHC.leInt
primPlusInt     = GHC.plusInt
primMinusInt    = GHC.minusInt
primDivInt      = GHC.divInt
primMulInt      = GHC.timesInt
primNegInt      = GHC.negateInt

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 b@(m,n) i
       | inRange b i = i - m
       | otherwise   = error "index out of range"
    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

primEqFloat (F# x) (F# y) = x `eqFloat#` y
primLeFloat (F# x) (F# y) = x `leFloat#` y
primPlusFloat  = plusFloat
primMinusFloat = minusFloat
primDivFloat   = divideFloat
primMulFloat   = timesFloat
primNegFloat   = negateFloat
primIntToFloat = int2Float

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

sin     = sinFloat
asin    = asinFloat
cos     = cosFloat
acos    = acosFloat
tan     = tanFloat
atan    = atanFloat
log     = logFloat
-- log10   = logBase 10 :: Float -> Float
exp      = expFloat
sqrt    = sqrtFloat
atan2    = atanFloat
truncate = float2Int

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

primEqChar (C# c1) (C# c2) = c1 `eqChar#` c2
primLeChar (C# c1) (C# c2) = c1 `leChar#` c2

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

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

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

instance Ix Char where
    range (c,c')      = [c..c']
    index b@(m,n) i
       | inRange b i  = ord i - ord m
       | otherwise    = error "index out of range"
    inRange (c,c') ci = ord c <= i && i <= ord c' where i = ord ci

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

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

div  = GHC.divInt
quot = GHC.quotInt
rem  = GHC.remInt
mod  = GHC.modInt

{-
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        = 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)

(^)       :: 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                   -- left and right identity [].
(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 (:)) []

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

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

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

-- primitive error "primError" :: String -> a
error = GHC.error

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
        -- in Haskell:
        -- showsPrec :: (Show a) => Int -> a -> String -> String
    showList       :: [a] -> ShowS

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

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
primShowsInt = GHC.showSignedInt
instance Text Int where showsPrec = primShowsInt

{- PC version off -}
-- primitive primShowsFloat "primShowsFloat"
primShowsFloat :: Int -> Float -> String -> String
primShowsFloat = GHC.showSignedFloat (GHC.shows :: Float -> ShowS)
instance Text Float where showsPrec = primShowsFloat
{- PC version on -}

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

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

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

-- 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       = GHC.unsafePerformIO (GHC.readFile f) 
    -- primFopen f (error ("can't open file "++f)) id

-- End of Gofer standard prelude: --------------------------------------------