[project @ 2003-10-21 12:54:17 by simonpj]

1. A tiresome change to HsType, to keep a record of whether or not
   the HsForAll was originally explicitly-quantified.  This is
   solely so that the type checker can print out messages that
   show the source code the programmer wrote.  Tiresome but
   easy.

2. Improve reporting of kind errors.

ghc/compiler/hsSyn/Convert.lhs

@@ -19,7 +19,7 @@ import HsSyn as Hs
 		HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..),
 		Stmt(..), HsBinds(..), MonoBinds(..), Sig(..),
 		Pat(..), HsConDetails(..), HsOverLit, BangType(..),
-		placeHolderType, HsType(..), 
+		placeHolderType, HsType(..), HsExplicitForAll(..),
 		HsTyVarBndr(..), HsContext,
 		mkSimpleMatch, mkHsForAllTy
 	) 
@@ -98,9 +98,7 @@ cvt_top (InstanceD tys ty decs)
   = Left $ InstD (InstDecl inst_ty binds sigs loc0)
   where
     (binds, sigs) = cvtBindsAndSigs decs
-    inst_ty = HsForAllTy Nothing 
-			 (cvt_context tys) 
-			 (HsPredTy (cvt_pred ty))
+    inst_ty = mkImplicitHsForAllTy (cvt_context tys) (HsPredTy (cvt_pred ty))
 
 cvt_top (Meta.SigD nm typ) = Left $ Hs.SigD (Sig (vName nm) (cvtType typ) loc0)
 
@@ -321,9 +319,8 @@ cvtType ty = trans (root ty [])
 	trans (VarT nm, args)	    = foldl HsAppTy (HsTyVar (tName nm)) args
         trans (ConT tc, args)       = foldl HsAppTy (HsTyVar (tconName tc)) args
 
-	trans (ForallT tvs cxt ty, []) = mkHsForAllTy (Just (cvt_tvs tvs))
-				  		      (cvt_context cxt)
-				      		      (cvtType ty)
+	trans (ForallT tvs cxt ty, []) = mkExplicitHsForAllTy 
+						(cvt_tvs tvs) (cvt_context cxt) (cvtType ty)
 
 split_ty_app :: Meta.Type -> (Meta.Type, [Meta.Type])
 split_ty_app ty = go ty []

ghc/compiler/hsSyn/HsDecls.lhs

@@ -476,7 +476,7 @@ unbangedType ty = BangType HsNoBang ty
 \begin{code}
 instance (OutputableBndr name) => Outputable (ConDecl name) where
     ppr (ConDecl con tvs cxt con_details loc)
-      = sep [pprHsForAll tvs cxt, ppr_con_details con con_details]
+      = sep [pprHsForAll Explicit tvs cxt, ppr_con_details con con_details]
 
 ppr_con_details con (InfixCon ty1 ty2)
   = hsep [ppr ty1, ppr con, ppr ty2]

ghc/compiler/hsSyn/HsTypes.lhs

