From: simonpj <unknown>
Date: Mon, 28 May 2001 11:42:56 +0000 (+0000)
Subject: [project @ 2001-05-28 11:42:56 by simonpj]
X-Git-Tag: Approximately_9120_patches~1855
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=5a023eed3e24d1506ebd5a55caf0400073683122;p=ghc-hetmet.git

[project @ 2001-05-28 11:42:56 by simonpj]
Wibble for scoped type variables
---

diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index ec92913..4831614 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -13,7 +13,7 @@ module HsPat (
 	patsAreAllCons, isConPat,
 	patsAreAllLits,	isLitPat,
 	collectPatBinders, collectPatsBinders,
-	collectSigTysFromPats
+	collectSigTysFromPat, collectSigTysFromPats
     ) where
 
 #include "HsVersions.h"
@@ -334,6 +334,9 @@ collect (TypePatIn ty)           bndrs = bndrs
 collectSigTysFromPats :: [InPat name] -> [HsType name]
 collectSigTysFromPats pats = foldr collect_pat [] pats
 
+collectSigTysFromPat :: InPat name -> [HsType name]
+collectSigTysFromPat pat = collect_pat pat []
+
 collect_pat (SigPatIn pat ty)	   acc = collect_pat pat (ty:acc)
 collect_pat WildPatIn	      	   acc = acc
 collect_pat (VarPatIn var)         acc = acc
diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index ea34147..a5c7f3f 100644
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -45,7 +45,6 @@ module RdrHsSyn (
 
 	extractHsTyRdrNames, 
 	extractHsTyRdrTyVars, extractHsTysRdrTyVars,
-	extractPatsTyVars, 
 	extractRuleBndrsTyVars,
 	extractHsCtxtRdrTyVars, extractGenericPatTyVars,
  
@@ -172,13 +171,6 @@ extract_ty (HsForAllTy (Just tvs) ctxt ty)
 				    where
 				      locals = hsTyVarNames tvs
 
-
-extractPatsTyVars :: [RdrNamePat] -> [RdrName]
-extractPatsTyVars = filter isRdrTyVar . 
-		    nub . 
-		    extract_tys .
-		    collectSigTysFromPats
-
 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
 -- Get the type variables out of the type patterns in a bunch of
 -- possibly-generic bindings in a class declaration
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index a019881..1b28b1a 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -146,8 +146,9 @@ rnPat (RecPatIn con rpats)
   = lookupOccRn con 	`thenRn` \ con' ->
     rnRpats rpats	`thenRn` \ (rpats', fvs) ->
     returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
+
 rnPat (TypePatIn name) =
-    (rnHsTypeFVs (text "type pattern") name) `thenRn` \ (name', fvs) ->
+    rnHsTypeFVs (text "type pattern") name	`thenRn` \ (name', fvs) ->
     returnRn (TypePatIn name', fvs)
 \end{code}
 
@@ -163,25 +164,21 @@ rnMatch :: RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
 rnMatch match@(Match _ pats maybe_rhs_sig grhss)
   = pushSrcLocRn (getMatchLoc match)	$
 
-	-- Find the universally quantified type variables
-	-- in the pattern type signatures
-    getLocalNameEnv			`thenRn` \ name_env ->
+	-- Bind pattern-bound type variables
     let
-	tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
-	rhs_sig_tyvars = case maybe_rhs_sig of
+	rhs_sig_tys =  case maybe_rhs_sig of
 				Nothing -> []
-				Just ty -> extractHsTyRdrTyVars ty
-	tyvars_in_pats = extractPatsTyVars pats
-	forall_tyvars  = filter (not . (`elemFM` name_env)) tyvars_in_sigs
-	doc_sig        = text "a pattern type-signature"
-	doc_pats       = text "a pattern match"
+				Just ty -> [ty]
+	pat_sig_tys = collectSigTysFromPats pats
+	doc_sig     = text "a result type-signature"
+ 	doc_pat     = text "a pattern match"
     in
-    bindNakedTyVarsFVRn doc_sig forall_tyvars	$ \ sig_tyvars ->
+    bindPatSigTyVars (rhs_sig_tys ++ pat_sig_tys)	$ \ sig_tyvars ->
 
 	-- Note that we do a single bindLocalsRn for all the
 	-- matches together, so that we spot the repeated variable in
 	--	f x x = 1
-    bindLocalsFVRn doc_pats (collectPatsBinders pats) $ \ new_binders ->
+    bindLocalsFVRn doc_pat (collectPatsBinders pats)	$ \ new_binders ->
 
     mapFvRn rnPat pats			`thenRn` \ (pats', pat_fvs) ->
     rnGRHSs grhss			`thenRn` \ (grhss', grhss_fvs) ->
@@ -203,6 +200,21 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss)
     
     returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
 	-- The bindLocals and bindTyVars will remove the bound FVs
+
+
+bindPatSigTyVars :: [RdrNameHsType]
+		 -> ([Name] -> RnMS (a, FreeVars))
+	  	 -> RnMS (a, FreeVars)
+  -- Find the type variables in the pattern type 
+  -- signatures that must be brought into scope
+bindPatSigTyVars tys thing_inside
+  = getLocalNameEnv			`thenRn` \ name_env ->
+    let
+	tyvars_in_sigs = extractHsTysRdrTyVars tys
+	forall_tyvars  = filter (not . (`elemFM` name_env)) tyvars_in_sigs
+	doc_sig        = text "a pattern type-signature"
+    in
+    bindNakedTyVarsFVRn doc_sig forall_tyvars thing_inside
 \end{code}
 
 %************************************************************************
@@ -575,14 +587,13 @@ rnStmt (ParStmt stmtss) thing_inside
 rnStmt (BindStmt pat expr src_loc) thing_inside
   = pushSrcLocRn src_loc $
     rnExpr expr					`thenRn` \ (expr', fv_expr) ->
-    bindLocalsFVRn doc binders			$ \ new_binders ->
+    bindPatSigTyVars (collectSigTysFromPat pat)	$ \ sig_tyvars ->
+    bindLocalsFVRn doc (collectPatBinders pat)	$ \ new_binders ->
     rnPat pat					`thenRn` \ (pat', fv_pat) ->
     thing_inside (BindStmt pat' expr' src_loc)	`thenRn` \ ((rest_binders, result), fvs) ->
-    -- ZZ is shadowing handled correctly?
     returnRn ((new_binders ++ rest_binders, result),
 	      fv_expr `plusFV` fvs `plusFV` fv_pat)
   where
-    binders = collectPatBinders pat
     doc = text "a pattern in do binding" 
 
 rnStmt (ExprStmt expr src_loc) thing_inside