path: root/ghc/compiler/typecheck/TcSimplify.lhs

%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcSimplify]{TcSimplify}

\begin{code}
#include "HsVersions.h"

module TcSimplify (
	tcSimplify, tcSimplifyAndCheck,
	tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2,
	bindInstsOfLocalFuns
    ) where

IMP_Ubiq()

import HsSyn		( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, 
			  Match, HsBinds, HsType, ArithSeqInfo, Fixity,
			  GRHSsAndBinds, Stmt, DoOrListComp, Fake )
import HsBinds		( andMonoBinds )
import TcHsSyn		( SYN_IE(TcExpr), SYN_IE(TcMonoBinds), SYN_IE(TcDictBinds) )

import TcMonad
import Inst		( lookupInst, lookupSimpleInst,
			  tyVarsOfInst, isTyVarDict, isDict,
			  matchesInst, instToId, instBindingRequired,
			  instCanBeGeneralised, newDictsAtLoc,
			  pprInst,
			  Inst(..), SYN_IE(LIE), zonkLIE, emptyLIE, pprLIE, pprLIEInFull,
			  plusLIE, unitLIE, consLIE, InstOrigin(..),
			  OverloadedLit )
import TcEnv		( tcGetGlobalTyVars )
import SpecEnv		( SpecEnv )
import TcType		( TcIdOcc(..), SYN_IE(TcIdBndr), 
			  SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), TcMaybe, tcInstType
			)
import Unify		( unifyTauTy )

import Bag		( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList, 
			  snocBag, consBag, unionBags, isEmptyBag )
import Class		( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv),
			  isSuperClassOf, classSuperDictSelId, classInstEnv
			)
import Id		( GenId )
import PrelInfo		( isNumericClass, isStandardClass, isCcallishClass )

import Maybes		( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
import Outputable	( PprStyle, Outputable(..){-instance * []-} )
import PprType		( GenType, GenTyVar )
import Pretty
import SrcLoc		( noSrcLoc )
import Type		( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy,
			  getTyVar_maybe )
import TysWiredIn	( intTy, unitTy )
import TyVar		( GenTyVar, SYN_IE(GenTyVarSet), 
			  elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
			  isEmptyTyVarSet, tyVarSetToList )
import Unique		( Unique )
import Util
\end{code}


%************************************************************************
%*									*
\subsection[tcSimplify-main]{Main entry function}
%*									*
%************************************************************************

* May modify the substitution to bind ambiguous type variables.

Specification
~~~~~~~~~~~~~
(1) If an inst constrains only ``global'' type variables, (or none),
    return it as a ``global'' inst.

OTHERWISE

(2) Simplify it repeatedly (checking for (1) of course) until it is a dict
    constraining only a type variable.

(3) If it constrains a ``local'' type variable, return it as a ``local'' inst.
    Otherwise it must be ambiguous, so try to resolve the ambiguity.


\begin{code}
tcSimpl :: Bool				-- True <=> simplify const insts
	-> TcTyVarSet s			-- ``Global'' type variables
	-> TcTyVarSet s			-- ``Local''  type variables
					-- ASSERT: both these tyvar sets are already zonked
	-> LIE s			-- Given; these constrain only local tyvars
	-> LIE s			-- Wanted
	-> TcM s (LIE s,			-- Free
		  TcMonoBinds s,		-- Bindings
		  LIE s)			-- Remaining wanteds; no dups

tcSimpl squash_consts global_tvs local_tvs givens wanteds
  =	-- ASSSERT: global_tvs and local_tvs are already zonked
	-- Make sure the insts fixed points of the substitution
    zonkLIE givens		 	`thenNF_Tc` \ givens ->
    zonkLIE wanteds		 	`thenNF_Tc` \ wanteds ->

	-- Deal with duplicates and type constructors
    elimTyCons
	 squash_consts (\tv -> tv `elementOfTyVarSet` global_tvs)
	 givens wanteds		`thenTc` \ (globals, tycon_binds, locals_and_ambigs) ->

   	-- Now disambiguate if necessary
    let
	ambigs = filterBag is_ambiguous locals_and_ambigs
    in
    if not (isEmptyBag ambigs) then
	-- Some ambiguous dictionaries.	 We now disambiguate them,
	-- which binds the offending type variables to suitable types in the
	-- substitution, and then we retry the whole process.  This
	-- time there won't be any ambiguous ones.
	-- There's no need to back-substitute on global and local tvs,
	-- because the ambiguous type variables can't be in either.

	-- Why do we retry the whole process?  Because binding a type variable
	-- to a particular type might enable a short-cut simplification which
	-- elimTyCons will have missed the first time.

	disambiguateDicts ambigs		`thenTc_`
	tcSimpl squash_consts global_tvs local_tvs givens wanteds

    else
	-- No ambiguous dictionaries.  Just bash on with the results
	-- of the elimTyCons

	-- Check for non-generalisable insts
    let
  	locals		= locals_and_ambigs	-- ambigs is empty
	cant_generalise = filterBag (not . instCanBeGeneralised) locals
    in
    checkTc (isEmptyBag cant_generalise)
	    (genCantGenErr cant_generalise)	`thenTc_`


	-- Deal with superclass relationships
    elimSCs givens locals		`thenNF_Tc` \ (sc_binds, locals2) ->

	 -- Finished
    returnTc (globals, sc_binds `AndMonoBinds` tycon_binds, locals2)
  where
    is_ambiguous (Dict _ _ ty _ _)
	= not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs)
