Modest refactoring in TcCanonical (and TcSMonad)

2 files changed, 34 insertions, 32 deletions

diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 18bfe2b416..a966a39f4e 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -247,20 +247,15 @@ canClassNC d ev cls tys
     `andWhenContinue` emitSuperclasses
 
 canClass d ev cls tys
-  = do { -- sctx <- getTcSContext
-       ; (xis, cos) <- flattenMany d FMFullFlatten (ctEvFlavour ev) tys
+  = do { (xis, cos) <- flattenMany d FMFullFlatten (ctEvFlavour ev) tys
        ; let co = mkTcTyConAppCo (classTyCon cls) cos 
              xi = mkClassPred cls xis
-             
        ; mb <- rewriteCtFlavor ev xi co
-
        ; case mb of
-           Just new_ev -> 
-             let (ClassPred cls xis_for_dict) = classifyPredType (ctEvPred new_ev)
-             in continueWith $ 
-                CDictCan { cc_ev = new_ev, cc_loc = d
-                         , cc_tyargs = xis_for_dict, cc_class = cls }
-           Nothing -> return Stop }
+           Nothing -> return Stop
+           Just new_ev -> continueWith $ 
+                          CDictCan { cc_ev = new_ev, cc_loc = d
+                                   , cc_tyargs = xis, cc_class = cls } }
 
 emitSuperclasses :: Ct -> TcS StopOrContinue
 emitSuperclasses ct@(CDictCan { cc_loc = d, cc_ev = ev
@@ -567,24 +562,22 @@ flatten loc f ctxt (TyConApp tc tys)
                             			     , cc_tyargs = xi_args    
                             			     , cc_rhs    = rhs_ty
                             			     , cc_loc  = loc }
-                                ; updWorkListTcS $ extendWorkListEq ct
+                                ; updWorkListTcS $ extendWorkListFunEq ct
                                 ; return (co, rhs_ty) }
 
                          | otherwise -- Wanted or Derived: make new unification variable
                          -> do { traceTcS "flatten/flat-cache miss" $ empty 
                                ; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty)
-                               ; let pred = mkTcEqPred fam_ty rhs_xi_var
-                               ; mw <- newWantedEvVar pred
-                               ; case mw of
-                                   Fresh ctev -> 
-                                     do { let ct = CFunEqCan { cc_ev = ctev
-                                                             , cc_fun = tc
-                                                             , cc_tyargs = xi_args
-                                                             , cc_rhs    = rhs_xi_var 
-                                                             , cc_loc    = loc }
-                                        ; updWorkListTcS $ extendWorkListEq ct
-                                        ; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var) }
-                                   Cached {} -> panic "flatten TyConApp, var must be fresh!" } 
+                               ; ctev <- newWantedEvVarNC (mkTcEqPred fam_ty rhs_xi_var)
+                                   -- NC (no-cache) version because we've already
+                                   -- looked in the solved goals an inerts (lookupFlatEqn)
+                               ; let ct = CFunEqCan { cc_ev = ctev
+                                                    , cc_fun = tc
+                                                    , cc_tyargs = xi_args
+                                                    , cc_rhs    = rhs_xi_var 
+                                                    , cc_loc    = loc }
+                               ; updWorkListTcS $ extendWorkListFunEq ct
+                               ; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var) }
                     }
                   -- Emit the flat constraints
          ; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable
@@ -1149,7 +1142,7 @@ canEqLeafFunEq loc ev fn tys1 ty2  -- ev :: F tys1 ~ ty2
            Nothing -> return Stop ;
            Just new_ev 
              | isTcReflCo xco -> continueWith new_ct
-             | otherwise      -> do { updWorkListTcS (extendWorkListEq new_ct); return Stop }
+             | otherwise      -> do { updWorkListTcS (extendWorkListFunEq new_ct); return Stop }
              where
                new_ct = CFunEqCan { cc_ev = new_ev, cc_loc = loc
                                   , cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 } } } 
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 7324798257..43457f44f8 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -13,7 +13,8 @@ module TcSMonad (
 
     WorkList(..), isEmptyWorkList, emptyWorkList,
     workListFromEq, workListFromNonEq, workListFromCt, 
-    extendWorkListEq, extendWorkListNonEq, extendWorkListCt, 
+    extendWorkListEq, extendWorkListFunEq, 
+    extendWorkListNonEq, extendWorkListCt, 
     extendWorkListCts, extendWorkListEqs, appendWorkList, selectWorkItem,
     withWorkList,
 
@@ -46,7 +47,7 @@ module TcSMonad (
 
     xCtFlavor,        -- Transform a CtEvidence during a step 
     rewriteCtFlavor,  -- Specialized version of xCtFlavor for coercions
-    newWantedEvVar, instDFunConstraints,
+    newWantedEvVar, newWantedEvVarNC, instDFunConstraints,
     newDerived,
     
        -- Creation of evidence variables
@@ -237,10 +238,14 @@ extendWorkListEq :: Ct -> WorkList -> WorkList
 -- Extension by equality
 extendWorkListEq ct wl 
   | Just {} <- isCFunEqCan_Maybe ct
-  = wl { wl_funeqs = insertDeque ct (wl_funeqs wl) }
+  = extendWorkListFunEq ct wl
   | otherwise
   = wl { wl_eqs = ct : wl_eqs wl }
 
+extendWorkListFunEq :: Ct -> WorkList -> WorkList
+extendWorkListFunEq ct wl 
+  = wl { wl_funeqs = insertDeque ct (wl_funeqs wl) }
+
 extendWorkListEqs :: [Ct] -> WorkList -> WorkList
 -- Append a list of equalities
 extendWorkListEqs cts wl = foldr extendWorkListEq wl cts
@@ -1404,6 +1409,12 @@ newGivenEvVar pred rhs
        ; setEvBind new_ev rhs
        ; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev }) }
 
+newWantedEvVarNC :: TcPredType -> TcS CtEvidence
+-- Don't look up in the solved/inerts; we know it's not there
+newWantedEvVarNC pty
+  = do { new_ev <- wrapTcS $ TcM.newEvVar pty
+       ; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev })}
+
 newWantedEvVar :: TcPredType -> TcS MaybeNew
 newWantedEvVar pty
   = do { mb_ct <- lookupInInerts pty
@@ -1411,10 +1422,8 @@ newWantedEvVar pty
             Just ctev | not (isDerived ctev) 
                       -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev
                             ; return (Cached (ctEvTerm ctev)) }
-            _ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty
-                    ; traceTcS "newWantedEvVar/cache miss" $ ppr new_ev
-                    ; let ctev = CtWanted { ctev_pred = pty
-                                          , ctev_evar = new_ev }
+            _ -> do { ctev <- newWantedEvVarNC pty
+                    ; traceTcS "newWantedEvVar/cache miss" $ ppr ctev
                     ; return (Fresh ctev) } }
 
 newDerived :: TcPredType -> TcS (Maybe CtEvidence)
@@ -1471,7 +1480,7 @@ See Note [Coercion evidence terms] in TcEvidence.
 
 
 \begin{code}
-xCtFlavor :: CtEvidence              -- Original flavor   
+xCtFlavor :: CtEvidence            -- Original flavor   
           -> [TcPredType]          -- New predicate types
           -> XEvTerm               -- Instructions about how to manipulate evidence
           -> TcS [CtEvidence]