@@ -5,10 +5,10 @@
 
 \begin{code}
 module HsTypes (
-	  HsType(..), HsTyVarBndr(..), 
+	  HsType(..), HsTyVarBndr(..), HsExplicitForAll(..),
 	, HsContext, HsPred(..)
 
-	, mkHsForAllTy, mkHsDictTy, mkHsIParamTy
+	, mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkHsDictTy, mkHsIParamTy
 	, hsTyVarName, hsTyVarNames, replaceTyVarName
 	, splitHsInstDeclTy
 	
@@ -32,6 +32,7 @@ import PprType		( {- instance Outputable Kind -}, pprParendKind, pprKind )
 import BasicTypes	( IPName, Boxity, tupleParens )
 import PrelNames	( unboundKey )
 import SrcLoc		( noSrcLoc )
+import CmdLineOpts	( opt_PprStyle_Debug )
 import Outputable
 \end{code}
 
@@ -80,7 +81,11 @@ data HsPred name = HsClassP name [HsType name]
 		 | HsIParam (IPName name) (HsType name)
 
 data HsType name
-  = HsForAllTy	(Maybe [HsTyVarBndr name])	-- Nothing for implicitly quantified signatures
+  = HsForAllTy	HsExplicitForAll	-- Renamer leaves this flag unchanged, to record the way
+					-- the user wrote it originally, so that the printer can
+					-- print it as the user wrote it
+		[HsTyVarBndr name]	-- With ImplicitForAll, this is the empty list
+					-- until the renamer fills in the variables
 		(HsContext name)
 		(HsType name)
 
@@ -117,6 +122,7 @@ data HsType name
   | HsKindSig		(HsType name)	-- (ty :: kind)
 			Kind		-- A type with a kind signature
 
+data HsExplicitForAll = Explicit | Implicit
 
 -----------------------
 -- Combine adjacent for-alls. 
@@ -128,18 +134,22 @@ data HsType name
 --
 -- A valid type must have one for-all at the top of the type, or of the fn arg types
 
-mkHsForAllTy mtvs []   ty = mk_forall_ty mtvs ty
-mkHsForAllTy mtvs ctxt ty = HsForAllTy mtvs ctxt ty
+mkImplicitHsForAllTy     ctxt ty = mkHsForAllTy Implicit [] ctxt ty
+mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty
+
+mkHsForAllTy :: HsExplicitForAll -> [HsTyVarBndr name] -> HsContext name -> HsType name -> HsType name
+-- Smart constructor for HsForAllTy
+mkHsForAllTy exp tvs []   ty = mk_forall_ty exp tvs ty
+mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty
 
 -- mk_forall_ty makes a pure for-all type (no context)
-mk_forall_ty (Just []) ty 			  = ty	-- Explicit for-all with no tyvars
-mk_forall_ty mtvs1     (HsParTy ty)		  = mk_forall_ty mtvs1 ty
-mk_forall_ty mtvs1     (HsForAllTy mtvs2 ctxt ty) = mkHsForAllTy (mtvs1 `plus` mtvs2) ctxt ty
-mk_forall_ty mtvs1     ty			  = HsForAllTy mtvs1 [] ty
+mk_forall_ty Explicit [] ty 			      = ty	-- Explicit for-all with no tyvars
+mk_forall_ty exp  tvs  (HsParTy ty)		      = mk_forall_ty exp tvs ty
+mk_forall_ty exp1 tvs1 (HsForAllTy exp2 tvs2 ctxt ty) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty
+mk_forall_ty exp  tvs  ty			      = HsForAllTy exp tvs [] ty
 
-mtvs1       `plus` Nothing     = mtvs1
-Nothing     `plus` mtvs2       = mtvs2 
-(Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
+Implicit `plus` Implicit = Implicit
+exp1     `plus` exp2     = Explicit
 
 mkHsDictTy cls tys = HsPredTy (HsClassP cls tys)
 mkHsIParamTy v ty  = HsPredTy (HsIParam v ty)
@@ -183,7 +193,8 @@ splitHsInstDeclTy
 
 splitHsInstDeclTy inst_ty
   = case inst_ty of
-	HsForAllTy (Just tvs) cxt1 tau 
+	HsForAllTy _ tvs cxt1 tau 	-- The type vars should have been
+					-- computed by now, even if they were implicit
 	      -> (tvs, cxt1++cxt2, cls, tys)
 	      where
 		 (cxt2, cls, tys) = split_tau tau
@@ -226,8 +237,14 @@ pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
 pprHsTyVarBndr name kind | kind `eqKind` liftedTypeKind = ppr name
 			 | otherwise 	  	        = hsep [ppr name, dcolon, pprParendKind kind]
 
-pprHsForAll []  []  = empty
-pprHsForAll tvs cxt = ptext SLIT("forall") <+> interppSP tvs <+> pprHsContext cxt
+pprHsForAll exp tvs cxt 
+  | show_forall = forall_part <+> pprHsContext cxt
+  | otherwise   = pprHsContext cxt
+  where
+    show_forall =  opt_PprStyle_Debug
+		|| (not (null tvs) && is_explicit)
+    is_explicit = case exp of {Explicit -> True; Implicit -> False}
+    forall_part = ptext SLIT("forall") <+> interppSP tvs <> dot
 
 pprHsContext :: (Outputable name) => HsContext name -> SDoc
 pprHsContext []	 = empty
@@ -264,16 +281,11 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty
 -- (b) Drop top-level for-all type variables in user style
 --     since they are implicit in Haskell
 prepare sty (HsParTy ty)	  = prepare sty ty
-prepare sty (HsForAllTy _ cxt ty) | userStyle sty = (HsForAllTy Nothing cxt ty)
 prepare sty ty			  = ty
 
-ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty)
+ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
   = maybeParen ctxt_prec pREC_FUN $
-    sep [pp_header, ppr_mono_ty pREC_TOP ty]
-  where
-    pp_header = case maybe_tvs of
-		  Just tvs -> pprHsForAll tvs ctxt
-		  Nothing  -> pprHsContext ctxt
+    sep [pprHsForAll exp tvs ctxt, ppr_mono_ty pREC_TOP ty]
 
 ppr_mono_ty ctxt_prec (HsTyVar name)      = ppr name
 ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   = ppr_fun_ty ctxt_prec ty1 ty2

ghc/compiler/parser/Parser.y

 {-								-*-haskell-*-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.126 2003/10/09 11:59:02 simonpj Exp $
+$Id: Parser.y,v 1.127 2003/10/21 12:54:21 simonpj Exp $
 
 Haskell grammar.
 
@@ -673,7 +673,8 @@ sigtypes :: { [RdrNameHsType] }
 	| sigtypes ',' sigtype		{ $3 : $1 }
 
 sigtype :: { RdrNameHsType }
-	: ctype				{ mkHsForAllTy Nothing [] $1 }
+	: ctype				{ mkImplicitHsForAllTy [] $1 }
+	-- Wrap an Implicit forall if there isn't one there already
 
 sig_vars :: { [RdrName] }
 	 : sig_vars ',' var		{ $3 : $1 }
@@ -684,8 +685,8 @@ sig_vars :: { [RdrName] }
 
 -- A ctype is a for-all type
 ctype	:: { RdrNameHsType }
-	: 'forall' tv_bndrs '.' ctype	{ mkHsForAllTy (Just $2) [] $4 }
-	| context '=>' type		{ mkHsForAllTy Nothing   $1 $3 }
+	: 'forall' tv_bndrs '.' ctype	{ mkExplicitHsForAllTy $2 [] $4 }
+	| context '=>' type		{ mkImplicitHsForAllTy   $1 $3 }
 	-- A type of form (context => type) is an *implicit* HsForAllTy
 	| type				{ $1 }
 

ghc/compiler/parser/ParserCore.y

@@ -318,8 +318,8 @@ ifaceExtRdrName :: IfaceExtName -> RdrName
 ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ
 ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
 
-add_forall tv (HsForAllTy (Just tvs) cxt t) = HsForAllTy (Just (tv:tvs)) cxt t
-add_forall tv t                             = HsForAllTy (Just [tv]) [] t
+add_forall tv (HsForAllTy exp tvs cxt t) = HsForAllTy exp (tv:tvs) cxt t
+add_forall tv t                          = HsForAllTy Explicit [tv] [] t
   
 happyError :: P a 
 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l

ghc/compiler/parser/RdrHsSyn.lhs

@@ -194,23 +194,22 @@ extract_ctxt ctxt acc = foldr extract_pred acc ctxt
 extract_pred (HsClassP cls tys) acc	= foldr extract_ty (cls : acc) tys
 extract_pred (HsIParam n ty) acc	= extract_ty ty acc
 
-extract_ty (HsAppTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (HsListTy ty)              acc = extract_ty ty acc
-extract_ty (HsPArrTy ty)              acc = extract_ty ty acc
-extract_ty (HsTupleTy _ tys)          acc = foldr extract_ty acc tys
-extract_ty (HsFunTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (HsPredTy p)		      acc = extract_pred p acc
-extract_ty (HsTyVar tv)               acc = tv : acc
-extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc)
-extract_ty (HsOpTy ty1 nam ty2)       acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (HsParTy ty)               acc = extract_ty ty acc
--- Generics
-extract_ty (HsNumTy num)              acc = acc
-extract_ty (HsKindSig ty k)	      acc = extract_ty ty acc
-extract_ty (HsForAllTy (Just tvs) ctxt ty) 
+extract_ty (HsAppTy ty1 ty2)         acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsListTy ty)             acc = extract_ty ty acc
+extract_ty (HsPArrTy ty)             acc = extract_ty ty acc
+extract_ty (HsTupleTy _ tys)         acc = foldr extract_ty acc tys
+extract_ty (HsFunTy ty1 ty2)         acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsPredTy p)		     acc = extract_pred p acc
+extract_ty (HsTyVar tv)              acc = tv : acc
+extract_ty (HsOpTy ty1 nam ty2)      acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsParTy ty)              acc = extract_ty ty acc
+extract_ty (HsNumTy num)             acc = acc
+extract_ty (HsKindSig ty k)	     acc = extract_ty ty acc
+extract_ty (HsForAllTy exp [] cx ty) acc = extract_ctxt cx (extract_ty ty acc)
+extract_ty (HsForAllTy exp tvs cx ty) 
                                 acc = acc ++
                                       (filter (`notElem` locals) $
-				       extract_ctxt ctxt (extract_ty ty []))
+				       extract_ctxt cx (extract_ty ty []))
 				    where
 				      locals = hsTyVarNames tvs
 
