Remove redundant import; spotted by Thorkil Naur

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

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 1e51ee0..ad7e5c2 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -16,6 +16,8 @@ module TcSimplify (
 
        tcSimplifyDeriv, tcSimplifyDefault,
        bindInstsOfLocalFuns, 
+       
+        tcSimplifyStagedExpr,
 
         misMatchMsg
     ) where
@@ -58,6 +60,7 @@ import Util
 import SrcLoc
 import DynFlags
 import FastString
+
 import Control.Monad
 import Data.List
 \end{code}
@@ -977,7 +980,7 @@ makeImplicationBind :: InstLoc -> [TcTyVar]
 --     (ir1, .., irn) = f qtvs givens
 -- where f is (evidence for) the new implication constraint
 --     f :: forall qtvs. givens => (ir1, .., irn)
--- qtvs includes coercion variables.
+-- qtvs includes coercion variables
 --
 -- This binding must line up the 'rhs' in reduceImplication
 makeImplicationBind loc all_tvs
@@ -997,7 +1000,7 @@ makeImplicationBind loc all_tvs
              name = mkInternalName uniq (mkVarOcc "ic") span
              implic_inst = ImplicInst { tci_name = name,
                                         tci_tyvars = all_tvs, 
-                                        tci_given = (eq_givens ++ dict_givens),
+                                        tci_given = eq_givens ++ dict_givens,
                                                        -- same order as binders
                                         tci_wanted = irreds, 
                                          tci_loc = loc }
@@ -1278,7 +1281,7 @@ tcSimplifySuperClasses loc this givens sc_wanteds
   = do { traceTc (text "tcSimplifySuperClasses")
        ; (irreds,binds1) <- checkLoop env sc_wanteds
        ; let (tidy_env, tidy_irreds) = tidyInsts irreds
-       ; reportNoInstances tidy_env (Just (loc, givens)) tidy_irreds
+       ; reportNoInstances tidy_env (Just (loc, givens)) [] tidy_irreds
        ; return binds1 }
   where
     env =  RedEnv { red_doc = pprInstLoc loc, 
@@ -2977,7 +2980,8 @@ tcSimplifyDeriv orig tyvars theta
        ; (irreds, _) <- tryHardCheckLoop doc wanteds
 
        ; let (tv_dicts, others) = partition ok irreds
-       ; addNoInstanceErrs others
+             (tidy_env, tidy_insts) = tidyInsts others
+        ; reportNoInstances tidy_env Nothing [alt_fix] tidy_insts
        -- See Note [Exotic derived instance contexts] in TcMType
 
        ; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
@@ -2991,6 +2995,8 @@ tcSimplifyDeriv orig tyvars theta
 
     ok dict | isDict dict = validDerivPred (dictPred dict)
            | otherwise   = False
+    alt_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration instead,"),
+                    ptext (sLit "so you can specify the instance context yourself")]
 \end{code}
 
 
@@ -3005,7 +3011,7 @@ tcSimplifyDefault :: ThetaType    -- Wanted; has no type variables in it
 tcSimplifyDefault theta = do
     wanteds <- newDictBndrsO DefaultOrigin theta
     (irreds, _) <- tryHardCheckLoop doc wanteds
-    addNoInstanceErrs  irreds
+    addNoInstanceErrs irreds
     if null irreds then
        return ()
      else
@@ -3014,6 +3020,26 @@ tcSimplifyDefault theta = do
     doc = ptext (sLit "default declaration")
 \end{code}
 
+@tcSimplifyStagedExpr@ performs a simplification but does so at a new
+stage. This is used when typechecking annotations and splices.
+
+\begin{code}
+
+tcSimplifyStagedExpr :: ThStage -> TcM a -> TcM (a, TcDictBinds)
+-- Type check an expression that runs at a top level stage as if
+--   it were going to be spliced and then simplify it
+tcSimplifyStagedExpr stage tc_action
+  = setStage stage $ do { 
+        -- Typecheck the expression
+         (thing', lie) <- getLIE tc_action
+       
+       -- Solve the constraints
+       ; const_binds <- tcSimplifyTop lie
+       
+       ; return (thing', const_binds) }
+
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *
@@ -3081,7 +3107,7 @@ addNoInstanceErrs :: [Inst]       -- Wanted (can include implications)
                  -> TcM ()     
 addNoInstanceErrs insts
   = do { let (tidy_env, tidy_insts) = tidyInsts insts
-       ; reportNoInstances tidy_env Nothing tidy_insts }
+       ; reportNoInstances tidy_env Nothing [] tidy_insts }
 
 reportNoInstances 
        :: TidyEnv
@@ -3089,14 +3115,15 @@ reportNoInstances
                        -- Nothing => top level
                        -- Just (d,g) => d describes the construct
                        --               with givens g
+        -> [SDoc]      -- Alternative fix for no-such-instance
        -> [Inst]       -- What is wanted (can include implications)
        -> TcM ()       
 
-reportNoInstances tidy_env mb_what insts 
-  = groupErrs (report_no_instances tidy_env mb_what) insts
+reportNoInstances tidy_env mb_what alt_fix insts 
+  = groupErrs (report_no_instances tidy_env mb_what alt_fix) insts
 
-report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [Inst] -> TcM ()
-report_no_instances tidy_env mb_what insts
+report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [SDoc] -> [Inst] -> TcM ()
+report_no_instances tidy_env mb_what alt_fixes insts
   = do { inst_envs <- tcGetInstEnvs
        ; let (implics, insts1)  = partition isImplicInst insts
             (insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1
@@ -3114,7 +3141,7 @@ report_no_instances tidy_env mb_what insts
     complain_implic inst       -- Recurse!
       = reportNoInstances tidy_env 
                          (Just (tci_loc inst, tci_given inst)) 
-                         (tci_wanted inst)
+                         alt_fixes (tci_wanted inst)
 
     check_overlap :: (InstEnv,InstEnv) -> Inst -> Either Inst SDoc
        -- Right msg  => overlap message
@@ -3162,13 +3189,13 @@ report_no_instances tidy_env mb_what insts
       = vcat [ addInstLoc insts $
               sep [ ptext (sLit "Could not deduce") <+> pprDictsTheta insts
                   , nest 2 $ ptext (sLit "from the context") <+> pprDictsTheta givens]
-            , show_fixes (fix1 loc : fixes2) ]
+            , show_fixes (fix1 loc : fixes2 ++ alt_fixes) ]
 
       | otherwise      -- Top level 
       = vcat [ addInstLoc insts $
               ptext (sLit "No instance") <> plural insts
                    <+> ptext (sLit "for") <+> pprDictsTheta insts
-            , show_fixes fixes2 ]
+            , show_fixes (fixes2 ++ alt_fixes) ]
 
       where
        fix1 loc = sep [ ptext (sLit "add") <+> pprDictsTheta insts