From f6d9b94062023a64b1ff44bd731201df901f237a Mon Sep 17 00:00:00 2001
From: lewie <unknown>
Date: Fri, 14 Jul 2000 23:54:06 +0000
Subject: [PATCH] [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.
---
ghc/compiler/typecheck/Inst.lhs | 3 +++
ghc/compiler/typecheck/TcSimplify.lhs | 20 ++++++++++++--------
2 files changed, 15 insertions(+), 8 deletions(-)
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index f3b13c803e24..d4d8b48a481e 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 f51ae48aacee..acb0827e2cb0 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}
%************************************************************************
--
GitLab