@@ -378,14 +377,14 @@ hsIfaceName rdr_name	-- Qualify unqualifed occurrences
   | otherwise         = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
 
 hsIfaceType :: HsType RdrName -> IfaceType	
-hsIfaceType (HsForAllTy mb_tvs cxt ty) 
-  = foldr (IfaceForAllTy . hsIfaceTv) rho tvs
+hsIfaceType (HsForAllTy exp tvs cxt ty) 
+  = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
   where
     rho = foldr (IfaceFunTy . IfacePredTy . hsIfacePred) tau cxt
     tau = hsIfaceType ty
-    tvs = case mb_tvs of
-	    Just tvs -> tvs
-	    Nothing  -> map UserTyVar (extractHsRhoRdrTyVars cxt ty)
+    tvs' = case exp of
+	     Explicit -> tvs
+	     Implicit -> map UserTyVar (extractHsRhoRdrTyVars cxt ty)
 
 hsIfaceType ty@(HsTyVar _)     = hs_tc_app ty []
 hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
@@ -634,14 +633,14 @@ tyConToDataCon tc
 checkInstType :: RdrNameHsType -> P RdrNameHsType
 checkInstType t 
   = case t of
-	HsForAllTy tvs ctxt ty ->
+	HsForAllTy exp tvs ctxt ty ->
 		checkDictTy ty [] >>= \ dict_ty ->
