[project @ 2000-05-25 12:41:14 by simonpj]

[ghc-hetmet.git] / ghc / compiler / types / FunDeps.lhs

diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs
index c1db64e..686d98d 100644 (file)
--- a/ghc/compiler/types/FunDeps.lhs
+++ b/ghc/compiler/types/FunDeps.lhs
@@ -15,20 +15,34 @@ module FunDeps (
 
 #include "HsVersions.h"
 
-import Class           ( classTvsFds )
-import Type            ( tyVarsOfType )
-import Outputable      ( interppSP, ptext, empty, hsep, punctuate, comma )
-import UniqSet         ( elementOfUniqSet, addOneToUniqSet,
-                         uniqSetToList, unionManyUniqSets )
+import Var             ( TyVar )
+import Class           ( Class, FunDep, classTvsFds )
+import Type            ( Type, tyVarsOfTypes )
+import Outputable      ( Outputable, SDoc, interppSP, ptext, empty, hsep, punctuate, comma )
+import UniqSet
+import VarSet
+import Unique          ( Uniquable )
 import List            ( elemIndex )
 \end{code}
 
 
 \begin{code}
+oclose :: Uniquable a => [FunDep a] -> UniqSet a -> UniqSet a
+-- (oclose fds tvs) closes the set of type variables tvs, 
+-- wrt the functional dependencies fds.  The result is a superset
+-- of the argument set.
+--
+-- For example,
+--     oclose [a -> b] {a}     = {a,b}
+--     oclose [a b -> c] {a}   = {a}
+--     oclose [a b -> c] {a,b} = {a,b,c}
+-- If all of the things on the left of an arrow are in the set, add
+-- the things on the right of that arrow.
+
 oclose fds vs =
     case oclose1 fds vs of
       (vs', False) -> vs'
-      (vs', True) -> oclose fds vs'
+      (vs', True)  -> oclose fds vs'
 
 oclose1 [] vs = (vs, False)
 oclose1 (fd@(ls, rs):fds) vs =
@@ -44,30 +58,32 @@ osubset [] vs = True
 osubset (u:us) vs = if u `elementOfUniqSet` vs then osubset us vs else False
 
 ounion [] ys = (ys, False)
-ounion (x:xs) ys =
-    if x `elementOfUniqSet` ys then (ys', b) else (addOneToUniqSet ys' x, True)
+ounion (x:xs) ys
+    | x `elementOfUniqSet` ys = (ys', b)
+    | otherwise                      = (addOneToUniqSet ys' x, True)
     where
        (ys', b) = ounion xs ys
 
-instantiateFdClassTys clas ts =
-    map (lookupInstFundep tyvars ts) fundeps
-    where
-       (tyvars, fundeps) = classTvsFds clas
-       lookupInstFundep tyvars ts (us, vs) =
-           (lookupInstTys tyvars ts us, lookupInstTys tyvars ts vs)
+instantiateFdClassTys :: Class -> [a] -> [([a], [a])]
+-- Get the FDs of the class, and instantiate them
+instantiateFdClassTys clas ts
+  = map (lookupInstFundep tyvars ts) fundeps
+  where
+    (tyvars, fundeps) = classTvsFds clas
+    lookupInstFundep tyvars ts (us, vs)
+       = (lookupInstTys tyvars ts us, lookupInstTys tyvars ts vs)
+
 lookupInstTys tyvars ts = map (lookupInstTy tyvars ts)
 lookupInstTy tyvars ts u = ts !! i
     where Just i = elemIndex u tyvars
 
-tyVarFunDep fdtys =
-    map (\(xs, ys) -> (unionMap getTyVars xs, unionMap getTyVars ys)) fdtys
-    where
-       getTyVars ty = tyVarsOfType ty
-       unionMap f xs = uniqSetToList (unionManyUniqSets (map f xs))
+tyVarFunDep :: [FunDep Type] -> [FunDep TyVar]
+tyVarFunDep fdtys 
+  = [(varSetElems (tyVarsOfTypes xs), varSetElems (tyVarsOfTypes xs)) | (xs,ys) <- fdtys]
 
+pprFundeps :: Outputable a => [FunDep a] -> SDoc
 pprFundeps [] = empty
 pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
 
 ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), interppSP vs]
-
 \end{code}