X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=98fdaf921c138c927426f0f4ce2d011fc913f167;hb=b2376468bde082d9b2018f1d5e1fc084955e8853;hp=1998cd2bc467b3aee682ac9fc47ca1bb646b4939;hpb=6d4bd8f7a1c1fe2bdb7c964179b657e0cf3351bf;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 1998cd2..98fdaf9 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -21,18 +21,19 @@ module TcSimplify (
 #include "HsVersions.h"
 
 import {-# SOURCE #-} TcUnify( unifyType )
-import HsSyn		( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
-import TcHsSyn		( mkHsApp, mkHsTyApp, mkHsDictApp )
+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,
-			  newDictsAtLoc, tcInstClassOp,
+			  fdPredsOfInst, 
+			  newDictBndrs, newDictBndrsO, tcInstClassOp,
 			  getDictClassTys, isTyVarDict, instLoc,
 			  zonkInst, tidyInsts, tidyMoreInsts,
 			  pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs,
@@ -1468,6 +1469,7 @@ extractResults avails wanteds
 		   new_binds  = addBind binds w rhs
 		   new_avails = addToFM avails w (LinRhss rhss)
 
+	-- get_root is just used for Linear
     get_root irreds frees (Given id _) w = returnM (irreds, frees, id)
     get_root irreds frees Irred	       w = cloneDict w	`thenM` \ w' ->
 					   returnM (w':irreds, frees, instToId w')
@@ -1540,7 +1542,7 @@ split n split_id root_id wanted
 		       returnM (L span (VarBind x (mk_app span split_id rhs)),
 				[mk_fs_app span fst_id ty x, mk_fs_app span snd_id ty x])
 
-mk_fs_app span id ty var = L span (HsVar id) `mkHsTyApp` [ty,ty] `mkHsApp` (L span (HsVar var))
+mk_fs_app span id ty var = nlHsTyApp id [ty,ty] `mkHsApp` (L span (HsVar var))
 
 mk_app span id rhs = L span (HsApp (L span (HsVar id)) rhs)
 
@@ -1910,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
@@ -1922,7 +1924,8 @@ addSCs is_loop avails dict
       | is_given sc_dict 	   = return avails
       | otherwise		   = addSCs is_loop avails' sc_dict
       where
-	sc_sel_rhs = mkHsDictApp (mkHsTyApp (L (instSpan dict) (HsVar sc_sel)) tys) [instToId dict]
+	sc_sel_rhs = L (instSpan dict) (HsCoerce co_fn (HsVar sc_sel))
+	co_fn	   = CoApp (instToId dict) <.> mkCoTyApps tys
 	avails'    = addToFM avails sc_dict (Rhs sc_sel_rhs [dict])
 
     is_given :: Inst -> Bool
@@ -2276,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
 
@@ -2322,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_`
@@ -2530,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