X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=d2497161f0243995c7cb5fb9958ee6fb428126aa;hb=ea2d0a53ff4ca7e6331d09225ad84ec9c9efe6d8;hp=e6ab82b2636a4765b478facf57835c98c64904fa;hpb=e6d057711f4d6d6ff6342c39fa2b9e44d25447f1;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index e6ab82b..d249716 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -1,4 +1,5 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[TcExpr]{Typecheck an expression}
@@ -11,81 +12,42 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC,
 
 #ifdef GHCI 	/* Only if bootstrapped */
 import {-# SOURCE #-}	TcSplice( tcSpliceExpr, tcBracket )
-import HsSyn		( nlHsVar )
-import Id		( Id, idName )
-import Name		( isExternalName )
-import TcType		( isTauTy )
-import TcEnv		( checkWellStaged )
-import HsSyn		( nlHsApp )
 import qualified DsMeta
 #endif
 
-import HsSyn		( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
-			  HsMatchContext(..), HsRecordBinds, mkHsWrap,
-			  mkHsApp, mkLHsWrap )
-import TcHsSyn		( hsLitType )
+import HsSyn
+import TcHsSyn
 import TcRnMonad
-import TcUnify		( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
-			  boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType,
-			  unBox )
-import BasicTypes	( Arity, isMarkedStrict )
-import Inst		( newMethodFromName, newIPDict, instCall,
-			  newMethodWithGivenTy, instStupidTheta )
-import TcBinds		( tcLocalBinds )
-import TcEnv		( tcLookup, tcLookupDataCon, tcLookupField )
-import TcArrows		( tcProc )
-import TcMatches	( tcMatchesCase, tcMatchLambda, tcDoStmts, tcBody,
-			  TcMatchCtxt(..) )
-import TcHsType		( tcHsSigType, UserTypeCtxt(..) )
-import TcPat		( tcOverloadedLit, addDataConStupidTheta, badFieldCon )
-import TcMType		( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars,
-			  readFilledBox, zonkTcTypes )
-import TcType		( TcType, TcSigmaType, TcRhoType, TvSubst,
-			  BoxySigmaType, BoxyRhoType, ThetaType,
-			  mkTyVarTys, mkFunTys, 
-			  tcMultiSplitSigmaTy, tcSplitFunTysN,
-			  tcSplitTyConApp_maybe, 
-			  isSigmaTy, mkFunTy, mkTyConApp, isLinearPred,
-			  exactTyVarsOfType, exactTyVarsOfTypes, 
-			  zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar
-			)
-import {- Kind parts of -} 
-       Type		( argTypeKind )
-
-import Id		( idType, recordSelectorFieldLabel,
-			  isRecordSelector, isNaughtyRecordSelector,
-			  isDataConId_maybe )
-import DataCon		( DataCon, dataConFieldLabels, dataConStrictMarks,
-			  dataConSourceArity, 
-			  dataConWrapId, isVanillaDataCon, dataConUnivTyVars,
-			  dataConOrigArgTys ) 
-import Name		( Name )
-import TyCon		( FieldLabel, tyConStupidTheta, tyConDataCons,
-			  isEnumerationTyCon ) 
-import Type		( substTheta, substTy )
-import Var		( TyVar, tyVarKind )
-import VarSet		( emptyVarSet, elemVarSet, unionVarSet )
-import TysWiredIn	( boolTy, parrTyCon, tupleTyCon )
-import PrelNames	( enumFromName, enumFromThenName, 
-			  enumFromToName, enumFromThenToName,
-			  enumFromToPName, enumFromThenToPName, negateName,
-			  hasKey
-			)
-import PrimOp		( tagToEnumKey )
-
+import TcUnify
+import BasicTypes
+import Inst
+import TcBinds
+import TcEnv
+import TcArrows
+import TcMatches
+import TcHsType
+import TcPat
+import TcMType
+import TcType
+import Id
+import DataCon
+import Name
+import TyCon
+import Type
+import Var
+import VarSet
+import TysWiredIn
+import PrelNames
+import PrimOp
 import DynFlags
-import StaticFlags	( opt_NoMethodSharing )
-import HscTypes		( TyThing(..) )
-import SrcLoc		( Located(..), unLoc )
+import StaticFlags
+import HscTypes
+import SrcLoc
 import Util
-import ListSetOps	( assocMaybe )
-import Maybes		( catMaybes )
+import ListSetOps
+import Maybes
 import Outputable
 import FastString
-
-#ifdef DEBUG
-import TyCon		( tyConArity )
-#endif
 \end{code}
 
 %************************************************************************
@@ -111,7 +73,7 @@ tcPolyExpr expr res_ty
 
 tcPolyExprNC expr res_ty 
   | isSigmaTy res_ty
-  = do	{ (gen_fn, expr') <- tcGen res_ty emptyVarSet (tcPolyExprNC expr)
+  = do	{ (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
 		-- Note the recursive call to tcPolyExpr, because the
 		-- type may have multiple layers of for-alls
 	; return (mkLHsWrap gen_fn expr') }
@@ -208,9 +170,14 @@ tcExpr (HsLam match) res_ty
 
 tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
  = do	{ sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
-	; expr' <- tcPolyExpr expr sig_tc_ty
+
+	-- Remember to extend the lexical type-variable environment
+	; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty ->
+		             tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
+			     tcPolyExprNC expr res_ty)
+
 	; co_fn <- tcSubExp sig_tc_ty res_ty
-	; return (mkHsWrap co_fn (ExprWithTySigOut expr' sig_ty)) }
+	; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
 
 tcExpr (HsType ty) res_ty
   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
@@ -796,19 +763,9 @@ instFun orig fun subst tv_theta_prs
 	= do { co_fn <- instCall orig tys theta
 	     ; go False (HsWrap co_fn fun) prs }
 
-	-- 	Hack Alert (want_method_inst)!
 	-- See Note [No method sharing]
-	-- If 	f :: (%x :: T) => Int -> Int
-	-- Then if we have two separate calls, (f 3, f 4), we cannot
-	-- make a method constraint that then gets shared, thus:
-	--	let m = f %x in (m 3, m 4)
-	-- because that loses the linearity of the constraint.
-	-- The simplest thing to do is never to construct a method constraint
-	-- in the first place that has a linear implicit parameter in it.
-    want_method_inst theta =  not (null theta)			-- Overloaded
-			   && not (any isLinearPred theta)	-- Not linear
+    want_method_inst theta =  not (null theta)	-- Overloaded
 		   	   && not opt_NoMethodSharing
-		-- See Note [No method sharing] below
 \end{code}
 
 Note [Multiple instantiation]