[project @ 1999-07-27 07:31:16 by simonpj]

Do a more correct job of explicit for-alls in types

8 files changed, 106 insertions, 67 deletions

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index dc00198d82..8e3704cbcb 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -66,8 +66,22 @@ data MonoUsageAnn name
   | MonoUsVar name
   
 
-mkHsForAllTy []  []   ty = ty
-mkHsForAllTy tvs ctxt ty = HsForAllTy (Just tvs) ctxt ty
+-- Combine adjacent for-alls. 
+-- The following awkward situation can happen otherwise:
+--	f :: forall a. ((Num a) => Int)
+-- might generate HsForAll (Just [a]) [] (HsForAll Nothing [Num a] t)
+-- Then a isn't discovered as ambiguous, and we abstract the AbsBinds wrt []
+-- but the export list abstracts f wrt [a].  Disaster.
+--
+-- A valid type must have one for-all at the top of the type, or of the fn arg types
+
+mkHsForAllTy (Just []) [] ty = ty	-- Explicit for-all with no tyvars
+mkHsForAllTy mtvs1     [] (HsForAllTy mtvs2 ctxt ty) = HsForAllTy (mtvs1 `plus` mtvs2) ctxt ty
+						     where
+						       mtvs1       `plus` Nothing     = mtvs1
+						       Nothing     `plus` mtvs2       = mtvs2 
+						       (Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
+mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
 
 mkHsUsForAllTy uvs ty = foldr (\ uv ty -> MonoUsgForAllTy uv ty)
                               ty uvs
@@ -103,7 +117,8 @@ instance (Outputable name) => Outputable (HsTyVar name) where
     ppr (UserTyVar name)       = ppr name
     ppr (IfaceTyVar name kind) = hsep [ppr name, dcolon, ppr kind]
 
-pprForAll []  = empty
+-- Better to see those for-alls
+-- pprForAll []  = empty
 pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
 
 pprContext :: (Outputable name) => Context name -> SDoc
@@ -133,11 +148,11 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty
 
 ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty)
   = maybeParen (ctxt_prec >= pREC_FUN) $
-    sep [pprForAll tvs, pprContext ctxt, pprHsType ty]
+    sep [pp_tvs, pprContext ctxt, pprHsType ty]
   where
-    tvs = case maybe_tvs of
-		Just tvs -> tvs
-		Nothing  -> []
+    pp_tvs = case maybe_tvs of
+		Just tvs -> pprForAll tvs
+		Nothing  -> text "{- implicit forall -}"
 
 ppr_mono_ty ctxt_prec (MonoTyVar name)
   = ppr name
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 606181bcf6..066bc1c150 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.11 1999/07/26 16:06:28 simonpj Exp $
+$Id: Parser.y,v 1.12 1999/07/27 07:31:18 simonpj Exp $
 
 Haskell grammar.
 
@@ -403,9 +403,7 @@ signdecl :: { RdrBinding }
 					      [ RdrSig (Sig n $4 $2) | n <- $1 ] }
 
 sigtype :: { RdrNameHsType }
