From 3df40b7b78044206bbcffe3e2c0a57d901baf5e8 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Tue, 27 Jul 1999 07:31:24 +0000
Subject: [PATCH] [project @ 1999-07-27 07:31:16 by simonpj] Do a more correct
job of explicit for-alls in types
---
ghc/compiler/hsSyn/HsTypes.lhs | 29 +++++--
ghc/compiler/parser/Parser.y | 13 ++--
ghc/compiler/rename/ParseIface.y | 2 +-
ghc/compiler/rename/RnExpr.lhs | 4 +-
ghc/compiler/rename/RnSource.hi-boot | 8 +-
ghc/compiler/rename/RnSource.hi-boot-5 | 8 +-
ghc/compiler/rename/RnSource.lhs | 102 +++++++++++++++----------
ghc/compiler/typecheck/TcType.lhs | 7 +-
8 files changed, 106 insertions(+), 67 deletions(-)
diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index dc00198d826a..8e3704cbcb92 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 606181bcf611..066bc1c15068 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 362126453ae6..83450fa07145 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 8a381e1e16b8..ad4a4085901d 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 21e9592ffdb7..399a3c98531c 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 bb0593a764b4..f2a15df1abf2 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 702ac985def8..a1e1678efce2 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 95a5bddd7efc..4f33951e2b42 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
--
GitLab