Wibbles to fe6ddf00, fixing infelicities
authorSimon Peyton Jones <simonpj@microsoft.com>
Sat, 1 Sep 2012 19:53:53 +0000 (20:53 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Sat, 1 Sep 2012 19:53:53 +0000 (20:53 +0100)
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcSMonad.lhs
compiler/typecheck/TcSimplify.lhs
compiler/typecheck/TcUnify.lhs

index 3038ce2..ed7b6fc 100644 (file)
@@ -515,7 +515,8 @@ thLevel (Brack s _ _) = thLevel s + 1
 -- Arrow-notation context
 ---------------------------
 
-{-
+{- Note [Escaping the arrow scope]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In arrow notation, a variable bound by a proc (or enclosed let/kappa)
 is not in scope to the left of an arrow tail (-<) or the head of (|..|).
 For example
@@ -532,6 +533,9 @@ Here, x and z are in scope in e1, but y is not.  We implement this by
 recording the environment when passing a proc (using newArrowScope),
 and returning to that (using escapeArrowScope) on the left of -< and the
 head of (|..|).
+
+All this can be dealt with by the *renamer*; by the time we get to 
+the *type checker* we have sorted out the scopes
 -}
 
 data ArrowCtxt
index b77e0cb..bc386f1 100644 (file)
@@ -19,7 +19,7 @@ module TcSMonad (
 
     updWorkListTcS, updWorkListTcS_return,
     
-    getTcSImplics, updTcSImplics, emitTcSImplication
+    updTcSImplics
 
     Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, 
     emitFrozenError,
@@ -32,7 +32,7 @@ module TcSMonad (
 
     TcS, runTcS, runTcSWithEvBinds, failTcS, panicTcS, traceTcS, -- Basic functionality 
     traceFireTcS, bumpStepCountTcS, 
-    tryTcS, nestImplicTcS, recoverTcS,
+    tryTcS, nestTcS, nestImplicTcS, recoverTcS,
     wrapErrTcS, wrapWarnTcS,
 
     -- Getting and setting the flattening cache
@@ -895,7 +895,6 @@ data TcSEnv
       tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
           -- Global type bindings
                      
-      tcs_ic_depth   :: Int,       -- Implication nesting depth
       tcs_count      :: IORef Int, -- Global step count
 
       tcs_inerts   :: IORef InertSet, -- Current inert set
@@ -961,9 +960,7 @@ traceFireTcS depth doc
   = TcS $ \env -> 
     TcM.ifDOptM Opt_D_dump_cs_trace $ 
     do { n <- TcM.readTcRef (tcs_count env)
-       ; let msg = int n 
-                <> text (replicate (tcs_ic_depth env) '>')
-                <> brackets (int depth) <+> doc
+       ; let msg = int n <> brackets (int depth) <+> doc
        ; TcM.dumpTcRn msg }
 
 runTcS :: TcS a                       -- What to run
@@ -985,7 +982,6 @@ runTcSWithEvBinds ev_binds_var tcs
        ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
                           , tcs_ty_binds = ty_binds_var
                          , tcs_count    = step_count
-                         , tcs_ic_depth = 0
                           , tcs_inerts   = inert_var
                           , tcs_worklist    = panic "runTcS: worklist"
                           , tcs_implics     = panic "runTcS: implics" }
@@ -1034,13 +1030,11 @@ checkForCyclicBinds ev_binds
 nestImplicTcS :: EvBindsVar -> Untouchables -> InertSet -> TcS a -> TcS a 
 nestImplicTcS ref inner_untch inerts (TcS thing_inside) 
   = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds
-                   , tcs_count = count
-                   , tcs_ic_depth = idepth } -> 
+                   , tcs_count = count } -> 
     do { new_inert_var <- TcM.newTcRef inerts
        ; let nest_env = TcSEnv { tcs_ev_binds    = ref
                                , tcs_ty_binds    = ty_binds
                                , tcs_count       = count
-                               , tcs_ic_depth    = idepth+1
                                , tcs_inerts      = new_inert_var
                                , tcs_worklist    = panic "nextImplicTcS: worklist"
                                , tcs_implics     = panic "nextImplicTcS: implics"
@@ -1062,23 +1056,35 @@ recoverTcS (TcS recovery_code) (TcS thing_inside)
   = TcS $ \ env ->
     TcM.recoverM (recovery_code env) (thing_inside env)
 
+nestTcS ::  TcS a -> TcS a 
+-- Use the current untouchables, augmenting the current
+-- evidence bindings, ty_binds, and solved caches
+-- But have no effect on the InertCans or insolubles
+nestTcS (TcS thing_inside) 
+  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->
+    do { inerts <- TcM.readTcRef inerts_var
+       ; new_inert_var <- TcM.newTcRef inerts
+       ; let nest_env = env { tcs_inerts   = new_inert_var
+                            , tcs_worklist = panic "nextImplicTcS: worklist"
+                            , tcs_implics  = panic "nextImplicTcS: implics" }
+       ; thing_inside nest_env }
+
 tryTcS :: TcS a -> TcS a
 -- Like runTcS, but from within the TcS monad 
 -- Completely afresh inerts and worklist, be careful! 
 -- Moreover, we will simply throw away all the evidence generated. 
-tryTcS tcs
-  = TcS (\env -> 
-             do { wl_var <- TcM.newTcRef emptyWorkList
-                ; is_var <- TcM.newTcRef emptyInert
-
-                ; ty_binds_var <- TcM.newTcRef emptyVarEnv
-                ; ev_binds_var <- TcM.newTcEvBinds
+tryTcS (TcS thing_inside)
+  = TcS $ \env -> 
+    do { is_var <- TcM.newTcRef emptyInert
+       ; ty_binds_var <- TcM.newTcRef emptyVarEnv
+       ; ev_binds_var <- TcM.newTcEvBinds
 
-                ; let env1 = env { tcs_ev_binds = ev_binds_var
-                                 , tcs_ty_binds = ty_binds_var
-                                 , tcs_inerts   = is_var
-                                 , tcs_worklist = wl_var } 
-                ; unTcS tcs env1 })
+       ; let nest_env = env { tcs_ev_binds = ev_binds_var
+                            , tcs_ty_binds = ty_binds_var
+                            , tcs_inerts   = is_var
+                            , tcs_worklist = panic "nextImplicTcS: worklist"
+                            , tcs_implics  = panic "nextImplicTcS: implics" }
+       ; thing_inside nest_env }
 
 -- Getters and setters of TcEnv fields
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1092,13 +1098,6 @@ getTcSWorkListRef = TcS (return . tcs_worklist)
 getTcSInerts :: TcS InertSet 
 getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef) 
 
-
-getTcSImplicsRef :: TcS (IORef (Bag Implication))
-getTcSImplicsRef = TcS (return . tcs_implics) 
-
-getTcSImplics :: TcS (Bag Implication)
-getTcSImplics = getTcSImplicsRef >>= wrapTcS . (TcM.readTcRef)
-
 updWorkListTcS :: (WorkList -> WorkList) -> TcS () 
 updWorkListTcS f 
   = do { wl_var <- getTcSWorkListRef
@@ -1136,13 +1135,8 @@ withWorkList work_items (TcS thing_inside)
 updTcSImplics :: (Bag Implication -> Bag Implication) -> TcS ()
 updTcSImplics f 
  = do { impl_ref <- getTcSImplicsRef
-      ; implics <- wrapTcS (TcM.readTcRef impl_ref)
-      ; let new_implics = f implics
-      ; wrapTcS (TcM.writeTcRef impl_ref new_implics) }
-
-emitTcSImplication :: Implication -> TcS ()
-emitTcSImplication imp = updTcSImplics (consBag imp)
-
+      ; wrapTcS $ do { implics <- TcM.readTcRef impl_ref
+                     ; TcM.writeTcRef impl_ref (f implics) } }
 
 emitFrozenError :: CtEvidence -> SubGoalDepth -> TcS ()
 -- Emits a non-canonical constraint that will stand for a frozen error in the inerts. 
@@ -1160,6 +1154,9 @@ emitFrozenError fl depth
     insol_ct = CNonCanonical { cc_ev = fl, cc_depth = depth } 
     this_pred = ctEvPred fl
 
+getTcSImplicsRef :: TcS (IORef (Bag Implication))
+getTcSImplicsRef = TcS (return . tcs_implics) 
+
 getTcEvBinds :: TcS EvBindsVar
 getTcEvBinds = TcS (return . tcs_ev_binds) 
 
@@ -1192,6 +1189,7 @@ setWantedTyBind tv ty
                   vcat [ text "TERRIBLE ERROR: double set of meta type variable"
                        , ppr tv <+> text ":=" <+> ppr ty
                        , text "Old value =" <+> ppr (lookupVarEnv_NF ty_binds tv)]
+            ; TcM.traceTc "setWantedTyBind" (ppr tv <+> text ":=" <+> ppr ty)
             ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } }
 \end{code}
 
