[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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