X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnExpr.lhs;h=942ac2d0fee9ec73c8be9ef65f394790c8639113;hb=83256c875683894a93cf4468947ccf11c65577ca;hp=70749938c117c84a44bb91af6a5048f7e6b004bf;hpb=96438b8912028d59873bdba4995838cc21cc804f;p=ghc-hetmet.git

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 7074993..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 (HsPar e)
+  = do	{ (e', fvs_e) <- rnLExpr e
+	; return (HsPar e', fvs_e) }
 
-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 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}
 
 %************************************************************************
 %*									*
@@ -564,9 +586,7 @@ rnBracket (VarBr n) = do { name <- lookupOccRn n
 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
 			 ; return (ExpBr e', fvs) }
 
-rnBracket (PatBr _) = do { addErr (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"));
-                           failM }
-
+rnBracket (PatBr _) = failWith (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
 			 ; return (TypBr t', fvs) }
 		    where
@@ -930,8 +950,7 @@ rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
                fv_pat)]
 
 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
-  = do	{ addErr (badIpBinds (ptext (sLit "an mdo expression")) binds)
-	; failM }
+  = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 
 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) 
     = do binds' <- rnValBindsLHS fix_env binds
@@ -993,8 +1012,7 @@ rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
 	      L loc (BindStmt pat' expr' bind_op fail_op))]
 
 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
-  = do	{ addErr (badIpBinds (ptext (sLit "an mdo expression")) binds)
-	; failM }
+  = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 
 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do 
   (binds', du_binds) <- 
@@ -1202,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)])