index 5c5bb09..2075f69 100644 (file)
@@ -63,46 +63,38 @@ simplifyTop :: WantedConstraints -> TcM (Bag EvBind)
 -- but when there is nothing to quantify we don't wrap
 -- in a degenerate implication, so we do that here instead
 simplifyTop wanteds 
-  = do { ev_binds_var <- newTcEvBinds
-                         
-       ; zonked_wanteds <- zonkWC wanteds
+  = do { zonked_wanteds <- zonkWC wanteds
 
        ; traceTc "simplifyTop {" $ text "zonked_wc =" <+> ppr zonked_wanteds
+       ; (final_wc, binds1) <- runTcS (simpl_top zonked_wanteds)
+       ; traceTc "End simplifyTop }" empty
+
+       ; traceTc "reportUnsolved {" empty
+                 -- See Note [Deferring coercion errors to runtime]
+       ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors
+       ; binds2 <- reportUnsolved runtimeCoercionErrors final_wc
+       ; traceTc "reportUnsolved }" empty
+       ; return (binds1 `unionBags` binds2) }
 
-       ; wc_first_go <- solveWantedsWithEvBinds ev_binds_var zonked_wanteds
-       ; cts <- applyTyVarDefaulting wc_first_go 
-                -- See Note [Top-level Defaulting Plan]
-                
-       ; let wc_for_loop = wc_first_go { wc_flat = wc_flat wc_first_go `unionBags` cts }
-                           
-       ; traceTc "simpl_top_loop" $ text "wc_for_loop =" <+> ppr wc_for_loop
-       ; simpl_top_loop ev_binds_var wc_for_loop }
+  where
+    -- See Note [Top-level Defaulting Plan]
+    simpl_top wanteds
+      = do { wc_first_go <- solveWantedsTcS wanteds
+           ; applyTyVarDefaulting wc_first_go 
+           ; simpl_top_loop wc_first_go }
     