-	      	return (HsForAllTy tvs ctxt dict_ty)
+	      	return (HsForAllTy exp tvs ctxt dict_ty)
 
         HsParTy ty -> checkInstType ty
 
 	ty ->   checkDictTy ty [] >>= \ dict_ty->
-	      	return (HsForAllTy Nothing [] dict_ty)
+	      	return (HsForAllTy Implicit [] [] dict_ty)
 
 checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
 checkTyVars tvs 
@@ -769,7 +768,7 @@ checkPat e [] = case e of
 			      -- but they aren't explicit forall points.  Hence
 			      -- we have to remove the implicit forall here.
 			      let t' = case t of 
-					  HsForAllTy Nothing [] ty -> ty
+					  HsForAllTy Implicit _ [] ty -> ty
 					  other -> other
 			      in
 			      return (SigPatIn e t')

ghc/compiler/rename/RnHsSyn.lhs

@@ -86,11 +86,10 @@ extractHsTyNames ty
     get (HsNumTy n)            = emptyNameSet
     get (HsTyVar tv)	       = unitNameSet tv
     get (HsKindSig ty k)       = get ty
-    get (HsForAllTy (Just tvs) 
+    get (HsForAllTy _ tvs 
 		    ctxt ty)   = (extractHsCtxtTyNames ctxt `unionNameSets` get ty)
 					    `minusNameSet`
 				  mkNameSet (hsTyVarNames tvs)
-    get ty@(HsForAllTy Nothing _ _) = pprPanic "extractHsTyNames" (ppr ty)
 
 extractHsTyNames_s  :: [RenamedHsType] -> NameSet
 extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys

ghc/compiler/rename/RnTypes.lhs

@@ -75,7 +75,7 @@ want a gratuitous knot.
 \begin{code}
 rnHsType :: SDoc -> RdrNameHsType -> RnM RenamedHsType
 
-rnHsType doc (HsForAllTy Nothing ctxt ty)
+rnHsType doc (HsForAllTy Implicit _ ctxt ty)
 	-- Implicit quantifiction in source code (no kinds on tyvars)
 	-- Given the signature  C => T  we universally quantify 
 	-- over FV(T) \ {in-scope-tyvars} 
@@ -89,9 +89,9 @@ rnHsType doc (HsForAllTy Nothing ctxt ty)
 	--	class C a where { op :: a -> a }
 	forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env)) mentioned
     in
