Global renamings in HsSyn

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

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 8f06270..7379993 100644 (file)
--- 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, 
-                         ExprCoFn(..), (<.>), nlHsTyApp, emptyLHsBinds )
+import HsSyn           ( HsBind(..), HsExpr(..), LHsExpr, mkWpTyApps,
+                         HsWrapper(..), (<.>), 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
@@ -1924,8 +1924,8 @@ addSCs is_loop avails dict
       | is_given sc_dict          = return avails
       | 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]
+       sc_sel_rhs = L (instSpan dict) (HsWrap co_fn (HsVar sc_sel))
+       co_fn      = WpApp (instToId dict) <.> mkWpTyApps 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_`
@@ -2533,7 +2533,7 @@ monomorphism_fix = ptext SLIT("Probable fix:") <+>
     
 warnDefault dicts default_ty
   = doptM Opt_WarnTypeDefaults  `thenM` \ warn_flag ->
-    addInstCtxt (instLoc (head dicts)) (warnTc warn_flag warn_msg)
+    addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
   where
        -- Tidy them first
     (_, tidy_dicts) = tidyInsts dicts