X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=eea1f86f0dcf5eb66f68a4383f6119cf4bed98ea;hb=861e836ed0cc1aa45932ecb3470967964440a0ef;hp=48279327b8d70cda85b81b95a86b20fc653cbd76;hpb=778b2c6bdbabf2c9f394f0ca2b76b55a7123aa5f;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 4827932..eea1f86 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -12,14 +12,14 @@ module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
 import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
 import {-# SOURCE #-} TcExpr  ( tcExpr )
 
-import HsSyn		( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
-			  Match(..), collectMonoBinders, andMonoBindList, andMonoBinds
+import HsSyn		( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), StmtCtxt(..),
+			  Match(..), collectMonoBinders, andMonoBinds
 			)
 import RnHsSyn		( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
-import TcHsSyn		( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
+import TcHsSyn		( TcMonoBinds, TcId, zonkId, mkHsLet )
 
 import TcMonad
-import Inst		( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
+import Inst		( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
 			  newDicts, tyVarsOfInst, instToId,
 			  getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps
 			)
@@ -35,33 +35,30 @@ import TcMonoType	( tcHsSigType, checkSigTyVars,
 			)
 import TcPat		( tcPat )
 import TcSimplify	( bindInstsOfLocalFuns )
-import TcType		( TcType, TcThetaType,
-			  TcTyVar,
-			  newTyVarTy, newTyVar, newTyVarTy_OpenKind, tcInstTcType,
-			  zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar
+import TcType		( TcThetaType, newTyVarTy, newTyVar, 
+			  zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar
 			)
 import TcUnify		( unifyTauTy, unifyTauTyLists )
 
-import Id		( Id, mkVanillaId, setInlinePragma, idFreeTyVars )
+import Id		( mkVanillaId, setInlinePragma, idFreeTyVars )
 import Var		( idType, idName )
-import IdInfo		( setInlinePragInfo, InlinePragInfo(..) )
-import Name		( Name, getName, getOccName, getSrcLoc )
+import IdInfo		( InlinePragInfo(..) )
+import Name		( Name, getOccName, getSrcLoc )
 import NameSet
 import Type		( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
-			  splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, 
-			  mkPredTy, splitRhoTy, mkForAllTy, isUnLiftedType, 
-			  isUnboxedType, unboxedTypeKind, boxedTypeKind
+			  mkForAllTys, mkFunTys, 
+			  mkPredTy, mkForAllTy, isUnLiftedType, 
+			  isUnboxedType, unboxedTypeKind, boxedTypeKind, openTypeKind
 			)
 import FunDeps		( tyVarFunDep, oclose )
-import Var		( TyVar, tyVarKind )
+import Var		( tyVarKind )
 import VarSet
 import Bag
 import Util		( isIn )
 import Maybes		( maybeToBool )
 import BasicTypes	( TopLevelFlag(..), RecFlag(..), isNotTopLevel )
 import FiniteMap	( listToFM, lookupFM )
-import Unique		( ioTyConKey, mainKey, hasKey, Uniquable(..) )
-import SrcLoc           ( SrcLoc )
+import PrelNames	( ioTyConKey, mainKey, hasKey )
 import Outputable
 \end{code}
 
@@ -613,7 +610,6 @@ tcMonoBinds :: RenamedMonoBinds
 tcMonoBinds mbinds tc_ty_sigs is_rec
   = tc_mb_pats mbinds		`thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
     let
-	tv_list		  = bagToList tvs
 	id_list 	  = bagToList ids
 	(names, mono_ids) = unzip id_list
 
@@ -681,7 +677,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
 		  lie_avail1 `plusLIE` lie_avail2)
 
     tc_mb_pats (FunMonoBind name inf matches locn)
-      = new_lhs_ty 			`thenNF_Tc` \ bndr_ty ->
+      = newTyVarTy kind 		`thenNF_Tc` \ bndr_ty -> 
 	tc_pat_bndr name bndr_ty	`thenTc` \ bndr_id ->
 	let
 	   complete_it xve = tcAddSrcLoc locn				$
@@ -692,7 +688,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
 
     tc_mb_pats bind@(PatMonoBind pat grhss locn)
       = tcAddSrcLoc locn	 	$
-	new_lhs_ty			`thenNF_Tc` \ pat_ty -> 
+	newTyVarTy kind 		`thenNF_Tc` \ pat_ty -> 
 
 		-- 	Now typecheck the pattern
 		-- We don't support binding fresh type variables in the
@@ -716,9 +712,9 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
 
 	-- Figure out the appropriate kind for the pattern,
 	-- and generate a suitable type variable 
-    new_lhs_ty = case is_rec of
-		     Recursive    -> newTyVarTy boxedTypeKind	-- Recursive, so no unboxed types
-		     NonRecursive -> newTyVarTy_OpenKind 	-- Non-recursive, so we permit unboxed types
+    kind = case is_rec of
+		Recursive    -> boxedTypeKind	-- Recursive, so no unboxed types
+		NonRecursive -> openTypeKind 	-- Non-recursive, so we permit unboxed types
 \end{code}
 
 %************************************************************************
@@ -910,21 +906,6 @@ valSpecSigCtxt v ty
 	 nest 4 (ppr v <+> dcolon <+> ppr ty)]
 
 -----------------------------------------------
-notAsPolyAsSigErr sig_tau mono_tyvars
-  = hang (ptext SLIT("A type signature is more polymorphic than the inferred type"))
-	4  (vcat [text "Can't for-all the type variable(s)" <+> 
-		  pprQuotedList mono_tyvars,
-		  text "in the type" <+> quotes (ppr sig_tau)
-	   ])
-
------------------------------------------------
-badMatchErr sig_ty inferred_ty
-  = hang (ptext SLIT("Type signature doesn't match inferred type"))
-	 4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sig_ty),
-		      hang (ptext SLIT("Inferred :")) 4 (ppr inferred_ty)
-	   ])
-
------------------------------------------------
 unboxedPatBindErr id
   = ptext SLIT("variable in a lazy pattern binding has unboxed type: ")
 	 <+> quotes (ppr id)