From: lewie <unknown>
Date: Tue, 30 Nov 1999 16:12:14 +0000 (+0000)
Subject: [project @ 1999-11-30 16:12:14 by lewie]
X-Git-Tag: Approximately_9120_patches~5464
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6b62bc530ae5042d55dc59ca99b9bf8f1c939470;p=ghc-hetmet.git

[project @ 1999-11-30 16:12:14 by lewie]
... and of course these files might come in handy ...
---

diff --git a/ghc/compiler/types/FunDeps.hi-boot b/ghc/compiler/types/FunDeps.hi-boot
new file mode 100644
index 0000000..a6a7b5e
--- /dev/null
+++ b/ghc/compiler/types/FunDeps.hi-boot
@@ -0,0 +1,9 @@
+_interface_ FunDeps 1
+_exports_
+instantiateFdClassTys instantiateFdTys instantiateFundeps oclose pprFundeps ;
+_declarations_
+1 instantiateFdClassTys _:_ _forall_ [b] => Class.Class -> [b] -> [([b], [b])] ;;
+1 instantiateFdTys _:_ Inst.Inst -> [([TypeRep.Type], [TypeRep.Type])] ;
+1 instantiateFundeps _:_ Inst.Inst -> [([Var.Var], [Var.Var])] ;
+1 oclose _:_ _forall_ [a] => {Unique.Uniquable a} -> [([a], [a])] -> UniqFM.UniqFM a -> UniqFM.UniqFM a ;;
+1 pprFundeps _:_ _forall_ [a a1] => {Outputable.Outputable a} -> {Outputable.Outputable a1} -> [([a], [a1])] -> Outputable.PprStyle -> Pretty.Doc ;;
diff --git a/ghc/compiler/types/FunDeps.hi-boot-5 b/ghc/compiler/types/FunDeps.hi-boot-5
new file mode 100644
index 0000000..168a86e
--- /dev/null
+++ b/ghc/compiler/types/FunDeps.hi-boot-5
@@ -0,0 +1,7 @@
+__interface FunDeps 1 0 where
+__export FunDeps instantiateFdClassTys instantiateFdTys instantiateFundeps oclose pprFundeps ;
+1 instantiateFdClassTys :: __forall [b] => Class.Class -> [b] -> [([b], [b])] ;
+1 instantiateFdTys :: Inst.Inst -> [([TypeRep.Type], [TypeRep.Type])] ;
+1 instantiateFundeps :: Inst.Inst -> [([Var.Var], [Var.Var])] ;
+1 oclose :: __forall [a] => {Unique.Uniquable a} -> [([a], [a])] -> UniqFM.UniqFM a -> UniqFM.UniqFM a ;
+1 pprFundeps :: __forall [a a1] => {Outputable.Outputable a} -> {Outputable.Outputable a1} -> [([a], [a1])] -> Outputable.PprStyle -> Pretty.Doc ;
diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs
new file mode 100644
index 0000000..bcbe643
--- /dev/null
+++ b/ghc/compiler/types/FunDeps.lhs
@@ -0,0 +1,68 @@
+It's better to read it as: "if we know these, then we're going to know these"
+
+\begin{code}
+module FunDeps(oclose, instantiateFundeps, instantiateFdTys, instantiateFdClassTys, pprFundeps) where
+
+#include "HsVersions.h"
+
+import Inst		(getDictClassTys)
+import Class		(classTvsFds)
+import Type		(getTyVar_maybe, tyVarsOfType)
+import Outputable	(interppSP, ptext, empty, hsep, punctuate, comma)
+import UniqSet		(elementOfUniqSet, addOneToUniqSet,
+			 uniqSetToList, unionManyUniqSets)
+import List		(elemIndex)
+import Maybe		(catMaybes)
+import FastString
+
+oclose fds vs =
+    case oclose1 fds vs of
+      (vs', False) -> vs'
+      (vs', True) -> oclose fds vs'
+
+oclose1 [] vs = (vs, False)
+oclose1 (fd@(ls, rs):fds) vs =
+    if osubset ls vs then
+	(vs'', b1 || b2)
+    else
+	vs'b1
+    where
+	vs'b1@(vs', b1) = oclose1 fds vs
+	(vs'', b2) = ounion rs vs'
+
+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)
+    where
+	(ys', b) = ounion xs ys
+
+-- instantiate fundeps to type variables
+instantiateFundeps dict =
+    map (\(xs, ys) -> (unionMap getTyVars xs, unionMap getTyVars ys)) fdtys
+    where
+	fdtys = instantiateFdTys dict
+	getTyVars ty = tyVarsOfType ty
+	unionMap f xs = uniqSetToList (unionManyUniqSets (map f xs))
+
+-- instantiate fundeps to types
+instantiateFdTys dict = instantiateFdClassTys clas ts
+    where (clas, ts) = getDictClassTys dict
+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
+
+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}