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/PreludeTuple.hs | 213 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 213 insertions(+) create mode 100644 progs/prelude/PreludeTuple.hs (limited to 'progs/prelude/PreludeTuple.hs') diff --git a/progs/prelude/PreludeTuple.hs b/progs/prelude/PreludeTuple.hs new file mode 100644 index 0000000..4f2637a --- /dev/null +++ b/progs/prelude/PreludeTuple.hs @@ -0,0 +1,213 @@ +module PreludeTuple where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +import PreludeTuplePrims + +-- This module contains support routines which handle tuple instances. +-- These are based on a implementation level data type which represents +-- general tuples and a data type to hold the set of dictionaries which +-- are associated with the tuple. + +-- Each of these functions takes the tupledicts as the first argument. +-- Force all of these functions to take strict arguments because they'll +-- never be called with 0-length tuples anyway. + +-- The following primitives operate on tuples. + +-- tupleSize :: TupleDicts -> Int +-- tupleSel :: Tuple -> Int -> Int -> a +-- dictSel :: TupleDicts -> method -> Int -> a +-- listToTuple :: [a] -> Tuple + +-- Eq functions + +tupleEq :: TupleDicts -> Tuple -> Tuple -> Bool +{-# tupleEq :: Strictness("S,S,S") #-} +tupleEq dicts x y = tupleEq1 0 where + tupleEq1 i | i == size = True + | otherwise = + ((dictSel (cmpEq dicts i)) x' y') && tupleEq1 (i+1) + where + x' = tupleSel x i size + y' = tupleSel y i size + size = tupleSize dicts + +cmpEq x y = x == y + +tupleNeq dicts x y = not (tupleEq dicts x y) + +-- Ord functions + +tupleLe :: TupleDicts -> Tuple -> Tuple -> Bool +{-# tupleLe :: Strictness("S,S,S") #-} +tupleLe dicts x y = tupleLe1 0 where + tupleLe1 i | i == size = False + | (dictSel (cmpLs dicts i)) x' y' = True + | (dictSel (ordEq dicts i)) x' y' = tupleLe1 (i+1) + | otherwise = False + where + x' = tupleSel x i size + y' = tupleSel y i size + size = tupleSize dicts + +cmpLs x y = x < y + +ordEq :: Ord a => a -> a -> Bool +ordEq x y = x == y + +tupleLeq :: TupleDicts -> Tuple -> Tuple -> Bool +{-# tupleLeq :: Strictness("S,S,S") #-} +tupleLeq dicts x y = tupleLeq1 0 where + tupleLeq1 i | i == size = True + | (dictSel (cmpLs dicts i)) x' y' = True + | (dictSel (ordEq dicts i)) x' y' = tupleLeq1 (i+1) + | otherwise = False + where + x' = tupleSel x i size + y' = tupleSel y i size + size = tupleSize dicts + +tupleGe :: TupleDicts -> Tuple -> Tuple -> Bool +tupleGe d x y = tupleLe d y x + +tupleGeq :: TupleDicts -> Tuple -> Tuple -> Bool +tupleGeq d x y = tupleLeq d y x + +tupleMax,tupleMin :: TupleDicts -> Tuple -> Tuple -> Tuple +tupleMax d x y = if tupleGe d x y then x else y +tupleMin d x y = if tupleLe d x y then x else y + +-- Ix functions + +tupleRange :: TupleDicts -> (Tuple,Tuple) -> [Tuple] +{-# tupleRange :: Strictness("S,S") #-} + +tupleRange dicts (x,y) = map listToTuple (tupleRange' 0) where + tupleRange' i | i == size = [[]] + | otherwise = + [(i1 : i2) | i1 <- r, i2 <- tupleRange' (i+1)] + where + x' = tupleSel x i size + y' = tupleSel y i size + r = (dictSel (range' dicts i)) (x',y') + size = tupleSize dicts + +range' x = range x + +tupleIndex :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Int +{-# tupleIndex :: Strictness("S,S,S") #-} + +tupleIndex dicts (low,high) n = tupleIndex' (size-1) where + size = tupleSize dicts + tupleIndex' i | i == 0 = i' + | otherwise = i' + r' * (tupleIndex' (i-1)) + where + low' = tupleSel low i size + high' = tupleSel high i size + n' = tupleSel n i size + i' = (dictSel (index' dicts i)) (low',high') n' + r' = (dictSel (rangeSize dicts i)) (low',high') + +index' x = index x + +rangeSize :: (Ix a) => (a,a) -> Int +rangeSize (l,u) = index (l,u) u + 1 + +tupleInRange :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Bool +{-# tupleInRange :: Strictness("S,S,S") #-} +tupleInRange dicts (low,high) n = tupleInRange' 0 where + size = tupleSize dicts + tupleInRange' i | i == size = True + | otherwise = (dictSel (inRange' dicts i)) (low',high') n' + && tupleInRange' (i+1) + where + low' = tupleSel low i size + high' = tupleSel high i size + n' = tupleSel n i size + +inRange' x = inRange x + +-- Text functions + +tupleReadsPrec :: TupleDicts -> Int -> ReadS Tuple + +tupleReadsPrec dicts p = readParen False + (\s -> map ( \ (t,w) -> (listToTuple t,w)) + (tRP' s 0)) + where + size = tupleSize dicts + tRP' s i | i == 0 = [(t':t,w) | + ("(",s1) <- lex s, + (t',s2) <- nextItem s1, + (t,w) <- tRP' s2 (i+1)] + | i == size = [([],w) | (")",w) <- lex s] + | otherwise = + [(t':t,w) | + (",",s1) <- lex s, + (t',s2) <- nextItem s1, + (t,w) <- tRP' s2 (i+1)] + where + nextItem s = (dictSel (reads dicts i)) s + +tupleShowsPrec :: TupleDicts -> Int -> Tuple -> ShowS + +tupleShowsPrec dicts p tuple = + showChar '(' . tSP' 0 + where + size = tupleSize dicts + tSP' i | i == (size-1) = + showTup . showChar ')' + | otherwise = + showTup . showChar ',' . tSP' (i+1) + where + showTup = (dictSel (shows dicts i)) (tupleSel tuple i size) + +tupleReadList :: TupleDicts -> ReadS [Tuple] + +tupleReadList dicts = + readParen False (\r -> [pr | ("[",s) <- lex r, + pr <- readl s]) + where readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- tupleReads s, + (xs,u) <- readl' t] + readl' s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, + (x,u) <- tupleReads t, + (xs,v) <- readl' u] + tupleReads s = tupleReadsPrec dicts 0 s + +tupleShowList :: TupleDicts -> [Tuple] -> ShowS + +tupleShowList dicts [] = showString "[]" +tupleShowList dicts (x:xs) + = showChar '[' . showsTuple x . showl xs + where showl [] = showChar ']' + showl (x:xs) = showString ", " . showsTuple x + . showl xs + showsTuple x = tupleShowsPrec dicts 0 x + +-- Binary functions + +tupleShowBin :: TupleDicts -> Tuple -> Bin -> Bin + +tupleShowBin dicts t bin = tSB' 0 + where + size = tupleSize dicts + tSB' i | i == size = bin + tSB' i | otherwise = + (dictSel (showBin' dicts i)) (tupleSel t i size) (tSB' (i+1)) + +showBin' x = showBin x + +tupleReadBin :: TupleDicts -> Bin -> (Tuple,Bin) + +tupleReadBin dicts bin = (listToTuple t,b) where + size = tupleSize dicts + (t,b) = tRB' bin 0 + tRB' b i | i == size = ([],b) + | otherwise = (t':ts,b') where + (t',b'') = (dictSel (readBin' dicts i)) b + (ts,b') = tRB' b'' (i+1) + +readBin' x = readBin x -- cgit v1.2.3