\end{code}

The main wrapper is @tcSimplify@.  It just calls @tcSimpl@, but with
the ``don't-squash-consts'' flag set depending on top-level ness.  For
top level defns we *do* squash constants, so that they stay local to a
single defn.  This makes things which are inlined more likely to be
exportable, because their constants are "inside".  Later passes will
float them out if poss, after inlinings are sorted out.

\begin{code}
tcSimplify
	:: TcTyVarSet s			-- ``Local''  type variables
	-> LIE s			-- Wanted
	-> TcM s (LIE s,			-- Free
		  TcDictBinds s,		-- Bindings
		  LIE s)			-- Remaining wanteds; no dups

tcSimplify local_tvs wanteds
  = tcGetGlobalTyVars			`thenNF_Tc` \ global_tvs ->
    tcSimpl False global_tvs local_tvs emptyBag wanteds
\end{code}

@tcSimplifyAndCheck@ is similar to the above, except that it checks
that there is an empty wanted-set at the end.  It may still return
some of constant insts, which have to be resolved finally at the end.

\begin{code}
tcSimplifyAndCheck
	 :: TcTyVarSet s		-- ``Local''  type variables; ASSERT is fixpoint
	 -> LIE s			-- Given
	 -> LIE s			-- Wanted
	 -> TcM s (LIE s,		-- Free
		   TcDictBinds s)	-- Bindings

