import Inst
import TcEnv
import InstEnv
-import TcGadt
import TcType
import TcMType
import TcIface
import UniqSet
import SrcLoc
import DynFlags
+import FastString
+import Control.Monad
import Data.List
\end{code}
-----------------------------------------------------------
-- tcSimplifyCheckPat is used for existential pattern match
tcSimplifyCheckPat :: InstLoc
- -> [CoVar]
-> [TcTyVar] -- Quantify over these
-> [Inst] -- Given
-> [Inst] -- Wanted
-> TcM TcDictBinds -- Bindings
-tcSimplifyCheckPat loc co_vars qtvs givens wanteds
+tcSimplifyCheckPat loc qtvs givens wanteds
= ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs )
do { traceTc (text "tcSimplifyCheckPat")
; (irreds, binds) <- gentleCheckLoop loc givens wanteds
- ; implic_bind <- bindIrredsR loc qtvs co_vars givens irreds
+ ; implic_bind <- bindIrredsR loc qtvs givens irreds
; return (binds `unionBags` implic_bind) }
-----------------------------------------------------------
-> [Inst] -> [Inst]
-> TcM TcDictBinds
bindIrreds loc qtvs givens irreds
- = bindIrredsR loc qtvs [] givens irreds
+ = bindIrredsR loc qtvs givens irreds
-bindIrredsR :: InstLoc -> [TcTyVar] -> [CoVar] -> [Inst] -> [Inst]
- -> TcM TcDictBinds
+bindIrredsR :: InstLoc -> [TcTyVar] -> [Inst] -> [Inst] -> TcM TcDictBinds
-- Make a binding that binds 'irreds', by generating an implication
-- constraint for them, *and* throwing the constraint into the LIE
-bindIrredsR loc qtvs co_vars givens irreds
+bindIrredsR loc qtvs givens irreds
| null irreds
= return emptyBag
| otherwise
; return real_irreds }
else return irreds
- ; let all_tvs = qtvs ++ co_vars -- Abstract over all these
- ; (implics, bind) <- makeImplicationBind loc all_tvs givens' irreds'
+ ; (implics, bind) <- makeImplicationBind loc qtvs givens' irreds'
-- This call does the real work
-- If irreds' is empty, it does something sensible
; extendLIEs implics
-- 'givens' must be a simple CoVar. This MUST be cleaned up.
; let name = mkInternalName uniq (mkVarOcc "ic") span
- implic_inst = ImplicInst { tci_name = name, tci_reft = emptyRefinement,
+ implic_inst = ImplicInst { tci_name = name,
tci_tyvars = all_tvs,
tci_given = (eq_givens ++ dict_givens),
tci_wanted = irreds, tci_loc = loc }
; let givens = red_givens env
(given_eqs0, given_dicts0) = partition isEqInst givens
(wanted_eqs0, wanted_non_eqs) = partition isEqInst wanteds
- (wanted_implics0, wanted_dicts0) = partition isImplicInst wanted_non_eqs
+ (wanted_implics0, wanted_dicts) = partition isImplicInst wanted_non_eqs
-- We want to add as wanted equalities those that (transitively)
-- occur in superclass contexts of wanted class constraints.
-- See Note [Ancestor Equalities]
- ; ancestor_eqs <- ancestorEqualities wanted_dicts0
+ ; ancestor_eqs <- ancestorEqualities wanted_dicts
; let wanted_eqs = wanted_eqs0 ++ ancestor_eqs
; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs
-- *** ToDo: what to do with the "extra_givens"? For the
-- moment I'm simply discarding them, which is probably wrong
- -- 7. Normalise the *wanted* *dictionary* constraints
- -- wrt. the toplevel and given equations
- -- NB: normalisation includes zonking as part of what it does
- -- so it's important to do it after any unifications
- -- that happened as a result of the addGivens
- ; (wanted_dicts,normalise_binds1) <- normaliseWantedDicts given_eqs wanted_dicts0
-
-- 6. Solve the *wanted* *dictionary* constraints (not implications)
-- This may expose some further equational constraints...
; (avails, extra_eqs) <- getLIE (reduceList env wanted_dicts init_state)
- ; (dict_binds, bound_dicts, dict_irreds) <- extractResults avails wanted_dicts
+ ; (dict_binds, bound_dicts, dict_irreds)
+ <- extractResults avails wanted_dicts
; traceTc $ text "reduceContext extractresults" <+> vcat
- [ppr avails,ppr wanted_dicts,ppr dict_binds]
-
- -- *** ToDo: what to do with the "extra_eqs"? For the
- -- moment I'm simply discarding them, which is probably wrong
+ [ppr avails, ppr wanted_dicts, ppr dict_binds]
-- Solve the wanted *implications*. In doing so, we can provide
-- as "given" all the dicts that were originally given,
-- *or* for which we now have bindings,
-- *or* which are now irreds
- ; let implic_env = env { red_givens = givens ++ bound_dicts ++ dict_irreds }
- ; (implic_binds_s, implic_irreds_s) <- mapAndUnzipM (reduceImplication implic_env) wanted_implics0
+ ; let implic_env = env { red_givens = givens ++ bound_dicts
+ ++ dict_irreds }
+ ; (implic_binds_s, implic_irreds_s)
+ <- mapAndUnzipM (reduceImplication implic_env) wanted_implics0
; let implic_binds = unionManyBags implic_binds_s
implic_irreds = concat implic_irreds_s
- -- 3. Solve the *wanted* *equation* constraints
- ; eq_irreds0 <- solveWantedEqs given_eqs wanted_eqs
-
- -- 4. Normalise the *wanted* equality constraints with respect to
- -- each other
- ; eq_irreds <- normaliseWantedEqs eq_irreds0
+ -- Normalise the wanted equality constraints
+ ; eq_irreds <- normaliseWantedEqs given_eqs (wanted_eqs ++ extra_eqs)
- -- 8. Substitute the wanted *equations* in the wanted *dictionaries*
+ -- Normalise the wanted dictionaries
; let irreds = dict_irreds ++ implic_irreds
- ; (norm_irreds, normalise_binds2) <- substEqInDictInsts True {-wanted-}
- eq_irreds irreds
+ eqs = eq_irreds ++ given_eqs
+ ; (norm_irreds, normalise_binds) <- normaliseWantedDicts eqs irreds
- -- 9. eliminate the artificial skolem constants introduced in 1.
--- ; eliminate_skolems
-
- -- Figure out whether we should go round again
- -- My current plan is to see if any of the mutable tyvars in
- -- givens or irreds has been filled in by improvement.
- -- If so, there is merit in going around again, because
- -- we may make further progress
+ -- Figure out whether we should go round again. We do so in either
+ -- two cases:
+ -- (1) If any of the mutable tyvars in givens or irreds has been
+ -- filled in by improvement, there is merit in going around
+ -- again, because we may make further progress.
+ -- (2) If we managed to normalise any dicts, there is merit in going
+ -- around gain, because reduceList may be able to get further.
--
- -- ToDo: is it only mutable stuff? We may have exposed new
+ -- ToDo: We may have exposed new
-- equality constraints and should probably go round again
-- then as well. But currently we are dropping them on the
-- floor anyway.
; let all_irreds = norm_irreds ++ eq_irreds
- ; improved <- anyM isFilledMetaTyVar $ varSetElems $
- tyVarsOfInsts (givens ++ all_irreds)
+ ; improvedMetaTy <- anyM isFilledMetaTyVar $ varSetElems $
+ tyVarsOfInsts (givens ++ all_irreds)
+ ; let improvedDicts = not $ isEmptyBag normalise_binds
+ improved = improvedMetaTy || improvedDicts
-- The old plan (fragile)
-- improveed = availsImproved avails
]))
; return (improved,
- given_binds `unionBags` normalise_binds1
- `unionBags` normalise_binds2
+ given_binds `unionBags` normalise_binds
`unionBags` dict_binds
`unionBags` implic_binds,
all_irreds,
reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state
= do { traceTc (text "reduceList " <+> (ppr wanteds $$ ppr state))
; dopts <- getDOpts
-#ifdef DEBUG
- ; if n > 8 then
+ ; when (debugIsOn && (n > 8)) $ do
dumpTcRn (hang (ptext SLIT("Interesting! Context reduction stack depth") <+> int n)
2 (ifPprDebug (nest 2 (pprStack stk))))
- else return ()
-#endif
; if n >= ctxtStkDepth dopts then
failWithTc (reduceDepthErr n stk)
else
--
reduceImplication env
orig_implic@(ImplicInst { tci_name = name, tci_loc = inst_loc,
- tci_tyvars = tvs, tci_reft = emptyRefinement,
+ tci_tyvars = tvs,
tci_given = extra_givens, tci_wanted = wanteds })
= do { -- Solve the sub-problem
; let try_me inst = ReduceMe AddSCs -- Note [Freeness and implications]
| not (isClassDict wanted) = Left wanted
| otherwise
= case lookupInstEnv inst_envs clas tys of
+ ([], _) -> Left wanted -- No match
-- The case of exactly one match and no unifiers means a
-- successful lookup. That can't happen here, because dicts
-- only end up here if they didn't match in Inst.lookupInst
-#ifdef DEBUG
- ([m],[]) -> pprPanic "reportNoInstance" (ppr wanted)
-#endif
- ([], _) -> Left wanted -- No match
- res -> Right (mk_overlap_msg wanted res)
+ ([m],[])
+ | debugIsOn -> pprPanic "reportNoInstance" (ppr wanted)
+ res -> Right (mk_overlap_msg wanted res)
where
(clas,tys) = getDictClassTys wanted
projects / ghc-hetmet.git / blobdiff