summaryrefslogtreecommitdiff
path: root/progs/prelude/PreludeTuple.hs
diff options
context:
space:
mode:
Diffstat (limited to 'progs/prelude/PreludeTuple.hs')
-rw-r--r--progs/prelude/PreludeTuple.hs213
1 files changed, 213 insertions, 0 deletions
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
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-16 19:06:14 +0000