From 98d5ffd5eaa8af06c2d3ac7118ed09737c7d2a50 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Wed, 23 Jun 1999 10:38:15 +0000
Subject: [PATCH] [project @ 1999-06-23 10:38:13 by simonmar] Make scoped type
variables work.
---
ghc/compiler/parser/ParseUtil.lhs | 9 ++++++++-
ghc/compiler/parser/RdrHsSyn.lhs | 24 +++++++++++++++---------
ghc/compiler/rename/RnExpr.lhs | 4 ++--
ghc/compiler/rename/RnSource.lhs | 13 +++++--------
4 files changed, 30 insertions(+), 20 deletions(-)
diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index e09f60feb146..ce4f71bfcfb9 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -182,7 +182,14 @@ checkPat e [] = case e of
ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn)
EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n)
ExprWithTySig e t -> checkPat e [] `thenP` \e ->
- returnP (SigPatIn e t)
+ -- pattern signatures are parsed as sigtypes,
+ -- 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
+ other -> other
+ in
+ returnP (SigPatIn e t')
OpApp (HsVar n) (HsVar plus) _ (HsLit k@(HsInt _)) | plus == plus_RDR
-> returnP (NPlusKPatIn n k)
diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index d063e59c0419..25aa168f4ba6 100644
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -48,7 +48,9 @@ module RdrHsSyn (
RdrNameGenPragmas,
RdrNameInstancePragmas,
extractHsTyRdrNames,
- extractPatsTyVars, extractRuleBndrsTyVars,
+ extractHsTyRdrTyVars,
+ extractPatsTyVars,
+ extractRuleBndrsTyVars,
mkOpApp, mkClassDecl, mkClassOpSig,
@@ -133,6 +135,9 @@ It's used when making the for-alls explicit.
extractHsTyRdrNames :: HsType RdrName -> [RdrName]
extractHsTyRdrNames ty = nub (extract_ty ty [])
+extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
+extractHsTyRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty)
+
extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
where
@@ -146,13 +151,14 @@ extract_ctxt ctxt acc = foldr extract_ass acc ctxt
where
extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys
-extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoListTy ty) acc = extract_ty ty acc
-extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys
-extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys
-extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc
-extract_ty (MonoTyVar tv) acc = tv : acc
+extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (MonoListTy ty) acc = extract_ty ty acc
+extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys
+extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys
+extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc
+extract_ty (MonoTyVar tv) acc = tv : acc
+extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
extract_ty (HsForAllTy (Just tvs) ctxt ty)
acc = acc ++
(filter (`notElem` locals) $
@@ -162,7 +168,7 @@ extract_ty (HsForAllTy (Just tvs) ctxt ty)
extractPatsTyVars :: [RdrNamePat] -> [RdrName]
-extractPatsTyVars pats = nub (foldr extract_pat [] pats)
+extractPatsTyVars pats = filter isRdrTyVar (nub (foldr extract_pat [] pats))
extract_pat (SigPatIn pat ty) acc = extract_ty ty acc
extract_pat WildPatIn acc = acc
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 34df4180050b..5e55fd09a1fc 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -829,8 +829,8 @@ nonStdGuardErr guard
) 4 (ppr guard)
patSigErr ty
- = hang (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
- 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
+ = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
+ $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)]
\end{code}
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index a2a1aeecaa05..0c0475fd1a34 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -14,7 +14,7 @@ import HsPragmas
import HsTypes ( getTyVarName, pprClassAssertion, cmpHsTypes )
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
- extractHsTyRdrNames, extractRuleBndrsTyVars
+ extractRuleBndrsTyVars, extractHsTyRdrTyVars
)
import RnHsSyn
import HsCore
@@ -565,13 +565,10 @@ checkConstraints explicit_forall doc forall_tyvars ctxt ty
| otherwise = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty)
`thenRn_` returnRn Nothing
where
- forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyRdrNames)
+ forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyRdrTyVars)
False
tys
-freeRdrTyVars :: RdrNameHsType -> [RdrName]
-freeRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty)
-
rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
rnHsType doc (HsForAllTy Nothing ctxt ty)
@@ -580,7 +577,7 @@ rnHsType doc (HsForAllTy Nothing ctxt ty)
-- over FV(T) \ {in-scope-tyvars}
= getLocalNameEnv `thenRn` \ name_env ->
let
- mentioned_in_tau = freeRdrTyVars ty
+ mentioned_in_tau = extractHsTyRdrTyVars ty
forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_in_tau
in
checkConstraints False doc forall_tyvars ctxt ty `thenRn` \ ctxt' ->
@@ -593,10 +590,10 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
-- That's only a warning... unless the tyvar is constrained by a
-- context in which case it's an error
= let
- mentioned_in_tau = freeRdrTyVars tau
+ mentioned_in_tau = extractHsTyRdrTyVars tau
mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt,
ty <- tys,
- tv <- freeRdrTyVars ty]
+ tv <- extractHsTyRdrTyVars ty]
dubious_guys = filter (`notElem` mentioned_in_tau) forall_tyvar_names
-- dubious = explicitly quantified but not mentioned in tau type
--
GitLab