[project @ 2003-04-10 15:46:11 by simonpj]

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

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 7b94e17..86522ad 100644 (file)
--- 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