Refactoring in TcSMonad

This patch is just refactoring: no change in
behaviour.

I removed the rather complicated
    checkConstraintsTcS
    checkTvConstraintsTcS

in favour of simpler functions
    emitImplicationTcS
    emitTvImplicationTcS
    pushLevelNoWorkList

The last of these is a little strange, but overall
it's much better I think.

3 files changed, 78 insertions, 89 deletions

diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 7bbaa1ec99..35900f0167 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -852,13 +852,16 @@ solveForAll ev tvs theta pred pend_sc
        ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs
        ; given_ev_vars <- mapM newEvVar (substTheta subst theta)
 
-       ; (w_id, ev_binds)
-             <- checkConstraintsTcS skol_info skol_tvs given_ev_vars $
+       ; (lvl, (w_id, wanteds))
+             <- pushLevelNoWorkList (ppr skol_info) $
                 do { wanted_ev <- newWantedEvVarNC loc $
                                   substTy subst pred
                    ; return ( ctEvEvId wanted_ev
                             , unitBag (mkNonCanonical wanted_ev)) }
 
+      ; ev_binds <- emitImplicationTcS lvl skol_info skol_tvs
+                                       given_ev_vars wanteds
+
       ; setWantedEvTerm dest $
         EvFun { et_tvs = skol_tvs, et_given = given_ev_vars
               , et_binds = ev_binds, et_body = w_id }
@@ -1118,8 +1121,9 @@ can_eq_nc_forall ev eq_rel s1 s2
 
             empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1)
 
-      ; all_co <- checkTvConstraintsTcS skol_info skol_tvs $
-                  go skol_tvs empty_subst2 bndrs2
+      ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $
+                                    go skol_tvs empty_subst2 bndrs2
+      ; emitTvImplicationTcS lvl skol_info skol_tvs wanteds
 
       ; setWantedEq orig_dest all_co
       ; stopWith ev "Deferred polytype equality" } }
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index d0e62d188a..83750c4d47 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -284,7 +284,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
                                         , sig_loc   = getLoc (hsSigType hs_ty) }
 
        ; (ev_binds, (tc_bind, _))
-               <- checkConstraints (TyConSkol ClassFlavour (getName clas)) tyvars [this_dict] $
+               <- checkConstraints skol_info tyvars [this_dict] $
                   tcPolyCheck no_prag_fn local_dm_sig
                               (L bind_loc lm_bind)
 
@@ -305,6 +305,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
 
   | otherwise = pprPanic "tcDefMeth" (ppr sel_id)
   where
+    skol_info = TyConSkol ClassFlavour (getName clas)
     sel_name = idName sel_id
     no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;
                                 -- they are all for meth_id
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 737ac7da8c..727419faeb 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -9,17 +9,17 @@ module TcSMonad (
     WorkList(..), isEmptyWorkList, emptyWorkList,
     extendWorkListNonEq, extendWorkListCt,
     extendWorkListCts, extendWorkListEq, extendWorkListFunEq,
-    appendWorkList, extendWorkListImplic,
+    appendWorkList,
     selectNextWorkItem,
     workListSize, workListWantedCount,
-    getWorkList, updWorkListTcS,
+    getWorkList, updWorkListTcS, pushLevelNoWorkList,
 
     -- The TcS monad
     TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,
     failTcS, warnTcS, addErrTcS,
     runTcSEqualities,
     nestTcS, nestImplicTcS, setEvBindsTcS,
-    checkConstraintsTcS, checkTvConstraintsTcS,
+    emitImplicationTcS, emitTvImplicationTcS,
 
     runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,
     matchGlobalInst, TcM.ClsInstResult(..),
@@ -319,8 +319,8 @@ extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList
 extendWorkListDeriveds evs wl
   = extendWorkListCts (map mkNonCanonical evs) wl
 
-extendWorkListImplic :: Bag Implication -> WorkList -> WorkList
-extendWorkListImplic implics wl = wl { wl_implics = implics `unionBags` wl_implics wl }
+extendWorkListImplic :: Implication -> WorkList -> WorkList
+extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl }
 
 extendWorkListCt :: Ct -> WorkList -> WorkList
 -- Agnostic
@@ -2905,85 +2905,48 @@ nestTcS (TcS thing_inside)
 
        ; return res }
 