-    rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
+    rnForAll doc Implicit (map UserTyVar forall_tyvars) ctxt ty
 
-rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
+rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau)
 	-- Explicit quantification.
 	-- Check that the forall'd tyvars are actually 
 	-- mentioned in the type, and produce a warning if not
@@ -103,7 +103,7 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
 	warn_guys = filter (`notElem` mentioned) forall_tyvar_names
     in
     mappM_ (forAllWarn doc tau) warn_guys	`thenM_`
-    rnForAll doc forall_tyvars ctxt tau
+    rnForAll doc Explicit forall_tyvars ctxt tau
 
 rnHsType doc (HsTyVar tyvar)
   = lookupOccRn tyvar 		`thenM` \ tyvar' ->
@@ -167,11 +167,11 @@ rnHsTypes doc tys = mappM (rnHsType doc) tys
 
 
 \begin{code}
-rnForAll doc forall_tyvars ctxt ty
+rnForAll doc exp forall_tyvars ctxt ty
   = bindTyVarsRn doc forall_tyvars	$ \ new_tyvars ->
     rnContext doc ctxt			`thenM` \ new_ctxt ->
     rnHsType doc ty			`thenM` \ new_ty ->
-    returnM (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
+    returnM (HsForAllTy exp new_tyvars new_ctxt new_ty)
 \end{code}
 
 

ghc/compiler/typecheck/TcBinds.lhs

@@ -544,7 +544,7 @@ checkSigsTyVars qtvs sigs
   where
     check_one (TySigInfo id sig_tyvars sig_theta sig_tau _ _ src_loc)
       = addSrcLoc src_loc						$
-	addErrCtxt (ptext SLIT("When checking the type signature for") 
+	addErrCtxt (ptext SLIT("In the type signature for") 
 		      <+> quotes (ppr id))				$
 	addErrCtxtM (sigCtxt id sig_tyvars sig_theta sig_tau)		$
 	checkSigTyVarsWrt (idFreeTyVars id) sig_tyvars

ghc/compiler/typecheck/TcClassDcl.lhs

@@ -12,10 +12,11 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
 
 #include "HsVersions.h"
 
-import HsSyn		( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..),
+import HsSyn		( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..), 
 			  HsExpr(..), HsLit(..), Pat(WildPat), HsTyVarBndr(..),
+			  HsExplicitForAll(..),
 			  mkSimpleMatch, andMonoBinds, andMonoBindList, 
-			  isPragSig, placeHolderType, mkHsForAllTy
+			  isPragSig, placeHolderType, mkExplicitHsForAllTy
 			)
 import BasicTypes	( RecFlag(..), NewOrData(..) )
 import RnHsSyn		( RenamedTyClDecl, RenamedSig,
@@ -699,8 +700,12 @@ groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
 eqPatType :: HsType Name -> HsType Name -> Bool
 -- A very simple equality function, only for 
 -- type patterns in generic function definitions.
-eqPatType (HsTyVar v1)    (HsTyVar v2)    = v1==v2
-eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2
+eqPatType (HsTyVar v1)       (HsTyVar v2)    	= v1==v2
+eqPatType (HsAppTy s1 t1)    (HsAppTy s2 t2) 	= s1 `eqPatType` s2 && t2 `eqPatType` t2
+eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2 && op1 == op2
+eqPatType (HsNumTy n1)	     (HsNumTy n2)	= n1 == n2
+eqPatType (HsParTy t1)	     t2			= t1 `eqPatType` t2
+eqPatType t1		     (HsParTy t2)	= t1 `eqPatType` t2
 eqPatType _ _ = False
 
 ---------------------------------
@@ -717,7 +722,7 @@ mkGenericInstance clas loc (hs_ty, binds)
 	-- works in the standard way
     let
 	sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty))
