[project @ 2000-11-07 14:07:09 by simonmar]

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

diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs
index c1db64e..7c6a27c 100644 (file)
--- a/ghc/compiler/types/FunDeps.lhs
+++ b/ghc/compiler/types/FunDeps.lhs
@@ -15,20 +15,35 @@ 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 List            ( elemIndex )
+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 VarEnv
+import Unique          ( Uniquable )
+import Util            ( zipEqual )
 \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 +59,30 @@ 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)
-lookupInstTys tyvars ts = map (lookupInstTy tyvars ts)
-lookupInstTy tyvars ts u = ts !! i
-    where Just i = elemIndex u tyvars
+instantiateFdClassTys :: Class -> [Type] -> [FunDep Type]
+-- Get the FDs of the class, and instantiate them
+instantiateFdClassTys clas tys
+  = [(map lookup us, map lookup vs) | (us,vs) <- fundeps]
+  where
+    (tyvars, fundeps) = classTvsFds clas
+    env       = mkVarEnv (zipEqual "instantiateFdClassTys" tyvars tys)
+    lookup tv = lookupVarEnv_NF env tv
 
-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 
+  = [(getTyvars xs, getTyvars ys) | (xs, ys) <- fdtys]
+  where 
+    getTyvars = varSetElems . tyVarsOfTypes
 
+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}