-  where simpl_top_loop ev_binds_var wc
-          | isEmptyWC wc 
-          = do { traceTc "simpl_top_loop }" empty
-               ; TcRnMonad.getTcEvBinds ev_binds_var }
-          | otherwise
-          = do { wc_residual <- solveWantedsWithEvBinds ev_binds_var wc
-               ; let wc_flat_approximate = approximateWC wc_residual
-               ; (dflt_eqs,_unused_bind) <- runTcS $
-                                            applyDefaultingRules wc_flat_approximate
-                                            -- See Note [Top-level Defaulting Plan]
-               ; if isEmptyBag dflt_eqs then 
-                   do { traceTc "End simplifyTop }" empty
-                      ; report_and_finish ev_binds_var wc_residual }
-                 else
-                   simpl_top_loop ev_binds_var $ 
-                   wc_residual { wc_flat = wc_flat wc_residual `unionBags` dflt_eqs } }
-
-        report_and_finish ev_binds_var wc_residual 
-          = do { eb1 <- TcRnMonad.getTcEvBinds ev_binds_var
-               ; traceTc "reportUnsolved {" empty
-                   -- See Note [Deferring coercion errors to runtime]
-               ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors
-               ; eb2 <- reportUnsolved runtimeCoercionErrors wc_residual
-               ; traceTc "reportUnsolved }" empty
-               ; return (eb1 `unionBags` eb2) }
+    simpl_top_loop wc
+      | isEmptyWC wc 
+      = return wc
+      | otherwise
+      = do { wc_residual <- solveWantedsTcS wc
+           ; let wc_flat_approximate = approximateWC wc_residual
+           ; something_happened <- applyDefaultingRules wc_flat_approximate
+                                        -- See Note [Top-level Defaulting Plan]
+           ; if something_happened then 
+               simpl_top_loop wc_residual 
+             else 
+               return wc_residual }
 \end{code}
 
 Note [Top-level Defaulting Plan]
