[project @ 2005-02-28 16:02:57 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 615a4b0..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,
@@ -34,21 +34,22 @@ import TcEnv                ( tcLookup, tcLookupId, checkProcLevel,
 import TcArrows                ( tcProc )
 import TcMatches       ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) )
 import TcHsType                ( tcHsSigType, UserTypeCtxt(..) )
-import TcPat           ( badFieldCon )
-import TcMType         ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType, readMetaTyVar )
-import TcType          ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType, MetaDetails(..),
+import TcPat           ( badFieldCon, refineTyVars )
+import TcMType         ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType )
+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 ->
 
@@ -634,7 +634,8 @@ tcApp fun args res_ty
            Infer _ -> do       -- Type check args first, then
                                -- refine result type, then do tcResult
                { the_app'       <- tcArgs fun fun' args expected_arg_tys
-               ; actual_res_ty' <- refineResultTy fun_tvs actual_res_ty
+               ; subst          <- refineTyVars fun_tvs
+               ; let actual_res_ty' = substTy subst actual_res_ty
                ; co_fn          <- tcResult fun args res_ty actual_res_ty'
                ; traceTc (text "tcApp: infer" <+> vcat [ppr fun <+> ppr args, ppr the_app',
                                                         ppr actual_res_ty, ppr actual_res_ty'])
@@ -722,24 +723,6 @@ checkArgsCtxt fun args (Check expected_res_ty) actual_res_ty tidy_env
              | otherwise                   = appCtxt fun args
     in
     returnM (env2, message)
-
-----------------
-refineResultTy :: [TcTyVar]    -- Newly instantiated meta-tyvars of the function
-              -> TcType        -- Result type, instantiated with those tyvars
-              -> TcM TcType    -- Refined result type
--- De-wobblify the result type, by taking account what we learned 
--- from type-checking the arguments.  Just one level of de-wobblification
--- though.  What a hack! 
-refineResultTy tvs res_ty
-  = do { mb_prs <- mapM mk_pr tvs
-       ; let subst = mkTopTvSubst (catMaybes mb_prs)
-       ; return (substTy subst res_ty) }
-  where
-    mk_pr tv = do { details <- readMetaTyVar tv
-                 ; case details of
-                       Indirect ty -> return (Just (tv,ty))
-                       other       -> return Nothing 
-                 }
 \end{code}
 
 
@@ -793,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