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

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

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index dc00198..8e3704c 100644 (file)
--- 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 606181b..066bc1c 100644 (file)
--- 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 3621264..83450fa 100644 (file)
--- 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 8a381e1..ad4a408 100644 (file)
--- 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 21e9592..399a3c9 100644 (file)
--- 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 bb0593a..f2a15df 100644 (file)
--- 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 702ac98..a1e1678 100644 (file)
--- 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 95a5bdd..4f33951 100644 (file)
--- 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