Functional Dependencies were not getting simplified away when the dictionary
that generated them was simplified by instance resolution. Fixed.
\begin{code}
newFunDepFromDict dict
\begin{code}
newFunDepFromDict 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)
= 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
addWanted avails wanted rhs_expr
= ASSERT( not (wanted `elemFM` avails) )
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.
-- 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.
addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
-- Add all the superclasses of the Inst to Avails
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
-- Invariant: the Inst is already in Avails.
addSuperClasses avails dict
| otherwise -- It is a dictionary
= foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) `thenNF_Tc` \ avails' ->
| 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
where
(clas, tys) = getDictClassTys dict
(tyvars, sc_theta, sc_sels, _) = classBigSig clas
avail = Avail (instToId super_dict)
(PassiveScSel sc_sel_rhs [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}
%************************************************************************
\end{code}
%************************************************************************