[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 (file)
--- 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 (file)
--- 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}