@@ -204,7 +196,7 @@ simplifyDeriv orig pred tvs theta
        ; traceTc "simplifyDeriv" $ 
          vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ]
        ; (residual_wanted, _ev_binds1)
-             <- solveWanteds (mkFlatWC wanted)
+             <- solveWantedsTcM (mkFlatWC wanted)
 
        ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted)
                          -- See Note [Exotic derived instance contexts]
@@ -380,51 +372,47 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
          do { _ev_binds <- reportUnsolved False wanted_transformed; failM }
 
               -- Step 4) Candidates for quantification are an approximation of wanted_transformed
-       ; let quant_candidates = approximateWC wanted_transformed               
               -- NB: Already the fixpoint of any unifications that may have happened                                
               -- NB: We do not do any defaulting when inferring a type, this can lead
               -- to less polymorphic types, see Note [Default while Inferring]
-              -- NB: quant_candidates here are wanted or derived, we filter the wanteds later, anyway
  
               -- Step 5) Minimize the quantification candidates                             
-       ; (quant_candidates_transformed, _extra_binds)   
-             <- solveWanteds $ WC { wc_flat  = quant_candidates
-                                  , wc_impl  = emptyBag
-                                  , wc_insol = emptyBag }
-
               -- Step 6) Final candidates for quantification                
-       ; let final_quant_candidates :: [PredType]
-             final_quant_candidates = map ctPred $ bagToList $
-                                      wc_flat quant_candidates_transformed
-             -- NB: Already the fixpoint of any unifications that may have happened
+              -- We discard bindings, insolubles etc, because all we are
+              -- care aout it 
+       ; (quant_pred_candidates, _extra_binds)   
+             <- runTcS $ do { let quant_candidates = approximateWC wanted_transformed               
+                            ; promoteTyVars quant_candidates
+                            ; _implics <- solveInteract quant_candidates
+                            ; (flats, _insols) <- getInertUnsolved
+                            ; return (map ctPred $ filter isWantedCt (bagToList flats)) }
+
+             -- NB: quant_pred_candidates is already the fixpoint of any 
+             --     unifications that may have happened
                   
        ; gbl_tvs        <- tcGetGlobalTyVars -- TODO: can we just use untch instead of gbl_tvs?
        ; zonked_tau_tvs <- zonkTyVarsAndFV zonked_tau_tvs
        
-       ; traceTc "simplifyWithApprox" $
-         vcat [ ptext (sLit "final_quant_candidates =") <+> ppr final_quant_candidates
-              , ptext (sLit "gbl_tvs=") <+> ppr gbl_tvs
-              , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs ]
-         
        ; let init_tvs  = zonked_tau_tvs `minusVarSet` gbl_tvs
-             poly_qtvs = growThetaTyVars final_quant_candidates init_tvs 
+             poly_qtvs = growThetaTyVars quant_pred_candidates init_tvs 
                          `minusVarSet` gbl_tvs
-             pbound    = filter (quantifyPred poly_qtvs) final_quant_candidates
+             pbound    = filter (quantifyPred poly_qtvs) quant_pred_candidates
              
-       ; traceTc "simplifyWithApprox" $
-         vcat [ ptext (sLit "pbound =") <+> ppr pbound
-              , ptext (sLit "init_qtvs =") <+> ppr init_tvs 
-              , ptext (sLit "poly_qtvs =") <+> ppr poly_qtvs ]
-         
             -- Monomorphism restriction
-       ; let mr_qtvs        = init_tvs `minusVarSet` constrained_tvs
-             constrained_tvs = tyVarsOfTypes final_quant_candidates
+             mr_qtvs        = init_tvs `minusVarSet` constrained_tvs
+             constrained_tvs = tyVarsOfTypes quant_pred_candidates
             mr_bites        = apply_mr && not (null pbound)
 
