Fix Haddock errors.

[ghc-hetmet.git] / compiler / typecheck / TcSimplify.lhs

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 63529c1..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,6 +26,7 @@ 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

@@ -40,7 +34,7 @@ import TcType
 import TcMType
 import TcIface
 import TcTyFuns
 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

@@ -54,16 +48,15 @@ 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
 
 import Control.Monad
 import Data.List

@@ -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}
 

@@ -1002,19 +999,17 @@ makeImplicationBind loc all_tvs
                                         tci_given = (eq_givens ++ dict_givens),
                                         tci_wanted = irreds, tci_loc = loc }
        ; let   -- only create binder for dict_irreds
                                         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)) 

@@ -1030,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
 
 -----------------------------------------------------------

@@ -1150,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]

@@ -1230,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}
 

@@ -1363,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

@@ -1385,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',

@@ -1773,12 +1768,12 @@ 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
 
           -- 6. Solve the *wanted* *dictionary* constraints (not implications)
        -- moment I'm simply discarding them, which is probably wrong
 
           -- 6. Solve the *wanted* *dictionary* constraints (not implications)

@@ -1878,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

@@ -1888,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) }

@@ -1907,7 +1905,7 @@ reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state
   = do { traceTc (text "reduceList " <+> (ppr wanteds $$ ppr state))
        ; dopts <- getDOpts
        ; when (debugIsOn && (n > 8)) $ do
   = do { traceTc (text "reduceList " <+> (ppr wanteds $$ ppr state))
        ; dopts <- getDOpts
        ; when (debugIsOn && (n > 8)) $ do

-               dumpTcRn (hang (ptext SLIT("Interesting! Context reduction stack depth") <+> int n) 
+               debugDumpTcRn (hang (ptext (sLit "Interesting! Context reduction stack depth") <+> int n) 

                             2 (ifPprDebug (nest 2 (pprStack stk))))
        ; if n >= ctxtStkDepth dopts then
            failWithTc (reduceDepthErr n stk)
                             2 (ifPprDebug (nest 2 (pprStack stk))))
        ; if n >= ctxtStkDepth dopts then
            failWithTc (reduceDepthErr n stk)

@@ -1919,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
        }

@@ -1961,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}
 
 

@@ -2052,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}

@@ -2123,11 +2122,11 @@ reduceImplication env
                                  tci_tyvars = tvs,
                                  tci_given = extra_givens, tci_wanted = wanteds })
   = do {       -- Solve the sub-problem
                                  tci_tyvars = tvs,
                                  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 }
 

@@ -2186,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]

@@ -2236,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

@@ -2279,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 ]]

@@ -2323,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.

@@ -2355,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)

@@ -2437,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

@@ -2477,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). 

@@ -2541,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

@@ -2550,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

@@ -2568,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

@@ -2657,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])

@@ -2718,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"

@@ -2790,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

@@ -2812,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}
 
 

@@ -2835,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)

@@ -2855,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

@@ -2863,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]

@@ -2877,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)

@@ -2898,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

@@ -2929,7 +2945,7 @@ report_no_instances tidy_env mb_what insts
                -- 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

-               ([m],[])
+               ([_],[])

                 | debugIsOn -> pprPanic "reportNoInstance" (ppr wanted)
                res -> Right (mk_overlap_msg wanted res)
          where
                 | debugIsOn -> pprPanic "reportNoInstance" (ppr wanted)
                res -> Right (mk_overlap_msg wanted res)
          where

@@ -2937,19 +2953,19 @@ report_no_instances tidy_env mb_what insts
 
     mk_overlap_msg dict (matches, unifiers)
       = ASSERT( not (null matches) )
 
     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]
 

@@ -2962,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

@@ -2988,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

@@ -3029,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)

@@ -3058,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}