[project @ 2005-03-08 17:19:28 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index de6ecff..a67d30e 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -11,6 +11,7 @@ module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where
 #ifdef GHCI    /* Only if bootstrapped */
 import {-# SOURCE #-}  TcSplice( tcSpliceExpr, tcBracket )
 import Id              ( Id )
+import Name            ( isExternalName )
 import TcType          ( isTauTy )
 import TcEnv           ( checkWellStaged )
 import HsSyn           ( nlHsApp )
@@ -24,8 +25,7 @@ import TcRnMonad
 import TcUnify         ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, tcSubExp, tcGen,
                          unifyFunTys, zapToListTy, zapToTyConApp )
 import BasicTypes      ( isMarkedStrict )
-import Inst            ( InstOrigin(..), 
-                         newOverloadedLit, newMethodFromName, newIPDict,
+import Inst            ( newOverloadedLit, newMethodFromName, newIPDict,
                          newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall )
 import TcBinds         ( tcBindsAndThen )
 import TcEnv           ( tcLookup, tcLookupId, checkProcLevel,
@@ -36,19 +36,20 @@ import TcMatches    ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMa
 import TcHsType                ( tcHsSigType, UserTypeCtxt(..) )
 import TcPat           ( badFieldCon, refineTyVars )
 import TcMType         ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType )
-import TcType          ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType, MetaDetails(..),
+import TcType          ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType, 
                          tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
                          isSigmaTy, mkFunTy, mkTyConApp, tyVarsOfTypes, isLinearPred,
                          tcSplitSigmaTy, tidyOpenType
                        )
 import Kind            ( openTypeKind, liftedTypeKind, argTypeKind )
 
-import Id              ( idType, recordSelectorFieldLabel, isRecordSelector, idName )
+import Id              ( idType, recordSelectorFieldLabel, isRecordSelector )
 import DataCon         ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId )
-import Name            ( Name, isExternalName )
+import Name            ( Name )
 import TyCon           ( TyCon, FieldLabel, tyConTyVars, tyConStupidTheta, 
                          tyConDataCons, tyConFields )
-import Type            ( zipTopTvSubst, mkTopTvSubst, substTheta, substTy )
+import Type            ( zipTopTvSubst, substTheta, substTy )
+import Var             ( tyVarKind )
 import VarSet          ( emptyVarSet, elemVarSet )
 import TysWiredIn      ( boolTy, parrTyCon, tupleTyCon )
 import PrelNames       ( enumFromName, enumFromThenName, 
@@ -60,7 +61,6 @@ import CmdLineOpts
 import HscTypes                ( TyThing(..) )
 import SrcLoc          ( Located(..), unLoc, getLoc )
 import Util
-import Maybes          ( catMaybes )
 import Outputable
 import FastString
 
@@ -459,11 +459,11 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty
        non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
        common_tyvars       = tyVarsOfTypes [ty | (fld,ty,_) <- tyConFields tycon,
                                                  fld `elem` non_upd_field_lbls]
+       is_common_tv tv = tv `elemVarSet` common_tyvars
 
-       mk_inst_ty tyvar result_inst_ty 
-         | tyvar `elemVarSet` common_tyvars = returnM result_inst_ty   -- Same as result type
--- gaw 2004 FIX?
-         | otherwise                        = newTyFlexiVarTy liftedTypeKind   -- Fresh type
+       mk_inst_ty tv result_inst_ty 
+         | is_common_tv tv = returnM result_inst_ty            -- Same as result type
+         | otherwise       = newTyFlexiVarTy (tyVarKind tv)    -- Fresh type, of correct kind
     in
     zipWithM mk_inst_ty tycon_tyvars result_inst_tys   `thenM` \ inst_tys ->
 
@@ -776,7 +776,8 @@ tcId id_name        -- Look up the Id and instantiate its type
          -> do { checkProcLevel id proc_level
                ; tc_local_id id th_level }
 
-    ;  other -> pprPanic "tcId" (ppr id_name $$ ppr thing)
+       -- THis 
+    ;  other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
     }
   where