From: simonmar Date: Wed, 23 Jun 1999 10:38:15 +0000 (+0000) Subject: [project @ 1999-06-23 10:38:13 by simonmar] X-Git-Tag: Approximately_9120_patches~6105 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=98d5ffd5eaa8af06c2d3ac7118ed09737c7d2a50 [project @ 1999-06-23 10:38:13 by simonmar] Make scoped type variables work. --- diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index e09f60f..ce4f71b 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 d063e59..25aa168 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 34df418..5e55fd0 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 a2a1aee..0c0475f 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