Significant refactoring of TcSimplify, in particular simplifyInfer and

simplifyTop, code beautification etc. Important things:

(a) New top-level defaulting plan, gotten rid of the SimplContext field.
    See Note [Top-level Defaulting Plan]

(b) Serious bug fix in the floatEqualities mechanism
    See Note [Extra TcS Untouchables],[Float Equalities out of Implications]

The changes are mostly confined in TcSimplify but there is a
simplification wave affecting other modules as well.

compiler/typecheck/Inst.lhs

@@ -516,15 +516,15 @@ hasEqualities :: [EvVar] -> Bool
 hasEqualities givens = any (has_eq . evVarPred) givens
   where
     has_eq = has_eq' . classifyPredType
-
+    
+    -- See Note [Float Equalities out of Implications] in TcSimplify
     has_eq' (EqPred {})          = True
-    has_eq' (IPPred {})          = False
+    has_eq' (IPPred {})          = False 
     has_eq' (ClassPred cls _tys) = any has_eq (classSCTheta cls)
     has_eq' (TuplePred ts)       = any has_eq ts
     has_eq' (IrredPred _)        = True -- Might have equalities in it after reduction?
 
 ---------------- Getting free tyvars -------------------------
-
 tyVarsOfCt :: Ct -> TcTyVarSet
 tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })    = extendVarSet (tyVarsOfType xi) tv
 tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)

compiler/typecheck/TcBinds.lhs

@@ -485,12 +485,14 @@ tcPolyInfer
   -> [LHsBind Name]
   -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
 tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list
-  = do { ((binds', mono_infos), wanted) 
+  = do { (((binds', mono_infos), untch), wanted)
              <- captureConstraints $
+                captureUntouchables $
                 tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list
 
        ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
-       ; (qtvs, givens, mr_bites, ev_binds) <- simplifyInfer closed mono name_taus wanted
+       ; (qtvs, givens, mr_bites, ev_binds) <- 
+                          simplifyInfer closed mono name_taus (untch,wanted)
 
        ; theta <- zonkTcThetaType (map evVarPred givens)
        ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos

compiler/typecheck/TcRnDriver.lhs

@@ -1483,13 +1483,14 @@ tcRnExpr hsc_env ictxt rdr_expr
         -- it might have a rank-2 type (e.g. :t runST)
     uniq <- newUnique ;
     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
-    ((_tc_expr, res_ty), lie)   <- captureConstraints (tcInferRho rn_expr) ;
+    (((_tc_expr, res_ty), untch), lie) <- captureConstraints $ 
+                                          captureUntouchables (tcInferRho rn_expr) ;
     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
                                       {-# SCC "simplifyInfer" #-}
                                       simplifyInfer True {- Free vars are closed -}
                                                     False {- No MR for now -}
                                                     [(fresh_it, res_ty)]
-                                                    lie  ;
+                                                    (untch,lie) ;
     _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
 
     let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;

compiler/typecheck/TcRnMonad.lhs

@@ -1018,12 +1018,17 @@ emitFlats :: Cts -> TcM ()
 emitFlats cts
   = do { lie_var <- getConstraintVar ;
          updTcRef lie_var (`addFlats` cts) }
-
+    
 emitImplication :: Implication -> TcM ()
 emitImplication ct
   = do { lie_var <- getConstraintVar ;
          updTcRef lie_var (`addImplics` unitBag ct) }
 
+emitWC :: WantedConstraints -> TcM ()
+emitWC wc
+  = do { emitFlats (keepWanted (wc_flat wc))
+       ; emitImplications (wc_impl wc) }
+
 emitImplications :: Bag Implication -> TcM ()
 emitImplications ct
   = do { lie_var <- getConstraintVar ;

compiler/typecheck/TcRnTypes.lhs

@@ -51,7 +51,7 @@ module TcRnTypes(
         Untouchables(..), inTouchableRange, isNoUntouchables,
 
        -- Canonical constraints
-        Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, 
+        Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, keepWanted,
         singleCt, extendCts, isEmptyCts, isCTyEqCan, isCFunEqCan,
         isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe,
         isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, 
@@ -917,6 +917,13 @@ ctEvidence = cc_ev
 
 ctPred :: Ct -> PredType 
 ctPred ct = ctEvPred (cc_ev ct)
+
+keepWanted :: Cts -> Cts
+keepWanted = filterBag isWantedCt
+    -- DV: there used to be a note here that read: 
+    -- ``Important: use fold*r*Bag to preserve the order of the evidence variables'' 
+    -- DV: Is this still relevant? 
+
 -- ToDo Check with Dimitrios
 {-
 ctPred (CNonCanonical { cc_ev = fl }) = ctEvPred fl

compiler/typecheck/TcSMonad.lhs

@@ -16,7 +16,7 @@ module TcSMonad (
     extendWorkListEq, extendWorkListNonEq, extendWorkListCt, 
     appendWorkListCt, appendWorkListEqs, unionWorkList, selectWorkItem,
 
-    getTcSWorkList, updWorkListTcS, updWorkListTcS_return, keepWanted,
+    getTcSWorkList, updWorkListTcS, updWorkListTcS_return,
     getTcSWorkListTvs, 
     
     getTcSImplics, updTcSImplics, emitTcSImplication, 
@@ -27,18 +27,16 @@ module TcSMonad (
     isWanted, isDerived, 
     isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising,
 
-    isFlexiTcsTv,
+    isFlexiTcsTv, instFlexiTcSHelperTcS,
 
     canRewrite, canSolve,
     mkGivenLoc, ctWantedLoc,
 
-    TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality 
+    TcS, runTcS, runTcSWithEvBinds, failTcS, panicTcS, traceTcS, -- Basic functionality 
     traceFireTcS, bumpStepCountTcS, doWithInert,
     tryTcS, nestImplicTcS, recoverTcS,
     wrapErrTcS, wrapWarnTcS,
 
-    SimplContext(..), isInteractive, performDefaulting,
-
     -- Getting and setting the flattening cache
     getFlatCache, updFlatCache, addToSolved, addSolvedFunEq,
     
@@ -50,7 +48,7 @@ module TcSMonad (
 
     xCtFlavor, -- Transform a CtEvidence during a step 
     rewriteCtFlavor,          -- Specialized version of xCtFlavor for coercions
-    newWantedEvVar, instDFunConstraints, newKindConstraint,
+    newWantedEvVar, instDFunConstraints,
     newDerived,
     xCtFlavor_cache, rewriteCtFlavor_cache,
     
@@ -59,7 +57,7 @@ module TcSMonad (
 
     getInstEnvs, getFamInstEnvs,                -- Getting the environments
     getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
-    getTcEvBindsMap, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
+    getTcEvBindsMap, getTcSTyBinds, getTcSTyBindsMap,
 
 
     newFlattenSkolemTy,                         -- Flatten skolems 
@@ -276,11 +274,6 @@ instance Outputable WorkList where
                 , text "WorkList (rest)  = " <+> ppr (wl_rest wl)
                 ]
 
-keepWanted :: Cts -> Cts
-keepWanted = filterBag isWantedCt
-    -- DV: there used to be a note here that read: 
-    -- ``Important: use fold*r*Bag to preserve the order of the evidence variables'' 
-    -- DV: Is this still relevant? 
 
 -- Canonical constraint maps
 data CCanMap a = CCanMap { cts_given   :: UniqFM Cts
@@ -830,8 +823,6 @@ data TcSEnv
       
       tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
           -- Global type bindings
-
-      tcs_context :: SimplContext,
                      
       tcs_untch :: TcsUntouchables,
 
@@ -853,24 +844,6 @@ type TcsUntouchables = (Untouchables,TcTyVarSet)
 \end{code}
 
 \begin{code}
-data SimplContext
-  = SimplInfer SDoc	   -- Inferring type of a let-bound thing
-  | SimplInteractive	   -- Inferring type at GHCi prompt
-  | SimplCheck SDoc	   -- Checking a type signature or RULE rhs
-
-instance Outputable SimplContext where
-  ppr (SimplInfer d)   = ptext (sLit "SimplInfer") <+> d
-  ppr (SimplCheck d)   = ptext (sLit "SimplCheck") <+> d
-  ppr SimplInteractive = ptext (sLit "SimplInteractive")
-
-isInteractive :: SimplContext -> Bool
-isInteractive SimplInteractive = True
-isInteractive _                = False
-
-performDefaulting :: SimplContext -> Bool
-performDefaulting (SimplInfer {})   = False
-performDefaulting SimplInteractive  = True
-performDefaulting (SimplCheck {})   = True
 
 ---------------
 newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } 
@@ -924,15 +897,11 @@ traceFireTcS depth doc
                 <> brackets (int depth) <+> doc
        ; TcM.dumpTcRn msg }
 
-runTcS :: SimplContext
-       -> Untouchables 	       -- Untouchables
-       -> InertSet             -- Initial inert set
-       -> WorkList             -- Initial work list
-       -> TcS a		       -- What to run
-       -> TcM (a, Bag EvBind)
-runTcS context untouch is wl tcs 
+runTcSWithEvBinds :: EvBindsVar
+                  -> TcS a 
+                  -> TcM a
+runTcSWithEvBinds ev_binds_var tcs
   = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
-       ; ev_binds_var <- TcM.newTcEvBinds
        ; impl_var <- TcM.newTcRef emptyBag
        ; step_count <- TcM.newTcRef 0
 
@@ -941,7 +910,6 @@ runTcS context untouch is wl tcs
 
        ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
                           , tcs_ty_binds = ty_binds_var
-                          , tcs_context  = context
                           , tcs_untch    = (untouch, emptyVarSet) -- No Tcs untouchables yet
 			  , tcs_count    = step_count
 			  , tcs_ic_depth = 0
@@ -955,18 +923,27 @@ runTcS context untouch is wl tcs
        ; ty_binds <- TcM.readTcRef ty_binds_var
        ; mapM_ do_unification (varEnvElts ty_binds)
 
-       ; when debugIsOn $ do {
-             count <- TcM.readTcRef step_count
-           ; when (opt_PprStyle_Debug && count > 0) $
-             TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") 
-                                <+> int count <+> ppr context)
-         }
+       ; when debugIsOn $ 
+         do { count <- TcM.readTcRef step_count
+            ; when (opt_PprStyle_Debug && count > 0) $
+              TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count ) }
              -- And return
        ; ev_binds <- TcM.getTcEvBinds ev_binds_var
        ; checkForCyclicBinds ev_binds
-       ; return (res, ev_binds) }
+       ; return res }
   where
     do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
+    untouch = NoUntouchables
+    is = emptyInert
+    wl = emptyWorkList
+    
+runTcS :: TcS a		       -- What to run
+       -> TcM (a, Bag EvBind)
+runTcS tcs
+  = do { ev_binds_var <- TcM.newTcEvBinds
+       ; res <- runTcSWithEvBinds ev_binds_var tcs
+       ; ev_binds <- TcM.getTcEvBinds ev_binds_var
+       ; return (res, ev_binds) }
 
 checkForCyclicBinds :: Bag EvBind -> TcM ()
 #ifndef DEBUG
@@ -1001,7 +978,6 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
                    , tcs_untch = (_outer_range, outer_tcs)
                    , tcs_count = count
                    , tcs_ic_depth = idepth
-                   , tcs_context = ctxt
                    , tcs_inerts = inert_var
                    , tcs_worklist = wl_var 
                    , tcs_implics = _impl_var } -> 
@@ -1024,14 +1000,19 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
                                , tcs_untch       = inner_untch
                                , tcs_count       = count
                                , tcs_ic_depth    = idepth+1
-                               , tcs_context     = ctxt 
                                , tcs_inerts      = new_inert_var
                                , tcs_worklist    = wl_var 
                                -- NB: worklist is going to be empty anyway, 
                                -- so reuse the same ref cell
                                , tcs_implics     = new_implics_var
                                }
-       ; thing_inside nest_env } 
+       ; res <- thing_inside nest_env 
+                
+       -- Perform a check that the thing_inside did not cause cycles
+       ; ev_binds <- TcM.getTcEvBinds ref
+       ; checkForCyclicBinds ev_binds
+         
+       ; return res }
 
 recoverTcS :: TcS a -> TcS a -> TcS a
 recoverTcS (TcS recovery_code) (TcS thing_inside)
@@ -1127,8 +1108,6 @@ emitFrozenError fl depth
 instance HasDynFlags TcS where
     getDynFlags = wrapTcS getDynFlags
 
-getTcSContext :: TcS SimplContext
-getTcSContext = TcS (return . tcs_context)
 
 getTcEvBinds :: TcS EvBindsVar
 getTcEvBinds = TcS (return . tcs_ev_binds) 
@@ -1232,11 +1211,8 @@ warnTcS loc warn_if doc
   | warn_if   = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc
   | otherwise = return ()
 
-getDefaultInfo ::  TcS (SimplContext, [Type], (Bool, Bool))
-getDefaultInfo 
-  = do { ctxt <- getTcSContext
-       ; (tys, flags) <- wrapTcS TcM.tcGetDefaultTys
-       ; return (ctxt, tys, flags) }
+getDefaultInfo ::  TcS ([Type], (Bool, Bool))
+getDefaultInfo = wrapTcS TcM.tcGetDefaultTys
 
 -- Just get some environments needed for instance looking up and matching
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1279,7 +1255,7 @@ isTouchableMetaTyVar_InRange (untch,untch_tcs) tv
     case tcTyVarDetails tv of 
       MetaTv TcsTv _ -> not (tv `elemVarSet` untch_tcs)
                         -- See Note [Touchable meta type variables] 
-      MetaTv {}      -> inTouchableRange untch tv 
+      MetaTv {}      -> inTouchableRange untch tv && not (tv `elemVarSet` untch_tcs)
       _              -> False 
 
 
@@ -1369,6 +1345,8 @@ instFlexiTcSHelper tvname tvkind
              kind = tvkind 
        ; return (mkTyVarTy (mkTcTyVar name kind (MetaTv TcsTv ref))) }
 
+instFlexiTcSHelperTcS :: Name -> Kind -> TcS TcType
+instFlexiTcSHelperTcS n k = wrapTcS (instFlexiTcSHelper n k)
 
 -- Creating and setting evidence variables and CtFlavors
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1435,12 +1413,6 @@ newDerived loc pty
             Just {} -> return Nothing
             _       -> return (Just Derived { ctev_wloc = loc
                                             , ctev_pred = pty }) }
-    
-newKindConstraint :: WantedLoc -> TcTyVar -> Kind -> TcS MaybeNew
--- Create new wanted CoVar that constrains the type to have the specified kind. 
-newKindConstraint loc tv knd
-  = do { ty_k <- wrapTcS (instFlexiTcSHelper (tyVarName tv) knd)
-       ; newWantedEvVar loc (mkTcEqPred (mkTyVarTy tv) ty_k) }
 
 instDFunConstraints :: WantedLoc -> TcThetaType -> TcS [MaybeNew]
 instDFunConstraints wl = mapM (newWantedEvVar wl)
@@ -1593,29 +1565,27 @@ matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Maybe TcType]))
 matchClass clas tys
   = do	{ let pred = mkClassPred clas tys 
         ; instEnvs <- getInstEnvs
---        ; traceTcS "matchClass" $ empty -- text "instEnvs=" <+> ppr instEnvs
         ; case lookupInstEnv instEnvs clas tys of {
-            ([], unifs, _)               -- Nothing matches  
-                -> do { traceTcS "matchClass not matching"
-                                 (vcat [ text "dict" <+> ppr pred, 
-                                         text "unifs" <+> ppr unifs,
-                                         ppr instEnvs ]) 
+            ([], _unifs, _)               -- Nothing matches  
+                -> do { traceTcS "matchClass not matching" $ 
+                        vcat [ text "dict" <+> ppr pred
+                             , ppr instEnvs ]
+                        
                       ; return MatchInstNo  
                       } ;  
 	    ([(ispec, inst_tys)], [], _) -- A single match 
 		-> do	{ let dfun_id = is_dfun ispec
-			; traceTcS "matchClass success"
-				   (vcat [text "dict" <+> ppr pred, 
-				          text "witness" <+> ppr dfun_id
-                                           <+> ppr (idType dfun_id) ])
+			; traceTcS "matchClass success" $
+                          vcat [text "dict" <+> ppr pred, 
+                                text "witness" <+> ppr dfun_id
+                                               <+> ppr (idType dfun_id) ]
 				  -- Record that this dfun is needed
                         ; return $ MatchInstSingle (dfun_id, inst_tys)
                         } ;
-     	    (matches, unifs, _)          -- More than one matches 
-		-> do	{ traceTcS "matchClass multiple matches, deferring choice"
-			           (vcat [text "dict" <+> ppr pred,
-				   	  text "matches" <+> ppr matches,
-				   	  text "unifs" <+> ppr unifs])
+     	    (matches, _unifs, _)          -- More than one matches 
+		-> do	{ traceTcS "matchClass multiple matches, deferring choice" $
+                          vcat [text "dict" <+> ppr pred,
+                                text "matches" <+> ppr matches]
                         ; return MatchInstMany 
 		        }
 	}