[project @ 1999-12-03 18:17:29 by lewie]

Extend getTyVarsToGen to take the closure of the set of tyvars
with respect to functional dependencies.  Really simple programs
using functional dependencies work now.  Also fixed a small glitch
where trivial (empty) FunDeps were being tossed into the context willy nilly.

ghc/compiler/typecheck/Inst.lhs

@@ -16,14 +16,14 @@ module Inst (
 	newDictFromOld, newDicts, newDictsAtLoc, 
 	newMethod, newMethodWithGivenTy, newOverloadedLit, instOverloadedFun,
 
-	tyVarsOfInst, instLoc, getDictClassTys, getFunDeps,
+	tyVarsOfInst, instLoc, getDictClassTys, getFunDeps, getFunDepsOfLIE,
 
 	lookupInst, lookupSimpleInst, LookupInstResult(..),
 
 	isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
 	instBindingRequired, instCanBeGeneralised,
 
-	zonkInst, zonkFunDeps, instToId, instToIdBndr,
+	zonkInst, zonkFunDeps, zonkTvFunDeps, instToId, instToIdBndr,
 
 	InstOrigin(..), InstLoc, pprInstLoc
     ) where
@@ -39,7 +39,7 @@ import TcMonad
 import TcEnv	( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
 import TcType	( TcThetaType,
 		  TcType, TcTauType, TcTyVarSet,
-		  zonkTcType, zonkTcTypes, 
+		  zonkTcTyVars, zonkTcType, zonkTcTypes, 
 		  zonkTcThetaType
 		)
 import Bag
@@ -76,6 +76,7 @@ import Unique	( fromRationalClassOpKey, rationalTyConKey,
 		  fromIntClassOpKey, fromIntegerClassOpKey, Unique
 		)
 import Maybes	( expectJust )
+import Maybe	( catMaybes )
 import Util	( thenCmp, zipWithEqual, mapAccumL )
 import Outputable
 \end{code}
@@ -232,6 +233,8 @@ getDictClassTys (Dict u clas tys _) = (clas, tys)
 getFunDeps (FunDep clas fds _) = Just (clas, fds)
 getFunDeps _ = Nothing
 
+getFunDepsOfLIE lie = catMaybes (map getFunDeps (bagToList lie))
+
 tyVarsOfInst :: Inst -> TcTyVarSet
 tyVarsOfInst (Dict _ _ tys _)        = tyVarsOfTypes  tys
 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
@@ -338,8 +341,10 @@ instOverloadedFun orig (HsVar v) arg_tys theta tau
 
 instFunDeps orig theta
   = tcGetInstLoc orig	`thenNF_Tc` \ loc ->
-    let ifd (clas, tys) = FunDep clas (instantiateFdClassTys clas tys) loc in
-    returnNF_Tc (map ifd theta)
+    let ifd (clas, tys) =
+	    let fds = instantiateFdClassTys clas tys in
+	    if null fds then Nothing else Just (FunDep clas fds loc)
+    in returnNF_Tc (catMaybes (map ifd theta))
 
 newMethodWithGivenTy orig id tys theta tau
   = tcGetInstLoc orig	`thenNF_Tc` \ loc ->
@@ -454,6 +459,13 @@ zonkFunDeps fds = mapNF_Tc zonkFd fds
     = zonkTcTypes ts1			`thenNF_Tc` \ ts1' ->
       zonkTcTypes ts2			`thenNF_Tc` \ ts2' ->
       returnNF_Tc (ts1', ts2')
+
+zonkTvFunDeps fds = mapNF_Tc zonkFd fds
+  where
+  zonkFd (tvs1, tvs2)
+    = zonkTcTyVars tvs1			`thenNF_Tc` \ tvs1' ->
+      zonkTcTyVars tvs2			`thenNF_Tc` \ tvs2' ->
+      returnNF_Tc (tvs1', tvs2')
 \end{code}
 
 
@@ -482,7 +494,7 @@ pprInst (Method u id tys _ _ loc)
 	  show_uniq u]
 
 pprInst (FunDep clas fds loc)
-  = ptext SLIT("fundep!")
+  = hsep [ppr clas, ppr fds]
 
 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
 tidyInst env (LitInst u lit ty loc)

ghc/compiler/typecheck/TcBinds.lhs