-	hs_forall_ty = mkHsForAllTy (Just sig_tvs) [] hs_ty
+	hs_forall_ty = mkExplicitHsForAllTy sig_tvs [] hs_ty
     in
 	-- Type-check the instance type, and check its form
     tcHsSigType GenPatCtxt hs_forall_ty		`thenM` \ forall_inst_ty ->
@@ -798,7 +803,7 @@ dupGenericInsts tc_inst_infos
 	  ptext SLIT("All the type patterns for a generic type constructor must be identical")
     ]
   where 
-    ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
+    ppr_inst_ty (tc,inst) = ppr tc <+> ppr (simpleInstInfoTy inst)
 
 mixedGenericErr op
   = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)

ghc/compiler/typecheck/TcExpr.lhs

@@ -986,7 +986,7 @@ caseScrutCtxt expr
   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
 
 exprSigCtxt expr
-  = hang (ptext SLIT("When checking the type signature of the expression:"))
+  = hang (ptext SLIT("In the type signature of the expression:"))
 	 4 (ppr expr)
 
 exprCtxt expr

ghc/compiler/typecheck/TcGenDeriv.lhs

@@ -1167,7 +1167,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
     get_tag_rhs = ExprWithTySig 
 			(HsLam (mkSimpleHsAlt (VarPat a_RDR) 
 					      (HsApp (HsVar getTag_RDR) a_Expr)))
-			(HsForAllTy (Just (map UserTyVar tvs)) [] con2tag_ty)
+			(mkExplicitHsForAllTy (map UserTyVar tvs) [] con2tag_ty)
 
     con2tag_ty = foldl HsAppTy (HsTyVar (getRdrName tycon)) 
 		       (map HsTyVar tvs)

ghc/compiler/typecheck/TcHsType.lhs

@@ -32,14 +32,14 @@ import TcEnv		( tcExtendTyVarEnv, tcExtendTyVarKindEnv,
 		 	  TyThing(..), TcTyThing(..), 
 			  getInLocalScope
 			)