tcSimplifyAndCheck local_tvs givens wanteds
  = tcGetGlobalTyVars			`thenNF_Tc` \ global_tvs ->
    tcSimpl False global_tvs local_tvs
	    givens wanteds		`thenTc` \ (free_insts, binds, wanteds') ->
    checkTc (isEmptyBag wanteds')
	    (reduceErr wanteds')	`thenTc_`
    returnTc (free_insts, binds)
\end{code}

@tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function
is not overloaded.

\begin{code}
tcSimplifyRank2 :: TcTyVarSet s		-- ``Local'' type variables; ASSERT is fixpoint
		-> LIE s		-- Given
		-> TcM s (LIE s,			-- Free
			  TcDictBinds s)	-- Bindings


tcSimplifyRank2 local_tvs givens
  = zonkLIE givens			`thenNF_Tc` \ givens' ->
    elimTyCons True
	       (\tv -> not (tv `elementOfTyVarSet` local_tvs))
		-- This predicate claims that all
		-- any non-local tyvars are global,
		-- thereby postponing dealing with
		-- ambiguity until the enclosing Gen
	       emptyLIE givens'	`thenTc` \ (free, dict_binds, wanteds) ->

    checkTc (isEmptyBag wanteds) (reduceErr wanteds)	`thenTc_`

    returnTc (free, dict_binds)
\end{code}

@tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
mechansim with the extra flag to say ``beat out constant insts''.

\begin{code}
tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
tcSimplifyTop dicts
  = tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts	`thenTc` \ (_, binds, _) ->
    returnTc binds
\end{code}

%************************************************************************
%*									*
\subsection[elimTyCons]{@elimTyCons@}
%*									*
%************************************************************************

\begin{code}
elimTyCons :: Bool				-- True <=> Simplify const insts
	   -> (TcTyVar s -> Bool)		-- Free tyvar predicate
	   -> LIE s				-- Given
	   -> LIE s				-- Wanted
	   -> TcM s (LIE s,			-- Free
		     TcDictBinds s,		-- Bindings
		     LIE s			-- Remaining wanteds; no dups;
						-- dicts only (no Methods)
	       )
\end{code}

The bindings returned may mention any or all of ``givens'', so the
order in which the generated binds are put together is {\em tricky}.
Case~4 of @try@ is the general case to see.

When we do @eTC givens (wanted:wanteds)@ [some details omitted], we...

    (1) first look up @wanted@; this gives us one binding to heave in:
	    wanted = rhs

    (2) step (1) also gave us some @simpler_wanteds@; we simplify
	these and get some (simpler-wanted-)bindings {\em that must be
	in scope} for the @wanted=rhs@ binding above!

    (3) we simplify the remaining @wanteds@ (recursive call), giving
	us yet more bindings.

The final arrangement of the {\em non-recursive} bindings is

    let <simpler-wanted-binds> in
    let wanted = rhs	       in
    let <yet-more-bindings> ...

\begin{code}
elimTyCons squash_consts is_free_tv givens wanteds
  = eTC givens (bagToList wanteds)	`thenTc` \ (_, free, binds, irreds) ->
    returnTc (free,binds,irreds)
  where
--    eTC :: LIE s -> [Inst s]
--	  -> TcM s (LIE s, LIE s, TcDictBinds s, LIE s)

    eTC givens [] = returnTc (givens, emptyBag, EmptyMonoBinds, emptyBag)

    eTC givens (wanted:wanteds)
    -- Case 0: same as an existing inst
      | maybeToBool maybe_equiv
      = eTC givens wanteds	`thenTc` \ (givens1, frees, binds, irreds) ->
	let
	  -- Create a new binding iff it's needed
	  this = expectJust "eTC" maybe_equiv
	  new_binds | instBindingRequired wanted = (VarMonoBind (instToId wanted) (HsVar (instToId this)))
						   `AndMonoBinds` binds
		    | otherwise			 = binds
	in
	returnTc (givens1, frees, new_binds, irreds)

    -- Case 1: constrains no type variables at all
    -- In this case we have a quick go to see if it has an
    -- instance which requires no inputs (ie a constant); if so we use
    -- it; if not, we give up on the instance and just heave it out the
    -- top in the free result
      | isEmptyTyVarSet tvs_of_wanted
      = simplify_it squash_consts	{- If squash_consts is false,
					   simplify only if trival -}
		    givens wanted wanteds

    -- Case 2: constrains free vars only, so fling it out the top in free_ids
      | all is_free_tv (tyVarSetToList tvs_of_wanted)
      = eTC (wanted `consBag` givens) wanteds	`thenTc` \ (givens1, frees, binds, irreds) ->
	returnTc (givens1, wanted `consBag` frees, binds, irreds)

    -- Case 3: is a dict constraining only a tyvar,
    -- so return it as part of the "wanteds" result
      | isTyVarDict wanted
      = eTC (wanted `consBag` givens) wanteds	`thenTc` \ (givens1, frees, binds, irreds) ->
	returnTc (givens1, frees, binds, wanted `consBag` irreds)

    -- Case 4: is not a simple dict, so look up in instance environment
      | otherwise
      = simplify_it True {- Simplify even if not trivial -}
		    givens wanted wanteds
      where
	tvs_of_wanted  = tyVarsOfInst wanted

	-- Look for something in "givens" that matches "wanted"
	Just the_equiv = maybe_equiv
	maybe_equiv    = foldBag seqMaybe try Nothing givens
	try given | wanted `matchesInst` given = Just given
		  | otherwise		       = Nothing


    simplify_it simplify_always givens wanted wanteds
	-- Recover immediately on no-such-instance errors
      = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, EmptyMonoBinds, emptyLIE)) 
		  (simplify_one simplify_always givens wanted)
				`thenTc` \ (givens1, frees1, binds1, irreds1) ->
	eTC givens1 wanteds	`thenTc` \ (givens2, frees2, binds2, irreds2) ->
	returnTc (givens2, frees1 `plusLIE` frees2,
			   binds1 `AndMonoBinds` binds2,
		  	   irreds1 `plusLIE` irreds2)


    simplify_one simplify_always givens wanted
     | not (instBindingRequired wanted)
     = 		-- No binding required for this chap, so squash right away
	   lookupInst wanted		`thenTc` \ (simpler_wanteds, _) ->
	   eTC givens simpler_wanteds	`thenTc` \ (givens1, frees1, binds1, irreds1) ->
	   returnTc (wanted `consBag` givens1, frees1, binds1, irreds1)

     | otherwise
     = 		-- An binding is required for this inst
	lookupInst wanted		`thenTc` \ (simpler_wanteds, bind@(VarMonoBind _ rhs)) ->

	if (not_var rhs && not simplify_always) then
	   -- Ho ho!  It isn't trivial to simplify "wanted",
	   -- because the rhs isn't a simple variable.	Unless the flag
	   -- simplify_always is set, just give up now and
	   -- just fling it out the top.
	   returnTc (wanted `consLIE` givens, unitLIE wanted, EmptyMonoBinds, emptyLIE)
	else
	   -- Aha! Either it's easy, or simplify_always is True
	   -- so we must do it right here.
	   eTC givens simpler_wanteds	`thenTc` \ (givens1, frees1, binds1, irreds1) ->
	   returnTc (wanted `consLIE` givens1, frees1,
		     binds1 `AndMonoBinds` bind,
		     irreds1)

    not_var :: TcExpr s -> Bool
    not_var (HsVar _) = False
    not_var other     = True
\end{code}


%************************************************************************
%*									*
\subsection[elimSCs]{@elimSCs@}
%*									*
%************************************************************************

\begin{code}
elimSCs :: LIE s				-- Given; no dups
	-> LIE s				-- Wanted; no dups; all dictionaries, all
						-- constraining just a type variable
	-> NF_TcM s (TcDictBinds s,		-- Bindings
		     LIE s)			-- Minimal wanted set

elimSCs givens wanteds
  = -- Sort the wanteds so that subclasses occur before superclasses
    elimSCs_help
	(filterBag isDict givens)	-- Filter out non-dictionaries
	(sortSC wanteds)

elimSCs_help :: LIE s					-- Given; no dups
	     -> [Inst s]				-- Wanted; no dups;
	     -> NF_TcM s (TcDictBinds s,		-- Bindings
		    	  LIE s)			-- Minimal wanted set

elimSCs_help given [] = returnNF_Tc (EmptyMonoBinds, emptyLIE)

elimSCs_help givens (wanted:wanteds)
  = trySC givens wanted 		`thenNF_Tc` \ (givens1, binds1, irreds1) ->
    elimSCs_help givens1 wanteds	`thenNF_Tc` \ (binds2, irreds2) ->
    returnNF_Tc (binds1 `AndMonoBinds` binds2, irreds1 `plusLIE` irreds2)


trySC :: LIE s				-- Givens
      -> Inst s				-- Wanted
      -> NF_TcM s (LIE s,			-- New givens,
		   TcDictBinds s,		-- Bindings
		   LIE s)			-- Irreducible wanted set

trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
  | not (maybeToBool maybe_best_subclass_chain)
  = 	-- No superclass relationship
    returnNF_Tc ((wanted `consLIE` givens), EmptyMonoBinds, unitLIE wanted)

  | otherwise
  = 	-- There's a subclass relationship with a "given"
	-- Build intermediate dictionaries
    let
	theta = [ (clas, wanted_ty) | clas <- reverse classes ]
	-- The reverse is because the list comes back in the "wrong" order I think
    in
    newDictsAtLoc wanted_orig loc theta		`thenNF_Tc` \ (intermediates, _) ->

	-- Create bindings for the wanted dictionary and the intermediates.
	-- Later binds may depend on earlier ones, so each new binding is pushed
	-- on the front of the accumulating parameter list of bindings
    let
	mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
	  = ((dict_sub, dict_sub_class),
	     (VarMonoBind (instToId dict)
			  (DictApp (TyApp (HsVar (RealId (classSuperDictSelId dict_sub_class 
									      clas)))
					    [ty])
				     [instToId dict_sub])))
	(_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates)
    in
    returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates,
	         andMonoBinds new_binds,
	         emptyLIE)

  where
    maybe_best_subclass_chain = foldBag choose_best find_subclass_chain Nothing givens
    Just (given, classes, _) = maybe_best_subclass_chain

    choose_best c1@(Just (_,_,n1)) c2@(Just (_,_,n2)) | n1 <= n2  = c1
						      | otherwise = c2
    choose_best Nothing		   c2				  = c2
    choose_best c1		   Nothing		  	  = c1

    find_subclass_chain given@(Dict _ given_class given_ty _ _)
	 | wanted_ty `eqSimpleTy` given_ty
	 = case (wanted_class `isSuperClassOf` given_class) of

		 Just classes -> Just (given,
				       classes,
				       length classes)

		 Nothing      -> Nothing

	 | otherwise = Nothing


sortSC :: LIE s     -- Expected to be all dicts (no MethodIds), all of
		    -- which constrain type variables
       -> [Inst s]  -- Sorted with subclasses before superclasses

sortSC dicts = sortLt lt (bagToList dicts)
  where
    (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _)
       = maybeToBool (c2 `isSuperClassOf` c1)
	-- The ice is a bit thin here because this "lt" isn't a total order
	-- But it *is* transitive, so it works ok
\end{code}


%************************************************************************
%*									*
\subsection[simple]{@Simple@ versions}
%*									*
%************************************************************************

Much simpler versions when there are no bindings to make!

@tcSimplifyThetas@ simplifies class-type constraints formed by
@deriving@ declarations and when specialising instances.  We are
only interested in the simplified bunch of class/type constraints.

\begin{code}
tcSimplifyThetas :: (Class -> ClassInstEnv)		-- How to find the ClassInstEnv
	       	 -> [(Class, TauType)]			-- Given
	       	 -> [(Class, TauType)]			-- Wanted
	       	 -> TcM s [(Class, TauType)]


tcSimplifyThetas inst_mapper given wanted
  = elimTyConsSimple inst_mapper wanted	`thenTc`    \ wanted1 ->
    returnTc (elimSCsSimple given wanted1)
\end{code}

@tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
used with \tr{default} declarations.  We are only interested in
whether it worked or not.

\begin{code}
tcSimplifyCheckThetas :: [(Class, TauType)]	-- Simplify this to nothing at all
		      -> TcM s ()

tcSimplifyCheckThetas theta
  = elimTyConsSimple classInstEnv theta    `thenTc`	\ theta1 ->
    ASSERT( null theta1 )
    returnTc ()
\end{code}


\begin{code}
elimTyConsSimple :: (Class -> ClassInstEnv) 
	         -> [(Class,Type)]
	         -> TcM s [(Class,Type)]
elimTyConsSimple inst_mapper theta
  = elim theta
  where
    elim []	          = returnTc []
    elim ((clas,ty):rest) = elim_one clas ty 	`thenTc` \ r1 ->
			    elim rest		`thenTc` \ r2 ->
			    returnTc (r1++r2)

    elim_one clas ty
	= case getTyVar_maybe ty of

	    Just tv   -> returnTc [(clas,ty)]

	    otherwise -> recoverTc (returnTc []) $
			 lookupSimpleInst (inst_mapper clas) clas ty	`thenTc` \ theta ->
			 elim theta

elimSCsSimple :: [(Class,Type)] 	-- Given
	      -> [(Class,Type)]		-- Wanted
	      -> [(Class,Type)]		-- Subset of wanted; no dups, no subclass relnships

