X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsType.lhs;h=3d365ab3d670503ea916e51d8c3bfb22f7b74ad2;hb=4f55ec2c7e78aa836b91ebc57ddd74675d92372c;hp=31cf70e140d06521bd6cc85e20e1167ac6009688;hpb=ef10d0a708995896b085b1c13ca7c9a92adca674;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 31cf70e..3d365ab 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -1,4 +1,5 @@
-
+%
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
@@ -23,41 +24,26 @@ module TcHsType (
 
 #include "HsVersions.h"
 
-import HsSyn		( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, 
-			  LHsContext, HsPred(..), LHsPred, HsExplicitForAll(..) )
-import RnHsSyn		( extractHsTyVars )
+import HsSyn
+import RnHsSyn
 import TcRnMonad
-import TcEnv		( tcExtendTyVarEnv, tcExtendKindEnvTvs, 
-			  tcLookup, tcLookupClass, tcLookupTyCon,
-		 	  TyThing(..), getInLocalScope, getScopedTyVarBinds,
-			  wrongThingErr
-			)
-import TcMType		( newKindVar, 
-			  zonkTcKindToKind, 
-			  tcInstBoxyTyVar, readFilledBox,
-			  checkValidType
-			)
-import TcUnify		( boxyUnify, unifyFunKind, checkExpectedKind )
-import TcIface		( checkWiredInTyCon )
-import TcType		( Type, PredType(..), ThetaType, BoxySigmaType,
-			  TcType, TcKind, isRigidTy,
-			  UserTypeCtxt(..), pprUserTypeCtxt,
-			  substTyWith, mkTyVarTys, tcEqType,
-		 	  tcIsTyVarTy, mkFunTy, mkSigmaTy, mkPredTy, 
-			  mkTyConApp, mkAppTys, typeKind )
-import Kind 		( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind, 
-			  openTypeKind, argTypeKind, splitKindFunTys )
-import Var		( TyVar, mkTyVar, tyVarName )
-import TyCon		( TyCon, tyConKind )
-import Class		( Class, classTyCon )
-import Name		( Name, mkInternalName )
-import OccName		( mkOccName, tvName )
+import TcEnv
+import TcMType
+import TcUnify
+import TcIface
+import TcType
+import {- Kind parts of -} Type
+import Var
+import TyCon
+import Class
+import Name
+import OccName
 import NameSet
-import PrelNames	( genUnitTyConName )
-import TysWiredIn	( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon )
-import BasicTypes	( Boxity(..) )
-import SrcLoc		( Located(..), unLoc, noLoc, getLoc, srcSpanStart )
-import UniqSupply	( uniqsFromSupply )
+import PrelNames
+import TysWiredIn
+import BasicTypes
+import SrcLoc
+import UniqSupply
 import Outputable
 \end{code}
 
@@ -245,10 +231,14 @@ kcCheckHsType (L span ty) exp_kind
 	; return (L span ty') }
   where
 	-- Wrap a context around only if we want to show that contexts.  
+    add_ctxt (HsPredTy p)		 thing = thing
 	-- Omit invisble ones and ones user's won't grok (HsPred p).
-    add_ctxt (HsPredTy p)		    	         thing = thing
-    add_ctxt (HsForAllTy Implicit tvs (L _ []) (L _ ty)) thing = add_ctxt ty thing
-    add_ctxt other_ty thing = addErrCtxt (typeCtxt ty) thing
+    add_ctxt (HsForAllTy _ _ (L _ []) _) thing = thing
+	-- Omit wrapping if the theta-part is empty
+	-- Reason: the recursive call to kcLiftedType, in the ForAllTy
+	--	   case of kc_hs_type, will do the wrapping instead
+	--	   and we don't want to duplicate
+    add_ctxt other_ty thing = addErrCtxt (typeCtxt other_ty) thing
 
 	-- We infer the kind of the type, and then complain if it's
 	-- not right.  But we don't want to complain about
@@ -333,17 +323,18 @@ kc_hs_type (HsPredTy pred)
 
 kc_hs_type (HsForAllTy exp tv_names context ty)
   = kcHsTyVars tv_names		$ \ tv_names' ->
-    kcHsContext context		`thenM`	\ ctxt' ->
-    kcLiftedType ty		`thenM` \ ty' ->
-	-- The body of a forall is usually a type, but in principle
-	-- there's no reason to prohibit *unlifted* types.
-	-- In fact, GHC can itself construct a function with an
-	-- unboxed tuple inside a for-all (via CPR analyis; see 
-	-- typecheck/should_compile/tc170)
-	--
-	-- Still, that's only for internal interfaces, which aren't
-	-- kind-checked, so we only allow liftedTypeKind here
-    returnM (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind)
+    do	{ ctxt' <- kcHsContext context
+	; ty'   <- kcLiftedType ty
+	     -- The body of a forall is usually a type, but in principle
+	     -- there's no reason to prohibit *unlifted* types.
+	     -- In fact, GHC can itself construct a function with an
+	     -- unboxed tuple inside a for-all (via CPR analyis; see 
+	     -- typecheck/should_compile/tc170)
+	     --
+	     -- Still, that's only for internal interfaces, which aren't
+	     -- kind-checked, so we only allow liftedTypeKind here
+
+  	; return (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) }
 
 kc_hs_type (HsBangTy b ty)
   = do { (ty', kind) <- kcHsType ty
@@ -352,6 +343,10 @@ kc_hs_type (HsBangTy b ty)
 kc_hs_type ty@(HsSpliceTy _)
   = failWithTc (ptext SLIT("Unexpected type splice:") <+> ppr ty)
 
+-- remove the doc nodes here, no need to worry about the location since
+-- its the same for a doc node and it's child type node
+kc_hs_type (HsDocTy ty _)
+  = kc_hs_type (unLoc ty) 
 
 ---------------------------
 kcApps :: TcKind			-- Function kind
@@ -501,6 +496,8 @@ ds_type full_ty@(HsForAllTy exp tv_names ctxt ty)
     dsHsType ty				`thenM` \ tau ->
     returnM (mkSigmaTy tyvars theta tau)
 
+ds_type (HsSpliceTy {}) = panic "ds_type: HsSpliceTy"
+
 dsHsTypes arg_tys = mappM dsHsType arg_tys
 \end{code}
 
@@ -623,7 +620,8 @@ tcDataKindSig :: Maybe Kind -> TcM [TyVar]
 -- GADT decls can have a (perhaps partial) kind signature
 --	e.g.  data T :: * -> * -> * where ...
 -- This function makes up suitable (kinded) type variables for 
--- the argument kinds, and checks that the result kind is indeed *
+-- the argument kinds, and checks that the result kind is indeed *.
+-- We use it also to make up argument type variables for for data instances.
 tcDataKindSig Nothing = return []
 tcDataKindSig (Just kind)
   = do	{ checkTc (isLiftedTypeKind res_kind) (badKindSig kind)