import FiniteMap
import Outputable
import ListSetOps ( equivClasses )
-import Util ( zipEqual )
+import Util ( zipEqual, isSingleton )
import List ( partition )
import CmdLineOpts
\end{code}
| isClassDict inst = DontReduceUnlessConstant -- Dicts
| otherwise = ReduceMe -- Lits and Methods
in
+ traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_`
-- Step 2
reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
= -- Step 1
mappM zonkInst givens `thenM` \ givens' ->
mappM zonkInst wanteds `thenM` \ wanteds' ->
- get_qtvs `thenM` \ qtvs' ->
+ get_qtvs `thenM` \ qtvs' ->
-- Step 2
let
-- foo = f (3::Int)
-- We want to infer the polymorphic type
-- foo :: forall b. b -> b
- let
- try_me inst = ReduceMe -- Reduce as far as we can. Don't stop at
- -- dicts; the idea is to get rid of as many type
- -- variables as possible, and we don't want to stop
- -- at (say) Monad (ST s), because that reduces
- -- immediately, with no constraint on s.
- in
- simpleReduceLoop doc try_me wanteds `thenM` \ (_, _, constrained_dicts) ->
+
+ -- 'reduceMe': Reduce as far as we can. Don't stop at
+ -- dicts; the idea is to get rid of as many type
+ -- variables as possible, and we don't want to stop
+ -- at (say) Monad (ST s), because that reduces
+ -- immediately, with no constraint on s.
+ simpleReduceLoop doc reduceMe wanteds `thenM` \ (foo_frees, foo_binds, constrained_dicts) ->
-- Next, figure out the tyvars we will quantify over
zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' ->
qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs)
`minusVarSet` constrained_tvs
in
+ traceTc (text "tcSimplifyRestricted" <+> vcat [
+ pprInsts wanteds, pprInsts foo_frees, pprInsts constrained_dicts,
+ ppr foo_binds,
+ ppr constrained_tvs, ppr tau_tvs', ppr qtvs ]) `thenM_`
-- The first step may have squashed more methods than
-- necessary, so try again, this time knowing the exact
-- Remember that we may need to do *some* simplification, to
-- (for example) squash {Monad (ST s)} into {}. It's not enough
-- just to float all constraints
- mappM zonkInst wanteds `thenM` \ wanteds' ->
+ restrict_loop doc qtvs wanteds
+ -- We still need a loop because improvement can take place
+ -- E.g. if we have (C (T a)) and the instance decl
+ -- instance D Int b => C (T a) where ...
+ -- and there's a functional dependency for D. Then we may improve
+ -- the tyep variable 'b'.
+
+restrict_loop doc qtvs wanteds
+ = mappM zonkInst wanteds `thenM` \ wanteds' ->
+ zonkTcTyVarsAndFV (varSetElems qtvs) `thenM` \ qtvs' ->
let
- try_me inst | isFreeWrtTyVars qtvs inst = Free
- | otherwise = ReduceMe
+ try_me inst | isFreeWrtTyVars qtvs' inst = Free
+ | otherwise = ReduceMe
in
reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
- ASSERT( no_improvement )
- ASSERT( null irreds )
- -- No need to loop because simpleReduceLoop will have
- -- already done any improvement necessary
-
- extendLIEs frees `thenM_`
- returnM (varSetElems qtvs, binds)
+ if no_improvement then
+ ASSERT( null irreds )
+ extendLIEs frees `thenM_`
+ returnM (varSetElems qtvs', binds)
+ else
+ restrict_loop doc qtvs' (irreds ++ frees) `thenM` \ (qtvs1, binds1) ->
+ returnM (qtvs1, binds `AndMonoBinds` binds1)
\end{code}
\begin{code}
tcSimplifyBracket :: [Inst] -> TcM ()
tcSimplifyBracket wanteds
- = simpleReduceLoop doc try_me wanteds `thenM_`
+ = simpleReduceLoop doc reduceMe wanteds `thenM_`
returnM ()
-
where
- doc = text "tcSimplifyBracket"
- try_me inst = ReduceMe
+ doc = text "tcSimplifyBracket"
\end{code}
\begin{code}
tcSimplifyTop :: [Inst] -> TcM TcDictBinds
+-- The TcLclEnv should be valid here, solely to improve
+-- error message generation for the monomorphism restriction
tcSimplifyTop wanteds
= getLclEnv `thenM` \ lcl_env ->
traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env)) `thenM_`
where
dicts = map fst pairs
msg = sep [text "Ambiguous type variable" <> plural tvs <+>
- pprQuotedList tvs <+> text "in these top-level constraint" <> plural dicts,
+ pprQuotedList tvs <+> in_msg,
nest 2 (pprInstsInFull dicts)]
+ in_msg | isSingleton dicts = text "in the top-level constraint:"
+ | otherwise = text "in these top-level constraints:"
mkMonomorphismMsg :: TidyEnv -> [Inst] -> TcM (TidyEnv, Message)