[project @ 2003-06-20 11:14:18 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 cd189a5..19c484f 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -36,38 +36,38 @@ module Inst (
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-}  TcExpr( tcExpr )
+import {-# SOURCE #-}  TcExpr( tcCheckSigma )
 
 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 )
 import InstEnv ( InstLookupResult(..), lookupInstEnv )
-import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
+import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, 
                  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,
-                 isClassPred, isTyVarClassPred, isLinearPred, predHasFDs,
+                 isClassPred, isTyVarClassPred, isLinearPred, 
                  getClassPredTys, getClassPredTys_maybe, mkPredName,
                  isInheritablePred, isIPPred, 
                  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(..) )
@@ -101,11 +101,14 @@ dictPred inst               = pprPanic "dictPred" (ppr inst)
 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 
 -- fdPredsOfInst is used to get predicates that contain functional 
--- dependencies; i.e. should participate in improvement
-fdPredsOfInst (Dict _ pred _) | predHasFDs pred = [pred]
-                             | otherwise       = []
-fdPredsOfInst (Method _ _ _ theta _ _) = filter predHasFDs theta
-fdPredsOfInst other                   = []
+-- dependencies *or* might do so.  The "might do" part is because
+-- a constraint (C a b) might have a superclass with FDs
+-- Leaving these in is really important for the call to fdPredsOfInsts
+-- in TcSimplify.inferLoop, because the result is fed to 'grow',
+-- which is supposed to be conservative
+fdPredsOfInst (Dict _ pred _)         = [pred]
+fdPredsOfInst (Method _ _ _ theta _ _) = theta
+fdPredsOfInst other                   = []     -- LitInsts etc
 
 fdPredsOfInsts :: [Inst] -> [PredType]
 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
@@ -257,7 +260,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 +268,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
@@ -381,9 +384,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 +504,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}
 
 
@@ -662,9 +662,11 @@ tcSyntaxName orig ty std_nm user_nm
        -- C.f. newMethodAtLoc
        ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
        tau1            = substTyWith [tv] [ty] tau
+       -- Actually, the "tau-type" might be a sigma-type in the
+       -- case of locally-polymorphic methods.
     in
     addErrCtxtM (syntaxNameCtxt user_nm orig tau1)     $
-    tcExpr (HsVar user_nm) tau1                                `thenM` \ user_fn ->
+    tcCheckSigma (HsVar user_nm) tau1                  `thenM` \ user_fn ->
     returnM (user_fn, tau1)
 
 syntaxNameCtxt name orig ty tidy_env