From: lewie <unknown>
Date: Fri, 14 Jul 2000 23:54:06 +0000 (+0000)
Subject: [project @ 2000-07-14 23:54:06 by lewie]
X-Git-Tag: Approximately_9120_patches~4005
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=f6d9b94062023a64b1ff44bd731201df901f237a;p=ghc-hetmet.git

[project @ 2000-07-14 23:54:06 by lewie]
Functional Dependencies were not getting simplified away when the dictionary
that generated them was simplified by instance resolution.  Fixed.
---

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index f3b13c8..d4d8b48 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -451,12 +451,15 @@ newOverloadedLit orig lit ty		-- The general case
 
 \begin{code}
 newFunDepFromDict dict
+  | isClassDict dict
   = tcGetUnique		`thenNF_Tc` \ uniq ->
     let (clas, tys) = getDictClassTys dict
 	fds = instantiateFdClassTys clas tys
 	inst = FunDep uniq clas fds (instLoc dict)
     in
 	if null fds then returnNF_Tc Nothing else returnNF_Tc (Just inst)
+  | otherwise
+  = returnNF_Tc Nothing
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index f51ae48..acb0827 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -709,7 +709,7 @@ activate avails wanted
     
 addWanted avails wanted rhs_expr
   = ASSERT( not (wanted `elemFM` avails) )
-    returnNF_Tc (addToFM avails wanted avail)
+    addFunDeps (addToFM avails wanted avail) wanted
 	-- NB: we don't add the thing's superclasses too!
 	-- Why not?  Because addWanted is used when we've successfully used an
 	-- instance decl to reduce something; e.g.
@@ -772,7 +772,6 @@ addAvail avails wanted avail
 
 addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
 		-- Add all the superclasses of the Inst to Avails
-		-- JRL - also add in the functional dependencies
 		-- Invariant: the Inst is already in Avails.
 
 addSuperClasses avails dict
@@ -781,12 +780,7 @@ addSuperClasses avails dict
 
   | otherwise	-- It is a dictionary
   = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) `thenNF_Tc` \ avails' ->
-    newFunDepFromDict dict	`thenNF_Tc` \ fdInst_maybe ->
-    case fdInst_maybe of
-      Nothing -> returnNF_Tc avails'
-      Just fdInst ->
-	let fdAvail = Avail (instToId (fromJust fdInst_maybe)) NoRhs [] in
-        addAvail avails fdInst fdAvail
+    addFunDeps avails' dict
   where
     (clas, tys) = getDictClassTys dict
     (tyvars, sc_theta, sc_sels, _) = classBigSig clas
@@ -821,6 +815,16 @@ addSuperClasses avails dict
 		  avail   = Avail (instToId super_dict) 
 				  (PassiveScSel sc_sel_rhs [dict])
 				  []
+
+addFunDeps :: Avails s -> Inst -> NF_TcM s (Avails s)
+	   -- Add in the functional dependencies generated by the inst
+addFunDeps avails inst
+  = newFunDepFromDict inst	`thenNF_Tc` \ fdInst_maybe ->
+    case fdInst_maybe of
+      Nothing -> returnNF_Tc avails
+      Just fdInst ->
+	let fdAvail = Avail (instToId (fromJust fdInst_maybe)) NoRhs [] in
+        addAvail avails fdInst fdAvail
 \end{code}
 
 %************************************************************************