From: simonpj <unknown>
Date: Mon, 29 Jan 2001 08:42:54 +0000 (+0000)
Subject: [project @ 2001-01-29 08:42:54 by simonpj]
X-Git-Tag: Approximately_9120_patches~2788
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=9c848a68f7b05aa352cd97d9a75488d20a774736;hp=6c936babdfb7f9c229b1d01be35728e2caf1d53d;p=ghc-hetmet.git

[project @ 2001-01-29 08:42:54 by simonpj]
Be a bit more liberal about allowing instance decls through.
In particular, allow this:

	instance C a b => C [a] [b] where ...

if we have

	class C a b | a -> b

This is an experimental feature. Furthermore it requires a
little more work (which I have not yet done) to make improvement
work properly.
---

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index ed4aa9f..8be560d 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -660,7 +660,7 @@ checkInstValidity dflags theta clas inst_tys
   | null errs = returnTc ()
   | otherwise = addErrsTc errs `thenNF_Tc_` failTc
   where
-    errs = checkInstHead dflags clas inst_tys ++
+    errs = checkInstHead dflags theta clas inst_tys ++
 	   [err | pred <- theta, err <- checkInstConstraint dflags pred]
 
 checkInstConstraint dflags pred
@@ -674,7 +674,7 @@ checkInstConstraint dflags pred
   |  otherwise
   =  [instConstraintErr pred]
 
-checkInstHead dflags clas inst_taus
+checkInstHead dflags theta clas inst_taus
   |	-- CCALL CHECK
 	-- A user declaration of a CCallable/CReturnable instance
 	-- must be for a "boxed primitive" type.
@@ -688,7 +688,7 @@ checkInstHead dflags clas inst_taus
 	-- If GlasgowExts then check at least one isn't a type variable
   | dopt Opt_GlasgowExts dflags
   = 	-- GlasgowExts case
-    check_tyvars dflags clas inst_taus ++ check_fundeps dflags clas inst_taus
+    check_tyvars dflags clas inst_taus ++ check_fundeps dflags theta clas inst_taus
 
 	-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
   | not (length inst_taus == 1 &&
@@ -725,9 +725,9 @@ check_tyvars dflags clas inst_taus
     the_err = instTypeErr clas inst_taus msg
     msg     = ptext SLIT("There must be at least one non-type-variable in the instance head")
 
-check_fundeps dflags clas inst_taus
-  | checkInstFDs clas inst_taus = []
-  | otherwise			= [the_err]
+check_fundeps dflags theta clas inst_taus
+  | checkInstFDs theta clas inst_taus = []
+  | otherwise			      = [the_err]
   where
     the_err = instTypeErr clas inst_taus msg
     msg  = ptext SLIT("the instance types do not agree with the functional dependencies of the class")
diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs
index 6419d77..f089e98 100644
--- a/ghc/compiler/types/FunDeps.lhs
+++ b/ghc/compiler/types/FunDeps.lhs
@@ -14,7 +14,7 @@ module FunDeps (
 
 import Var		( TyVar )
 import Class		( Class, FunDep, classTvsFds )
-import Type		( Type, PredType(..), predTyUnique, tyVarsOfTypes, tyVarsOfPred )
+import Type		( Type, ThetaType, PredType(..), predTyUnique, tyVarsOfTypes, tyVarsOfPred )
 import Subst		( mkSubst, emptyInScopeSet, substTy )
 import Unify		( unifyTyListsX )
 import Outputable	( Outputable, SDoc, interppSP, ptext, empty, hsep, punctuate, comma )
@@ -241,7 +241,8 @@ checkGroup inst_env clss@(Class cls tys : _)
 
 
 ----------
-checkClsFD :: TyVarSet 
+checkClsFD :: TyVarSet 			-- The quantified type variables, which
+					-- can be instantiated to make the types match
 	   -> FunDep TyVar -> [TyVar] 	-- One functional dependency from the class
 	   -> [Type] -> [Type]
 	   -> [Equation]
@@ -271,18 +272,18 @@ instFD (ls,rs) tvs tys
 \end{code}
 
 \begin{code}
-checkInstFDs :: Class -> [Type] -> Bool
+checkInstFDs :: ThetaType -> Class -> [Type] -> Bool
 -- Check that functional dependencies are obeyed in an instance decl
 -- For example, if we have 
---	class C a b | a -> b
+--	class theta => C a b | a -> b
 -- 	instance C t1 t2 
--- Then we require fv(t2) `subset` fv(t1)
+-- Then we require fv(t2) `subset` oclose(fv(t1), theta)
 
-checkInstFDs clas inst_taus
+checkInstFDs theta clas inst_taus
   = all fundep_ok fds
   where
     (tyvars, fds) = classTvsFds clas
-    fundep_ok fd  = tyVarsOfTypes rs `subVarSet` tyVarsOfTypes ls
+    fundep_ok fd  = tyVarsOfTypes rs `subVarSet` oclose theta (tyVarsOfTypes ls)
 		 where
 		   (ls,rs) = instFD fd tyvars inst_taus
 \end{code}