X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=e3f29552c0b15dc28c854bb70b5fc685ec62e777;hb=e9f9ec1e57d53b9302a395ce0d02c0fa59e28341;hp=8632895b10893c194b036a2ab034c8f7490d6d0c;hpb=2f223e8f4a4e2fb22a8bb0638cd48256e9f2f0e2;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 8632895..e3f2955 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -17,8 +17,6 @@ module TcSimplify (
 	tcSimplifyDeriv, tcSimplifyDefault,
 	bindInstsOfLocalFuns, 
 	
-        tcSimplifyStagedExpr,
-
         misMatchMsg
     ) where
 
@@ -1020,16 +1018,17 @@ makeImplicationBind loc all_tvs
 		     <.> mkWpTyApps eq_cotvs
 		     <.> mkWpTyApps (mkTyVarTys all_tvs)
 	      bind | [dict_irred_id] <- dict_irred_ids  
-                   = VarBind dict_irred_id rhs
+                   = mkVarBind dict_irred_id rhs
 		   | otherwise        
-                   = PatBind { pat_lhs = lpat
+                   = L span $ 
+                     PatBind { pat_lhs = lpat
 			     , pat_rhs = unguardedGRHSs rhs 
 			     , pat_rhs_ty = hsLPatType lpat
 			     , bind_fvs = placeHolderNames 
                              }
 
 	; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
-	; return ([implic_inst], unitBag (L span bind)) 
+	; return ([implic_inst], unitBag bind) 
         }
 
 -----------------------------------------------------------
@@ -1493,7 +1492,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
 	-- (for example) squash {Monad (ST s)} into {}.  It's not enough
 	-- just to float all constraints
 	--
-	-- At top level, we *do* squash methods becuase we want to 
+	-- At top level, we *do* squash methods because we want to 
 	-- expose implicit parameters to the test that follows
 	; let is_nested_group = isNotTopLevel top_lvl
 	      try_me inst | isFreeWrtTyVars qtvs inst,
@@ -2383,11 +2382,7 @@ reduceImplication env
               eq_cotvs = map instToVar extra_eq_givens
 	      dict_ids = map instToId  extra_dict_givens 
 
-                        -- Note [Always inline implication constraints]
-              wrap_inline | null dict_ids = idHsWrapper
-                          | otherwise	  = WpInline
-              co         = wrap_inline
-                           <.> mkWpTyLams tvs
+              co         = mkWpTyLams tvs
                            <.> mkWpTyLams eq_cotvs
                            <.> mkWpLams dict_ids
                            <.> WpLet (binds `unionBags` bind)
@@ -2399,12 +2394,15 @@ reduceImplication env
                            . filter (not . isEqInst) 
                            $ wanteds
               payload    = mkBigLHsTup dict_bndrs
-
 	
 	; traceTc (vcat [text "reduceImplication" <+> ppr name,
 			 ppr simpler_implic_insts,
 			 text "->" <+> ppr rhs])
-	; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)),
+	; return (unitBag (L loc (VarBind { var_id= instToId orig_implic
+					  , var_rhs = rhs
+					  , var_inline = notNull dict_ids }
+				-- See Note [Always inline implication constraints]
+			  )),
 		  simpler_implic_insts)
   	} 
     }
@@ -3057,25 +3055,6 @@ 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}
 
 
 %************************************************************************
@@ -3107,7 +3086,7 @@ groupErrs report_err (inst:insts)
    (friends, others) = partition is_friend insts
    loc_msg	     = showSDoc (pprInstLoc (instLoc inst))
    is_friend friend  = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
-   do_one insts = addInstCtxt (instLoc (head insts)) (report_err insts)
+   do_one insts = setInstCtxt (instLoc (head insts)) (report_err insts)
 		-- Add location and context information derived from the Insts
 
 -- Add the "arising from..." part to a message about bunch of dicts
@@ -3316,7 +3295,7 @@ monomorphism_fix dflags
 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)
+    setInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
   where
     dicts = [d | (d,_,_) <- ups]