elimSCsSimple givens [] = []
elimSCsSimple givens (c_t@(clas,ty) : rest)
  | any (`subsumes` c_t) givens ||
    any (`subsumes` c_t) rest				-- (clas,ty) is old hat
  = elimSCsSimple givens rest
  | otherwise						-- (clas,ty) is new
  = c_t : elimSCsSimple (c_t : givens) rest
  where
    rest' = elimSCsSimple rest
    (c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 && 
				 (c1 == c2 || maybeToBool (c2 `isSuperClassOf` c1))
-- We deal with duplicates here   ^^^^^^^^
-- It's a simple place to do it, although it's done in elimTyCons in the
-- full-blown version of the simpifier.
\end{code}

%************************************************************************
%*									*
\subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
%*									*
%************************************************************************

When doing a binding group, we may have @Insts@ of local functions.
For example, we might have...
\begin{verbatim}
let f x = x + 1	    -- orig local function (overloaded)
    f.1 = f Int	    -- two instances of f
    f.2 = f Float
 in
    (f.1 5, f.2 6.7)
\end{verbatim}
The point is: we must drop the bindings for @f.1@ and @f.2@ here,
where @f@ is in scope; those @Insts@ must certainly not be passed
upwards towards the top-level.	If the @Insts@ were binding-ified up
there, they would have unresolvable references to @f@.

We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
For each method @Inst@ in the @init_lie@ that mentions one of the
@Ids@, we create a binding.  We return the remaining @Insts@ (in an
@LIE@), as well as the @HsBinds@ generated.

\begin{code}
bindInstsOfLocalFuns ::	LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)

bindInstsOfLocalFuns init_lie local_ids
  = foldrTc bind_inst (emptyBag, EmptyMonoBinds) (bagToList init_lie)
  where
    bind_inst inst@(Method uniq (TcId id) tys _ _ orig loc) (insts, binds)
      | id `is_elem` local_ids
      = lookupInst inst		`thenTc` \ (dict_insts, bind) ->
	returnTc (listToBag dict_insts `plusLIE` insts, 
		  bind `AndMonoBinds` binds)

    bind_inst some_other_inst (insts, binds)
	-- Either not a method, or a method instance for an id not in local_ids
      = returnTc (some_other_inst `consBag` insts, binds)

    is_elem = isIn "bindInstsOfLocalFuns"
\end{code}


%************************************************************************
%*									*
\section[Disambig]{Disambiguation of overloading}
%*									*
%************************************************************************


If a dictionary constrains a type variable which is
\begin{itemize}
\item
not mentioned in the environment
\item
and not mentioned in the type of the expression
\end{itemize}
then it is ambiguous. No further information will arise to instantiate
the type variable; nor will it be generalised and turned into an extra
parameter to a function.

It is an error for this to occur, except that Haskell provided for
certain rules to be applied in the special case of numeric types.

Specifically, if
\begin{itemize}
\item
at least one of its classes is a numeric class, and
\item
all of its classes are numeric or standard
\end{itemize}
then the type variable can be defaulted to the first type in the
default-type list which is an instance of all the offending classes.

