[project @ 1998-12-18 17:40:31 by simonpj]

Another big commit from Simon.  Actually, the last one
didn't all go into the main trunk; because of a CVS glitch it
ended up in the wrong branch.

So this commit includes:

* Scoped type variables
* Warnings for unused variables should work now (they didn't before)
* Simplifier improvements:
	- Much better treatment of strict arguments
	- Better treatment of bottoming Ids
	- No need for w/w split for fns that are merely strict
	- Fewer iterations needed, I hope
* Less gratuitous renaming in interface files and abs C
* OccName is a separate module, and is an abstract data type

I think the whole Prelude and Exts libraries compile correctly.
Something isn't quite right about typechecking existentials though.

1 files changed, 58 insertions, 90 deletions

diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs
index c09fff192e..7fe648d25e 100644
--- a/ghc/compiler/hsSyn/HsMatches.lhs
+++ b/ghc/compiler/hsSyn/HsMatches.lhs
@@ -3,7 +3,7 @@
 %
 \section[HsMatches]{Abstract syntax: matches and guarded right-hand-sides}
 
-The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes.
+The @Match@, @GRHSs@ and @GRHS@ datatypes.
 
 \begin{code}
 module HsMatches where
@@ -12,10 +12,11 @@ module HsMatches where
 
 -- Friends
 import HsExpr		( HsExpr, Stmt(..) )
-import HsBinds		( HsBinds, nullBinds )
+import HsBinds		( HsBinds(..), nullBinds )
+import HsTypes		( HsTyVar, HsType )
 
 -- Others
-import Type		( GenType )
+import Type		( Type )
 import SrcLoc		( SrcLoc )
 import Outputable
 import Name		( NamedThing )
@@ -23,7 +24,7 @@ import Name		( NamedThing )
 
 %************************************************************************
 %*									*
-\subsection{@Match@, @GRHSsAndBinds@, and @GRHS@ datatypes}
+\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
 %*									*
 %************************************************************************
 
@@ -37,46 +38,38 @@ g ((x:ys),y) = y+1,
 then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.
 
 It is always the case that each element of an @[Match]@ list has the
-same number of @PatMatch@s inside it.  This corresponds to saying that
+same number of @pats@s inside it.  This corresponds to saying that
 a function defined by pattern matching must have the same number of
 patterns in each equation.
 
 \begin{code}
-data Match flexi id pat
-  = PatMatch	    pat
-		    (Match flexi id pat)
-  | GRHSMatch	    (GRHSsAndBinds flexi id pat)
-
-  | SimpleMatch	    (HsExpr flexi id pat)		-- Used in translations
-\end{code}
-
-Sets of guarded right hand sides (GRHSs). In:
-\begin{verbatim}
-f (x,y) | x==True = y
-	| otherwise = y*2
-\end{verbatim}
-a guarded right hand side is either
-@(x==True = y)@, or @(otherwise = y*2)@.
-
-For each match, there may be several guarded right hand
-sides, as the definition of @f@ shows.
-
-\begin{code}
-data GRHSsAndBinds flexi id pat
-  = GRHSsAndBindsIn 	[GRHS flexi id pat]	    -- at least one GRHS
-			(HsBinds flexi id pat)
-
-  | GRHSsAndBindsOut 	[GRHS flexi id pat]	    -- at least one GRHS
-			(HsBinds flexi id pat)
-			(GenType flexi)
-
-data GRHS flexi id pat
-  = GRHS	    [Stmt flexi id pat]		-- The RHS is the final ExprStmt
-						-- I considered using a RetunStmt, but
-						-- it printed 'wrong' in error messages 
-		    SrcLoc
-
-unguardedRHS :: (HsExpr flexi id pat) -> SrcLoc -> [GRHS flexi id pat]
+data Match id pat
+  = Match
+	[HsTyVar id] 			-- Tyvars wrt which this match is universally quantified
+					-- 	emtpy after typechecking
+	[pat]				-- The patterns
+	(Maybe (HsType id))		-- A type signature for the result of the match
+					--	Nothing after typechecking
+
+	(GRHSs id pat)
+
+-- GRHSs are used both for pattern bindings and for Matches
+data GRHSs id pat	
+  = GRHSs [GRHS id pat]		-- Guarded RHSs
+	  (HsBinds id pat)	-- The where clause
+	  (Maybe Type)		-- Just rhs_ty after type checking
+
+data GRHS id pat
+  = GRHS  [Stmt id pat]		-- The RHS is the final ExprStmt
+				-- I considered using a RetunStmt, but
+				-- it printed 'wrong' in error messages 
+	  SrcLoc
+
+mkSimpleMatch :: [pat] -> HsExpr id pat -> Maybe Type -> SrcLoc -> Match id pat
+mkSimpleMatch pats rhs maybe_rhs_ty locn
+  = Match [] pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds maybe_rhs_ty)
+
+unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat]
 unguardedRHS rhs loc = [GRHS [ExprStmt rhs loc] loc]
 \end{code}
 
