getDictClassTys, getIPs, isTyVarDict,
instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
Inst, LIE, pprInsts, pprInstsInFull,
- mkLIE, plusLIE, isEmptyLIE,
- lieToList
+ mkLIE, lieToList
)
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
-- Check for non-generalisable insts
mapTc_ addCantGenErr (filter (not . instCanBeGeneralised) irreds) `thenTc_`
- returnTc (qtvs, frees, binds, map instToId irreds)
+ returnTc (qtvs, mkLIE frees, binds, map instToId irreds)
inferLoop doc tau_tvs wanteds
= -- Step 1
-- Step 3
if no_improvement then
- returnTc (varSetElems qtvs, frees, binds, irreds)
+ returnTc (varSetElems qtvs, frees, binds, irreds)
else
- -- We start again with irreds, not wanteds
- -- Using an instance decl might have introduced a fresh type variable
- -- which might have been unified, so we'd get an infinite loop
- -- if we started again with wanteds! See example [LOOP]
- inferLoop doc tau_tvs irreds `thenTc` \ (qtvs1, frees1, binds1, irreds1) ->
- returnTc (qtvs1, frees1 `plusLIE` frees, binds `AndMonoBinds` binds1, irreds1)
+ -- If improvement did some unification, we go round again. There
+ -- are two subtleties:
+ -- a) We start again with irreds, not wanteds
+ -- Using an instance decl might have introduced a fresh type variable
+ -- which might have been unified, so we'd get an infinite loop
+ -- if we started again with wanteds! See example [LOOP]
+ --
+ -- b) It's also essential to re-process frees, because unification
+ -- might mean that a type variable that looked free isn't now.
+ --
+ -- Hence the (irreds ++ frees)
+
+ inferLoop doc tau_tvs (irreds ++ frees) `thenTc` \ (qtvs1, frees1, binds1, irreds1) ->
+ returnTc (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
\end{code}
Example [LOOP]
%************************************************************************
@tcSimplifyCheck@ is used when we know exactly the set of variables
-we are going to quantify over.
+we are going to quantify over. For example, a class or instance declaration.
\begin{code}
tcSimplifyCheck
complainCheck doc givens irreds `thenNF_Tc_`
-- Done
- returnTc (frees, binds)
+ returnTc (mkLIE frees, binds)
checkLoop doc qtvs givens wanteds
= -- Step 1
-- Step 3
if no_improvement then
- returnTc (frees, binds, irreds)
+ returnTc (frees, binds, irreds)
else
- checkLoop doc qtvs givens irreds `thenTc` \ (frees1, binds1, irreds1) ->
- returnTc (frees `plusLIE` frees1, binds `AndMonoBinds` binds1, irreds1)
+ checkLoop doc qtvs givens' (irreds ++ frees) `thenTc` \ (frees1, binds1, irreds1) ->
+ returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
complainCheck doc givens irreds
= mapNF_Tc zonkInst given_dicts `thenNF_Tc` \ givens' ->
@tcSimplifyInferCheck@ is used when we know the consraints we are to simplify
against, but we don't know the type variables over which we are going to quantify.
+This happens when we have a type signature for a mutually recursive
+group.
\begin{code}
tcSimplifyInferCheck
complainCheck doc givens irreds `thenNF_Tc_`
-- Done
- returnTc (qtvs, frees, binds)
+ returnTc (qtvs, mkLIE frees, binds)
inferCheckLoop doc tau_tvs givens wanteds
= -- Step 1
-- Step 3
if no_improvement then
- returnTc (varSetElems qtvs, frees, binds, irreds)
+ returnTc (varSetElems qtvs, frees, binds, irreds)
else
- inferCheckLoop doc tau_tvs givens wanteds `thenTc` \ (qtvs1, frees1, binds1, irreds1) ->
- returnTc (qtvs1, frees1 `plusLIE` frees, binds `AndMonoBinds` binds1, irreds1)
+ inferCheckLoop doc tau_tvs givens' (irreds ++ frees) `thenTc` \ (qtvs1, frees1, binds1, irreds1) ->
+ returnTc (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
\end{code}
-
%************************************************************************
%* *
\subsection{tcSimplifyToDicts}
= simpleReduceLoop doc try_me wanteds `thenTc` \ (frees, binds, irreds) ->
-- Since try_me doesn't look at types, we don't need to
-- do any zonking, so it's safe to call reduceContext directly
- ASSERT( isEmptyLIE frees )
+ ASSERT( null frees )
returnTc (irreds, binds)
where
-- The irreducible ones should be a subset of the implicit
-- parameters we provided
ASSERT( all here_ip irreds )
- returnTc (frees, binds)
+ returnTc (mkLIE frees, binds)
where
doc = text "tcSimplifyIPs" <+> ppr ip_names
| otherwise
= simpleReduceLoop doc try_me wanteds `thenTc` \ (frees, binds, irreds) ->
ASSERT( null irreds )
- returnTc (frees, binds)
+ returnTc (mkLIE frees, binds)
where
doc = text "bindInsts" <+> ppr local_ids
wanteds = lieToList init_lie
simpleReduceLoop :: SDoc
-> (Inst -> WhatToDo) -- What to do, *not* based on the quantified type variables
-> [Inst] -- Wanted
- -> TcM (LIE, -- Free
+ -> TcM ([Inst], -- Free
TcDictBinds,
[Inst]) -- Irreducible
if no_improvement then
returnTc (frees, binds, irreds)
else
- simpleReduceLoop doc try_me irreds `thenTc` \ (frees1, binds1, irreds1) ->
- returnTc (frees `plusLIE` frees1, binds `AndMonoBinds` binds1, irreds1)
+ simpleReduceLoop doc try_me (irreds ++ frees) `thenTc` \ (frees1, binds1, irreds1) ->
+ returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
\end{code}
-> [Inst] -- Given
-> [Inst] -- Wanted
-> NF_TcM (Bool, -- True <=> improve step did no unification
- LIE, -- Free
+ [Inst], -- Free
TcDictBinds, -- Dictionary bindings
[Inst]) -- Irreducible
let
(binds, irreds) = bindsAndIrreds avails wanteds
in
- returnTc (no_improvement, mkLIE frees, binds, irreds)
+ returnTc (no_improvement, frees, binds, irreds)
tcImprove avails
= tcGetInstEnv `thenTc` \ inst_env ->
tcSimplifyTop :: LIE -> TcM TcDictBinds
tcSimplifyTop wanted_lie
= simpleReduceLoop (text "tcSimplTop") try_me wanteds `thenTc` \ (frees, binds, irreds) ->
- ASSERT( isEmptyLIE frees )
+ ASSERT( null frees )
let
-- All the non-std ones are definite errors
unifyTauTy chosen_default_ty (mkTyVarTy tyvar) `thenTc_`
simpleReduceLoop (text "disambig" <+> ppr dicts)
try_me dicts `thenTc` \ (frees, binds, ambigs) ->
- WARN( not (isEmptyLIE frees && null ambigs), ppr frees $$ ppr ambigs )
+ WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs )
warnDefault dicts chosen_default_ty `thenTc_`
returnTc binds
projects / ghc-hetmet.git / blobdiff