projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Fix Haddock errors.
[ghc-hetmet.git] / compiler / typecheck / TcSimplify.lhs
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 4ba185f..9ebae01 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -6,13 +6,6 @@
 TcSimplify
 
 \begin{code}
 TcSimplify
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module TcSimplify (
        tcSimplifyInfer, tcSimplifyInferCheck,
        tcSimplifyCheck, tcSimplifyRestricted,
 module TcSimplify (
        tcSimplifyInfer, tcSimplifyInferCheck,
        tcSimplifyCheck, tcSimplifyRestricted,
@@ -33,15 +26,15 @@ import {-# SOURCE #-} TcUnify( unifyType )
 import HsSyn
 
 import TcRnMonad
 import HsSyn
 
 import TcRnMonad
+import TcHsSyn ( hsLPatType )
 import Inst
 import TcEnv
 import InstEnv
 import Inst
 import TcEnv
 import InstEnv
-import TcGadt
 import TcType
 import TcMType
 import TcIface
 import TcTyFuns
 import TcType
 import TcMType
 import TcIface
 import TcTyFuns
-import TypeRep
+import DsUtils -- Big-tuple functions
 import Var
 import Name
 import NameSet
 import Var
 import Name
 import NameSet
@@ -55,17 +48,17 @@ import ErrUtils
 import BasicTypes
 import VarSet
 import VarEnv
 import BasicTypes
 import VarSet
 import VarEnv
-import Module
 import FiniteMap
 import Bag
 import Outputable
 import Maybes
 import ListSetOps
 import Util
 import FiniteMap
 import Bag
 import Outputable
 import Maybes
 import ListSetOps
 import Util
-import UniqSet
 import SrcLoc
 import DynFlags
 import SrcLoc
 import DynFlags
+import FastString
 
 
+import Control.Monad
 import Data.List
 \end{code}
 
 import Data.List
 \end{code}
 
@@ -98,34 +91,36 @@ we reduce the (C a b1) constraint from the call of f to (D a b1).
 
 Here is a more complicated example:
 
 
 Here is a more complicated example:
 
-| > class Foo a b | a->b
-| >
-| > class Bar a b | a->b
-| >
-| > data Obj = Obj
-| >
-| > instance Bar Obj Obj
-| >
-| > instance (Bar a b) => Foo a b
-| >
-| > foo:: (Foo a b) => a -> String
-| > foo _ = "works"
-| >
-| > runFoo:: (forall a b. (Foo a b) => a -> w) -> w
-| > runFoo f = f Obj
-| 
-| *Test> runFoo foo
-| 
-| <interactive>:1:
-|     Could not deduce (Bar a b) from the context (Foo a b)
-|       arising from use of `foo' at <interactive>:1
-|     Probable fix:
-|         Add (Bar a b) to the expected type of an expression
-|     In the first argument of `runFoo', namely `foo'
-|     In the definition of `it': it = runFoo foo
-| 
-| Why all of the sudden does GHC need the constraint Bar a b? The
-| function foo didn't ask for that... 
+@
+  > class Foo a b | a->b
+  >
+  > class Bar a b | a->b
+  >
+  > data Obj = Obj
+  >
+  > instance Bar Obj Obj
+  >
+  > instance (Bar a b) => Foo a b
+  >
+  > foo:: (Foo a b) => a -> String
+  > foo _ = "works"
+  >
+  > runFoo:: (forall a b. (Foo a b) => a -> w) -> w
+  > runFoo f = f Obj
+
+  *Test> runFoo foo
+
+  <interactive>:1:
+      Could not deduce (Bar a b) from the context (Foo a b)
+        arising from use of `foo' at <interactive>:1
+      Probable fix:
+          Add (Bar a b) to the expected type of an expression
+      In the first argument of `runFoo', namely `foo'
+      In the definition of `it': it = runFoo foo
+
+  Why all of the sudden does GHC need the constraint Bar a b? The
+  function foo didn't ask for that...
+@
 
 The trouble is that to type (runFoo foo), GHC has to solve the problem:
 
 
 The trouble is that to type (runFoo foo), GHC has to solve the problem:
 
@@ -888,7 +883,9 @@ isFreeWhenChecking qtvs ips inst
   && isFreeWrtIPs    ips inst
 -}
 
   && isFreeWrtIPs    ips inst
 -}
 
+isFreeWrtTyVars :: VarSet -> Inst -> Bool
 isFreeWrtTyVars qtvs inst = tyVarsOfInst inst `disjointVarSet` qtvs
 isFreeWrtTyVars qtvs inst = tyVarsOfInst inst `disjointVarSet` qtvs
+isFreeWrtIPs :: NameSet -> Inst -> Bool
 isFreeWrtIPs     ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
 \end{code}
 
 isFreeWrtIPs     ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
 \end{code}
 
@@ -921,16 +918,15 @@ tcSimplifyCheck loc qtvs givens wanteds
 -----------------------------------------------------------
 -- tcSimplifyCheckPat is used for existential pattern match
 tcSimplifyCheckPat :: InstLoc
 -----------------------------------------------------------
 -- tcSimplifyCheckPat is used for existential pattern match
 tcSimplifyCheckPat :: InstLoc
-                  -> [CoVar]
                   -> [TcTyVar]         -- Quantify over these
                   -> [Inst]            -- Given
                   -> [Inst]            -- Wanted
                   -> TcM TcDictBinds   -- Bindings
                   -> [TcTyVar]         -- Quantify over these
                   -> [Inst]            -- Given
                   -> [Inst]            -- Wanted
                   -> TcM TcDictBinds   -- Bindings
-tcSimplifyCheckPat loc co_vars qtvs givens wanteds
+tcSimplifyCheckPat loc qtvs givens wanteds
   = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs )
     do { traceTc (text "tcSimplifyCheckPat")
        ; (irreds, binds) <- gentleCheckLoop loc givens wanteds
   = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs )
     do { traceTc (text "tcSimplifyCheckPat")
        ; (irreds, binds) <- gentleCheckLoop loc givens wanteds
-       ; implic_bind <- bindIrredsR loc qtvs co_vars givens irreds
+       ; implic_bind <- bindIrredsR loc qtvs givens irreds
        ; return (binds `unionBags` implic_bind) }
 
 -----------------------------------------------------------
        ; return (binds `unionBags` implic_bind) }
 
 -----------------------------------------------------------
@@ -938,13 +934,12 @@ bindIrreds :: InstLoc -> [TcTyVar]
           -> [Inst] -> [Inst]
           -> TcM TcDictBinds
 bindIrreds loc qtvs givens irreds 
           -> [Inst] -> [Inst]
           -> TcM TcDictBinds
 bindIrreds loc qtvs givens irreds 
-  = bindIrredsR loc qtvs [] givens irreds
+  = bindIrredsR loc qtvs givens irreds
 
 
-bindIrredsR :: InstLoc -> [TcTyVar] -> [CoVar] -> [Inst] -> [Inst]
-           -> TcM TcDictBinds  
+bindIrredsR :: InstLoc -> [TcTyVar] -> [Inst] -> [Inst] -> TcM TcDictBinds     
 -- Make a binding that binds 'irreds', by generating an implication
 -- constraint for them, *and* throwing the constraint into the LIE
 -- Make a binding that binds 'irreds', by generating an implication
 -- constraint for them, *and* throwing the constraint into the LIE
-bindIrredsR loc qtvs co_vars givens irreds
+bindIrredsR loc qtvs givens irreds
   | null irreds
   = return emptyBag
   | otherwise
   | null irreds
   = return emptyBag
   | otherwise
@@ -965,8 +960,7 @@ bindIrredsR loc qtvs co_vars givens irreds
                        ; return real_irreds }
                     else return irreds
        
                        ; return real_irreds }
                     else return irreds
        
-       ; let all_tvs = qtvs ++ co_vars -- Abstract over all these
-       ; (implics, bind) <- makeImplicationBind loc all_tvs givens' irreds'
+       ; (implics, bind) <- makeImplicationBind loc qtvs givens' irreds'
                        -- This call does the real work
                        -- If irreds' is empty, it does something sensible
        ; extendLIEs implics
                        -- This call does the real work
                        -- If irreds' is empty, it does something sensible
        ; extendLIEs implics
@@ -1000,24 +994,22 @@ makeImplicationBind loc all_tvs
                -- 'givens' must be a simple CoVar.  This MUST be cleaned up.
 
        ; let name = mkInternalName uniq (mkVarOcc "ic") span
                -- 'givens' must be a simple CoVar.  This MUST be cleaned up.
 
        ; let name = mkInternalName uniq (mkVarOcc "ic") span
-             implic_inst = ImplicInst { tci_name = name, tci_reft = emptyRefinement,
+             implic_inst = ImplicInst { tci_name = name,
                                         tci_tyvars = all_tvs, 
                                         tci_given = (eq_givens ++ dict_givens),
                                         tci_wanted = irreds, tci_loc = loc }
        ; let   -- only create binder for dict_irreds
                                         tci_tyvars = all_tvs, 
                                         tci_given = (eq_givens ++ dict_givens),
                                         tci_wanted = irreds, tci_loc = loc }
        ; let   -- only create binder for dict_irreds
-             (eq_irreds, dict_irreds) = partition isEqInst irreds
-              n_dict_irreds = length dict_irreds
+             (_, dict_irreds) = partition isEqInst irreds
              dict_irred_ids = map instToId dict_irreds
              dict_irred_ids = map instToId dict_irreds
-             tup_ty = mkTupleTy Boxed n_dict_irreds (map idType dict_irred_ids)
-             pat = TuplePat (map nlVarPat dict_irred_ids) Boxed tup_ty
+             lpat = mkBigLHsPatTup (map (L span . VarPat) dict_irred_ids)
              rhs = L span (mkHsWrap co (HsVar (instToId implic_inst)))
              co  = mkWpApps (map instToId dict_givens)
                    <.> mkWpTyApps eq_tyvar_cos
                    <.> mkWpTyApps (mkTyVarTys all_tvs)
              bind | [dict_irred_id] <- dict_irred_ids  = VarBind dict_irred_id rhs
              rhs = L span (mkHsWrap co (HsVar (instToId implic_inst)))
              co  = mkWpApps (map instToId dict_givens)
                    <.> mkWpTyApps eq_tyvar_cos
                    <.> mkWpTyApps (mkTyVarTys all_tvs)
              bind | [dict_irred_id] <- dict_irred_ids  = VarBind dict_irred_id rhs
-                  | otherwise        = PatBind { pat_lhs = L span pat, 
+                  | otherwise        = PatBind { pat_lhs = lpat, 
                                                  pat_rhs = unguardedGRHSs rhs, 
                                                  pat_rhs = unguardedGRHSs rhs, 
-                                                 pat_rhs_ty = tup_ty,
+                                                 pat_rhs_ty = hsLPatType lpat,
                                                  bind_fvs = placeHolderNames }
        ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
        ; return ([implic_inst], unitBag (L span bind)) 
                                                  bind_fvs = placeHolderNames }
        ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
        ; return ([implic_inst], unitBag (L span bind)) 
@@ -1033,7 +1025,7 @@ tryHardCheckLoop doc wanteds
        ; return (irreds,binds)
        }
   where
        ; return (irreds,binds)
        }
   where
-    try_me inst = ReduceMe AddSCs
+    try_me _ = ReduceMe AddSCs
        -- Here's the try-hard bit
 
 -----------------------------------------------------------
        -- Here's the try-hard bit
 
 -----------------------------------------------------------
@@ -1153,7 +1145,7 @@ Given the FD of Modular in this example, class improvement will instantiate
 t_a to 'a', where 'a' is the skolem from test5's signatures (due to the
 Modular s a predicate in that signature).  If we don't zonk (Modular s t_a) in
 the givens, we will get into a loop as improveOne uses the unification engine
 t_a to 'a', where 'a' is the skolem from test5's signatures (due to the
 Modular s a predicate in that signature).  If we don't zonk (Modular s t_a) in
 the givens, we will get into a loop as improveOne uses the unification engine
-TcGadt.tcUnifyTys, which doesn't know about mutable type variables.
+Unify.tcUnifyTys, which doesn't know about mutable type variables.
 
 
 Note [LOOP]
 
 
 Note [LOOP]
@@ -1233,7 +1225,7 @@ tcSimplifySuperClasses loc givens sc_wanteds
        ; return binds1 }
   where
     env = mkRedEnv (pprInstLoc loc) try_me givens
        ; return binds1 }
   where
     env = mkRedEnv (pprInstLoc loc) try_me givens
-    try_me inst = ReduceMe NoSCs
+    try_me _ = ReduceMe NoSCs
        -- Like tryHardCheckLoop, but with NoSCs
 \end{code}
 
        -- Like tryHardCheckLoop, but with NoSCs
 \end{code}
 
@@ -1366,7 +1358,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
        -- BUT do no improvement!  See Plan D above
        -- HOWEVER, some unification may take place, if we instantiate
        --          a method Inst with an equality constraint
        -- BUT do no improvement!  See Plan D above
        -- HOWEVER, some unification may take place, if we instantiate
        --          a method Inst with an equality constraint
-       ; let env = mkNoImproveRedEnv doc (\i -> ReduceMe AddSCs)
+       ; let env = mkNoImproveRedEnv doc (\_ -> ReduceMe AddSCs)
        ; (_imp, _binds, constrained_dicts, elim_skolems) 
             <- reduceContext env wanteds'
         ; elim_skolems
        ; (_imp, _binds, constrained_dicts, elim_skolems) 
             <- reduceContext env wanteds'
         ; elim_skolems
@@ -1388,9 +1380,9 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
        -- Warn in the mono
        ; warn_mono <- doptM Opt_WarnMonomorphism
        ; warnTc (warn_mono && (constrained_tvs' `intersectsVarSet` qtvs1))
        -- Warn in the mono
        ; warn_mono <- doptM Opt_WarnMonomorphism
        ; warnTc (warn_mono && (constrained_tvs' `intersectsVarSet` qtvs1))
-                (vcat[ ptext SLIT("the Monomorphism Restriction applies to the binding")
-                               <> plural bndrs <+> ptext SLIT("for") <+> pp_bndrs,
-                       ptext SLIT("Consider giving a type signature for") <+> pp_bndrs])
+                (vcat[ ptext (sLit "the Monomorphism Restriction applies to the binding")
+                               <> plural bndrs <+> ptext (sLit "for") <+> pp_bndrs,
+                       ptext (sLit "Consider giving a type signature for") <+> pp_bndrs])
 
        ; traceTc (text "tcSimplifyRestricted" <+> vcat [
                pprInsts wanteds, pprInsts constrained_dicts',
 
        ; traceTc (text "tcSimplifyRestricted" <+> vcat [
                pprInsts wanteds, pprInsts constrained_dicts',
@@ -1758,12 +1750,12 @@ reduceContext env wanteds
        ; let givens                       = red_givens env
              (given_eqs0, given_dicts0)   = partition isEqInst givens
              (wanted_eqs0, wanted_non_eqs) = partition isEqInst wanteds
        ; let givens                       = red_givens env
              (given_eqs0, given_dicts0)   = partition isEqInst givens
              (wanted_eqs0, wanted_non_eqs) = partition isEqInst wanteds
-             (wanted_implics0, wanted_dicts0) = partition isImplicInst wanted_non_eqs
+             (wanted_implics0, wanted_dicts) = partition isImplicInst wanted_non_eqs
 
           -- We want to add as wanted equalities those that (transitively) 
           -- occur in superclass contexts of wanted class constraints.
           -- See Note [Ancestor Equalities]
 
           -- We want to add as wanted equalities those that (transitively) 
           -- occur in superclass contexts of wanted class constraints.
           -- See Note [Ancestor Equalities]
-       ; ancestor_eqs <- ancestorEqualities wanted_dicts0
+       ; ancestor_eqs <- ancestorEqualities wanted_dicts
         ; let wanted_eqs = wanted_eqs0 ++ ancestor_eqs
        ; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs
 
         ; let wanted_eqs = wanted_eqs0 ++ ancestor_eqs
        ; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs
 
@@ -1776,69 +1768,59 @@ reduceContext env wanteds
                                                             given_dicts0
 
           -- 5. Build the Avail mapping from "given_dicts"
                                                             given_dicts0
 
           -- 5. Build the Avail mapping from "given_dicts"
-       ; (init_state, extra_givens) <- getLIE $ do 
+       ; (init_state, _) <- getLIE $ do 
                { init_state <- foldlM addGiven emptyAvails given_dicts
                ; return init_state
                 }
 
                { init_state <- foldlM addGiven emptyAvails given_dicts
                ; return init_state
                 }
 
-       -- *** ToDo: what to do with the "extra_givens"?  For the
+       -- !!! ToDo: what to do with the "extra_givens"?  For the
        -- moment I'm simply discarding them, which is probably wrong
 
        -- moment I'm simply discarding them, which is probably wrong
 
-         -- 7. Normalise the *wanted* *dictionary* constraints
-         --    wrt. the toplevel and given equations
-         -- NB: normalisation includes zonking as part of what it does
-         --     so it's important to do it after any unifications
-         --     that happened as a result of the addGivens
-       ; (wanted_dicts,normalise_binds1) <- normaliseWantedDicts given_eqs wanted_dicts0
-
           -- 6. Solve the *wanted* *dictionary* constraints (not implications)
          --    This may expose some further equational constraints...
        ; (avails, extra_eqs) <- getLIE (reduceList env wanted_dicts init_state)
           -- 6. Solve the *wanted* *dictionary* constraints (not implications)
          --    This may expose some further equational constraints...
        ; (avails, extra_eqs) <- getLIE (reduceList env wanted_dicts init_state)
-       ; (dict_binds, bound_dicts, dict_irreds) <- extractResults avails wanted_dicts
+       ; (dict_binds, bound_dicts, dict_irreds) 
+            <- extractResults avails wanted_dicts
        ; traceTc $ text "reduceContext extractresults" <+> vcat
        ; traceTc $ text "reduceContext extractresults" <+> vcat
-                     [ppr avails,ppr wanted_dicts,ppr dict_binds]
-
-       -- *** ToDo: what to do with the "extra_eqs"?  For the
-       -- moment I'm simply discarding them, which is probably wrong
+                     [ppr avails, ppr wanted_dicts, ppr dict_binds]
 
          -- Solve the wanted *implications*.  In doing so, we can provide
          -- as "given"   all the dicts that were originally given, 
          --              *or* for which we now have bindings, 
          --              *or* which are now irreds
 
          -- Solve the wanted *implications*.  In doing so, we can provide
          -- as "given"   all the dicts that were originally given, 
          --              *or* for which we now have bindings, 
          --              *or* which are now irreds
-       ; let implic_env = env { red_givens = givens ++ bound_dicts ++ dict_irreds }
-       ; (implic_binds_s, implic_irreds_s) <- mapAndUnzipM (reduceImplication implic_env) wanted_implics0
+       ; let implic_env = env { red_givens = givens ++ bound_dicts 
+                                              ++ dict_irreds }
+       ; (implic_binds_s, implic_irreds_s) 
+            <- mapAndUnzipM (reduceImplication implic_env) wanted_implics0
        ; let implic_binds  = unionManyBags implic_binds_s
              implic_irreds = concat implic_irreds_s
 
        ; let implic_binds  = unionManyBags implic_binds_s
              implic_irreds = concat implic_irreds_s
 
-         -- 3. Solve the *wanted* *equation* constraints
-       ; eq_irreds0 <- solveWantedEqs given_eqs wanted_eqs
-
-         -- 4. Normalise the *wanted* equality constraints with respect to
-         --    each other 
-       ; eq_irreds <- normaliseWantedEqs eq_irreds0
+         -- Normalise the wanted equality constraints
+       ; eq_irreds <- normaliseWantedEqs given_eqs (wanted_eqs ++ extra_eqs)
 
 
-         -- 8. Substitute the wanted *equations* in the wanted *dictionaries*
+         -- Normalise the wanted dictionaries
        ; let irreds = dict_irreds ++ implic_irreds
        ; let irreds = dict_irreds ++ implic_irreds
-       ; (norm_irreds, normalise_binds2) <- substEqInDictInsts True {-wanted-}
-                                                                eq_irreds irreds
+              eqs    = eq_irreds ++ given_eqs
+       ; (norm_irreds, normalise_binds) <- normaliseWantedDicts eqs irreds
                
                
-         -- 9. eliminate the artificial skolem constants introduced in 1.
---     ; eliminate_skolems     
-
-         -- Figure out whether we should go round again
-         -- My current plan is to see if any of the mutable tyvars in
-         -- givens or irreds has been filled in by improvement.  
-         -- If so, there is merit in going around again, because
-         -- we may make further progress
+         -- Figure out whether we should go round again.  We do so in either
+          -- two cases:
+          -- (1) If any of the mutable tyvars in givens or irreds has been
+          --     filled in by improvement, there is merit in going around 
+          --     again, because we may make further progress.
+          -- (2) If we managed to normalise any dicts, there is merit in going
+          --     around gain, because reduceList may be able to get further.
          -- 
          -- 
-         -- ToDo: is it only mutable stuff?  We may have exposed new
+         -- ToDo: We may have exposed new
          --       equality constraints and should probably go round again
          --       then as well.  But currently we are dropping them on the
          --       floor anyway.
 
        ; let all_irreds = norm_irreds ++ eq_irreds
          --       equality constraints and should probably go round again
          --       then as well.  But currently we are dropping them on the
          --       floor anyway.
 
        ; let all_irreds = norm_irreds ++ eq_irreds
-       ; improved <- anyM isFilledMetaTyVar $ varSetElems $
-                     tyVarsOfInsts (givens ++ all_irreds)
+       ; improvedMetaTy <- anyM isFilledMetaTyVar $ varSetElems $
+                           tyVarsOfInsts (givens ++ all_irreds)
+        ; let improvedDicts = not $ isEmptyBag normalise_binds
+              improved      = improvedMetaTy || improvedDicts
 
        -- The old plan (fragile)
        -- improveed   = availsImproved avails 
 
        -- The old plan (fragile)
        -- improveed   = availsImproved avails 
@@ -1863,8 +1845,7 @@ reduceContext env wanteds
             ]))
 
        ; return (improved, 
             ]))
 
        ; return (improved, 
-                  given_binds `unionBags` normalise_binds1 
-                              `unionBags` normalise_binds2 
+                  given_binds `unionBags` normalise_binds
                               `unionBags` dict_binds 
                               `unionBags` implic_binds, 
                   all_irreds,
                               `unionBags` dict_binds 
                               `unionBags` implic_binds, 
                   all_irreds,
@@ -1892,7 +1873,7 @@ unifyEqns :: [(Equation,(PredType,SDoc),(PredType,SDoc))]
          -> TcM ImprovementDone
 unifyEqns [] = return False
 unifyEqns eqns
          -> TcM ImprovementDone
 unifyEqns [] = return False
 unifyEqns eqns
-  = do { traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns))
+  = do { traceTc (ptext (sLit "Improve:") <+> vcat (map pprEquationDoc eqns))
         ; mapM_ unify eqns
        ; return True }
   where
         ; mapM_ unify eqns
        ; return True }
   where
@@ -1902,12 +1883,15 @@ unifyEqns eqns
            mapM_ (unif_pr tenv) pairs
     unif_pr tenv (ty1,ty2) =  unifyType (substTy tenv ty1) (substTy tenv ty2)
 
            mapM_ (unif_pr tenv) pairs
     unif_pr tenv (ty1,ty2) =  unifyType (substTy tenv ty1) (substTy tenv ty2)
 
-pprEquationDoc (eqn, (p1,w1), (p2,w2)) = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
+pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc
+pprEquationDoc (eqn, (p1, _), (p2, _)) = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
 
 
+mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv
+         -> TcM (TidyEnv, SDoc)
 mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
   = do { pred1' <- zonkTcPredType pred1; pred2' <- zonkTcPredType pred2
        ; let { pred1'' = tidyPred tidy_env pred1'; pred2'' = tidyPred tidy_env pred2' }
 mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
   = do { pred1' <- zonkTcPredType pred1; pred2' <- zonkTcPredType pred2
        ; let { pred1'' = tidyPred tidy_env pred1'; pred2'' = tidyPred tidy_env pred2' }
-       ; let msg = vcat [ptext SLIT("When using functional dependencies to combine"),
+       ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"),
                          nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]), 
                          nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])]
        ; return (tidy_env, msg) }
                          nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]), 
                          nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])]
        ; return (tidy_env, msg) }
@@ -1920,12 +1904,9 @@ reduceList :: RedEnv -> [Inst] -> Avails -> TcM Avails
 reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state
   = do { traceTc (text "reduceList " <+> (ppr wanteds $$ ppr state))
        ; dopts <- getDOpts
 reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state
   = do { traceTc (text "reduceList " <+> (ppr wanteds $$ ppr state))
        ; dopts <- getDOpts
-#ifdef DEBUG
-       ; if n > 8 then
-               dumpTcRn (hang (ptext SLIT("Interesting! Context reduction stack depth") <+> int n) 
+       ; when (debugIsOn && (n > 8)) $ do
+               debugDumpTcRn (hang (ptext (sLit "Interesting! Context reduction stack depth") <+> int n) 
                             2 (ifPprDebug (nest 2 (pprStack stk))))
                             2 (ifPprDebug (nest 2 (pprStack stk))))
-         else return ()
-#endif
        ; if n >= ctxtStkDepth dopts then
            failWithTc (reduceDepthErr n stk)
          else
        ; if n >= ctxtStkDepth dopts then
            failWithTc (reduceDepthErr n stk)
          else
@@ -1936,9 +1917,10 @@ reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state
                         ; go ws state' }
 
     -- Base case: we're done!
                         ; go ws state' }
 
     -- Base case: we're done!
+reduce :: RedEnv -> Inst -> Avails -> TcM Avails
 reduce env wanted avails
     -- It's the same as an existing inst, or a superclass thereof
 reduce env wanted avails
     -- It's the same as an existing inst, or a superclass thereof
-  | Just avail <- findAvail avails wanted
+  | Just _ <- findAvail avails wanted
   = do { traceTc (text "reduce: found " <+> ppr wanted)
        ; return avails
        }
   = do { traceTc (text "reduce: found " <+> ppr wanted)
        ; return avails
        }
@@ -1978,7 +1960,7 @@ reduce env wanted avails
       = do { res <- lookupSimpleInst wanted
           ; case res of
                GenInst [] rhs -> addWanted AddSCs avails wanted rhs []
       = do { res <- lookupSimpleInst wanted
           ; case res of
                GenInst [] rhs -> addWanted AddSCs avails wanted rhs []
-               other          -> do_this_otherwise avails wanted }
+               _              -> do_this_otherwise avails wanted }
 \end{code}
 
 
 \end{code}
 
 
@@ -2069,7 +2051,7 @@ contributing clauses.
 \begin{code}
 ---------------------------------------------
 reduceInst :: RedEnv -> Avails -> Inst -> TcM (Avails, LookupInstResult)
 \begin{code}
 ---------------------------------------------
 reduceInst :: RedEnv -> Avails -> Inst -> TcM (Avails, LookupInstResult)
-reduceInst env avails other_inst
+reduceInst _ avails other_inst
   = do { result <- lookupSimpleInst other_inst
        ; return (avails, result) }
 \end{code}
   = do { result <- lookupSimpleInst other_inst
        ; return (avails, result) }
 \end{code}
@@ -2137,14 +2119,14 @@ Note that
        --
 reduceImplication env
        orig_implic@(ImplicInst { tci_name = name, tci_loc = inst_loc,
        --
 reduceImplication env
        orig_implic@(ImplicInst { tci_name = name, tci_loc = inst_loc,
-                                 tci_tyvars = tvs, tci_reft = emptyRefinement,
+                                 tci_tyvars = tvs,
                                  tci_given = extra_givens, tci_wanted = wanteds })
   = do {       -- Solve the sub-problem
                                  tci_given = extra_givens, tci_wanted = wanteds })
   = do {       -- Solve the sub-problem
-       ; let try_me inst = ReduceMe AddSCs  -- Note [Freeness and implications]
+       ; let try_me _ = ReduceMe AddSCs  -- Note [Freeness and implications]
              env' = env { red_givens = extra_givens ++ red_givens env
              env' = env { red_givens = extra_givens ++ red_givens env
-                        , red_doc = sep [ptext SLIT("reduceImplication for") 
+                        , red_doc = sep [ptext (sLit "reduceImplication for") 
                                             <+> ppr name,
                                             <+> ppr name,
-                                         nest 2 (parens $ ptext SLIT("within")
+                                         nest 2 (parens $ ptext (sLit "within")
                                                            <+> red_doc env)]
                         , red_try_me = try_me }
 
                                                            <+> red_doc env)]
                         , red_try_me = try_me }
 
@@ -2203,19 +2185,19 @@ reduceImplication env
                      <.> WpLet (binds `unionBags` bind)
                wrap_inline | null dict_ids = idHsWrapper
                            | otherwise     = WpInline
                      <.> WpLet (binds `unionBags` bind)
                wrap_inline | null dict_ids = idHsWrapper
                            | otherwise     = WpInline
-               rhs = mkHsWrap co payload
+               rhs = mkLHsWrap co payload
                loc = instLocSpan inst_loc
                loc = instLocSpan inst_loc
-               payload | [dict_wanted] <- dict_wanteds = HsVar (instToId dict_wanted)
-                       | otherwise = ExplicitTuple (map (L loc . HsVar . instToId) dict_wanteds) Boxed
+               payload = mkBigLHsTup (map (L loc . HsVar . instToId) dict_wanteds)
 
        
        ; traceTc (vcat [text "reduceImplication" <+> ppr name,
                         ppr simpler_implic_insts,
                         text "->" <+> ppr rhs])
 
        
        ; traceTc (vcat [text "reduceImplication" <+> ppr name,
                         ppr simpler_implic_insts,
                         text "->" <+> ppr rhs])
-       ; return (unitBag (L loc (VarBind (instToId orig_implic) (L loc rhs))),
+       ; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)),
                  simpler_implic_insts)
        } 
     }
                  simpler_implic_insts)
        } 
     }
+reduceImplication _ i = pprPanic "reduceImplication" (ppr i)
 \end{code}
 
 Note [Always inline implication constraints]
 \end{code}
 
 Note [Always inline implication constraints]
@@ -2253,12 +2235,29 @@ We can satisfy the (C Int) from the superclass of D, so we don't want
 to float the (C Int) out, even though it mentions no type variable in
 the constraints!
 
 to float the (C Int) out, even though it mentions no type variable in
 the constraints!
 
+One more example: the constraint
+       class C a => D a b
+       instance (C a, E c) => E (a,c)
+
+       constraint: forall b. D Int b => E (Int,c)
+
+You might think that the (D Int b) can't possibly contribute
+to solving (E (Int,c)), since the latter mentions 'c'.  But 
+in fact it can, because solving the (E (Int,c)) constraint needs 
+dictionaries
+       C Int, E c
+and the (C Int) can be satisfied from the superclass of (D Int b).
+So we must still not float (E (Int,c)) out.
+
+To think about: special cases for unary type classes?
+
 Note [Pruning the givens in an implication constraint]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we are about to form the implication constraint
        forall tvs.  Eq a => Ord b
 The (Eq a) cannot contribute to the (Ord b), because it has no access to
 the type variable 'b'.  So we could filter out the (Eq a) from the givens.
 Note [Pruning the givens in an implication constraint]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we are about to form the implication constraint
        forall tvs.  Eq a => Ord b
 The (Eq a) cannot contribute to the (Ord b), because it has no access to
 the type variable 'b'.  So we could filter out the (Eq a) from the givens.
+But BE CAREFUL of the examples above in [Freeness and implications].
 
 Doing so would be a bit tidier, but all the implication constraints get
 simplified away by the optimiser, so it's no great win.   So I don't take
 
 Doing so would be a bit tidier, but all the implication constraints get
 simplified away by the optimiser, so it's no great win.   So I don't take
@@ -2296,8 +2295,9 @@ data AvailHow
 instance Outputable Avails where
   ppr = pprAvails
 
 instance Outputable Avails where
   ppr = pprAvails
 
+pprAvails :: Avails -> SDoc
 pprAvails (Avails imp avails)
 pprAvails (Avails imp avails)
-  = vcat [ ptext SLIT("Avails") <> (if imp then ptext SLIT("[improved]") else empty)
+  = vcat [ ptext (sLit "Avails") <> (if imp then ptext (sLit "[improved]") else empty)
         , nest 2 $ braces $ 
           vcat [ sep [ppr inst, nest 2 (equals <+> ppr avail)]
                | (inst,avail) <- fmToList avails ]]
         , nest 2 $ braces $ 
           vcat [ sep [ppr inst, nest 2 (equals <+> ppr avail)]
                | (inst,avail) <- fmToList avails ]]
@@ -2340,11 +2340,8 @@ extendAvails avails@(Avails imp env) inst avail
 availsInsts :: Avails -> [Inst]
 availsInsts (Avails _ avails) = keysFM avails
 
 availsInsts :: Avails -> [Inst]
 availsInsts (Avails _ avails) = keysFM avails
 
-availsImproved (Avails imp _) = imp
-
-updateImprovement :: Avails -> Avails -> Avails
--- (updateImprovement a1 a2) sets a1's improvement flag from a2
-updateImprovement (Avails _ avails1) (Avails imp2 _) = Avails imp2 avails1
+_availsImproved :: Avails -> ImprovementDone
+_availsImproved (Avails imp _) = imp
 \end{code}
 
 Extracting the bindings from a bunch of Avails.
 \end{code}
 
 Extracting the bindings from a bunch of Avails.
@@ -2372,7 +2369,7 @@ extractResults (Avails _ avails) wanteds
        -> DoneEnv      -- Has an entry for each inst in the above three sets
        -> [Inst]       -- Wanted
        -> TcM (TcDictBinds, [Inst], [Inst])
        -> DoneEnv      -- Has an entry for each inst in the above three sets
        -> [Inst]       -- Wanted
        -> TcM (TcDictBinds, [Inst], [Inst])
-    go binds bound_dicts irreds done [] 
+    go binds bound_dicts irreds _ [] 
       = return (binds, bound_dicts, irreds)
 
     go binds bound_dicts irreds done (w:ws)
       = return (binds, bound_dicts, irreds)
 
     go binds bound_dicts irreds done (w:ws)
@@ -2454,7 +2451,7 @@ addAvailAndSCs want_scs avails inst avail
     -- Watch out, though.  Since the avails may contain loops 
     -- (see Note [RECURSIVE DICTIONARIES]), so we need to track the ones we've seen so far
     findAllDeps so_far (Rhs _ kids) = foldl find_all so_far kids
     -- Watch out, though.  Since the avails may contain loops 
     -- (see Note [RECURSIVE DICTIONARIES]), so we need to track the ones we've seen so far
     findAllDeps so_far (Rhs _ kids) = foldl find_all so_far kids
-    findAllDeps so_far other       = so_far
+    findAllDeps so_far _            = so_far
 
     find_all :: IdSet -> Inst -> IdSet
     find_all so_far kid
 
     find_all :: IdSet -> Inst -> IdSet
     find_all so_far kid
@@ -2494,7 +2491,7 @@ addSCs is_loop avails dict
     is_given :: Inst -> Bool
     is_given sc_dict = case findAvail avails sc_dict of
                          Just (Given _) -> True        -- Given is cheaper than superclass selection
     is_given :: Inst -> Bool
     is_given sc_dict = case findAvail avails sc_dict of
                          Just (Given _) -> True        -- Given is cheaper than superclass selection
-                         other          -> False       
+                         _              -> False
 
 -- From the a set of insts obtain all equalities that (transitively) occur in
 -- superclass contexts of class constraints (aka the ancestor equalities). 
 
 -- From the a set of insts obtain all equalities that (transitively) occur in
 -- superclass contexts of class constraints (aka the ancestor equalities). 
@@ -2558,6 +2555,7 @@ tcSimplifyInteractive wanteds
 
 -- The TcLclEnv should be valid here, solely to improve
 -- error message generation for the monomorphism restriction
 
 -- The TcLclEnv should be valid here, solely to improve
 -- error message generation for the monomorphism restriction
+tc_simplify_top :: SDoc -> Bool -> [Inst] -> TcM (Bag (LHsBind TcId))
 tc_simplify_top doc interactive wanteds
   = do { dflags <- getDOpts
        ; wanteds <- zonkInsts wanteds
 tc_simplify_top doc interactive wanteds
   = do { dflags <- getDOpts
        ; wanteds <- zonkInsts wanteds
@@ -2567,7 +2565,7 @@ tc_simplify_top doc interactive wanteds
        ; (irreds1, binds1) <- tryHardCheckLoop doc1 wanteds
 --     ; (irreds1, binds1) <- gentleInferLoop doc1 wanteds
        ; traceTc (text "tc_simplify_top 1: " <+> ppr irreds1)
        ; (irreds1, binds1) <- tryHardCheckLoop doc1 wanteds
 --     ; (irreds1, binds1) <- gentleInferLoop doc1 wanteds
        ; traceTc (text "tc_simplify_top 1: " <+> ppr irreds1)
-       ; (irreds2, binds2) <- approximateImplications doc2 (\d -> True) irreds1
+       ; (irreds2, binds2) <- approximateImplications doc2 (\_ -> True) irreds1
        ; traceTc (text "tc_simplify_top 2: " <+> ppr irreds2)
 
                -- Use the defaulting rules to do extra unification
        ; traceTc (text "tc_simplify_top 2: " <+> ppr irreds2)
 
                -- Use the defaulting rules to do extra unification
@@ -2585,9 +2583,9 @@ tc_simplify_top doc interactive wanteds
 
        ; return (binds1 `unionBags` binds2 `unionBags` binds3) }
   where
 
        ; return (binds1 `unionBags` binds2 `unionBags` binds3) }
   where
-    doc1 = doc <+> ptext SLIT("(first round)")
-    doc2 = doc <+> ptext SLIT("(approximate)")
-    doc3 = doc <+> ptext SLIT("(disambiguate)")
+    doc1 = doc <+> ptext (sLit "(first round)")
+    doc2 = doc <+> ptext (sLit "(approximate)")
+    doc3 = doc <+> ptext (sLit "(disambiguate)")
 \end{code}
 
 If a dictionary constrains a type variable which is
 \end{code}
 
 If a dictionary constrains a type variable which is
@@ -2674,7 +2672,7 @@ disambiguate doc interactive dflags insts
        | extended_defaulting = any isInteractiveClass clss
        | otherwise           = all is_std_class clss && (any is_num_class clss)
 
        | extended_defaulting = any isInteractiveClass clss
        | otherwise           = all is_std_class clss && (any is_num_class clss)
 
-       -- In interactive mode, or with -fextended-default-rules,
+       -- In interactive mode, or with -XExtendedDefaultRules,
        -- we default Show a to Show () to avoid graututious errors on "show []"
    isInteractiveClass cls 
        = is_num_class cls || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
        -- we default Show a to Show () to avoid graututious errors on "show []"
    isInteractiveClass cls 
        = is_num_class cls || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
@@ -2735,12 +2733,12 @@ getDefaultTys extended_deflts ovl_strings
                  opt_deflt ovl_strings string_ty) } } }
   where
     opt_deflt True  ty = [ty]
                  opt_deflt ovl_strings string_ty) } } }
   where
     opt_deflt True  ty = [ty]
-    opt_deflt False ty = []
+    opt_deflt False _  = []
 \end{code}
 
 Note [Default unitTy]
 ~~~~~~~~~~~~~~~~~~~~~
 \end{code}
 
 Note [Default unitTy]
 ~~~~~~~~~~~~~~~~~~~~~
-In interative mode (or with -fextended-default-rules) we add () as the first type we
+In interative mode (or with -XExtendedDefaultRules) we add () as the first type we
 try when defaulting.  This has very little real impact, except in the following case.
 Consider: 
        Text.Printf.printf "hello"
 try when defaulting.  This has very little real impact, except in the following case.
 Consider: 
        Text.Printf.printf "hello"
@@ -2807,7 +2805,7 @@ tcSimplifyDeriv orig tyvars theta
 
        ; return simpl_theta }
   where
 
        ; return simpl_theta }
   where
-    doc = ptext SLIT("deriving classes for a data type")
+    doc = ptext (sLit "deriving classes for a data type")
 
     ok dict | isDict dict = validDerivPred (dictPred dict)
            | otherwise   = False
 
     ok dict | isDict dict = validDerivPred (dictPred dict)
            | otherwise   = False
@@ -2829,9 +2827,9 @@ tcSimplifyDefault theta = do
     if null irreds then
        return ()
      else
     if null irreds then
        return ()
      else
-       traceTc (ptext SLIT("tcSimplifyDefault failing")) >> failM
+       traceTc (ptext (sLit "tcSimplifyDefault failing")) >> failM
   where
   where
-    doc = ptext SLIT("default declaration")
+    doc = ptext (sLit "default declaration")
 \end{code}
 
 
 \end{code}
 
 
@@ -2852,7 +2850,7 @@ groupErrs :: ([Inst] -> TcM ())   -- Deal with one group
 -- Group together insts with the same origin
 -- We want to report them together in error messages
 
 -- Group together insts with the same origin
 -- We want to report them together in error messages
 
-groupErrs report_err [] 
+groupErrs _ [] 
   = return ()
 groupErrs report_err (inst:insts)
   = do { do_one (inst:friends)
   = return ()
 groupErrs report_err (inst:insts)
   = do { do_one (inst:friends)
@@ -2872,7 +2870,7 @@ addInstLoc :: [Inst] -> Message -> Message
 addInstLoc insts msg = msg $$ nest 2 (pprInstArising (head insts))
 
 addTopIPErrs :: [Name] -> [Inst] -> TcM ()
 addInstLoc insts msg = msg $$ nest 2 (pprInstArising (head insts))
 
 addTopIPErrs :: [Name] -> [Inst] -> TcM ()
-addTopIPErrs bndrs [] 
+addTopIPErrs _ [] 
   = return ()
 addTopIPErrs bndrs ips
   = do { dflags <- getDOpts
   = return ()
 addTopIPErrs bndrs ips
   = do { dflags <- getDOpts
@@ -2880,9 +2878,9 @@ addTopIPErrs bndrs ips
   where
     (tidy_env, tidy_ips) = tidyInsts ips
     mk_msg dflags ips 
   where
     (tidy_env, tidy_ips) = tidyInsts ips
     mk_msg dflags ips 
-       = vcat [sep [ptext SLIT("Implicit parameters escape from"),
-               nest 2 (ptext SLIT("the monomorphic top-level binding") 
-                                           <> plural bndrs <+> ptext SLIT("of")
+       = vcat [sep [ptext (sLit "Implicit parameters escape from"),
+               nest 2 (ptext (sLit "the monomorphic top-level binding") 
+                                           <> plural bndrs <+> ptext (sLit "of")
                                            <+> pprBinders bndrs <> colon)],
                nest 2 (vcat (map ppr_ip ips)),
                monomorphism_fix dflags]
                                            <+> pprBinders bndrs <> colon)],
                nest 2 (vcat (map ppr_ip ips)),
                monomorphism_fix dflags]
@@ -2894,7 +2892,7 @@ topIPErrs dicts
   where
     (tidy_env, tidy_dicts) = tidyInsts dicts
     report dicts = addErrTcM (tidy_env, mk_msg dicts)
   where
     (tidy_env, tidy_dicts) = tidyInsts dicts
     report dicts = addErrTcM (tidy_env, mk_msg dicts)
-    mk_msg dicts = addInstLoc dicts (ptext SLIT("Unbound implicit parameter") <> 
+    mk_msg dicts = addInstLoc dicts (ptext (sLit "Unbound implicit parameter") <> 
                                     plural tidy_dicts <+> pprDictsTheta tidy_dicts)
 
 addNoInstanceErrs :: [Inst]    -- Wanted (can include implications)
                                     plural tidy_dicts <+> pprDictsTheta tidy_dicts)
 
 addNoInstanceErrs :: [Inst]    -- Wanted (can include implications)
@@ -2915,6 +2913,7 @@ reportNoInstances
 reportNoInstances tidy_env mb_what insts 
   = groupErrs (report_no_instances tidy_env mb_what) insts
 
 reportNoInstances tidy_env mb_what insts 
   = groupErrs (report_no_instances tidy_env mb_what) insts
 
+report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [Inst] -> TcM ()
 report_no_instances tidy_env mb_what insts
   = do { inst_envs <- tcGetInstEnvs
        ; let (implics, insts1)  = partition isImplicInst insts
 report_no_instances tidy_env mb_what insts
   = do { inst_envs <- tcGetInstEnvs
        ; let (implics, insts1)  = partition isImplicInst insts
@@ -2942,32 +2941,31 @@ report_no_instances tidy_env mb_what insts
        | not (isClassDict wanted) = Left wanted
        | otherwise
        = case lookupInstEnv inst_envs clas tys of
        | not (isClassDict wanted) = Left wanted
        | otherwise
        = case lookupInstEnv inst_envs clas tys of
+               ([], _) -> Left wanted          -- No match
                -- The case of exactly one match and no unifiers means a
                -- successful lookup.  That can't happen here, because dicts
                -- only end up here if they didn't match in Inst.lookupInst
                -- The case of exactly one match and no unifiers means a
                -- successful lookup.  That can't happen here, because dicts
                -- only end up here if they didn't match in Inst.lookupInst
-#ifdef DEBUG
-               ([m],[]) -> pprPanic "reportNoInstance" (ppr wanted)
-#endif
-               ([], _)  -> Left wanted         -- No match
-               res      -> Right (mk_overlap_msg wanted res)
+               ([_],[])
+                | debugIsOn -> pprPanic "reportNoInstance" (ppr wanted)
+               res -> Right (mk_overlap_msg wanted res)
          where
            (clas,tys) = getDictClassTys wanted
 
     mk_overlap_msg dict (matches, unifiers)
       = ASSERT( not (null matches) )
          where
            (clas,tys) = getDictClassTys wanted
 
     mk_overlap_msg dict (matches, unifiers)
       = ASSERT( not (null matches) )
-        vcat [ addInstLoc [dict] ((ptext SLIT("Overlapping instances for") 
+        vcat [ addInstLoc [dict] ((ptext (sLit "Overlapping instances for") 
                                        <+> pprPred (dictPred dict))),
                                        <+> pprPred (dictPred dict))),
-               sep [ptext SLIT("Matching instances") <> colon,
+               sep [ptext (sLit "Matching instances") <> colon,
                     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])],
                if not (isSingleton matches)
                then    -- Two or more matches
                     empty
                else    -- One match, plus some unifiers
                ASSERT( not (null unifiers) )
                     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])],
                if not (isSingleton matches)
                then    -- Two or more matches
                     empty
                else    -- One match, plus some unifiers
                ASSERT( not (null unifiers) )
-               parens (vcat [ptext SLIT("The choice depends on the instantiation of") <+>
+               parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
                                 quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))),
                                 quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))),
-                             ptext SLIT("To pick the first instance above, use -fallow-incoherent-instances"),
-                             ptext SLIT("when compiling the other instance declarations")])]
+                             ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
+                             ptext (sLit "when compiling the other instance declarations")])]
       where
        ispecs = [ispec | (ispec, _) <- matches]
 
       where
        ispecs = [ispec | (ispec, _) <- matches]
 
@@ -2980,25 +2978,25 @@ report_no_instances tidy_env mb_what insts
       | Just (loc, givens) <- mb_what,   -- Nested (type signatures, instance decls)
        not (isEmptyVarSet (tyVarsOfInsts insts))
       = vcat [ addInstLoc insts $
       | Just (loc, givens) <- mb_what,   -- Nested (type signatures, instance decls)
        not (isEmptyVarSet (tyVarsOfInsts insts))
       = vcat [ addInstLoc insts $
-              sep [ ptext SLIT("Could not deduce") <+> pprDictsTheta insts
-                  , nest 2 $ ptext SLIT("from the context") <+> pprDictsTheta givens]
+              sep [ ptext (sLit "Could not deduce") <+> pprDictsTheta insts
+                  , nest 2 $ ptext (sLit "from the context") <+> pprDictsTheta givens]
             , show_fixes (fix1 loc : fixes2) ]
 
       | otherwise      -- Top level 
       = vcat [ addInstLoc insts $
             , show_fixes (fix1 loc : fixes2) ]
 
       | otherwise      -- Top level 
       = vcat [ addInstLoc insts $
-              ptext SLIT("No instance") <> plural insts
-                   <+> ptext SLIT("for") <+> pprDictsTheta insts
+              ptext (sLit "No instance") <> plural insts
+                   <+> ptext (sLit "for") <+> pprDictsTheta insts
             , show_fixes fixes2 ]
 
       where
             , show_fixes fixes2 ]
 
       where
-       fix1 loc = sep [ ptext SLIT("add") <+> pprDictsTheta insts
-                                <+> ptext SLIT("to the context of"),
+       fix1 loc = sep [ ptext (sLit "add") <+> pprDictsTheta insts
+                                <+> ptext (sLit "to the context of"),
                         nest 2 (ppr (instLocOrigin loc)) ]
                         -- I'm not sure it helps to add the location
                         nest 2 (ppr (instLocOrigin loc)) ]
                         -- I'm not sure it helps to add the location
-                        -- nest 2 (ptext SLIT("at") <+> ppr (instLocSpan loc)) ]
+                        -- nest 2 (ptext (sLit "at") <+> ppr (instLocSpan loc)) ]
 
        fixes2 | null instance_dicts = []
 
        fixes2 | null instance_dicts = []
-              | otherwise           = [sep [ptext SLIT("add an instance declaration for"),
+              | otherwise           = [sep [ptext (sLit "add an instance declaration for"),
                                        pprDictsTheta instance_dicts]]
        instance_dicts = [d | d <- insts, isClassDict d, not (isTyVarDict d)]
                -- Insts for which it is worth suggesting an adding an instance declaration
                                        pprDictsTheta instance_dicts]]
        instance_dicts = [d | d <- insts, isClassDict d, not (isTyVarDict d)]
                -- Insts for which it is worth suggesting an adding an instance declaration
@@ -3006,9 +3004,10 @@ report_no_instances tidy_env mb_what insts
 
        show_fixes :: [SDoc] -> SDoc
        show_fixes []     = empty
 
        show_fixes :: [SDoc] -> SDoc
        show_fixes []     = empty
-       show_fixes (f:fs) = sep [ptext SLIT("Possible fix:"), 
-                                nest 2 (vcat (f : map (ptext SLIT("or") <+>) fs))]
+       show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), 
+                                nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
 
 
+addTopAmbigErrs :: [Inst] -> TcRn ()
 addTopAmbigErrs dicts
 -- Divide into groups that share a common set of ambiguous tyvars
   = ifErrsM (return ()) $      -- Only report ambiguity if no other errors happened
 addTopAmbigErrs dicts
 -- Divide into groups that share a common set of ambiguous tyvars
   = ifErrsM (return ()) $      -- Only report ambiguity if no other errors happened
@@ -3047,27 +3046,28 @@ mkMonomorphismMsg tidy_env inst_tvs
        ; return (tidy_env, mk_msg dflags docs) }
   where
     mk_msg _ _ | any isRuntimeUnk inst_tvs
        ; return (tidy_env, mk_msg dflags docs) }
   where
     mk_msg _ _ | any isRuntimeUnk inst_tvs
-        =  vcat [ptext SLIT("Cannot resolve unknown runtime types:") <+>
+        =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
                    (pprWithCommas ppr inst_tvs),
                    (pprWithCommas ppr inst_tvs),
-                ptext SLIT("Use :print or :force to determine these types")]
-    mk_msg _ []   = ptext SLIT("Probable fix: add a type signature that fixes these type variable(s)")
+                ptext (sLit "Use :print or :force to determine these types")]
+    mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
                        -- This happens in things like
                        --      f x = show (read "foo")
                        -- where monomorphism doesn't play any role
     mk_msg dflags docs 
                        -- This happens in things like
                        --      f x = show (read "foo")
                        -- where monomorphism doesn't play any role
     mk_msg dflags docs 
-       = vcat [ptext SLIT("Possible cause: the monomorphism restriction applied to the following:"),
+       = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
                nest 2 (vcat docs),
                monomorphism_fix dflags]
 
 monomorphism_fix :: DynFlags -> SDoc
 monomorphism_fix dflags
                nest 2 (vcat docs),
                monomorphism_fix dflags]
 
 monomorphism_fix :: DynFlags -> SDoc
 monomorphism_fix dflags
-  = ptext SLIT("Probable fix:") <+> vcat
-       [ptext SLIT("give these definition(s) an explicit type signature"),
+  = ptext (sLit "Probable fix:") <+> vcat
+       [ptext (sLit "give these definition(s) an explicit type signature"),
         if dopt Opt_MonomorphismRestriction dflags
         if dopt Opt_MonomorphismRestriction dflags
-           then ptext SLIT("or use -fno-monomorphism-restriction")
-           else empty] -- Only suggest adding "-fno-monomorphism-restriction"
+           then ptext (sLit "or use -XNoMonomorphismRestriction")
+           else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
                        -- if it is not already set!
     
                        -- if it is not already set!
     
+warnDefault :: [(Inst, Class, Var)] -> Type -> TcM ()
 warnDefault ups default_ty = do
     warn_flag <- doptM Opt_WarnTypeDefaults
     addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
 warnDefault ups default_ty = do
     warn_flag <- doptM Opt_WarnTypeDefaults
     addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
@@ -3076,14 +3076,16 @@ warnDefault ups default_ty = do
 
        -- Tidy them first
     (_, tidy_dicts) = tidyInsts dicts
 
        -- Tidy them first
     (_, tidy_dicts) = tidyInsts dicts
-    warn_msg  = vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+>
+    warn_msg  = vcat [ptext (sLit "Defaulting the following constraint(s) to type") <+>
                                quotes (ppr default_ty),
                      pprDictsInFull tidy_dicts]
 
                                quotes (ppr default_ty),
                      pprDictsInFull tidy_dicts]
 
+reduceDepthErr :: Int -> [Inst] -> SDoc
 reduceDepthErr n stack
 reduceDepthErr n stack
-  = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
-         ptext SLIT("Use -fcontext-stack=N to increase stack size to N"),
+  = vcat [ptext (sLit "Context reduction stack overflow; size =") <+> int n,
+         ptext (sLit "Use -fcontext-stack=N to increase stack size to N"),
          nest 4 (pprStack stack)]
 
          nest 4 (pprStack stack)]
 
+pprStack :: [Inst] -> SDoc
 pprStack stack = vcat (map pprInstInFull stack)
 \end{code}
 pprStack stack = vcat (map pprInstInFull stack)
 \end{code}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)