home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / prelude / PreludeTuple.hs < prev    next >
Encoding:
Text File  |  1994-09-27  |  6.6 KB  |  217 lines  |  [TEXT/YHS2]
  1. module PreludeTuple where
  2.  
  3. {-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
  4.  
  5. import PreludeTuplePrims
  6.  
  7. data Tuple = Tuple
  8. data TupleDicts = TupleDicts
  9.  
  10. -- This module contains support routines which handle tuple instances.
  11. -- These are based on a implementation level data type which represents
  12. -- general tuples and a data type to hold the set of dictionaries which
  13. -- are associated with the tuple.
  14.  
  15. -- Each of these functions takes the tupledicts as the first argument.
  16. -- Force all of these functions to take strict arguments because they'll
  17. -- never be called with 0-length tuples anyway.
  18.  
  19. -- The following primitives operate on tuples.  
  20.  
  21. --  tupleSize :: TupleDicts -> Int
  22. --  tupleSel :: Tuple -> Int -> Int -> a
  23. --  dictSel :: TupleDicts -> method -> Int -> a
  24. --  listToTuple :: [a] -> Tuple
  25.  
  26. -- Eq functions
  27.  
  28. tupleEq :: TupleDicts -> Tuple -> Tuple -> Bool
  29. {-#  tupleEq :: Strictness("S,S,S") #-}
  30. tupleEq dicts x y = tupleEq1 0 where
  31.   tupleEq1 i | i == size = True
  32.              | otherwise =
  33.                   ((dictSel (cmpEq dicts i)) x' y') && tupleEq1 (i+1)
  34.      where
  35.         x' = tupleSel x i size
  36.         y' = tupleSel y i size
  37.   size = tupleSize dicts
  38.  
  39. cmpEq x y = x == y
  40.  
  41. tupleNeq dicts x y = not (tupleEq dicts x y)
  42.  
  43. -- Ord functions
  44.  
  45. tupleLe :: TupleDicts -> Tuple -> Tuple -> Bool
  46. {-#  tupleLe :: Strictness("S,S,S") #-}
  47. tupleLe dicts x y = tupleLe1 0 where
  48.   tupleLe1 i | i == size = False
  49.              | (dictSel (cmpLs dicts i)) x' y' = True
  50.          | (dictSel (ordEq dicts i)) x' y' = tupleLe1 (i+1)
  51.          | otherwise = False
  52.       where
  53.         x' = tupleSel x i size
  54.         y' = tupleSel y i size
  55.   size = tupleSize dicts
  56.  
  57. cmpLs x y = x < y
  58.  
  59. ordEq :: Ord a => a -> a -> Bool
  60. ordEq x y = x == y
  61.  
  62. tupleLeq :: TupleDicts -> Tuple -> Tuple -> Bool
  63. {-#  tupleLeq :: Strictness("S,S,S") #-}
  64. tupleLeq dicts x y = tupleLeq1 0 where
  65.   tupleLeq1 i | i == size = True
  66.              | (dictSel (cmpLs dicts i)) x' y' = True
  67.          | (dictSel (ordEq dicts i)) x' y' = tupleLeq1 (i+1)
  68.          | otherwise = False
  69.       where
  70.         x' = tupleSel x i size
  71.         y' = tupleSel y i size
  72.   size = tupleSize dicts
  73.  
  74. tupleGe :: TupleDicts -> Tuple -> Tuple -> Bool
  75. tupleGe d x y = tupleLe d y x
  76.  
  77. tupleGeq :: TupleDicts -> Tuple -> Tuple -> Bool
  78. tupleGeq d x y = tupleLeq d y x
  79.  
  80. tupleMax,tupleMin :: TupleDicts -> Tuple -> Tuple -> Tuple
  81. tupleMax d x y = if tupleGe d x y then x else y
  82. tupleMin d x y = if tupleLe d x y then x else y
  83.  
  84. -- Ix functions
  85.  
  86. tupleRange :: TupleDicts -> (Tuple,Tuple) -> [Tuple]
  87. {-#  tupleRange :: Strictness("S,S") #-}
  88.  
  89. tupleRange dicts (x,y) = map listToTuple (tupleRange' 0) where
  90.   tupleRange' i | i == size = [[]]
  91.                 | otherwise =
  92.                    [(i1 : i2) | i1 <- r, i2 <- tupleRange' (i+1)]
  93.       where
  94.         x' = tupleSel x i size
  95.         y' = tupleSel y i size
  96.         r = (dictSel (range' dicts i)) (x',y')
  97.   size = tupleSize dicts
  98.  
  99. range' x = range x
  100.  
  101. tupleIndex :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Int
  102. {-#  tupleIndex :: Strictness("S,S,S") #-}
  103.  
  104. tupleIndex dicts (low,high) n = tupleIndex' (size-1) where
  105.   size = tupleSize dicts
  106.   tupleIndex' i | i == 0 = i'
  107.                 | otherwise = i' + r' * (tupleIndex' (i-1))
  108.    where
  109.     low' = tupleSel low i size
  110.     high' = tupleSel high i size
  111.     n' = tupleSel n i size
  112.     i' = (dictSel (index' dicts i)) (low',high') n'
  113.     r' = (dictSel (rangeSize dicts i)) (low',high')
  114.  
  115. index' x = index x
  116.  
  117. rangeSize               :: (Ix a) => (a,a) -> Int
  118. rangeSize (l,u)         =  index (l,u) u + 1
  119.  
  120. tupleInRange :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Bool
  121. {-#  tupleInRange :: Strictness("S,S,S") #-}
  122. tupleInRange dicts (low,high) n = tupleInRange' 0 where
  123.   size = tupleSize dicts
  124.   tupleInRange' i | i == size = True
  125.                   | otherwise = (dictSel (inRange' dicts i)) (low',high') n'
  126.                         && tupleInRange' (i+1)
  127.    where
  128.     low' = tupleSel low i size
  129.     high' = tupleSel high i size
  130.     n' = tupleSel n i size
  131.    
  132. inRange' x = inRange x
  133.  
  134. -- Text functions
  135.  
  136. tupleReadsPrec :: TupleDicts -> Int -> ReadS Tuple
  137.  
  138. tupleReadsPrec dicts p = readParen False
  139.                           (\s -> map ( \ (t,w) -> (listToTuple t,w))
  140.                          (tRP' s 0))
  141.     where
  142.       size = tupleSize dicts
  143.       tRP' s i | i == 0 = [(t':t,w) |
  144.                              ("(",s1) <- lex s,
  145.                              (t',s2) <- nextItem s1,
  146.                              (t,w) <- tRP' s2 (i+1)]
  147.                | i == size = [([],w) | (")",w) <- lex s]
  148.                | otherwise =
  149.                         [(t':t,w) | 
  150.                              (",",s1) <- lex s,
  151.                              (t',s2) <- nextItem s1,
  152.                              (t,w) <- tRP' s2 (i+1)]
  153.        where
  154.         nextItem s = (dictSel (reads dicts i)) s
  155.  
  156. tupleShowsPrec :: TupleDicts -> Int -> Tuple -> ShowS
  157.  
  158. tupleShowsPrec dicts p tuple =  
  159.   showChar '(' . tSP' 0
  160.     where
  161.       size = tupleSize dicts
  162.       tSP' i | i == (size-1) =
  163.                  showTup . showChar ')'
  164.              | otherwise =
  165.                  showTup . showChar ',' . tSP' (i+1)
  166.         where
  167.           showTup = (dictSel (shows dicts i)) (tupleSel tuple i size)
  168.                                     
  169. tupleReadList :: TupleDicts -> ReadS [Tuple]
  170.  
  171. tupleReadList dicts =
  172.                   readParen False (\r -> [pr | ("[",s)    <- lex r,
  173.                            pr    <- readl s])
  174.               where readl  s = [([],t)   | ("]",t)  <- lex s] ++
  175.                    [(x:xs,u) | (x,t)    <- tupleReads s,
  176.                            (xs,u)   <- readl' t]
  177.             readl' s = [([],t)   | ("]",t)  <- lex s] ++
  178.                        [(x:xs,v) | (",",t)  <- lex s,
  179.                            (x,u)    <- tupleReads t,
  180.                            (xs,v)   <- readl' u]
  181.                         tupleReads s = tupleReadsPrec dicts 0 s
  182.  
  183. tupleShowList :: TupleDicts -> [Tuple] -> ShowS
  184.  
  185. tupleShowList dicts [] = showString "[]"
  186. tupleShowList dicts (x:xs)
  187.         = showChar '[' . showsTuple x . showl xs
  188.           where showl []     = showChar ']'
  189.             showl (x:xs) = showString ", " . showsTuple x
  190.                                            . showl xs
  191.                         showsTuple x = tupleShowsPrec dicts 0 x
  192.  
  193. -- Binary functions
  194.  
  195. tupleShowBin :: TupleDicts -> Tuple -> Bin -> Bin
  196.  
  197. tupleShowBin dicts t bin = tSB' 0
  198.   where
  199.     size = tupleSize dicts
  200.     tSB' i | i == size = bin
  201.     tSB' i | otherwise =
  202.                   (dictSel (showBin' dicts i)) (tupleSel t i size) (tSB' (i+1))
  203.  
  204. showBin' x = showBin x
  205.  
  206. tupleReadBin :: TupleDicts -> Bin -> (Tuple,Bin)
  207.  
  208. tupleReadBin dicts bin = (listToTuple t,b) where
  209.   size = tupleSize dicts
  210.   (t,b) = tRB' bin 0
  211.   tRB' b i | i == size = ([],b)
  212.            | otherwise = (t':ts,b') where
  213.      (t',b'') = (dictSel (readBin' dicts i)) b
  214.      (ts,b') = tRB' b'' (i+1)
  215.  
  216. readBin' x = readBin x
  217.