@@ -85,9 +78,8 @@ source-location gotten from the GRHS inside.
 THis is something of a nuisance, but no more.
 
 \begin{code}
-getMatchLoc :: Match flexi id pat -> SrcLoc
-getMatchLoc (PatMatch _ m)				     = getMatchLoc m
-getMatchLoc (GRHSMatch (GRHSsAndBindsIn (GRHS _ loc : _) _)) = loc
+getMatchLoc :: Match id pat -> SrcLoc
+getMatchLoc (Match _ _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc
 \end{code}
 
 %************************************************************************
@@ -99,59 +91,35 @@ getMatchLoc (GRHSMatch (GRHSsAndBindsIn (GRHS _ loc : _) _)) = loc
 We know the list must have at least one @Match@ in it.
 \begin{code}
 pprMatches :: (NamedThing id, Outputable id, Outputable pat)
-	   => (Bool, SDoc) -> [Match flexi id pat] -> SDoc
-
-pprMatches print_info@(is_case, name) [match]
-  = if is_case then
-    	pprMatch is_case match
-    else
-    	name <+> (pprMatch is_case match)
+	   => (Bool, SDoc) -> [Match id pat] -> SDoc
+pprMatches print_info matches = vcat (map (pprMatch print_info) matches)
 
-pprMatches print_info (match1 : rest)
- = ($$) (pprMatches print_info [match1])
-	   (pprMatches print_info rest)
 
----------------------------------------------
 pprMatch :: (NamedThing id, Outputable id, Outputable pat)
-	 => Bool -> Match flexi id pat -> SDoc
-
-pprMatch is_case first_match
- = sep [(sep (map (ppr) row_of_pats)),
-	grhss_etc_stuff]
- where
-    (row_of_pats, grhss_etc_stuff) = ppr_match is_case first_match
-
-    ppr_match is_case (PatMatch pat match)
-      = (pat:pats, grhss_stuff)
-      where
-	(pats, grhss_stuff) = ppr_match is_case match
-
-    ppr_match is_case (GRHSMatch grhss_n_binds)
-      = ([], pprGRHSsAndBinds is_case grhss_n_binds)
-
-    ppr_match is_case (SimpleMatch expr)
-      = ([], text (if is_case then "->" else "=") <+> ppr expr)
-
-----------------------------------------------------------
-
-pprGRHSsAndBinds :: (NamedThing id, Outputable id, Outputable pat)
-		 => Bool -> GRHSsAndBinds flexi id pat -> SDoc
-
-pprGRHSsAndBinds is_case (GRHSsAndBindsIn grhss binds)
- = ($$) (vcat (map (pprGRHS is_case) grhss))
-	   (if (nullBinds binds)
-	    then empty
-	    else vcat [ text "where", nest 4 (pprDeeper (ppr binds)) ])
+	   => (Bool, SDoc) -> Match id pat -> SDoc
+pprMatch print_info@(is_case, name) (Match _ pats maybe_ty grhss)
+  = maybe_name <+> sep [sep (map ppr pats), 
+			ppr_maybe_ty,
+			nest 2 (pprGRHSs is_case grhss)]
+  where
+    maybe_name | is_case   = empty
+	       | otherwise = name
+    ppr_maybe_ty = case maybe_ty of
+			Just ty -> dcolon <+> ppr ty
+			Nothing -> empty
+
+
+pprGRHSs :: (NamedThing id, Outputable id, Outputable pat)
+	 => Bool -> GRHSs id pat -> SDoc
+pprGRHSs is_case (GRHSs grhss binds maybe_ty)
+  = vcat (map (pprGRHS is_case) grhss)
+    $$
+    (if nullBinds binds then empty
+     else text "where" $$ nest 4 (pprDeeper (ppr binds)))
 
-pprGRHSsAndBinds is_case (GRHSsAndBindsOut grhss binds ty)
- = ($$) (vcat (map (pprGRHS is_case) grhss))
-	   (if (nullBinds binds)
-	    then empty
-	    else vcat [text "where", nest 4 (pprDeeper (ppr binds)) ])
 
----------------------------------------------
 pprGRHS :: (NamedThing id, Outputable id, Outputable pat)
-	=> Bool -> GRHS flexi id pat -> SDoc
+	=> Bool -> GRHS id pat -> SDoc
 
 pprGRHS is_case (GRHS [ExprStmt expr _] locn)
  =  text (if is_case then "->" else "=") <+> pprDeeper (ppr expr)