Introducing a datatype for WorkLists that properly prioritizes equalities.

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

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index cc18707..f68239e 100644 (file)
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -348,10 +348,22 @@ tcBracket brack res_ty
           -- instance), but we aren't otherwise interested in the
           -- results. Nor do we care about ambiguous dictionaries etc.
           -- We will type check this bracket again at its usage site.
-       ; _ <- newImplication BracketSkol [] [] $
-              setStage brack_stage $
-              do { meta_ty <- tc_bracket cur_stage brack
-                 ; unifyType meta_ty res_ty }
+         --
+         -- We build a single implication constraint with a BracketSkol;
+         -- that in turn tells simplifyCheck to report only definite
+         -- errors
+       ; (_,lie) <- captureConstraints $
+                   newImplication BracketSkol [] [] $
+                   setStage brack_stage $
+                   do { meta_ty <- tc_bracket cur_stage brack
+                      ; unifyType meta_ty res_ty }
+
+          -- It's best to simplify the constraint now, even though in 
+         -- principle some later unification might be useful for it,
+         -- because we don't want these essentially-junk TH implication
+         -- contraints floating around nested inside other constraints
+         -- See for example Trac #4949
+       ; _ <- simplifyTop lie
 
         -- Return the original expression, not the type-decorated one
        ; pendings <- readMutVar pending_splices
@@ -374,7 +386,7 @@ tc_bracket outer_stage (VarBr name)         -- Note [Quoting names]
        }
 
 tc_bracket _ (ExpBr expr) 
-  = do { any_ty <- newFlexiTyVarTy liftedTypeKind
+  = do { any_ty <- newFlexiTyVarTy openTypeKind
        ; _ <- tcMonoExprNC expr any_ty  -- NC for no context; tcBracket does that
        ; tcMetaTy expQTyConName }
        -- Result type is ExpQ (= Q Exp)
@@ -395,7 +407,7 @@ tc_bracket _ (DecBrG decls)
        ; tcMetaTy decsQTyConName } -- Result type is Q [Dec]
 
 tc_bracket _ (PatBr pat)
-  = do { any_ty <- newFlexiTyVarTy liftedTypeKind
+  = do { any_ty <- newFlexiTyVarTy openTypeKind
        ; _ <- tcPat ThPatQuote pat any_ty $ 
                return ()
        ; tcMetaTy patQTyConName }
@@ -941,7 +953,7 @@ illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (withou
 %************************************************************************
 
 \begin{code}
-lookupClassInstances :: TH.Name -> [TH.Type] -> TcM [TH.Name]
+lookupClassInstances :: TH.Name -> [TH.Type] -> TcM [TH.ClassInstance]
 lookupClassInstances c ts
    = do { loc <- getSrcSpanM
         ; case convertToHsPred loc (TH.ClassP c ts) of {
@@ -954,8 +966,7 @@ lookupClassInstances c ts
        -- Now look up instances
         ; inst_envs <- tcGetInstEnvs
         ; let (matches, unifies) = lookupInstEnv inst_envs cls tys
-              dfuns = map is_dfun (map fst matches ++ unifies)
-        ; return (map reifyName dfuns) } } }
+        ; mapM reifyClassInstance (map fst matches ++ unifies) } } }
   where
     doc = ptext (sLit "TcSplice.classInstances")
 \end{code}