So here is the function which does the work.  It takes the ambiguous
dictionaries and either resolves them (producing bindings) or
complains.  It works by splitting the dictionary list by type
variable, and using @disambigOne@ to do the real business.

IMPORTANT: @disambiguate@ assumes that its argument dictionaries
constrain only a simple type variable.

\begin{code}
type SimpleDictInfo s = (Inst s, Class, TcTyVar s)

disambiguateDicts :: LIE s -> TcM s ()

disambiguateDicts insts
  = mapTc disambigOne inst_infos    `thenTc` \ binds_lists ->
    returnTc ()
  where
    inst_infos = equivClasses cmp_tyvars (map mk_inst_info (bagToList insts))
    (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmp` tv2

    mk_inst_info dict@(Dict _ clas ty _ _)
      = (dict, clas, getTyVar "disambiguateDicts" ty)
\end{code}

@disambigOne@ assumes that its arguments dictionaries constrain all
the same type variable.

ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
@()@ instead of @Int@.  I reckon this is the Right Thing to do since
the most common use of defaulting is code like:
\begin{verbatim}
	_ccall_ foo	`seqPrimIO` bar
\end{verbatim}
Since we're not using the result of @foo@, the result if (presumably)
@void@.

\begin{code}
disambigOne :: [SimpleDictInfo s] -> TcM s ()

disambigOne dict_infos
  |  any isNumericClass classes && all isStandardClass classes
  = 	-- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
	-- SO, TRY DEFAULT TYPES IN ORDER

	-- Failure here is caused by there being no type in the
	-- default list which can satisfy all the ambiguous classes.
	-- For example, if Real a is reqd, but the only type in the
	-- default list is Int.
    tcGetDefaultTys			`thenNF_Tc` \ default_tys ->
    let
      try_default [] 	-- No defaults work, so fail
	= failTc (ambigErr dicts) 

      try_default (default_ty : default_tys)
	= tryTc (try_default default_tys) $	-- If default_ty fails, we try
						-- default_tys instead
	  tcSimplifyCheckThetas thetas	`thenTc` \ _ ->
	  returnTc default_ty
        where
	  thetas = classes `zip` repeat default_ty
    in
	-- See if any default works, and if so bind the type variable to it
    try_default default_tys		`thenTc` \ chosen_default_ty ->
    tcInstType [] chosen_default_ty	`thenNF_Tc` \ chosen_default_tc_ty ->	-- Tiresome!
    unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)

  | all isCcallishClass classes
  = 	-- Default CCall stuff to (); we don't even both to check that () is an 
	-- instance of CCallable/CReturnable, because we know it is.
    unifyTauTy (mkTyVarTy tyvar) unitTy    
    
  | otherwise -- No defaults
  = failTc (ambigErr dicts)

  where
    (_,_,tyvar) = head dict_infos		-- Should be non-empty
    dicts   = [dict | (dict,_,_) <- dict_infos]
    classes = [clas | (_,clas,_) <- dict_infos]

\end{code}



Errors and contexts
~~~~~~~~~~~~~~~~~~~
ToDo: for these error messages, should we note the location as coming
from the insts, or just whatever seems to be around in the monad just
now?

\begin{code}
genCantGenErr insts sty	-- Can't generalise these Insts
  = hang (ptext SLIT("Cannot generalise these overloadings (in a _ccall_):")) 
	   4  (vcat (map (ppr sty) (bagToList insts)))
\end{code}

\begin{code}
ambigErr dicts sty
  = sep [text "Ambiguous context" <+> pprLIE sty lie,
	 nest 4 (pprLIEInFull sty lie)
    ]
  where
    lie = listToBag dicts	-- Yuk
\end{code}

@reduceErr@ complains if we can't express required dictionaries in
terms of the signature.

\begin{code}
reduceErr lie sty
  = sep [text "Context" <+> pprLIE sty lie,
	 nest 4 (text "required by inferred type, but missing on a type signature"),
	 nest 4 (pprLIEInFull sty lie)
    ]
\end{code}