X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=c592652a99e38e7c1079678b75491ef87a910c8c;hb=1a0edd6c064a24042fa20c7014d11716a2d90a60;hp=c0bb23bc47fbd7b78353bee3bb0de58d51d048af;hpb=44ba24dc84d271ca9bd5ab5060cb63ed87f585e3;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index c0bb23b..c592652 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -21,19 +21,19 @@ module TcSimplify (
 #include "HsVersions.h"
 
 import {-# SOURCE #-} TcUnify( unifyType )
-import HsSyn		( HsBind(..), HsExpr(..), LHsExpr, 
+import HsSyn		( HsBind(..), HsExpr(..), LHsExpr, mkCoTyApps,
 			  ExprCoFn(..), (<.>), nlHsTyApp, emptyLHsBinds )
 import TcHsSyn		( mkHsApp )
 
 import TcRnMonad
 import Inst		( lookupInst, LookupInstResult(..),
-			  tyVarsOfInst, fdPredsOfInsts, newDicts, 
+			  tyVarsOfInst, fdPredsOfInsts,
 			  isDict, isClassDict, isLinearInst, linearInstType,
 			  isMethodFor, isMethod,
 			  instToId, tyVarsOfInsts,  cloneDict,
 			  ipNamesOfInsts, ipNamesOfInst, dictPred,
-			  fdPredsOfInst, mkInstCoFn,
-			  newDictsAtLoc, tcInstClassOp,
+			  fdPredsOfInst, 
+			  newDictBndrs, newDictBndrsO, tcInstClassOp,
 			  getDictClassTys, isTyVarDict, instLoc,
 			  zonkInst, tidyInsts, tidyMoreInsts,
 			  pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs,
@@ -773,7 +773,7 @@ isFreeWhenChecking qtvs ips inst
   =  isFreeWrtTyVars qtvs inst
   && isFreeWrtIPs    ips inst
 
-isFreeWrtTyVars qtvs inst = not (tyVarsOfInst inst `intersectsVarSet` qtvs)
+isFreeWrtTyVars qtvs inst = tyVarsOfInst inst `disjointVarSet` qtvs
 isFreeWrtIPs     ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
 \end{code}
 
@@ -1912,7 +1912,7 @@ addSCs :: (TcPredType -> Bool) -> Avails -> Inst -> TcM Avails
 	-- Invariant: the Inst is already in Avails.
 
 addSCs is_loop avails dict
-  = do	{ sc_dicts <- newDictsAtLoc (instLoc dict) sc_theta'
+  = do	{ sc_dicts <- newDictBndrs (instLoc dict) sc_theta'
 	; foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) }
   where
     (clas, tys) = getDictClassTys dict
@@ -1925,7 +1925,7 @@ addSCs is_loop avails dict
       | otherwise		   = addSCs is_loop avails' sc_dict
       where
 	sc_sel_rhs = L (instSpan dict) (HsCoerce co_fn (HsVar sc_sel))
-	co_fn	   = mkInstCoFn tys [dict]
+	co_fn	   = CoApp (instToId dict) <.> mkCoTyApps tys
 	avails'    = addToFM avails sc_dict (Rhs sc_sel_rhs [dict])
 
     is_given :: Inst -> Bool
@@ -2070,7 +2070,7 @@ tc_simplify_top doc use_extended_defaulting want_scs wanteds
 		-- up with one of the non-tyvar classes
 	    (default_gps, non_default_gps) = partition defaultable_group tv_groups
 	    defaultable_group ds
-		=  not (bad_tyvars `intersectsVarSet` tyVarsOfInst (head ds))
+		=  (bad_tyvars `disjointVarSet` tyVarsOfInst (head ds))
 		&& defaultable_classes (map get_clas ds)
 	    defaultable_classes clss 
 		| use_extended_defaulting = any isInteractiveClass clss
@@ -2279,7 +2279,7 @@ tcSimplifyDeriv tc tyvars theta
 	-- The main loop may do unification, and that may crash if 
 	-- it doesn't see a TcTyVar, so we have to instantiate. Sigh
 	-- ToDo: what if two of them do get unified?
-    newDicts DerivOrigin (substTheta tenv theta)	`thenM` \ wanteds ->
+    newDictBndrsO DerivOrigin (substTheta tenv theta)	`thenM` \ wanteds ->
     simpleReduceLoop doc reduceMe wanteds		`thenM` \ (frees, _, irreds) ->
     ASSERT( null frees )			-- reduceMe never returns Free
 
@@ -2325,7 +2325,7 @@ tcSimplifyDefault :: ThetaType	-- Wanted; has no type variables in it
 		  -> TcM ()
 
 tcSimplifyDefault theta
-  = newDicts DefaultOrigin theta		`thenM` \ wanteds ->
+  = newDictBndrsO DefaultOrigin theta		`thenM` \ wanteds ->
     simpleReduceLoop doc reduceMe wanteds	`thenM` \ (frees, _, irreds) ->
     ASSERT( null frees )	-- try_me never returns Free
     addNoInstanceErrs Nothing []  irreds 	`thenM_`