-             (qtvs, bound)
-                | mr_bites  = (mr_qtvs,   [])
-                | otherwise = (poly_qtvs, pbound)
+             (qtvs, bound) | mr_bites  = (mr_qtvs,   [])
+                           | otherwise = (poly_qtvs, pbound)
              
+       ; traceTc "simplifyWithApprox" $
+         vcat [ ptext (sLit "quant_pred_candidates =") <+> ppr quant_pred_candidates
+              , ptext (sLit "gbl_tvs=") <+> ppr gbl_tvs
+              , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs
+              , ptext (sLit "pbound =") <+> ppr pbound
+              , ptext (sLit "init_qtvs =") <+> ppr init_tvs 
+              , ptext (sLit "poly_qtvs =") <+> ppr poly_qtvs ]
 
        ; if isEmptyVarSet qtvs && null bound
          then do { traceTc "} simplifyInfer/no quantification" empty                   
@@ -469,7 +457,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
              vcat [ ptext (sLit "implic =") <+> ppr implic
                        -- ic_skols, ic_given give rest of result
                   , ptext (sLit "qtvs =") <+> ppr qtvs_to_return
-                  , ptext (sLit "spb =") <+> ppr final_quant_candidates
+                  , ptext (sLit "spb =") <+> ppr quant_pred_candidates
                   , ptext (sLit "bound =") <+> ppr bound ]
 
        ; return ( qtvs_to_return, minimal_bound_ev_vars
@@ -524,31 +512,6 @@ from superclass selection from Ord alpha. This minimization is what
 mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint
 to check the original wanted.
 
-\begin{code}
-approximateWC :: WantedConstraints -> Cts
--- Postcondition: Wanted or Derived Cts 
-approximateWC wc = float_wc emptyVarSet wc
-  where 
-    float_wc :: TcTyVarSet -> WantedConstraints -> Cts
-    float_wc skols (WC { wc_flat = flat, wc_impl = implic }) = floats1 `unionBags` floats2
-      where floats1 = do_bag (float_flat skols) flat
-            floats2 = do_bag (float_implic skols) implic
-                                 
-    float_implic :: TcTyVarSet -> Implication -> Cts
-    float_implic skols imp
-      = float_wc skols' (ic_wanted imp)
-      where
-        skols' = skols `extendVarSetList` ic_skols imp `extendVarSetList` ic_fsks imp
-            
-    float_flat :: TcTyVarSet -> Ct -> Cts
-    float_flat skols ct
-      | tyVarsOfCt ct `disjointVarSet` skols 
-      = singleCt ct
-      | otherwise = emptyCts
-        
-    do_bag :: (a -> Bag c) -> Bag a -> Bag c
-    do_bag f = foldrBag (unionBags.f) emptyBag
-\end{code}
 
 Note [Avoid unecessary constraint simplification]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -609,7 +572,7 @@ simplifyRule name lhs_wanted rhs_wanted
              
                 -- We allow ourselves to unify environment 
                 -- variables: runTcS runs with NoUntouchables
-       ; (resid_wanted, _) <- solveWanteds zonked_all
+       ; (resid_wanted, _) <- solveWantedsTcM zonked_all
 
        ; zonked_lhs <- zonkWC lhs_wanted
 
@@ -663,7 +626,7 @@ simplifyCheck wanteds
        ; traceTc "simplifyCheck {" (vcat
              [ ptext (sLit "wanted =") <+> ppr wanteds ])
 
-       ; (unsolved, eb1) <- solveWanteds wanteds
+       ; (unsolved, eb1) <- solveWantedsTcM wanteds
 
        ; traceTc "simplifyCheck }" $ ptext (sLit "unsolved =") <+> ppr unsolved
 
@@ -716,22 +679,32 @@ compilation. The errors are turned into warnings in `reportUnsolved`.
 
 \begin{code}
 
-solveWanteds :: WantedConstraints -> TcM (WantedConstraints, Bag EvBind)
+solveWantedsTcM :: WantedConstraints -> TcM (WantedConstraints, Bag EvBind)
 -- Return the evidence binds in the BagEvBinds result
 -- Discards all Derived stuff in result
-solveWanteds wanted 
-  = runTcS $ do { wc <- solve_wanteds wanted 
-                ; return (dropDerivedWC wc) }
+solveWantedsTcM wanted = runTcS (solve_wanteds_and_drop wanted)
 
 solveWantedsWithEvBinds :: EvBindsVar -> WantedConstraints -> TcM WantedConstraints
 -- Side-effect the EvBindsVar argument to add new bindings from solving
 -- Discards all Derived stuff in result
 solveWantedsWithEvBinds ev_binds_var wanted
-  = runTcSWithEvBinds ev_binds_var $ 
-    do { wc <- solve_wanteds wanted 
-       ; return (dropDerivedWC wc) }
+  = runTcSWithEvBinds ev_binds_var (solve_wanteds_and_drop wanted)
+
+solveWantedsTcS :: WantedConstraints -> TcS WantedConstraints
+-- Solve, with current untouchables, augmenting the current
+-- evidence bindings, ty_binds, and solved caches
+-- However, revert the InertCans to the way they were at 
+-- the beginning (since we are returning the residual)
+solveWantedsTcS wanted = nestTcS (solve_wanteds_and_drop wanted)
+
+solve_wanteds_and_drop :: WantedConstraints -> TcS (WantedConstraints)
+-- Since solve_wanteds returns the residual WantedConstraints,
+-- it should alway be called within a runTcS or something similar,
+solve_wanteds_and_drop wanted = do { wc <- solve_wanteds wanted 
+                                   ; return (dropDerivedWC wc) }
 
 solve_wanteds :: WantedConstraints -> TcS WantedConstraints 
+-- so that the inert set doesn't mindlessly propagate.
 -- NB: wc_flats may be wanted /or/ derived now
 solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols }) 
   = do { traceTcS "solveWanteds {" (ppr wanted)
@@ -869,15 +842,13 @@ floatEqualities skols can_given wanteds@(WC { wc_flat = flats })
   | hasEqualities can_given 
   = return (emptyBag, wanteds)   -- Note [Float Equalities out of Implications]
   | otherwise 
-  = do { untch <- TcSMonad.getUntouchables
-       ; mapM_ (promote_tv untch) (varSetElems (tyVarsOfCts float_eqs))
+  = do { let (float_eqs, remaining_flats) = partitionBag is_floatable flats
+       ; promoteTyVars float_eqs
        ; ty_binds <- getTcSTyBindsMap
-       ; traceTcS "floatEqualities" (vcat [ text "Ctxt untoucables =" <+> ppr untch
-                                          , text "Floated eqs =" <+> ppr float_eqs
+       ; traceTcS "floatEqualities" (vcat [ text "Floated eqs =" <+> ppr float_eqs
                                           , text "Ty binds =" <+> ppr ty_binds])
        ; return (float_eqs, wanteds { wc_flat = remaining_flats }) }
   where 
-    (float_eqs, remaining_flats) = partitionBag is_floatable flats
     skol_set = growSkols wanteds (mkVarSet skols)
 
     is_floatable :: Ct -> Bool
@@ -886,6 +857,11 @@ floatEqualities skols can_given wanteds@(WC { wc_flat = flats })
        where
          pred = ctPred ct
 
+promoteTyVars :: Cts -> TcS ()
+promoteTyVars cts
+  = do { untch <- TcSMonad.getUntouchables
+       ; mapM_ (promote_tv untch) (varSetElems (tyVarsOfCts cts)) }
+  where
     promote_tv untch tv 
       | isFloatedTouchableMetaTyVar untch tv
       = do { cloned_tv <- TcSMonad.cloneMetaTyVar tv
@@ -903,6 +879,31 @@ growSkols (WC { wc_flat = flats }) skols
   = growThetaTyVars theta skols
   where
     theta = foldrBag ((:) . ctPred) [] flats
+
+approximateWC :: WantedConstraints -> Cts
+-- Postcondition: Wanted or Derived Cts 
+approximateWC wc = float_wc emptyVarSet wc
+  where 
+    float_wc :: TcTyVarSet -> WantedConstraints -> Cts
+    float_wc skols (WC { wc_flat = flat, wc_impl = implic }) = floats1 `unionBags` floats2
+      where floats1 = do_bag (float_flat skols) flat
+            floats2 = do_bag (float_implic skols) implic
+                                 
+    float_implic :: TcTyVarSet -> Implication -> Cts
+    float_implic skols imp
+      = float_wc skols' (ic_wanted imp)
+      where
+        skols' = skols `extendVarSetList` ic_skols imp `extendVarSetList` ic_fsks imp
+            
+    float_flat :: TcTyVarSet -> Ct -> Cts
+    float_flat skols ct
+      | tyVarsOfCt ct `disjointVarSet` skols 
+      = singleCt ct
+      | otherwise = emptyCts
+        
+    do_bag :: (a -> Bag c) -> Bag a -> Bag c
+    do_bag f = foldrBag (unionBags.f) emptyBag
+\end{code}
 \end{code}
 
 Note [Float Equalities out of Implications]
@@ -1134,13 +1135,14 @@ When is it ok to do so?
 *                                                                               *
 *********************************************************************************
 \begin{code}
-applyDefaultingRules :: Cts      -- Wanteds or Deriveds
-                     -> TcS Cts  -- Derived equalities 
+applyDefaultingRules :: Cts -> TcS Bool
+  -- True <=> I did some defaulting, reflected in ty_binds
+                 
 -- Return some extra derived equalities, which express the
 -- type-class default choice. 
 applyDefaultingRules wanteds
   | isEmptyBag wanteds 
-  = return emptyBag
+  = return False
   | otherwise
   = do { traceTcS "applyDefaultingRules { " $ 
                   text "wanteds =" <+> ppr wanteds
@@ -1149,12 +1151,11 @@ applyDefaultingRules wanteds
        ; let groups = findDefaultableGroups info wanteds
        ; traceTcS "findDefaultableGroups" $ vcat [ text "groups=" <+> ppr groups
                                                  , text "info=" <+> ppr info ]
-       ; deflt_cts <- mapM (disambigGroup default_tys) groups
+       ; something_happeneds <- mapM (disambigGroup default_tys) groups
 
-       ; traceTcS "applyDefaultingRules }" $ 
-                  vcat [ text "Type defaults =" <+> ppr deflt_cts]
+       ; traceTcS "applyDefaultingRules }" (ppr something_happeneds)
 
-       ; return (unionManyBags deflt_cts) }
+       ; return (or something_happeneds) }
 \end{code}
 
 Note [tryTcS in defaulting]
@@ -1181,29 +1182,24 @@ in the cache!
 
 
 \begin{code}
-applyTyVarDefaulting :: WantedConstraints -> TcM Cts
+applyTyVarDefaulting :: WantedConstraints -> TcS ()
 applyTyVarDefaulting wc 
-  = do { tv_cts <- mapM defaultTyVar $ 
-                   varSetElems (tyVarsOfWC wc)
-       ; return (unionManyBags tv_cts) }
+  = do { let tvs = varSetElems (tyVarsOfWC wc) 
+       ; traceTcS "applyTyVarDefaulting {" (ppr tvs)
+       ; mapM_ defaultTyVar tvs
+       ; traceTcS "applyTyVarDefaulting end }" empty }
 
-defaultTyVar :: TcTyVar -> TcM Cts
--- Precondition: a touchable meta-variable
+defaultTyVar :: TcTyVar -> TcS ()
 defaultTyVar the_tv
   | not (k `eqKind` default_k)
-  = do { tv' <- TcMType.cloneMetaTyVar the_tv
+  = do { tv' <- TcSMonad.cloneMetaTyVar the_tv
        ; let rhs_ty = mkTyVarTy (setTyVarKind tv' default_k)
-             loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk
-             derived_pred = mkTcEqPred (mkTyVarTy the_tv) rhs_ty
-             -- Why not directly derived_pred = mkTcEqPred k default_k? 
+       ; setWantedTyBind the_tv rhs_ty }
+             -- Why not directly derived_pred = mkTcEqPred k default_k?
              -- See Note [DefaultTyVar]
-             derived_cts = mkNonCanonical $
-                           CtDerived { ctev_wloc = loc
-                                     , ctev_pred = derived_pred } 
-       
-       ; return (unitBag derived_cts) }
+             -- We keep the same Untouchables on tv'
 
-  | otherwise = return emptyBag         -- The common case
+  | otherwise = return ()       -- The common case
   where
     k = tyVarKind the_tv
     default_k = defaultKind k
@@ -1290,22 +1286,17 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
 disambigGroup :: [Type]                  -- The default types 
               -> [(Ct, Class, TcTyVar)]  -- All classes of the form (C a)
                                         --  sharing same type variable
-              -> TcS Cts
+              -> TcS Bool   -- True <=> something happened, reflected in ty_binds
 
 disambigGroup []  _grp
-  = return emptyBag
+  = return False
 disambigGroup (default_ty:default_tys) group
   = do { traceTcS "disambigGroup" (ppr group $$ ppr default_ty)
        ; success <- tryTcS $ -- Why tryTcS? See Note [tryTcS in defaulting]
-                    do { let derived_pred = mkTcEqPred (mkTyVarTy the_tv) default_ty
-                             derived_cts = unitBag $ mkNonCanonical $
-                                           CtDerived { ctev_wloc = the_loc
-                                                     , ctev_pred = derived_pred }
-                            
+                    do { setWantedTyBind the_tv default_ty
                        ; traceTcS "disambigGroup (solving) {" $
                          text "trying to solve constraints along with default equations ..."
-                       ; implics_from_defaulting <- 
-                                    solveInteract (derived_cts `unionBags` wanteds)
+                       ; implics_from_defaulting <- solveInteract wanteds
                        ; MASSERT (isEmptyBag implics_from_defaulting)
                            -- I am not certain if any implications can be generated
                            -- but I am letting this fail aggressively if this ever happens.
@@ -1313,25 +1304,21 @@ disambigGroup (default_ty:default_tys) group
                        ; all_solved <- checkAllSolved
                        ; traceTcS "disambigGroup (solving) }" $
                          text "disambigGroup solved =" <+> ppr all_solved
-                       ; if all_solved then
-                             return (Just derived_cts) 
-                         else 
-                             return Nothing 
-                       }
-       ; case success of
-           Just cts -> -- Success: record the type variable binding, and return
-                    do { wrapWarnTcS $ warnDefaulting wanteds default_ty
-                       ; traceTcS "disambigGroup succeeded" (ppr default_ty)
-                       ; return cts }
-           Nothing -> -- Failure: try with the next type
-                    do { traceTcS "disambigGroup failed, will try other default types"
-                                  (ppr default_ty)
-                       ; disambigGroup default_tys group } }
+                       ; return all_solved }
+       ; if success then
+             -- Success: record the type variable binding, and return
+             do { setWantedTyBind the_tv default_ty
+                ; wrapWarnTcS $ warnDefaulting wanteds default_ty
+                ; traceTcS "disambigGroup succeeded" (ppr default_ty)
+                ; return True }
+         else
+             -- Failure: try with the next type
+             do { traceTcS "disambigGroup failed, will try other default types"
+                           (ppr default_ty)
+                ; disambigGroup default_tys group } }
   where
-    ((the_ct,_,the_tv):_) = group
-    the_fl                = cc_ev the_ct
-    the_loc               = ctev_wloc the_fl
-    wanteds               = listToBag (map fstOf3 group)
+    ((_,_,the_tv):_) = group
+    wanteds          = listToBag (map fstOf3 group)
 \end{code}
 
 Note [Avoiding spurious errors]
index 2ce6865..6da7632 100644 (file)
@@ -558,8 +558,10 @@ uType origin ty1 ty2  -- Push a new item on the origin stack
 --------------
 -- unify_np (short for "no push" on the origin stack) does the work
 uType_np origin orig_ty1 orig_ty2
-  = do { traceTc "u_tys " $ vcat 
-              [ sep [ ppr orig_ty1, text "~", ppr orig_ty2]
+  = do { untch <- getUntouchables
+       ; traceTc "u_tys " $ vcat 
+              [ text "untch" <+> ppr untch
+              , sep [ ppr orig_ty1, text "~", ppr orig_ty2]
               , ppr origin]
        ; co <- go orig_ty1 orig_ty2
        ; if isTcReflCo co