-checkTvConstraintsTcS :: SkolemInfo
-                      -> [TcTyVar]        -- Skolems
-                      -> TcS (result, Cts)
-                      -> TcS result
--- Just like TcUnify.checkTvConstraints, but
---   - In the TcS monnad
---   - The thing-inside should not put things in the work-list
---     Instead, it returns the Wanted constraints it needs
---   - No 'givens', and no TcEvBinds; this is type-level constraints only
-checkTvConstraintsTcS skol_info skol_tvs (TcS thing_inside)
-  = TcS $ \ tcs_env ->
-    do { let wl_panic  = pprPanic "TcSMonad.buildImplication" $
-                         ppr skol_info $$ ppr skol_tvs
-                         -- This panic checks that the thing-inside
-                         -- does not emit any work-list constraints
-             new_tcs_env = tcs_env { tcs_worklist = wl_panic }
-
-       ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $
-                                        thing_inside new_tcs_env
-
-       ; unless (null wanteds) $
-         do { ev_binds_var <- TcM.newNoTcEvBinds
-            ; imp <- TcM.newImplication
-            ; let wc = emptyWC { wc_simple = wanteds }
-                  imp' = imp { ic_tclvl  = new_tclvl
-                             , ic_skols  = skol_tvs
-                             , ic_wanted = wc
-                             , ic_binds  = ev_binds_var
-                             , ic_info   = skol_info }
-
-           -- Add the implication to the work-list
-           ; TcM.updTcRef (tcs_worklist tcs_env)
-                          (extendWorkListImplic (unitBag imp')) }
-
-      ; return res }
-
-checkConstraintsTcS :: SkolemInfo
-                    -> [TcTyVar]        -- Skolems
-                    -> [EvVar]          -- Givens
-                    -> TcS (result, Cts)
-                    -> TcS (result, TcEvBinds)
--- Just like checkConstraintsTcS, but
---   - In the TcS monnad
---   - The thing-inside should not put things in the work-list
---     Instead, it returns the Wanted constraints it needs
---   - I did not bother to put in the fast-path for
---     empty-skols/empty-givens, or for empty-wanteds, because
---     this function is used only for "quantified constraints" in
---     with both tests are pretty much guaranteed to fail
-checkConstraintsTcS skol_info skol_tvs given (TcS thing_inside)
-  = TcS $ \ tcs_env ->
-    do { let wl_panic  = pprPanic "TcSMonad.buildImplication" $
-                         ppr skol_info $$ ppr skol_tvs
-                         -- This panic checks that the thing-inside
-                         -- does not emit any work-list constraints
-             new_tcs_env = tcs_env { tcs_worklist = wl_panic }
-
-       ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $
-                                        thing_inside new_tcs_env
-
-       ; ev_binds_var <- TcM.newTcEvBinds
-       ; imp <- TcM.newImplication
-       ; let wc = emptyWC { wc_simple = wanteds }
-             imp' = imp { ic_tclvl  = new_tclvl
-                        , ic_skols  = skol_tvs
-                        , ic_given  = given
-                        , ic_wanted = wc
-                        , ic_binds  = ev_binds_var
-                        , ic_info   = skol_info }
-
-           -- Add the implication to the work-list
-       ; TcM.updTcRef (tcs_worklist tcs_env)
-                      (extendWorkListImplic (unitBag imp'))
-
-       ; return (res, TcEvBinds ev_binds_var) }
-
-{-
-Note [Propagate the solved dictionaries]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+emitImplicationTcS :: TcLevel -> SkolemInfo
+                   -> [TcTyVar]        -- Skolems
+                   -> [EvVar]          -- Givens
+                   -> Cts              -- Wanteds
+                   -> TcS TcEvBinds
+-- Add an implication to the TcS monad work-list
+emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds
+  = do { let wc = emptyWC { wc_simple = wanteds }
+       ; imp <- wrapTcS $
+                do { ev_binds_var <- TcM.newTcEvBinds
+                   ; imp <- TcM.newImplication
+                   ; return (imp { ic_tclvl  = new_tclvl
+                                 , ic_skols  = skol_tvs
+                                 , ic_given  = givens
+                                 , ic_wanted = wc
+                                 , ic_binds  = ev_binds_var
+                                 , ic_info   = skol_info }) }
+
+       ; emitImplication imp
+       ; return (TcEvBinds (ic_binds imp)) }
+
+emitTvImplicationTcS :: TcLevel -> SkolemInfo
+                     -> [TcTyVar]        -- Skolems
+                     -> Cts              -- Wanteds
+                     -> TcS ()
+-- Just like emitImplicationTcS but no givens and no bindings
+emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds
+  = do { let wc = emptyWC { wc_simple = wanteds }
+       ; imp <- wrapTcS $
+                do { ev_binds_var <- TcM.newNoTcEvBinds
+                   ; imp <- TcM.newImplication
+                   ; return (imp { ic_tclvl  = new_tclvl
+                                 , ic_skols  = skol_tvs
+                                 , ic_wanted = wc
+                                 , ic_binds  = ev_binds_var
+                                 , ic_info   = skol_info }) }
+
+       ; emitImplication imp }
+
+
+{- Note [Propagate the solved dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It's really quite important that nestTcS does not discard the solved
 dictionaries from the thing_inside.
 Consider
@@ -3017,6 +2980,23 @@ getWorkListImplics
        ; wl_curr <- readTcRef wl_var
        ; return (wl_implics wl_curr) }
 
+pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a)
+-- Push the level and run thing_inside
+-- However, thing_inside should not generate any work items
+#if defined(DEBUG)
+pushLevelNoWorkList err_doc (TcS thing_inside)
+  = TcS (\env -> TcM.pushTcLevelM $
+                 thing_inside (env { tcs_worklist = wl_panic })
+        )
+  where
+    wl_panic  = pprPanic "TcSMonad.buildImplication" err_doc
+                         -- This panic checks that the thing-inside
+                         -- does not emit any work-list constraints
+#else
+pushLevelNoWorkList _ (TcS thing_inside)
+  = TcS (\env -> TcM.pushTcLevelM (thing_inside env))  -- Don't check
+#endif
+
 updWorkListTcS :: (WorkList -> WorkList) -> TcS ()
 updWorkListTcS f
   = do { wl_var <- getTcSWorkListRef
@@ -3035,6 +3015,10 @@ emitWork cts
   = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))
        ; updWorkListTcS (extendWorkListCts cts) }
 
+emitImplication :: Implication -> TcS ()
+emitImplication implic
+  = updWorkListTcS (extendWorkListImplic implic)
+
 newTcRef :: a -> TcS (TcRef a)
 newTcRef x = wrapTcS (TcM.newTcRef x)