From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- progs/prelude/PreludeCore.hs | 817 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 817 insertions(+) create mode 100644 progs/prelude/PreludeCore.hs (limited to 'progs/prelude/PreludeCore.hs') diff --git a/progs/prelude/PreludeCore.hs b/progs/prelude/PreludeCore.hs new file mode 100644 index 0000000..f8a7be2 --- /dev/null +++ b/progs/prelude/PreludeCore.hs @@ -0,0 +1,817 @@ +-- Standard types, classes, and instances + +module PreludeCore ( + Eq((==), (/=)), + Ord((<), (<=), (>=), (>), max, min), + Num((+), (-), (*), negate, abs, signum, fromInteger), + Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger), + Fractional((/), recip, fromRational), + Floating(pi, exp, log, sqrt, (**), logBase, + sin, cos, tan, asin, acos, atan, + sinh, cosh, tanh, asinh, acosh, atanh), + Real(toRational), + RealFrac(properFraction, truncate, round, ceiling, floor), + RealFloat(floatRadix, floatDigits, floatRange, + encodeFloat, decodeFloat, exponent, significand, scaleFloat), + Ix(range, index, inRange), + Enum(enumFrom, enumFromThen, enumFromTo, enumFromThenTo), + Text(readsPrec, showsPrec, readList, showList), ReadS(..), ShowS(..), + Binary(readBin, showBin), +-- List type: [_]((:), []) +-- Tuple types: (_,_), (_,_,_), etc. +-- Trivial type: () + Bool(True, False), + Char, Int, Integer, Float, Double, Bin, + Ratio, Complex((:+)), Assoc((:=)), Array, + String(..), Rational(..) ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +import PreludePrims +import PreludeText +import PreludeRatio(Ratio, Rational(..)) +import PreludeComplex(Complex((:+))) +import PreludeArray(Assoc((:=)), Array) +import PreludeIO({-Request, Response,-} IOError, + Dialogue(..), SuccCont(..), StrCont(..), + StrListCont(..), BinCont(..), FailCont(..)) + +infixr 8 ** +infixl 7 *, /, `quot`, `rem`, `div`, `mod` +infixl 6 +, - +infix 4 ==, /=, <, <=, >=, > + + +infixr 5 : + +data Int = MkInt +data Integer = MkInteger +data Float = MkFloat +data Double = MkDouble +data Char = MkChar +data Bin = MkBin +data List a = a : (List a) | Nil deriving (Eq, Ord) +data Arrow a b = MkArrow a b +data UnitType = UnitConstructor deriving (Eq, Ord, Ix, Enum, Binary) + +-- Equality and Ordered classes + +class Eq a where + (==), (/=) :: a -> a -> Bool + + x /= y = not (x == y) + +class (Eq a) => Ord a where + (<), (<=), (>=), (>):: a -> a -> Bool + max, min :: a -> a -> a + + x < y = x <= y && x /= y + x >= y = y <= x + x > y = y < x + + -- The following default methods are appropriate for partial orders. + -- Note that the second guards in each function can be replaced + -- by "otherwise" and the error cases, eliminated for total orders. + max x y | x >= y = x + | y >= x = y + |otherwise = error "max{PreludeCore}: no ordering relation" + min x y | x <= y = x + | y <= x = y + |otherwise = error "min{PreludeCore}: no ordering relation" + + +-- Numeric classes + +class (Eq a, Text a) => Num a where + (+), (-), (*) :: a -> a -> a + negate :: a -> a + abs, signum :: a -> a + fromInteger :: Integer -> a + + x - y = x + negate y + +class (Num a, Enum a) => Real a where + toRational :: a -> Rational + +class (Real a, Ix a) => Integral a where + quot, rem, div, mod :: a -> a -> a + quotRem, divMod :: a -> a -> (a,a) + even, odd :: a -> Bool + toInteger :: a -> Integer + + n `quot` d = q where (q,r) = quotRem n d + n `rem` d = r where (q,r) = quotRem n d + n `div` d = q where (q,r) = divMod n d + n `mod` d = r where (q,r) = divMod n d + divMod n d = if signum r == - signum d then (q-1, r+d) else qr + where qr@(q,r) = quotRem n d + even n = n `rem` 2 == 0 + odd = not . even + +class (Num a) => Fractional a where + (/) :: a -> a -> a + recip :: a -> a + fromRational :: Rational -> a + + recip x = 1 / x + +class (Fractional a) => Floating a where + pi :: a + exp, log, sqrt :: a -> a + (**), logBase :: a -> a -> a + sin, cos, tan :: a -> a + asin, acos, atan :: a -> a + sinh, cosh, tanh :: a -> a + asinh, acosh, atanh :: a -> a + + x ** y = exp (log x * y) + logBase x y = log y / log x + sqrt x = x ** 0.5 + tan x = sin x / cos x + tanh x = sinh x / cosh x + +class (Real a, Fractional a) => RealFrac a where + properFraction :: (Integral b) => a -> (b,a) + truncate, round :: (Integral b) => a -> b + ceiling, floor :: (Integral b) => a -> b + + truncate x = m where (m,_) = properFraction x + + round x = let (n,r) = properFraction x + m = if r < 0 then n - 1 else n + 1 + in case signum (abs r - 0.5) of + -1 -> n + 0 -> if even n then n else m + 1 -> m + + ceiling x = if r > 0 then n + 1 else n + where (n,r) = properFraction x + + floor x = if r < 0 then n - 1 else n + where (n,r) = properFraction x + +class (RealFrac a, Floating a) => RealFloat a where + floatRadix :: a -> Integer + floatDigits :: a -> Int + floatRange :: a -> (Int,Int) + decodeFloat :: a -> (Integer,Int) + encodeFloat :: Integer -> Int -> a + exponent :: a -> Int + significand :: a -> a + scaleFloat :: Int -> a -> a + + exponent x = if m == 0 then 0 else n + floatDigits x + where (m,n) = decodeFloat x + + significand x = encodeFloat m (- floatDigits x) + where (m,_) = decodeFloat x + + scaleFloat k x = encodeFloat m (n+k) + where (m,n) = decodeFloat x + + +-- Index and Enumeration classes + +class (Ord a, Text a) => Ix a where -- This is a Yale modification + range :: (a,a) -> [a] + index :: (a,a) -> a -> Int + inRange :: (a,a) -> a -> Bool + +class (Ord a) => Enum a where + enumFrom :: a -> [a] -- [n..] + enumFromThen :: a -> a -> [a] -- [n,n'..] + enumFromTo :: a -> a -> [a] -- [n..m] + enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] + + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + +defaultEnumFromTo n m = takeWhile (<= m) (enumFrom n) +defaultEnumFromThenTo n n' m + = takeWhile (if n' >= n then (<= m) else (>= m)) + (enumFromThen n n') +{-# defaultEnumFromTo :: Inline #-} +{-# defaultEnumFromThenTo :: Inline #-} + +-- Text class + +type ReadS a = String -> [(a,String)] +type ShowS = String -> String + +class Text a where + readsPrec :: Int -> ReadS a + showsPrec :: Int -> a -> ShowS + readList :: ReadS [a] + showList :: [a] -> ShowS + + readList = readParen False (\r -> [pr | ("[",s) <- lex r, + pr <- readl s]) + where readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- reads s, + (xs,u) <- readl' t] + readl' s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, + (x,u) <- reads t, + (xs,v) <- readl' u] + showList [] = showString "[]" + showList (x:xs) + = showChar '[' . shows x . showl xs + where showl [] = showChar ']' + showl (x:xs) = showString ", " . shows x . showl xs + + + +-- Binary class + +class Binary a where + readBin :: Bin -> (a,Bin) + showBin :: a -> Bin -> Bin + + +-- Trivial type + +-- data () = () deriving (Eq, Ord, Ix, Enum, Binary) + +instance Text () where + readsPrec p = readParen False + (\r -> [((),t) | ("(",s) <- lex r, + (")",t) <- lex s ] ) + showsPrec p () = showString "()" + + +-- Binary type + +instance Text Bin where + readsPrec p s = error "readsPrec{PreludeText}: Cannot read Bin." + showsPrec p b = showString "<>" + + +-- 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 "<>" + +-- 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 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 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 ')' + + +-} -- cgit v1.2.3