X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsMatches.lhs;h=c09fff192eca82ed89ac0bba29c6cb91773f18a9;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=5800e5e62f965964e193a5b3fea9f5fa23af1b0b;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs
index 5800e5e..c09fff1 100644
--- a/ghc/compiler/hsSyn/HsMatches.lhs
+++ b/ghc/compiler/hsSyn/HsMatches.lhs
@@ -1,23 +1,24 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[HsMatches]{Abstract syntax: matches and guarded right-hand-sides}
 
 The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes.
 
 \begin{code}
-#include "HsVersions.h"
-
 module HsMatches where
 
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
+
+-- Friends
+import HsExpr		( HsExpr, Stmt(..) )
+import HsBinds		( HsBinds, nullBinds )
 
-IMPORT_DELOOPER(HsLoop)		( HsExpr, nullBinds, HsBinds )
-import Outputable	( ifPprShowAll )
-import PprType		( GenType{-instance Outputable-} )
-import Pretty
-import SrcLoc		( SrcLoc{-instances-} )
-import Util		( panic )
+-- Others
+import Type		( GenType )
+import SrcLoc		( SrcLoc )
+import Outputable
+import Name		( NamedThing )
 \end{code}
 
 %************************************************************************
@@ -41,12 +42,12 @@ a function defined by pattern matching must have the same number of
 patterns in each equation.
 
 \begin{code}
-data Match tyvar uvar id pat
+data Match flexi id pat
   = PatMatch	    pat
-		    (Match tyvar uvar id pat)
-  | GRHSMatch	    (GRHSsAndBinds tyvar uvar id pat)
+		    (Match flexi id pat)
+  | GRHSMatch	    (GRHSsAndBinds flexi id pat)
 
-  | SimpleMatch	    (HsExpr tyvar uvar id pat)		-- Used in translations
+  | SimpleMatch	    (HsExpr flexi id pat)		-- Used in translations
 \end{code}
 
 Sets of guarded right hand sides (GRHSs). In:
@@ -61,21 +62,32 @@ For each match, there may be several guarded right hand
 sides, as the definition of @f@ shows.
 
 \begin{code}
-data GRHSsAndBinds tyvar uvar id pat
-  = GRHSsAndBindsIn 	[GRHS tyvar uvar id pat]	    -- at least one GRHS
-			(HsBinds tyvar uvar id pat)
+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
 
-  | GRHSsAndBindsOut 	[GRHS tyvar uvar id pat]	    -- at least one GRHS
-			(HsBinds tyvar uvar id pat)
-			(GenType tyvar uvar)
+unguardedRHS :: (HsExpr flexi id pat) -> SrcLoc -> [GRHS flexi id pat]
+unguardedRHS rhs loc = [GRHS [ExprStmt rhs loc] loc]
+\end{code}
 
-data GRHS tyvar uvar id pat
-  = GRHS	    (HsExpr tyvar uvar id pat)	-- guard(ed)...
-		    (HsExpr tyvar uvar id pat)	-- ... right-hand side
-		    SrcLoc
+@getMatchLoc@ takes a @Match@ and returns the
+source-location gotten from the GRHS inside.
+THis is something of a nuisance, but no more.
 
-  | OtherwiseGRHS   (HsExpr tyvar uvar id pat)	-- guard-free
-		    SrcLoc
+\begin{code}
+getMatchLoc :: Match flexi id pat -> SrcLoc
+getMatchLoc (PatMatch _ m)				     = getMatchLoc m
+getMatchLoc (GRHSMatch (GRHSsAndBindsIn (GRHS _ loc : _) _)) = loc
 \end{code}
 
 %************************************************************************
@@ -86,68 +98,69 @@ data GRHS tyvar uvar id pat
 
 We know the list must have at least one @Match@ in it.
 \begin{code}
