X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsExpr.lhs;h=153c7d7ad68dcf3e3ebfcd6b76946010a778c4df;hb=d62615eab75a09749ea3ec1423587d432411309d;hp=5c5f09587d641d0cfeadb5a8bb9b2782f097c5a0;hpb=5e6242927839c8ddc73a55eb7828c0b7e4cc3ab2;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 5c5f095..153c7d7 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -9,15 +9,15 @@ module HsExpr where
 #include "HsVersions.h"
 
 -- friends:
-import {-# SOURCE #-} HsMatches ( pprMatches, pprMatch, Match )
-
-import HsBinds		( HsBinds(..) )
+import HsBinds		( HsBinds(..), nullBinds )
 import HsLit		( HsLit, HsOverLit )
 import BasicTypes	( Fixity(..) )
 import HsTypes		( HsType )
+import HsImpExp		( isOperator )
 
 -- others:
-import Name		( Name, isLexSym ) 
+import ForeignCall	( Safety )
+import Name		( Name )
 import Outputable	
 import PprType		( pprParendType )
 import Type		( Type )
@@ -83,15 +83,15 @@ data HsExpr id pat
   | HsWith	(HsExpr id pat)	-- implicit parameter binding
   		[(id, HsExpr id pat)]
 
-  | HsDo	StmtCtxt
+  | HsDo	HsMatchContext
 		[Stmt id pat]	-- "do":one or more stmts
 		SrcLoc
 
-  | HsDoOut	StmtCtxt
+  | HsDoOut	HsMatchContext
 		[Stmt id pat]	-- "do":one or more stmts
 		id		-- id for return
 		id		-- id for >>=
-		id				-- id for zero
+		id		-- id for fail
 		Type		-- Type of the whole expression
 		SrcLoc
 
@@ -140,7 +140,7 @@ data HsExpr id pat
   | HsCCall	CLabelString	-- call into the C world; string is
 		[HsExpr id pat]	-- the C function; exprs are the
 				-- arguments to pass.
-		Bool		-- True <=> might cause Haskell
+		Safety		-- True <=> might cause Haskell
 				-- garbage-collection (must generate
 				-- more paranoid code)
 		Bool		-- True <=> it's really a "casm"
@@ -217,7 +217,7 @@ ppr_expr (HsVar v)
   | isOperator v = parens (ppr v)
   | otherwise    = ppr v
 
-ppr_expr (HsIPVar v)     = {- char '?' <> -} ppr v
+ppr_expr (HsIPVar v)     = char '?' <> ppr v
 ppr_expr (HsLit lit)     = ppr lit
 ppr_expr (HsOverLit lit) = ppr lit
 
@@ -390,14 +390,6 @@ pprParendExpr expr
       _			    -> parens pp_as_was
 \end{code}
 
-\begin{code}
-isOperator :: Outputable a => a -> Bool
-isOperator v = isLexSym (_PK_ (showSDocUnqual (ppr v)))
-	-- We use (showSDoc (ppr v)), rather than isSymOcc (getOccName v) simply so
-	-- that we don't need NamedThing in the context of all these functions.
-	-- Gruesome, but simple.
-\end{code}
-
 %************************************************************************
 %*									*
 \subsection{Record binds}
@@ -421,50 +413,170 @@ pp_rbinds thing rbinds
 	   hsep [ppr v, char '=', ppr e]
 \end{code}
 
+
+
 %************************************************************************
 %*									*
-\subsection{Do stmts and list comprehensions}
+\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
 %*									*
 %************************************************************************
 
+@Match@es are sets of pattern bindings and right hand sides for
+functions, patterns or case branches. For example, if a function @g@
+is defined as:
+\begin{verbatim}
+g (x,y) = y
+g ((x:ys),y) = y+1,
+\end{verbatim}
+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 @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 StmtCtxt	-- Context of a Stmt
-  = DoStmt		-- Do Statment
-  | ListComp		-- List comprehension
-  | CaseAlt		-- Guard on a case alternative
-  | PatBindRhs		-- Guard on a pattern binding
-  | FunRhs Name		-- Guard on a function defn for f
-  | LambdaBody		-- Body of a lambda abstraction
-		
-pprDo DoStmt stmts
-  = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
-pprDo ListComp stmts
-  = brackets $
-    hang (pprExpr expr <+> char '|')
-       4 (interpp'SP quals)
+data Match id pat
+  = Match
+	[id] 			-- Tyvars wrt which this match is universally quantified
+				-- empty 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 ResultStmt
+				-- 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 [ResultStmt rhs loc] loc]
+\end{code}
+
+@getMatchLoc@ takes a @Match@ and returns the
+source-location gotten from the GRHS inside.
+THis is something of a nuisance, but no more.
+
+\begin{code}
+getMatchLoc :: Match id pat -> SrcLoc
+getMatchLoc (Match _ _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc
+\end{code}
+
+We know the list must have at least one @Match@ in it.
+
+\begin{code}
+pprMatches :: (Outputable id, Outputable pat)
+	   => (Bool, SDoc) -> [Match id pat] -> SDoc
+pprMatches print_info matches = vcat (map (pprMatch print_info) matches)
+
+
+pprMatch :: (Outputable id, Outputable pat)
+	   => (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
-    ReturnStmt expr = last stmts	-- Last stmt should be a ReturnStmt for list comps
-    quals	    = init stmts
+    maybe_name | is_case   = empty
+	       | otherwise = name
+    ppr_maybe_ty = case maybe_ty of
+			Just ty -> dcolon <+> ppr ty
+			Nothing -> empty
+
+
+pprGRHSs :: (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)))
+
+
+pprGRHS :: (Outputable id, Outputable pat)
+	=> Bool -> GRHS id pat -> SDoc
+
+pprGRHS is_case (GRHS [ResultStmt expr _] locn)
+ =  pp_rhs is_case expr
+
+pprGRHS is_case (GRHS guarded locn)
+ = sep [char '|' <+> interpp'SP guards, pp_rhs is_case expr]
+ where
+    ResultStmt expr _ = last guarded	-- Last stmt should be a ResultStmt for guards
+    guards	      = init guarded
+
+pp_rhs is_case rhs = text (if is_case then "->" else "=") <+> pprDeeper (ppr rhs)
 \end{code}
 
+
+
+%************************************************************************
+%*									*
+\subsection{Do stmts and list comprehensions}
+%*									*
+%************************************************************************
+
 \begin{code}
 data Stmt id pat
-  = ParStmt	[[Stmt id pat]]		-- List comp only: parallel set of quals
-  | ParStmtOut	[([id], [Stmt id pat])]	-- PLC after renaming
-  | BindStmt	pat
-		(HsExpr id pat)
-		SrcLoc
-
+  = BindStmt	pat (HsExpr id pat) SrcLoc
   | LetStmt	(HsBinds id pat)
+  | ResultStmt	(HsExpr id pat)	SrcLoc	-- See notes that follow
+  | ExprStmt	(HsExpr id pat)	SrcLoc	-- See notes that follow
+  | ParStmt	[[Stmt id pat]]		-- List comp only: parallel set of quals
+  | ParStmtOut	[([id], [Stmt id pat])]	-- PLC after renaming; the ids are the binders
+					-- bound by the stmts
+\end{code}
 
-  | GuardStmt	(HsExpr id pat)		-- List comps only
-		SrcLoc
+ExprStmts and ResultStmts are a bit tricky, because what they mean
+depends on the context.  Consider the following contexts:
+
+	A do expression of type (m res_ty)
+	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+	* ExprStmt E:   do { ....; E; ... }
+		E :: m any_ty
+	  Translation: E >> ...
+	
+	* ResultStmt E:   do { ....; E }
+		E :: m res_ty
+	  Translation: E
+	
+	A list comprehensions of type [elt_ty]
+	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+	* ExprStmt E:   [ .. | .... E ]
+			[ .. | ..., E, ... ]
+			[ .. | .... | ..., E | ... ]
+		E :: Bool
+	  Translation: if E then fail else ...
+
+	* ResultStmt E:   [ E | ... ]
+		E :: elt_ty
+	  Translation: return E
+	
+	A guard list, guarding a RHS of type rhs_ty
+	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+	* ExprStmt E:   f x | ..., E, ... = ...rhs...
+		E :: Bool
+	  Translation: if E then fail else ...
+	
+	* ResultStmt E:   f x | ...guards... = E
+		E :: rhs_ty
+	  Translation: E
 
-  | ExprStmt	(HsExpr id pat)		-- Do stmts; and guarded things at the end
-		SrcLoc
-
-  | ReturnStmt	(HsExpr id pat)		-- List comps only, at the end
 
+\begin{code}
 consLetStmt :: HsBinds id pat -> [Stmt id pat] -> [Stmt id pat]
 consLetStmt EmptyBinds stmts = stmts
 consLetStmt binds      stmts = LetStmt binds : stmts
@@ -475,20 +587,23 @@ instance (Outputable id, Outputable pat) =>
 		Outputable (Stmt id pat) where
     ppr stmt = pprStmt stmt
 
+pprStmt (BindStmt pat expr _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
+pprStmt (LetStmt binds)       = hsep [ptext SLIT("let"), pprBinds binds]
+pprStmt (ExprStmt expr _)     = ppr expr
+pprStmt (ResultStmt expr _)   = ppr expr
 pprStmt (ParStmt stmtss)
  = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
 pprStmt (ParStmtOut stmtss)
  = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
-pprStmt (BindStmt pat expr _)
- = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
-pprStmt (LetStmt binds)
- = hsep [ptext SLIT("let"), pprBinds binds]
-pprStmt (ExprStmt expr _)
- = ppr expr
-pprStmt (GuardStmt expr _)
- = ppr expr
-pprStmt (ReturnStmt expr)
- = hsep [ptext SLIT("return"), ppr expr]    
+
+pprDo :: (Outputable id, Outputable pat) => HsMatchContext -> [Stmt id pat] -> SDoc
+pprDo DoExpr stmts   = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
+pprDo ListComp stmts = brackets $
+		       hang (pprExpr expr <+> char '|')
+			  4 (interpp'SP quals)
+		     where
+		       ResultStmt expr _ = last stmts	-- Last stmt should
+		       quals	         = init stmts	-- be an ResultStmt
 \end{code}
 
 %************************************************************************
@@ -520,3 +635,57 @@ instance (Outputable id, Outputable pat) =>
 
 pp_dotdot = ptext SLIT(" .. ")
 \end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{HsMatchCtxt}
+%*									*
+%************************************************************************
+
+\begin{code}
+data HsMatchContext	-- Context of a Match or Stmt
+  = ListComp		-- List comprehension
+  | DoExpr		-- Do Statment
+
+  | FunRhs Name		-- Function binding for f
+  | CaseAlt		-- Guard on a case alternative
+  | LambdaExpr		-- Lambda
+  | PatBindRhs		-- Pattern binding
+  | RecUpd		-- Record update
+  deriving ()
+
+-- It's convenient to have FunRhs as a Name
+-- throughout so that HsMatchContext doesn't
+-- need to be parameterised.
+-- In the RdrName world we never use the FunRhs variant.
+\end{code}
+
+\begin{code}
+isDoExpr DoExpr = True
+isDoExpr other  = False
+
+isDoOrListComp ListComp = True
+isDoOrListComp DoExpr   = True
+isDoOrListComp other    = False
+\end{code}
+
+\begin{code}
+matchSeparator (FunRhs _)   = SLIT("=")
+matchSeparator CaseAlt      = SLIT("->") 
+matchSeparator LambdaExpr   = SLIT("->") 
+matchSeparator PatBindRhs   = SLIT("=") 
+matchSeparator DoExpr       = SLIT("<-")  
+matchSeparator ListComp     = SLIT("<-")  
+matchSeparator RecUpd       = panic "When is this used?"
+\end{code}
+
+\begin{code}
+pprMatchContext (FunRhs fun) = ptext SLIT("In the definition of") <+> quotes (ppr fun)
+pprMatchContext CaseAlt	     = ptext SLIT("In a group of case alternatives beginning")
+pprMatchContext RecUpd	     = ptext SLIT("In a record-update construct")
+pprMatchContext PatBindRhs   = ptext SLIT("In a pattern binding")
+pprMatchContext LambdaExpr   = ptext SLIT("In a lambda abstraction")
+pprMatchContext DoExpr       = ptext SLIT("In a 'do' expression pattern binding")
+pprMatchContext ListComp     = ptext SLIT("In a 'list comprehension' pattern binding")
+\end{code}