Comments only

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

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 3212e53..a6bae24 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -64,7 +64,9 @@ import Util
 import UniqSet
 import SrcLoc
 import DynFlags
 import UniqSet
 import SrcLoc
 import DynFlags

+import FastString

 
 

+import Control.Monad

 import Data.List
 \end{code}
 
 import Data.List
 \end{code}
 

@@ -1149,7 +1151,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]

@@ -1384,9 +1386,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',

@@ -1754,12 +1756,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
 

@@ -1780,61 +1782,51 @@ reduceContext env wanteds
        -- *** ToDo: what to do with the "extra_givens"?  For the
        -- moment I'm simply discarding them, which is probably wrong
 
        -- *** ToDo: what to do with the "extra_givens"?  For the
        -- 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 

@@ -1859,8 +1851,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,

@@ -1888,7 +1879,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

@@ -1903,7 +1894,7 @@ pprEquationDoc (eqn, (p1,w1), (p2,w2)) = vcat [pprEquation eqn, nest 2 (ppr p1),
 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) }

@@ -1916,12 +1907,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

@@ -2138,9 +2126,9 @@ reduceImplication env
   = do {       -- Solve the sub-problem
        ; let try_me inst = ReduceMe AddSCs  -- Note [Freeness and implications]
              env' = env { red_givens = extra_givens ++ red_givens env
   = do {       -- Solve the sub-problem
        ; let try_me inst = ReduceMe AddSCs  -- Note [Freeness and implications]
              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 }
 

@@ -2249,12 +2237,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

@@ -2293,7 +2298,7 @@ instance Outputable Avails where
   ppr = pprAvails
 
 pprAvails (Avails imp avails)
   ppr = pprAvails
 
 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 ]]

@@ -2581,9 +2586,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

@@ -2803,7 +2808,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

@@ -2825,9 +2830,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}
 
 

@@ -2876,9 +2881,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]

@@ -2890,7 +2895,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)

@@ -2938,32 +2943,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)
+               ([m],[])
+                | 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 -fallow-incoherent-instances"),
+                             ptext (sLit "when compiling the other instance declarations")])]

       where
        ispecs = [ispec | (ispec, _) <- matches]
 
       where
        ispecs = [ispec | (ispec, _) <- matches]
 

@@ -2976,25 +2980,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

@@ -3002,8 +3006,8 @@ 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 dicts
 -- Divide into groups that share a common set of ambiguous tyvars
 
 addTopAmbigErrs dicts
 -- Divide into groups that share a common set of ambiguous tyvars

@@ -3043,24 +3047,24 @@ 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")
+           then ptext (sLit "or use -fno-monomorphism-restriction")

            else empty] -- Only suggest adding "-fno-monomorphism-restriction"
                        -- if it is not already set!
     
            else empty] -- Only suggest adding "-fno-monomorphism-restriction"
                        -- if it is not already set!
     

@@ -3072,13 +3076,13 @@ 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]
 
 reduceDepthErr n stack
                                quotes (ppr default_ty),
                      pprDictsInFull tidy_dicts]
 
 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)]
 
 pprStack stack = vcat (map pprInstInFull stack)
          nest 4 (pprStack stack)]
 
 pprStack stack = vcat (map pprInstInFull stack)