X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=d232eface3707218615cfeb712384245e9f46983;hb=7f021f25e4c1b8546e346501ae34f1126755b739;hp=cb4043e239e4da96a259c99fdbba8925730d8aa6;hpb=25f0bf0245a59268fbfa8dc4ee4986b65c79ed16;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index cb4043e..d232efa 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -343,16 +343,29 @@ tcBracket brack res_ty
        ; lie_var <- getConstraintVar
        ; let brack_stage = Brack cur_stage pending_splices lie_var
 
-       ; (meta_ty, lie) <- setStage brack_stage $
-                           captureConstraints $
-                           tc_bracket cur_stage brack
-
-       ; simplifyBracket lie
-
-	-- Make the expected type have the right shape
-       ; _ <- unifyType meta_ty res_ty
-
-	-- Return the original expression, not the type-decorated one
+          -- We want to check that there aren't any constraints that
+          -- can't be satisfied (e.g. Show Foo, where Foo has no Show
+          -- 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.
+	  --
+	  -- 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
        ; return (noLoc (HsBracketOut brack pendings)) }
 
@@ -373,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)
@@ -394,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 }
@@ -940,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 {
@@ -953,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}
@@ -1177,7 +1189,7 @@ reifyClassInstance i
 reifyType :: TypeRep.Type -> TcM TH.Type
 -- Monadic only because of failure
 reifyType ty@(ForAllTy _ _)        = reify_for_all ty
-reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty	        -- Types like ((?x::Int) => Char -> Char)
+reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty  -- Types like ((?x::Int) => Char -> Char)
 reifyType (TyVarTy tv)	    = return (TH.VarT (reifyName tv))
 reifyType (TyConApp tc tys) = reify_tc_app tc tys   -- Do not expand type synonyms here
 reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }