X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FInst.lhs;h=86522ad04548a307ce332a1b409de15346a64d63;hb=8a86866e9e382c1d4d06cad722ddbe965d09997c;hp=cd189a5475862c1b3b7e99d7ad486aac00957d84;hpb=115f0fae2f782836550a9419f739fd29c09e4f1b;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index cd189a5..86522ad 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -39,8 +39,9 @@ module Inst (
 import {-# SOURCE #-}	TcExpr( tcExpr )
 
 import HsSyn	( HsLit(..), HsOverLit(..), HsExpr(..) )
-import TcHsSyn	( TcExpr, TcId, TcIdSet, TypecheckedHsExpr,
-		  mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
+import TcHsSyn	( TcExpr, TcId, TcIdSet, 
+		  mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
+		  mkCoercion, ExprCoFn
 		)
 import TcRnMonad
 import TcEnv	( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl )
@@ -49,9 +50,9 @@ import TcMType	( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
 		  zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
 		)
 import TcType	( Type, TcType, TcThetaType, TcTyVarSet,
-		  SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
+		  SourceType(..), PredType, TyVarDetails(VanillaTv),
 		  tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
-		  tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp,
+		  tcSplitPhiTy, mkGenTyConApp,
 		  isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
 		  tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
 		  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
@@ -61,13 +62,12 @@ import TcType	( Type, TcType, TcThetaType, TcTyVarSet,
 		  tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
 		)
 import CoreFVs	( idFreeTyVars )
-import Class	( Class )
 import DataCon	( DataCon,dataConSig )
 import Id	( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
 import PrelInfo	( isStandardClass, isCcallishClass, isNoDictClass )
 import Name	( Name, mkMethodOcc, getOccName )
 import PprType	( pprPred, pprParendType )	
-import Subst	( emptyInScopeSet, mkSubst, substTy, substTyWith, substTheta, mkTyVarSubst )
+import Subst	( substTy, substTyWith, substTheta, mkTyVarSubst )
 import Literal	( inIntRange )
 import Var	( TyVar )
 import VarEnv	( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
@@ -257,7 +257,7 @@ newIPDict orig ip_name ty
 
 
 \begin{code}
-tcInstCall :: InstOrigin  -> TcType -> TcM (TypecheckedHsExpr -> TypecheckedHsExpr, TcType)
+tcInstCall :: InstOrigin  -> TcType -> TcM (ExprCoFn, TcType)
 tcInstCall orig fun_ty	-- fun_ty is usually a sigma-type
   = tcInstType VanillaTv fun_ty	`thenM` \ (tyvars, theta, tau) ->
     newDicts orig theta		`thenM` \ dicts ->
@@ -265,7 +265,7 @@ tcInstCall orig fun_ty	-- fun_ty is usually a sigma-type
     let
 	inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
     in
-    returnM (inst_fn, tau)
+    returnM (mkCoercion inst_fn, tau)
 
 tcInstDataCon :: InstOrigin -> DataCon
 	      -> TcM ([TcType],	-- Types to instantiate at
@@ -353,7 +353,13 @@ newOverloadedLit :: InstOrigin
 		 -> HsOverLit
 		 -> TcType
 		 -> TcM TcExpr
-newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
+newOverloadedLit orig lit expected_ty
+  = zapToType expected_ty	`thenM_` 
+	-- The expected type might be a 'hole' type variable, 
+	-- in which case we must zap it to an ordinary type variable
+    new_over_lit orig lit expected_ty
+
+new_over_lit orig lit@(HsIntegral i fi) expected_ty
   | fi /= fromIntegerName	-- Do not generate a LitInst for rebindable
 				-- syntax.  Reason: tcSyntaxName does unification
 				-- which is very inconvenient in tcSimplify
@@ -366,7 +372,7 @@ newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
   | otherwise
   = newLitInst orig lit expected_ty
 
-newOverloadedLit orig lit@(HsFractional r fr) expected_ty
+new_over_lit orig lit@(HsFractional r fr) expected_ty
   | fr /= fromRationalName	-- c.f. HsIntegral case
   = tcSyntaxName orig expected_ty fromRationalName fr	`thenM` \ (expr, _) ->
     mkRatLit r						`thenM` \ rat_lit ->
@@ -381,9 +387,6 @@ newOverloadedLit orig lit@(HsFractional r fr) expected_ty
 newLitInst orig lit expected_ty
   = getInstLoc orig		`thenM` \ loc ->
     newUnique			`thenM` \ new_uniq ->
-    zapToType expected_ty	`thenM_` 
-	-- The expected type might be a 'hole' type variable, 
-	-- in which case we must zap it to an ordinary type variable
     let
 	lit_inst = LitInst lit_id lit expected_ty loc
 	lit_id   = mkSysLocal FSLIT("lit") new_uniq expected_ty
@@ -504,11 +507,11 @@ tidyMoreInsts env insts
 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 
-showLIE :: String -> TcM ()	-- Debugging
+showLIE :: SDoc -> TcM ()	-- Debugging
 showLIE str
   = do { lie_var <- getLIEVar ;
 	 lie <- readMutVar lie_var ;
-	 traceTc (text str <+> pprInstsInFull (lieToList lie)) }
+	 traceTc (str <+> pprInstsInFull (lieToList lie)) }
 \end{code}