-import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
-import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp )
+import HsSyn ( HsBind(..), HsExpr(..), LHsExpr,
+ ExprCoFn(..), (<.>), nlHsTyApp, emptyLHsBinds )
+import TcHsSyn ( mkHsApp )
isMethodFor, isMethod,
instToId, tyVarsOfInsts, cloneDict,
ipNamesOfInsts, ipNamesOfInst, dictPred,
isMethodFor, isMethod,
instToId, tyVarsOfInsts, cloneDict,
ipNamesOfInsts, ipNamesOfInst, dictPred,
newDictsAtLoc, tcInstClassOp,
getDictClassTys, isTyVarDict, instLoc,
zonkInst, tidyInsts, tidyMoreInsts,
newDictsAtLoc, tcInstClassOp,
getDictClassTys, isTyVarDict, instLoc,
zonkInst, tidyInsts, tidyMoreInsts,
tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
-- Zonk everything in sight
= mappM zonkInst wanteds `thenM` \ wanteds' ->
tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
-- Zonk everything in sight
= mappM zonkInst wanteds `thenM` \ wanteds' ->
-- 'reduceMe': Reduce as far as we can. Don't stop at
-- dicts; the idea is to get rid of as many type
-- 'reduceMe': Reduce as far as we can. Don't stop at
-- dicts; the idea is to get rid of as many type
-- immediately, with no constraint on s.
--
-- BUT do no improvement! See Plan D above
-- immediately, with no constraint on s.
--
-- BUT do no improvement! See Plan D above
reduceContextWithoutImprovement
doc reduceMe wanteds' `thenM` \ (_frees, _binds, constrained_dicts) ->
-- Next, figure out the tyvars we will quantify over
reduceContextWithoutImprovement
doc reduceMe wanteds' `thenM` \ (_frees, _binds, constrained_dicts) ->
-- Next, figure out the tyvars we will quantify over
- constrained_tvs = tyVarsOfInsts constrained_dicts
- qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs')
- `minusVarSet` constrained_tvs
+ constrained_tvs' = tyVarsOfInsts constrained_dicts'
+ qtvs' = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs')
+ `minusVarSet` constrained_tvs'
- pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts,
+ pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts',
-- The first step may have squashed more methods than
-- necessary, so try again, this time more gently, knowing the exact
-- set of type variables to quantify over.
--
-- The first step may have squashed more methods than
-- necessary, so try again, this time more gently, knowing the exact
-- set of type variables to quantify over.
--
-- these will just be a subset of non-dicts. This in contrast
-- to normal inference (using isFreeWhenInferring) in which we quantify over
-- all *non-inheritable* constraints too. This implements choice
-- these will just be a subset of non-dicts. This in contrast
-- to normal inference (using isFreeWhenInferring) in which we quantify over
-- all *non-inheritable* constraints too. This implements choice
-- See "Notes on implicit parameters, Question 4: top level"
if is_nested_group then
extendLIEs frees `thenM_`
-- See "Notes on implicit parameters, Question 4: top level"
if is_nested_group then
extendLIEs frees `thenM_`
else
let
(non_ips, bad_ips) = partition isClassDict frees
in
addTopIPErrs bndrs bad_ips `thenM_`
extendLIEs non_ips `thenM_`
else
let
(non_ips, bad_ips) = partition isClassDict frees
in
addTopIPErrs bndrs bad_ips `thenM_`
extendLIEs non_ips `thenM_`
get_root irreds frees (Given id _) w = returnM (irreds, frees, id)
get_root irreds frees Irred w = cloneDict w `thenM` \ w' ->
returnM (w':irreds, frees, instToId w')
get_root irreds frees (Given id _) w = returnM (irreds, frees, id)
get_root irreds frees Irred w = cloneDict w `thenM` \ w' ->
returnM (w':irreds, frees, instToId w')
returnM (L span (VarBind x (mk_app span split_id rhs)),
[mk_fs_app span fst_id ty x, mk_fs_app span snd_id ty x])
returnM (L span (VarBind x (mk_app span split_id rhs)),
[mk_fs_app span fst_id ty x, mk_fs_app span snd_id ty x])