#include "HsVersions.h"
import {-# SOURCE #-} TcUnify( unifyType )
-import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
-import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp )
+import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, mkWpTyApps,
+ HsWrapper(..), (<.>), nlHsTyApp, emptyLHsBinds )
+import TcHsSyn ( mkHsApp )
import TcRnMonad
import Inst ( lookupInst, LookupInstResult(..),
- tyVarsOfInst, fdPredsOfInsts, newDicts,
+ tyVarsOfInst, fdPredsOfInsts,
isDict, isClassDict, isLinearInst, linearInstType,
isMethodFor, isMethod,
instToId, tyVarsOfInsts, cloneDict,
ipNamesOfInsts, ipNamesOfInst, dictPred,
- fdPredsOfInst,
- newDictsAtLoc, tcInstClassOp,
+ fdPredsOfInst,
+ newDictBndrs, newDictBndrsO, tcInstClassOp,
getDictClassTys, isTyVarDict, instLoc,
zonkInst, tidyInsts, tidyMoreInsts,
pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs,
= isFreeWrtTyVars qtvs inst
&& isFreeWrtIPs ips inst
-isFreeWrtTyVars qtvs inst = not (tyVarsOfInst inst `intersectsVarSet` qtvs)
+isFreeWrtTyVars qtvs inst = tyVarsOfInst inst `disjointVarSet` qtvs
isFreeWrtIPs ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
\end{code}
tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
-- Zonk everything in sight
= mappM zonkInst wanteds `thenM` \ wanteds' ->
- zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' ->
- tcGetGlobalTyVars `thenM` \ gbl_tvs' ->
-- '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
+ -- HOWEVER, some unification may take place, if we instantiate
+ -- a method Inst with an equality constraint
reduceContextWithoutImprovement
doc reduceMe wanteds' `thenM` \ (_frees, _binds, constrained_dicts) ->
-- Next, figure out the tyvars we will quantify over
+ zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' ->
+ tcGetGlobalTyVars `thenM` \ gbl_tvs' ->
+ mappM zonkInst constrained_dicts `thenM` \ constrained_dicts' ->
let
- 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'
in
traceTc (text "tcSimplifyRestricted" <+> vcat [
- pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts,
+ pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts',
ppr _binds,
- ppr constrained_tvs, ppr tau_tvs', ppr qtvs ]) `thenM_`
+ ppr constrained_tvs', ppr tau_tvs', ppr qtvs' ]) `thenM_`
-- 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.
--
- -- We quantify only over constraints that are captured by qtvs;
+ -- We quantify only over constraints that are captured by qtvs';
-- 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
-- expose implicit parameters to the test that follows
let
is_nested_group = isNotTopLevel top_lvl
- try_me inst | isFreeWrtTyVars qtvs inst,
+ try_me inst | isFreeWrtTyVars qtvs' inst,
(is_nested_group || isDict inst) = Free
| otherwise = ReduceMe AddSCs
in
-- See "Notes on implicit parameters, Question 4: top level"
if is_nested_group then
extendLIEs frees `thenM_`
- returnM (varSetElems qtvs, binds)
+ returnM (varSetElems qtvs', binds)
else
let
(non_ips, bad_ips) = partition isClassDict frees
in
addTopIPErrs bndrs bad_ips `thenM_`
extendLIEs non_ips `thenM_`
- returnM (varSetElems qtvs, binds)
+ returnM (varSetElems qtvs', binds)
\end{code}
new_binds = addBind binds w rhs
new_avails = addToFM avails w (LinRhss rhss)
+ -- get_root is just used for Linear
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])
-mk_fs_app span id ty var = L span (HsVar id) `mkHsTyApp` [ty,ty] `mkHsApp` (L span (HsVar var))
+mk_fs_app span id ty var = nlHsTyApp id [ty,ty] `mkHsApp` (L span (HsVar var))
mk_app span id rhs = L span (HsApp (L span (HsVar id)) rhs)
-- Invariant: the Inst is already in Avails.
addSCs is_loop avails dict
- = do { sc_dicts <- newDictsAtLoc (instLoc dict) sc_theta'
+ = do { sc_dicts <- newDictBndrs (instLoc dict) sc_theta'
; foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) }
where
(clas, tys) = getDictClassTys dict
| is_given sc_dict = return avails
| otherwise = addSCs is_loop avails' sc_dict
where
- sc_sel_rhs = mkHsDictApp (mkHsTyApp (L (instSpan dict) (HsVar sc_sel)) tys) [instToId dict]
+ sc_sel_rhs = L (instSpan dict) (HsWrap co_fn (HsVar sc_sel))
+ co_fn = WpApp (instToId dict) <.> mkWpTyApps tys
avails' = addToFM avails sc_dict (Rhs sc_sel_rhs [dict])
is_given :: Inst -> Bool
-- up with one of the non-tyvar classes
(default_gps, non_default_gps) = partition defaultable_group tv_groups
defaultable_group ds
- = not (bad_tyvars `intersectsVarSet` tyVarsOfInst (head ds))
+ = (bad_tyvars `disjointVarSet` tyVarsOfInst (head ds))
&& defaultable_classes (map get_clas ds)
defaultable_classes clss
| use_extended_defaulting = any isInteractiveClass clss
-- The main loop may do unification, and that may crash if
-- it doesn't see a TcTyVar, so we have to instantiate. Sigh
-- ToDo: what if two of them do get unified?
- newDicts DerivOrigin (substTheta tenv theta) `thenM` \ wanteds ->
+ newDictBndrsO DerivOrigin (substTheta tenv theta) `thenM` \ wanteds ->
simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
ASSERT( null frees ) -- reduceMe never returns Free
-> TcM ()
tcSimplifyDefault theta
- = newDicts DefaultOrigin theta `thenM` \ wanteds ->
+ = newDictBndrsO DefaultOrigin theta `thenM` \ wanteds ->
simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
ASSERT( null frees ) -- try_me never returns Free
addNoInstanceErrs Nothing [] irreds `thenM_`
warnDefault dicts default_ty
= doptM Opt_WarnTypeDefaults `thenM` \ warn_flag ->
- addInstCtxt (instLoc (head dicts)) (warnTc warn_flag warn_msg)
+ addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
where
-- Tidy them first
(_, tidy_dicts) = tidyInsts dicts
projects / ghc-hetmet.git / blobdiff