-	: ctype			{ case $1 of
-		    	      	    HsForAllTy _ _ _ -> $1
-		    	      	    other	     -> HsForAllTy Nothing [] $1 }
+	: ctype			{ mkHsForAllTy Nothing [] $1 }
 
 {-
   ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var
@@ -502,9 +500,10 @@ inst_type :: { RdrNameHsType }
 
 ctype	:: { RdrNameHsType }
 	: 'forall' tyvars '.' context type
-					{ HsForAllTy (Just $2) $4 $5 }
-	| 'forall' tyvars '.' type	{ HsForAllTy (Just $2) [] $4 }
-	| context type			{ HsForAllTy Nothing   $1 $2 }
+					{ mkHsForAllTy (Just $2) $4 $5 }
+	| 'forall' tyvars '.' type	{ mkHsForAllTy (Just $2) [] $4 }
+	| context type			{ mkHsForAllTy Nothing   $1 $2 }
+		-- A type of form (context => type) is an *implicit* HsForAllTy
 	| type				{ $1 }
 
 types0  :: { [RdrNameHsType] }
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 362126453a..83450fa071 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -403,7 +403,7 @@ field		:  var_names1 '::' type		{ ($1, Unbanged $3) }
 type		:: { RdrNameHsType }
 type		: '__fuall'  fuall '=>' type    { mkHsUsForAllTy $2 $4 }
                 | '__forall' forall context '=>' type	
-						{ mkHsForAllTy $2 $3 $5 }
+						{ mkHsForAllTy (Just $2) $3 $5 }
 		| btype '->' type		{ MonoFunTy $1 $3 }
 		| btype				{ $1 }
 
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 8a381e1e16..ad4a408590 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -18,7 +18,7 @@ module RnExpr (
 #include "HsVersions.h"
 
 import {-# SOURCE #-} RnBinds  ( rnBinds ) 
-import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
+import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsPolyType, rnHsType )
 
 import HsSyn
 import RdrHsSyn
@@ -70,7 +70,7 @@ rnPat (VarPatIn name)
 rnPat (SigPatIn pat ty)
   | opt_GlasgowExts
   = rnPat pat		`thenRn` \ (pat', fvs1) ->
-    rnHsType doc ty	`thenRn` \ (ty',  fvs2) ->
+    rnHsPolyType doc ty	`thenRn` \ (ty',  fvs2) ->
     returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
 
   | otherwise
diff --git a/ghc/compiler/rename/RnSource.hi-boot b/ghc/compiler/rename/RnSource.hi-boot
index 21e9592ffd..399a3c9853 100644
--- a/ghc/compiler/rename/RnSource.hi-boot
+++ b/ghc/compiler/rename/RnSource.hi-boot
@@ -1,9 +1,11 @@
 _interface_ RnSource 1
 _exports_
-RnSource rnHsType rnHsSigType;
+RnSource rnHsType rnHsPolyType rnHsSigType;
 _declarations_
+1 rnHsType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
+			          -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
 1 rnHsSigType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
 			          -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
-1 rnHsType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
-			       -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
+1 rnHsPolyType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
+			           -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
 
diff --git a/ghc/compiler/rename/RnSource.hi-boot-5 b/ghc/compiler/rename/RnSource.hi-boot-5
index bb0593a764..f2a15df1ab 100644
--- a/ghc/compiler/rename/RnSource.hi-boot-5
+++ b/ghc/compiler/rename/RnSource.hi-boot-5
@@ -1,6 +1,8 @@
 __interface RnSource 1 0 where
-__export RnSource rnHsSigType rnHsType;
+__export RnSource rnHsType rnHsSigType rnHsPolyType;
+1 rnHsType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType
+			         -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
 1 rnHsSigType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType
 			         -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
-1 rnHsType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType
-			      -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
+1 rnHsPolyType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType
+			          -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 702ac985de..a1e1678efc 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -4,7 +4,7 @@
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}
-module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
+module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) where
 
 #include "HsVersions.h"
 
@@ -106,7 +106,7 @@ rnDecl (ValD binds) = rnTopBinds binds	`thenRn` \ (new_binds, fvs) ->
 rnDecl (SigD (IfaceSig name ty id_infos loc))
   = pushSrcLocRn loc $
     lookupBndrRn name		`thenRn` \ name' ->
-    rnHsType doc_str ty		`thenRn` \ (ty',fvs1) ->
+    rnHsPolyType doc_str ty	`thenRn` \ (ty',fvs1) ->
     mapFvRn rnIdInfo id_infos	`thenRn` \ (id_infos', fvs2) -> 
     returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
   where
@@ -420,7 +420,7 @@ rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
     get_var (RuleBndrSig v _) = v
 
     rn_var (RuleBndr v, id)	 = returnRn (RuleBndr id, emptyFVs)
-    rn_var (RuleBndrSig v t, id) = rnHsType doc t	`thenRn` \ (t', fvs) ->
+    rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t	`thenRn` \ (t', fvs) ->
 				   returnRn (RuleBndrSig id t', fvs)
 \end{code}
 
@@ -474,7 +474,7 @@ rnConDetails doc locn (InfixCon ty1 ty2)
     returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
 
 rnConDetails doc locn (NewCon ty mb_field)
-  = rnHsType doc ty			`thenRn` \ (new_ty, fvs) ->
+  = rnHsPolyType doc ty			`thenRn` \ (new_ty, fvs) ->
     rn_field mb_field			`thenRn` \ new_mb_field  ->
     returnRn (NewCon new_ty new_mb_field, fvs)
   where
@@ -496,15 +496,15 @@ rnField doc (names, ty)
     returnRn ((new_names, new_ty), fvs) 
 
 rnBangTy doc (Banged ty)
-  = rnHsType doc ty		`thenRn` \ (new_ty, fvs) ->
+  = rnHsPolyType doc ty		`thenRn` \ (new_ty, fvs) ->
     returnRn (Banged new_ty, fvs)
 
 rnBangTy doc (Unbanged ty)
-  = rnHsType doc ty 		`thenRn` \ (new_ty, fvs) ->
+  = rnHsPolyType doc ty 	`thenRn` \ (new_ty, fvs) ->
     returnRn (Unbanged new_ty, fvs)
 
 rnBangTy doc (Unpacked ty)
-  = rnHsType doc ty 		`thenRn` \ (new_ty, fvs) ->
+  = rnHsPolyType doc ty 	`thenRn` \ (new_ty, fvs) ->
     returnRn (Unpacked new_ty, fvs)
 
 -- This data decl will parse OK
@@ -534,36 +534,15 @@ rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 	-- rnHsSigType is used for source-language type signatures,
 	-- which use *implicit* universal quantification.
 rnHsSigType doc_str ty
-  = rnHsType (text "the type signature for" <+> doc_str) ty
+  = rnHsPolyType (text "the type signature for" <+> doc_str) ty
     
-rnForAll doc forall_tyvars ctxt ty
-  = bindTyVarsFVRn doc forall_tyvars	$ \ new_tyvars ->
-    rnContext doc ctxt			`thenRn` \ (new_ctxt, cxt_fvs) ->
-    rnHsType doc ty			`thenRn` \ (new_ty, ty_fvs) ->
-    returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
-	      cxt_fvs `plusFV` ty_fvs)
-
--- Check that each constraint mentions at least one of the forall'd type variables
--- Since the forall'd type variables are a subset of the free tyvars
--- of the tau-type part, this guarantees that every constraint mentions
--- at least one of the free tyvars in ty
-checkConstraints explicit_forall doc forall_tyvars ctxt ty
-   = mapRn check ctxt			`thenRn` \ maybe_ctxt' ->
-     returnRn (catMaybes maybe_ctxt')
-	    -- Remove problem ones, to avoid duplicate error message.
-   where
-     check ct@(_,tys)
-	| forall_mentioned = returnRn (Just ct)
-	| otherwise	   = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty)
-			     `thenRn_` returnRn Nothing
-        where
-	  forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyRdrTyVars)
-			     False
-			     tys
+---------------------------------------
+rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
+-- rnHsPolyType is prepared to see a for-all; rnHsType is not
+-- The former is called for the top level of type sigs and function args.
 
-rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
-
-rnHsType doc (HsForAllTy Nothing ctxt ty)
+---------------------------------------
+rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
 	-- From source code (no kinds on tyvars)
 	-- Given the signature  C => T  we universally quantify 
 	-- over FV(T) \ {in-scope-tyvars} 
@@ -575,7 +554,7 @@ rnHsType doc (HsForAllTy Nothing ctxt ty)
     checkConstraints False doc forall_tyvars ctxt ty	`thenRn` \ ctxt' ->
     rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
 
-rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
+rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
 	-- Explicit quantification.
 	-- Check that the forall'd tyvars are a subset of the
 	-- free tyvars in the tau-type part
@@ -601,13 +580,49 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
     checkConstraints True doc forall_tyvar_names ctxt tau	`thenRn` \ ctxt' ->
     rnForAll doc forall_tyvars ctxt' tau
 
+rnHsPolyType doc other_ty = rnHsType doc other_ty
+
+
+-- Check that each constraint mentions at least one of the forall'd type variables
+-- Since the forall'd type variables are a subset of the free tyvars
+-- of the tau-type part, this guarantees that every constraint mentions
+-- at least one of the free tyvars in ty
+checkConstraints explicit_forall doc forall_tyvars ctxt ty
+   = mapRn check ctxt			`thenRn` \ maybe_ctxt' ->
+     returnRn (catMaybes maybe_ctxt')
+	    -- Remove problem ones, to avoid duplicate error message.
+   where
+     check ct@(_,tys)
+	| forall_mentioned = returnRn (Just ct)
+	| otherwise	   = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty)
+			     `thenRn_` returnRn Nothing
+        where
+	  forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyRdrTyVars)
+			     False
+			     tys
+
+rnForAll doc forall_tyvars ctxt ty
+  = bindTyVarsFVRn doc forall_tyvars	$ \ new_tyvars ->
+    rnContext doc ctxt			`thenRn` \ (new_ctxt, cxt_fvs) ->
+    rnHsType doc ty			`thenRn` \ (new_ty, ty_fvs) ->
+    returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
+	      cxt_fvs `plusFV` ty_fvs)
+
+---------------------------------------
+rnHsType doc ty@(HsForAllTy _ _ inner_ty)
+  = addErrRn (unexpectedForAllTy ty)	`thenRn_`
+    rnHsPolyType doc ty
+
 rnHsType doc (MonoTyVar tyvar)
   = lookupOccRn tyvar 		`thenRn` \ tyvar' ->
     returnRn (MonoTyVar tyvar', unitFV tyvar')
 
 rnHsType doc (MonoFunTy ty1 ty2)
-  = rnHsType doc ty1	`thenRn` \ (ty1', fvs1) ->
-    rnHsType doc ty2	`thenRn` \ (ty2', fvs2) ->
+  = rnHsPolyType doc ty1	`thenRn` \ (ty1', fvs1) ->
+	-- Might find a for-all as the arg of a function type
+    rnHsPolyType doc ty2	`thenRn` \ (ty2', fvs2) ->
+	-- Or as the result.  This happens when reading Prelude.hi
+	-- when we find return :: forall m. Monad m -> forall a. a -> m a
     returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
 
 rnHsType doc (MonoListTy ty)
@@ -711,7 +726,7 @@ rnRuleBody (UfRuleBody str vars args rhs)
 
 \begin{code}
 rnCoreExpr (UfType ty)
-  = rnHsType (text "unfolding type") ty	`thenRn` \ (ty', fvs) ->
+  = rnHsPolyType (text "unfolding type") ty	`thenRn` \ (ty', fvs) ->
     returnRn (UfType ty', fvs)
 
 rnCoreExpr (UfVar v)
@@ -770,7 +785,7 @@ rnCoreExpr (UfLet (UfRec pairs) body)
 
 \begin{code}
 rnCoreBndr (UfValBinder name ty) thing_inside
-  = rnHsType doc ty		`thenRn` \ (ty', fvs1) ->
+  = rnHsPolyType doc ty		`thenRn` \ (ty', fvs1) ->
     bindCoreLocalFVRn name	( \ name' ->
 	    thing_inside (UfValBinder name' ty')
     )				`thenRn` \ (result, fvs2) ->
@@ -798,7 +813,7 @@ rnCoreAlt (con, bndrs, rhs)
     returnRn (result, fvs1 `plusFV` fvs3)
 
 rnNote (UfCoerce ty)
-  = rnHsType (text "unfolding coerce") ty	`thenRn` \ (ty', fvs) ->
+  = rnHsPolyType (text "unfolding coerce") ty	`thenRn` \ (ty', fvs) ->
     returnRn (UfCoerce ty', fvs)
 
 rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
@@ -817,7 +832,7 @@ rnUfCon (UfLitCon lit)
   = returnRn (UfLitCon lit, emptyFVs)
 
 rnUfCon (UfLitLitCon lit ty)
-  = rnHsType (text "litlit") ty		`thenRn` \ (ty', fvs) ->
+  = rnHsPolyType (text "litlit") ty		`thenRn` \ (ty', fvs) ->
     returnRn (UfLitLitCon lit ty', fvs)
 
 rnUfCon (UfPrimOp op)
@@ -910,6 +925,9 @@ ctxtErr explicit_forall doc tyvars constraint ty
     $$
     (ptext SLIT("In") <+> doc)
 
+unexpectedForAllTy ty
+  = ptext SLIT("Unexpected forall type:") <+> ppr ty
+
 badRuleLhsErr name lhs
   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 	 nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 95a5bddd7e..4f33951e2b 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -312,8 +312,11 @@ zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars
 
 zonkTcTyVarBndr :: TcTyVar -> NF_TcM s TcTyVar
 zonkTcTyVarBndr tyvar
-  = zonkTcTyVar tyvar	`thenNF_Tc` \ (TyVarTy tyvar') ->
-    returnNF_Tc tyvar'
+  = zonkTcTyVar tyvar	`thenNF_Tc` \ ty ->
+    case ty of
+	TyVarTy tyvar' -> returnNF_Tc tyvar'
+	_	       -> pprTrace "zonkTcTyVarBndr" (ppr tyvar <+> ppr ty) $
+			  returnNF_Tc tyvar
 	
 zonkTcTyVar :: TcTyVar -> NF_TcM s TcType
 zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnNF_Tc (TyVarTy tv)) tyvar