@@ -20,7 +20,8 @@ import TcHsSyn		( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
 
 import TcMonad
 import Inst		( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
-			  newDicts, tyVarsOfInst, instToId,
+			  newDicts, tyVarsOfInst, instToId, getFunDepsOfLIE,
+			  zonkFunDeps
 			)
 import TcEnv		( tcExtendLocalValEnv,
 			  newSpecPragmaId, newLocalId,
@@ -53,6 +54,7 @@ import Type		( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
 			  mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType, 
 			  isUnboxedType, unboxedTypeKind, boxedTypeKind
 			)
+import FunDeps		( tyVarFunDep, oclose )
 import Var		( TyVar, tyVarKind )
 import VarSet
 import Bag
@@ -533,22 +535,27 @@ getTyVarsToGen is_unrestricted mono_id_tys lie
   = tcGetGlobalTyVars			`thenNF_Tc` \ free_tyvars ->
     zonkTcTypes mono_id_tys		`thenNF_Tc` \ zonked_mono_id_tys ->
     let
-	tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
+	body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
     in
     if is_unrestricted
     then
-	returnNF_Tc (emptyVarSet, tyvars_to_gen)
+	let fds = concatMap snd (getFunDepsOfLIE lie) in
+	zonkFunDeps fds		`thenNF_Tc` \ fds' ->
+	let tvFundep = tyVarFunDep fds'
+	    extended_tyvars = oclose tvFundep body_tyvars in
+	-- pprTrace "gTVTG" (ppr (lie, body_tyvars, extended_tyvars)) $
+	returnNF_Tc (emptyVarSet, extended_tyvars)
     else
 	-- This recover and discard-errs is to avoid duplicate error
 	-- messages; this, after all, is an "extra" call to tcSimplify
-	recoverNF_Tc (returnNF_Tc (emptyVarSet, tyvars_to_gen))		$
+	recoverNF_Tc (returnNF_Tc (emptyVarSet, body_tyvars))		$
 	discardErrsTc							$
 
-	tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie    `thenTc` \ (_, _, constrained_dicts) ->
+	tcSimplify (text "getTVG") NotTopLevel body_tyvars lie    `thenTc` \ (_, _, constrained_dicts) ->
 	let
 	  -- ASSERT: dicts_sig is already zonked!
 	    constrained_tyvars    = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts
-	    reduced_tyvars_to_gen = tyvars_to_gen `minusVarSet` constrained_tyvars
+	    reduced_tyvars_to_gen = body_tyvars `minusVarSet` constrained_tyvars
         in
         returnTc (constrained_tyvars, reduced_tyvars_to_gen)
 \end{code}

ghc/compiler/typecheck/TcImprove.lhs

@@ -11,7 +11,7 @@ import TcMonad
 import TcType		( zonkTcType, zonkTcTypes )
 import TcUnify		( unifyTauTyLists )
 import Inst		( Inst, LookupInstResult(..),
-			  lookupInst, isDict, getDictClassTys, getFunDeps,
+			  lookupInst, isDict, getDictClassTys, getFunDepsOfLIE,
 			  zonkLIE {- for debugging -} )
 import VarSet		( emptyVarSet )
 import VarEnv		( emptyVarEnv )
@@ -19,15 +19,12 @@ import FunDeps		( instantiateFdClassTys )
 import Bag		( bagToList )
 import Outputable
 import List		( elemIndex )
-import Maybe		( catMaybes )
 \end{code}
 
 Improvement goes here.
 
 \begin{code}
-tcImprove lie
-  = let cfdss = catMaybes (map getFunDeps (bagToList lie)) in
-    iterImprove cfdss
+tcImprove lie = iterImprove (getFunDepsOfLIE lie)
 
 iterImprove cfdss
   = instImprove cfdss			`thenTc` \ change1 ->

ghc/compiler/types/FunDeps.lhs

 It's better to read it as: "if we know these, then we're going to know these"
 
 \begin{code}
-module FunDeps(oclose, instantiateFdClassTys, pprFundeps) where
+module FunDeps(oclose, instantiateFdClassTys, tyVarFunDep, pprFundeps) where
 
 #include "HsVersions.h"
 
 import Class		(classTvsFds)
+import Type		(tyVarsOfType)
 import Outputable	(interppSP, ptext, empty, hsep, punctuate, comma)
-import UniqSet		(elementOfUniqSet, addOneToUniqSet )
+import UniqSet		(elementOfUniqSet, addOneToUniqSet,
+			 uniqSetToList, unionManyUniqSets)
 import List		(elemIndex)
 
 oclose fds vs =
@@ -44,6 +46,12 @@ 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))
+
 pprFundeps [] = empty
 pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
 

ghc/compiler/utils/UniqFM.lhs

@@ -209,6 +209,9 @@ instance Outputable (UniqFM a) where
 	ppr (LeafUFM x a) = text "LeafUFM " <+> int IBOX(x)
 	ppr (EmptyUFM)    = empty
 -}
+-- and when not debugging the package itself...
+instance Outputable a => Outputable (UniqFM a) where
+    ppr ufm = ppr (ufmToList ufm)
 \end{code}
 
 %************************************************************************