path: root/progs/prelude/PreludeCore.hs

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


-}