--- eTC :: LIE s -> [Inst s]
--- -> TcM s (LIE s, LIE s, Bag (TcIdOcc s, TcExpr s), LIE s)
-
- eTC givens [] = returnTc (givens, emptyBag, emptyBag, 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 = (instToId wanted, HsVar (instToId this))
- `consBag` 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, emptyBag, 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 `unionBags` 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@(_,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, emptyBag, 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 `snocBag` bind,
- irreds1)
-
- not_var :: TcExpr s -> Bool
- not_var (HsVar _) = False
- not_var other = True