+\begin{code}
+activate :: Avails s -> Inst -> Avails s
+ -- Activate the binding for Inst, ensuring that a binding for the
+ -- wanted Inst will be generated.
+ -- (Activate its parent if necessary, recursively).
+ -- Precondition: the Inst is in Avails already
+
+activate avails wanted
+ | not (instBindingRequired wanted)
+ = avails
+
+ | otherwise
+ = case lookupFM avails wanted of
+
+ Just (Avail main_id (PassiveScSel rhs insts) ids) ->
+ foldl activate avails' insts -- Activate anything it needs
+ where
+ avails' = addToFM avails wanted avail'
+ avail' = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
+
+ Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
+ addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
+
+ Nothing -> panic "activate"
+ where
+ wanted_id = instToId wanted
+
+addWanted avails wanted rhs_expr
+ = ASSERT( not (wanted `elemFM` avails) )
+ 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.
+ -- d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
+ -- Note that we pass the superclasses to the dfun, so they will be "wanted".
+ -- If we put the superclasses of "d" in avails, then we might end up
+ -- expressing "d1" in terms of "d", which would be a disaster.
+ where
+ avail = Avail (instToId wanted) rhs []
+
+ rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
+ | otherwise = NoRhs
+
+addFree :: Avails s -> Inst -> (Avails s)
+ -- When an Inst is tossed upstairs as 'free' we nevertheless add it
+ -- to avails, so that any other equal Insts will be commoned up right
+ -- here rather than also being tossed upstairs. This is really just
+ -- an optimisation, and perhaps it is more trouble that it is worth,
+ -- as the following comments show!
+ --
+ -- NB1: do *not* add superclasses. If we have
+ -- df::Floating a
+ -- dn::Num a
+ -- but a is not bound here, then we *don't* want to derive
+ -- dn from df here lest we lose sharing.
+ --
+ -- NB2: do *not* add the Inst to avails at all if it's a method.
+ -- The following situation shows why this is bad:
+ -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
+ -- From an application (truncate f i) we get
+ -- t1 = truncate at f
+ -- t2 = t1 at i
+ -- If we have also have a secon occurrence of truncate, we get
+ -- t3 = truncate at f
+ -- t4 = t3 at i
+ -- When simplifying with i,f free, we might still notice that
+ -- t1=t3; but alas, the binding for t2 (which mentions t1)
+ -- will continue to float out!
+ -- Solution: never put methods in avail till they are captured
+ -- in which case addFree isn't used
+addFree avails free
+ | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
+ | otherwise = avails
+
+addGiven :: Avails s -> Inst -> NF_TcM (Avails s)
+addGiven avails given
+ = -- ASSERT( not (given `elemFM` avails) )
+ -- This assertion isn't necessarily true. It's permitted
+ -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
+ -- and when typechecking instance decls we generate redundant "givens" too.
+ -- addAvail avails given avail
+ addAvail avails given avail `thenNF_Tc` \av ->
+ zonkInst given `thenNF_Tc` \given' ->
+ returnNF_Tc av
+ where
+ avail = Avail (instToId given) NoRhs []
+
+addAvail avails wanted avail
+ = addSuperClasses (addToFM avails wanted avail) wanted
+
+addSuperClasses :: Avails s -> Inst -> NF_TcM (Avails s)
+ -- Add all the superclasses of the Inst to Avails
+ -- Invariant: the Inst is already in Avails.
+
+addSuperClasses avails dict
+ | not (isClassDict dict)
+ = returnNF_Tc avails
+
+ | otherwise -- It is a dictionary
+ = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) `thenNF_Tc` \ avails' ->
+ addFunDeps avails' dict
+ where
+ (clas, tys) = getDictClassTys dict
+ (tyvars, sc_theta, sc_sels, _) = classBigSig clas
+ sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
+
+ add_sc avails ((super_clas, super_tys), sc_sel)
+ = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
+ let
+ sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
+ [instToId dict]
+ in
+ case lookupFM avails super_dict of
+
+ Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
+ -- Already there, but not as a superclass selector
+ -- No need to look at its superclasses; since it's there
+ -- already they must be already in avails
+ -- However, we must remember to activate the dictionary
+ -- from which it is (now) generated
+ returnNF_Tc (activate avails' dict)
+ where
+ avails' = addToFM avails super_dict avail
+ avail = Avail main_id (Rhs sc_sel_rhs True) ids -- Superclass selection
+
+ Just (Avail _ _ _) -> returnNF_Tc avails
+ -- Already there; no need to do anything
+
+ Nothing ->
+ -- Not there at all, so add it, and its superclasses
+ addAvail avails super_dict avail
+ where
+ avail = Avail (instToId super_dict)
+ (PassiveScSel sc_sel_rhs [dict])
+ []
+
+addFunDeps :: Avails s -> Inst -> NF_TcM (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}
+