+ | null overloaded_ids
+ -- Common case
+ = returnTc (init_lie, EmptyMonoBinds)
+
+ | otherwise
+ = simpleReduceLoop doc try_me wanteds `thenTc` \ (frees, binds, irreds) ->
+ ASSERT( null irreds )
+ returnTc (mkLIE frees, binds)
+ where
+ doc = text "bindInsts" <+> ppr local_ids
+ wanteds = lieToList init_lie
+ overloaded_ids = filter is_overloaded local_ids
+ is_overloaded id = case splitSigmaTy (idType id) of
+ (_, theta, _) -> not (null theta)
+
+ overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
+ -- so it's worth building a set, so that
+ -- lookup (in isMethodFor) is faster
+
+ try_me inst | isMethodFor overloaded_set inst = ReduceMe
+ | otherwise = Free
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Data types for the reduction mechanism}
+%* *
+%************************************************************************
+
+The main control over context reduction is here
+
+\begin{code}
+data WhatToDo
+ = ReduceMe -- Try to reduce this
+ -- If there's no instance, behave exactly like
+ -- DontReduce: add the inst to
+ -- the irreductible ones, but don't
+ -- produce an error message of any kind.
+ -- It might be quite legitimate such as (Eq a)!
+
+ | DontReduce WantSCs -- Return as irreducible
+
+ | DontReduceUnlessConstant -- Return as irreducible unless it can
+ -- be reduced to a constant in one step
+
+ | Free -- Return as free
+
+data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses
+ -- of a predicate when adding it to the avails
+\end{code}
+
+
+
+\begin{code}
+type RedState = (Avails, -- What's available
+ [Inst]) -- Insts for which try_me returned Free
+
+type Avails = FiniteMap Inst Avail
+
+data Avail
+ = Irred -- Used for irreducible dictionaries,
+ -- which are going to be lambda bound
+
+ | BoundTo TcId -- Used for dictionaries for which we have a binding
+ -- e.g. those "given" in a signature
+
+ | NoRhs -- Used for Insts like (CCallable f)
+ -- where no witness is required.
+
+ | Rhs -- Used when there is a RHS
+ TcExpr -- The RHS
+ [Inst] -- Insts free in the RHS; we need these too
+
+pprAvails avails = vcat [ppr inst <+> equals <+> pprAvail avail
+ | (inst,avail) <- fmToList avails ]
+
+instance Outputable Avail where
+ ppr = pprAvail
+
+pprAvail NoRhs = text "<no rhs>"
+pprAvail Irred = text "Irred"
+pprAvail (BoundTo x) = text "Bound to" <+> ppr x
+pprAvail (Rhs rhs bs) = ppr rhs <+> braces (ppr bs)
+\end{code}
+
+Extracting the bindings from a bunch of Avails.
+The bindings do *not* come back sorted in dependency order.
+We assume that they'll be wrapped in a big Rec, so that the
+dependency analyser can sort them out later
+
+The loop startes
+\begin{code}
+bindsAndIrreds :: Avails
+ -> [Inst] -- Wanted
+ -> (TcDictBinds, -- Bindings
+ [Inst]) -- Irreducible ones
+
+bindsAndIrreds avails wanteds
+ = go avails EmptyMonoBinds [] wanteds
+ where
+ go avails binds irreds [] = (binds, irreds)
+
+ go avails binds irreds (w:ws)
+ = case lookupFM avails w of
+ Nothing -> -- Free guys come out here
+ -- (If we didn't do addFree we could use this as the
+ -- criterion for free-ness, and pick up the free ones here too)
+ go avails binds irreds ws
+
+ Just NoRhs -> go avails binds irreds ws
+
+ Just Irred -> go (addToFM avails w (BoundTo (instToId w))) binds (w:irreds) ws
+
+ Just (BoundTo id) -> go avails new_binds irreds ws
+ where
+ -- For implicit parameters, all occurrences share the same
+ -- Id, so there is no need for synonym bindings
+ new_binds | new_id == id = binds
+ | otherwise = addBind binds new_id (HsVar id)
+ new_id = instToId w
+
+ Just (Rhs rhs ws') -> go avails' (addBind binds id rhs) irreds (ws' ++ ws)
+ where
+ id = instToId w
+ avails' = addToFM avails w (BoundTo id)
+
+addBind binds id rhs = binds `AndMonoBinds` VarMonoBind id rhs
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[reduce]{@reduce@}
+%* *
+%************************************************************************
+
+When the "what to do" predicate doesn't depend on the quantified type variables,
+matters are easier. We don't need to do any zonking, unless the improvement step
+does something, in which case we zonk before iterating.
+
+The "given" set is always empty.
+
+\begin{code}
+simpleReduceLoop :: SDoc
+ -> (Inst -> WhatToDo) -- What to do, *not* based on the quantified type variables
+ -> [Inst] -- Wanted
+ -> TcM ([Inst], -- Free
+ TcDictBinds,
+ [Inst]) -- Irreducible
+
+simpleReduceLoop doc try_me wanteds
+ = mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
+ reduceContext doc try_me [] wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
+ if no_improvement then
+ returnTc (frees, binds, irreds)
+ else
+ simpleReduceLoop doc try_me (irreds ++ frees) `thenTc` \ (frees1, binds1, irreds1) ->
+ returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
+\end{code}
+
+
+
+\begin{code}
+reduceContext :: SDoc
+ -> (Inst -> WhatToDo)
+ -> [Inst] -- Given
+ -> [Inst] -- Wanted
+ -> NF_TcM (Bool, -- True <=> improve step did no unification
+ [Inst], -- Free
+ TcDictBinds, -- Dictionary bindings
+ [Inst]) -- Irreducible
+
+reduceContext doc try_me givens wanteds
+ =
+ traceTc (text "reduceContext" <+> (vcat [
+ text "----------------------",
+ doc,
+ text "given" <+> ppr givens,
+ text "wanted" <+> ppr wanteds,
+ text "----------------------"
+ ])) `thenNF_Tc_`
+
+ -- Build the Avail mapping from "givens"
+ foldlNF_Tc addGiven (emptyFM, []) givens `thenNF_Tc` \ init_state ->
+
+ -- Do the real work
+ reduceList (0,[]) try_me wanteds init_state `thenNF_Tc` \ state@(avails, frees) ->
+
+ -- Do improvement, using everything in avails
+ -- In particular, avails includes all superclasses of everything
+ tcImprove avails `thenTc` \ no_improvement ->
+
+ traceTc (text "reduceContext end" <+> (vcat [
+ text "----------------------",
+ doc,
+ text "given" <+> ppr givens,
+ text "wanted" <+> ppr wanteds,
+ text "----",
+ text "avails" <+> pprAvails avails,
+ text "frees" <+> ppr frees,
+ text "no_improvement =" <+> ppr no_improvement,
+ text "----------------------"
+ ])) `thenNF_Tc_`
+ let
+ (binds, irreds) = bindsAndIrreds avails wanteds
+ in
+ returnTc (no_improvement, frees, binds, irreds)
+
+tcImprove avails
+ = tcGetInstEnv `thenTc` \ inst_env ->
+ let
+ preds = [ (pred, pp_loc)
+ | inst <- keysFM avails,
+ let pp_loc = pprInstLoc (instLoc inst),
+ pred <- predsOfInst inst,
+ predHasFDs pred
+ ]
+ -- Avails has all the superclasses etc (good)
+ -- It also has all the intermediates of the deduction (good)
+ -- It does not have duplicates (good)
+ -- NB that (?x::t1) and (?x::t2) will be held separately in avails
+ -- so that improve will see them separate
+ eqns = improve (classInstEnv inst_env) preds
+ in
+ if null eqns then
+ returnTc True
+ else
+ traceTc (ptext SLIT("Improve:") <+> vcat (map ppr_eqn eqns)) `thenNF_Tc_`
+ mapTc_ unify eqns `thenTc_`
+ returnTc False
+ where
+ unify ((qtvs, t1, t2), doc)
+ = tcAddErrCtxt doc $
+ tcInstTyVars (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
+ unifyTauTy (substTy tenv t1) (substTy tenv t2)
+ ppr_eqn ((qtvs, t1, t2), doc)
+ = vcat [ptext SLIT("forall") <+> braces (pprWithCommas ppr (varSetElems qtvs))
+ <+> ppr t1 <+> equals <+> ppr t2,
+ doc]
+\end{code}
+
+The main context-reduction function is @reduce@. Here's its game plan.
+
+\begin{code}
+reduceList :: (Int,[Inst]) -- Stack (for err msgs)
+ -- along with its depth
+ -> (Inst -> WhatToDo)
+ -> [Inst]
+ -> RedState
+ -> TcM RedState
+\end{code}
+
+@reduce@ is passed
+ try_me: given an inst, this function returns
+ Reduce reduce this
+ DontReduce return this in "irreds"
+ Free return this in "frees"
+
+ wanteds: The list of insts to reduce
+ state: An accumulating parameter of type RedState
+ that contains the state of the algorithm
+
+ It returns a RedState.
+
+The (n,stack) pair is just used for error reporting.
+n is always the depth of the stack.
+The stack is the stack of Insts being reduced: to produce X
+I had to produce Y, to produce Y I had to produce Z, and so on.
+
+\begin{code}
+reduceList (n,stack) try_me wanteds state
+ | n > opt_MaxContextReductionDepth
+ = failWithTc (reduceDepthErr n stack)
+
+ | otherwise
+ =
+#ifdef DEBUG
+ (if n > 8 then
+ pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
+ else (\x->x))
+#endif
+ go wanteds state
+ where
+ go [] state = returnTc state
+ go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' ->
+ go ws state'
+
+ -- Base case: we're done!
+reduce stack try_me wanted state
+ -- It's the same as an existing inst, or a superclass thereof
+ | isAvailable state wanted
+ = returnTc state
+
+ | otherwise
+ = case try_me wanted of {
+
+ DontReduce want_scs -> addIrred want_scs state wanted
+
+ ; DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
+ -- First, see if the inst can be reduced to a constant in one step
+ try_simple (addIrred AddSCs) -- Assume want superclasses
+
+ ; Free -> -- It's free so just chuck it upstairs
+ -- First, see if the inst can be reduced to a constant in one step
+ try_simple addFree
+
+ ; ReduceMe -> -- It should be reduced
+ lookupInst wanted `thenNF_Tc` \ lookup_result ->
+ case lookup_result of
+ GenInst wanteds' rhs -> reduceList stack try_me wanteds' state `thenTc` \ state' ->
+ addWanted state' wanted rhs wanteds'
+ SimpleInst rhs -> addWanted state wanted rhs []
+
+ NoInstance -> -- No such instance!
+ -- Add it and its superclasses
+ addIrred AddSCs state wanted
+
+ }