-import TcMType		( newKindVar, tcInstType, newMutTyVar,
+import TcMType		( newKindVar, newOpenTypeKind, tcInstType, newMutTyVar, 
 			  zonkTcType, zonkTcKindToKind,
 			  checkValidType, UserTypeCtxt(..), pprHsSigCtxt
 			)
-import TcUnify		( unifyKind, unifyFunKind, unifyTypeKind )
+import TcUnify		( unifyKind, unifyFunKind )
 import TcType		( Type, PredType(..), ThetaType, TyVarDetails(..),
 			  TcTyVar, TcKind, TcThetaType, TcTauType,
-			  mkTyVarTy, mkTyVarTys, mkFunTy, 
+			  mkTyVarTy, mkTyVarTys, mkFunTy, isTypeKind,
 		 	  mkForAllTys, mkFunTys, tcEqType, isPredTy,
 			  mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, 
 			  liftedTypeKind, unliftedTypeKind, eqKind,
@@ -204,15 +204,21 @@ tcHsKindedContext hs_theta = mappM dsHsPred hs_theta
 \begin{code}
 ---------------------------
 kcLiftedType :: HsType Name -> TcM (HsType Name)
-	-- The type ty must be a *lifted* *type*
+-- The type ty must be a *lifted* *type*
 kcLiftedType ty = kcCheckHsType ty liftedTypeKind
     
 ---------------------------
 kcTypeType :: HsType Name -> TcM (HsType Name)
-	-- The type ty must be a *type*, but it can be lifted or unlifted
+-- The type ty must be a *type*, but it can be lifted or unlifted
+-- Be sure to use checkExpectedKind, rather than simply unifying 
+-- with (Type bx), because it gives better error messages
 kcTypeType ty
   = kcHsType ty			`thenM` \ (ty', kind) ->
-    unifyTypeKind kind		`thenM_`
+    if isTypeKind kind then
+	return ty'
+    else
+    newOpenTypeKind				`thenM` \ type_kind ->
+    checkExpectedKind (ppr ty) kind type_kind	`thenM_`
     returnM ty'
 
 ---------------------------
@@ -292,14 +298,14 @@ kcHsType (HsPredTy pred)
   = kcHsPred pred		`thenM` \ pred' ->
     returnM (HsPredTy pred', liftedTypeKind)
 
-kcHsType (HsForAllTy (Just tv_names) context ty)
+kcHsType (HsForAllTy exp tv_names context ty)
   = kcHsTyVars tv_names		$ \ tv_names' ->
     kcHsContext context		`thenM`	\ ctxt' ->
     kcLiftedType ty		`thenM` \ ty' ->
 	-- The body of a forall must be of kind *
 	-- In principle, I suppose, we could allow unlifted types,
 	-- but it seems simpler to stick to lifted types for now.
-    returnM (HsForAllTy (Just tv_names') ctxt' ty', liftedTypeKind)
+    returnM (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind)
 
 ---------------------------
 kcApps :: TcKind		-- Function kind
@@ -483,7 +489,7 @@ dsHsType (HsPredTy pred)
   = dsHsPred pred	`thenM` \ pred' ->
     returnM (mkPredTy pred')
 
-dsHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty)
+dsHsType full_ty@(HsForAllTy exp tv_names ctxt ty)
   = tcTyVarBndrs tv_names		$ \ tyvars ->
     mappM dsHsPred ctxt			`thenM` \ theta ->
     dsHsType ty				`thenM` \ tau ->

ghc/compiler/typecheck/TcInstDcls.lhs

@@ -680,9 +680,9 @@ simplified: only zeze2 is extracted and its body is simplified.
 \begin{code}
 instDeclCtxt1 hs_inst_ty 
   = inst_decl_ctxt (case hs_inst_ty of
-			HsForAllTy _ _ (HsPredTy pred) -> ppr pred
-			HsPredTy pred	      	       -> ppr pred
-			other			       -> ppr hs_inst_ty)	-- Don't expect this
+			HsForAllTy _ _ _ (HsPredTy pred) -> ppr pred
+			HsPredTy pred	                 -> ppr pred
+			other			         -> ppr hs_inst_ty)	-- Don't expect this
 instDeclCtxt2 dfun_ty
   = inst_decl_ctxt (ppr (mkClassPred cls tys))
   where

ghc/compiler/typecheck/TcMType.lhs

@@ -14,7 +14,7 @@ module TcMType (
   newTyVar, newSigTyVar,
   newTyVarTy,		-- Kind -> TcM TcType
   newTyVarTys,		-- Int -> Kind -> TcM [TcType]
-  newKindVar, newKindVars, newBoxityVar,
+  newKindVar, newKindVars, newOpenTypeKind,
   putTcTyVar, getTcTyVar,
   newMutTyVar, readMutTyVar, writeMutTyVar, 
 
@@ -49,7 +49,7 @@ import TypeRep		( Type(..), PredType(..), TyNote(..),	 -- Friend; can see repres
 			) 
 import TcType		( TcType, TcThetaType, TcTauType, TcPredType,
 			  TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..),
-			  tcEqType, tcCmpPred, isClassPred,
+			  tcEqType, tcCmpPred, isClassPred, mkTyConApp, typeCon,
 			  tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, 
 			  tcSplitTyConApp_maybe, tcSplitForAllTys,
 			  tcIsTyVarTy, tcSplitSigmaTy, tcIsTyVarTy,
@@ -134,6 +134,10 @@ newBoxityVar :: TcM TcKind	-- Really TcBoxity
     newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) 
 		superBoxity VanillaTv			  `thenM` \ kv ->
     returnM (TyVarTy kv)
+
+newOpenTypeKind :: TcM TcKind
+newOpenTypeKind = newBoxityVar	`thenM` \ bx_var ->
+		  returnM (mkTyConApp typeCon [bx_var])
 \end{code}
 
 

ghc/compiler/typecheck/TcType.lhs

@@ -86,7 +86,7 @@ module TcType (
   Kind, 	-- Stuff to do with kinds is insensitive to pre/post Tc
   unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, 
   superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind,
-  isTypeKind, isAnyTypeKind,
+  isTypeKind, isAnyTypeKind, typeCon,
 
   Type, PredType(..), ThetaType, 
   mkForAllTy, mkForAllTys, 
@@ -117,7 +117,7 @@ import TypeRep		( Type(..), TyNote(..), funTyCon )  -- friend
 import Type		(	-- Re-exports
 			  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
 			  tyVarsOfTheta, Kind, Type, PredType(..),
-			  ThetaType, unliftedTypeKind,
+			  ThetaType, unliftedTypeKind, typeCon,
 			  liftedTypeKind, openTypeKind, mkArrowKind,
 			  mkArrowKinds, mkForAllTy, mkForAllTys,
 			  defaultKind, isTypeKind, isAnyTypeKind,

ghc/compiler/typecheck/TcUnify.lhs

@@ -11,7 +11,7 @@ module TcUnify (
 
 	-- Various unifications
   unifyTauTy, unifyTauTyList, unifyTauTyLists, 
-  unifyKind, unifyKinds, unifyTypeKind, unifyFunKind,
+  unifyKind, unifyKinds, unifyFunKind, 
 
   --------------------------------
   -- Holes
@@ -47,7 +47,7 @@ import TcType		( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
 			)
 import Inst		( newDicts, instToId, tcInstCall )
 import TcMType		( getTcTyVar, putTcTyVar, tcInstType, newKindVar,
-			  newTyVarTy, newTyVarTys, newBoxityVar, 
+			  newTyVarTy, newTyVarTys, newOpenTypeKind,
 			  zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV )
 import TcSimplify	( tcSimplifyCheck )
 import TysWiredIn	( listTyCon, parrTyCon, tupleTyCon )
@@ -921,8 +921,8 @@ unifyTypeKind ty@(TyVarTy tyvar)
   = getTcTyVar tyvar	`thenM` \ maybe_ty ->
     case maybe_ty of
 	Just ty' -> unifyTypeKind ty'
-	Nothing	 -> newBoxityVar					`thenM` \ bx_var ->
-		    putTcTyVar tyvar (mkTyConApp typeCon [bx_var])	`thenM_`
+	Nothing	 -> newOpenTypeKind		`thenM` \ kind -> 
+		    putTcTyVar tyvar kind	`thenM_`
 		    returnM ()
 	
 unifyTypeKind ty