From: simonpj@microsoft.com <unknown>
Date: Tue, 12 Aug 2008 08:23:32 +0000 (+0000)
Subject: Fix Trac #2490: sections should be parenthesised
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=83256c875683894a93cf4468947ccf11c65577ca

Fix Trac #2490: sections should be parenthesised

When I added bang patterns I had to slightly generalise where the
parser would recognise sections.  See Note [Parsing sections] in
parser.y.pp.

I forgot to check that ordinary H98 sections obey the original
rules.  This patch adds the check.
---

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 86ce98c..67b2dca 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1429,16 +1429,27 @@ cvtopdecls0 :: { [LHsDecl RdrName] }
 	: {- empty -}		{ [] }
 	| cvtopdecls		{ $1 }
 
--- tuple expressions: things that can appear unparenthesized as long as they're
+-- "texp" is short for tuple expressions: 
+-- things that can appear unparenthesized as long as they're
 -- inside parens or delimitted by commas
 texp :: { LHsExpr RdrName }
 	: exp				{ $1 }
-	-- Technically, this should only be used for bang patterns,
-       -- but we can be a little more liberal here and avoid parens
-       -- inside tuples
-       | infixexp qop 	{ LL $ SectionL $1 $2 }
+
+	-- Note [Parsing sections]
+	-- ~~~~~~~~~~~~~~~~~~~~~~~
+	-- We include left and right sections here, which isn't
+	-- technically right according to Haskell 98.  For example
+	--	(3 +, True) isn't legal
+	-- However, we want to parse bang patterns like
+	--	(!x, !y)
+	-- and it's convenient to do so here as a section
+        -- Then when converting expr to pattern we unravel it again
+	-- Meanwhile, the renamer checks that real sections appear
+	-- inside parens.
+        | infixexp qop 	{ LL $ SectionL $1 $2 }
 	| qopm infixexp       { LL $ SectionR $1 $2 }
-       -- view patterns get parenthesized above
+
+       -- View patterns get parenthesized above
 	| exp '->' exp   { LL $ EViewPat $1 $3 }
 
 texps :: { [LHsExpr RdrName] }
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 716a7a2..942ac2d 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -166,10 +166,7 @@ rnExpr (NegApp e _)
     mkNegAppRn e' neg_name	`thenM` \ final_e ->
     returnM (final_e, fv_e `plusFV` fv_neg)
 
-rnExpr (HsPar e)
-  = rnLExpr e 		`thenM` \ (e', fvs_e) ->
-    returnM (HsPar e', fvs_e)
-
+------------------------------------------
 -- Template Haskell extensions
 -- Don't ifdef-GHCI them because we want to fail gracefully
 -- (not with an rnExpr crash) in a stage-1 compiler.
@@ -192,18 +189,27 @@ rnExpr (HsQuasiQuoteE qq)
     returnM (expr'', fvs_qq `plusFV` fvs_expr)
 #endif 	/* GHCI */
 
-rnExpr section@(SectionL expr op)
-  = rnLExpr expr	 	`thenM` \ (expr', fvs_expr) ->
-    rnLExpr op	 		`thenM` \ (op', fvs_op) ->
-    checkSectionPrec InfixL section op' expr' `thenM_`
-    returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
+---------------------------------------------
+--	Sections
+-- See Note [Parsing sections] in Parser.y.pp
+rnExpr (HsPar (L loc (section@(SectionL {}))))
+  = do	{ (section', fvs) <- rnSection section
+	; return (HsPar (L loc section'), fvs) }
+
+rnExpr (HsPar (L loc (section@(SectionR {}))))
+  = do	{ (section', fvs) <- rnSection section
+	; return (HsPar (L loc section'), fvs) }
 
-rnExpr section@(SectionR op expr)
-  = rnLExpr op	 				`thenM` \ (op',   fvs_op) ->
-    rnLExpr expr	 				`thenM` \ (expr', fvs_expr) ->
-    checkSectionPrec InfixR section op' expr'	`thenM_`
-    returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
+rnExpr (HsPar e)
+  = do	{ (e', fvs_e) <- rnLExpr e
+	; return (HsPar e', fvs_e) }
 
+rnExpr expr@(SectionL {})
+  = do	{ addErr (sectionErr expr); rnSection expr }
+rnExpr expr@(SectionR {})
+  = do	{ addErr (sectionErr expr); rnSection expr }
+
+---------------------------------------------
 rnExpr (HsCoreAnn ann expr)
   = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
     returnM (HsCoreAnn ann expr', fvs_expr)
@@ -344,8 +350,24 @@ rnExpr (HsArrForm op fixity cmds)
 
 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
 	-- HsWrap
-\end{code}
 
+----------------------
+-- See Note [Parsing sections] in Parser.y.pp
+rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
+rnSection section@(SectionR op expr)
+  = do	{ (op', fvs_op)     <- rnLExpr op
+	; (expr', fvs_expr) <- rnLExpr expr
+	; checkSectionPrec InfixR section op' expr'
+	; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
+
+rnSection section@(SectionL expr op)
+  = do	{ (expr', fvs_expr) <- rnLExpr expr
+	; (op', fvs_op)     <- rnLExpr op
+	; checkSectionPrec InfixL section op' expr'
+	; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
+
+rnSection other = pprPanic "rnSection" (ppr other)
+\end{code}
 
 %************************************************************************
 %*									*
@@ -1198,6 +1220,11 @@ checkTransformStmt ctxt = addErr msg
     msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
     
 ---------
+sectionErr :: HsExpr RdrName -> SDoc
+sectionErr expr
+  = hang (ptext (sLit "A section must be enclosed in parentheses"))
+       2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
+
 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
 			 	nest 4 (ppr e)])