-pprMatches :: (NamedThing id, Outputable id, Outputable pat,
-	       Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
-		PprStyle -> (Bool, Pretty) -> [Match tyvar uvar id pat] -> Pretty
+pprMatches :: (NamedThing id, Outputable id, Outputable pat)
+	   => (Bool, SDoc) -> [Match flexi id pat] -> SDoc
 
-pprMatches sty print_info@(is_case, name) [match]
+pprMatches print_info@(is_case, name) [match]
   = if is_case then
-    	pprMatch sty is_case match
+    	pprMatch is_case match
     else
-    	ppHang name 4 (pprMatch sty is_case match)
+    	name <+> (pprMatch is_case match)
 
-pprMatches sty print_info (match1 : rest)
- = ppAbove (pprMatches sty print_info [match1])
-	   (pprMatches sty print_info rest)
+pprMatches print_info (match1 : rest)
+ = ($$) (pprMatches print_info [match1])
+	   (pprMatches print_info rest)
 
 ---------------------------------------------
-pprMatch :: (NamedThing id, Outputable id, Outputable pat,
-	       Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
-	PprStyle -> Bool -> Match tyvar uvar id pat -> Pretty
+pprMatch :: (NamedThing id, Outputable id, Outputable pat)
+	 => Bool -> Match flexi id pat -> SDoc
 
-pprMatch sty is_case first_match
- = ppHang (ppSep (map (ppr sty) row_of_pats))
-	8 grhss_etc_stuff
+pprMatch is_case first_match
+ = sep [(sep (map (ppr) row_of_pats)),
+	grhss_etc_stuff]
  where
-    (row_of_pats, grhss_etc_stuff) = ppr_match sty is_case first_match
+    (row_of_pats, grhss_etc_stuff) = ppr_match is_case first_match
 
-    ppr_match sty is_case (PatMatch pat match)
+    ppr_match is_case (PatMatch pat match)
       = (pat:pats, grhss_stuff)
       where
-	(pats, grhss_stuff) = ppr_match sty is_case match
+	(pats, grhss_stuff) = ppr_match is_case match
 
-    ppr_match sty is_case (GRHSMatch grhss_n_binds)
-      = ([], pprGRHSsAndBinds sty is_case grhss_n_binds)
+    ppr_match is_case (GRHSMatch grhss_n_binds)
+      = ([], pprGRHSsAndBinds is_case grhss_n_binds)
 
-    ppr_match sty is_case (SimpleMatch expr)
-      = ([], ppr sty expr)
+    ppr_match is_case (SimpleMatch expr)
+      = ([], text (if is_case then "->" else "=") <+> ppr expr)
 
 ----------------------------------------------------------
 
-pprGRHSsAndBinds sty is_case (GRHSsAndBindsIn grhss binds)
- = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss))
+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 ppNil
-	    else ppAboves [ ppStr "where", ppNest 4 (ppr sty binds) ])
+	    then empty
+	    else vcat [ text "where", nest 4 (pprDeeper (ppr binds)) ])
 
-pprGRHSsAndBinds sty is_case (GRHSsAndBindsOut grhss binds ty)
- = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss))
+pprGRHSsAndBinds is_case (GRHSsAndBindsOut grhss binds ty)
+ = ($$) (vcat (map (pprGRHS is_case) grhss))
 	   (if (nullBinds binds)
-	    then ppNil
-	    else ppAboves [ ifPprShowAll sty
-				(ppCat [ppStr "{- ty:", ppr sty ty, ppStr "-}"]),
-			    ppStr "where", ppNest 4 (ppr sty binds) ])
+	    then empty
+	    else vcat [text "where", nest 4 (pprDeeper (ppr binds)) ])
 
 ---------------------------------------------
-pprGRHS :: (NamedThing id, Outputable id, Outputable pat,
-	    Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
-	=> PprStyle -> Bool -> GRHS tyvar uvar id pat -> Pretty
+pprGRHS :: (NamedThing id, Outputable id, Outputable pat)
+	=> Bool -> GRHS flexi id pat -> SDoc
 
-pprGRHS sty is_case (GRHS guard expr locn)
- = ppHang (ppCat [ppChar '|', ppr sty guard, ppStr (if is_case then "->" else "=")])
-        4 (ppr sty expr)
+pprGRHS is_case (GRHS [ExprStmt expr _] locn)
+ =  text (if is_case then "->" else "=") <+> pprDeeper (ppr expr)
 
-pprGRHS sty is_case (OtherwiseGRHS  expr locn)
-  = ppHang (ppStr (if is_case then "->" else "="))
-	 4 (ppr sty expr)
+pprGRHS is_case (GRHS guarded locn)
+ = sep [char '|' <+> interpp'SP guards,
+	text (if is_case then "->" else "=") <+> pprDeeper (ppr expr)
+   ]
+ where
+    ExprStmt expr _ = last guarded	-- Last stmt should be a ExprStmt for guards
+    guards	    = init guarded
 \end{code}