From: Ian Lynagh <igloo@earth.li>
Date: Sun, 8 Aug 2010 19:46:25 +0000 (+0000)
Subject: Add DoAndIfThenElse support
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=0cbdc7b1bd76c61ad31a14a43398ae05ce138489

Add DoAndIfThenElse support
---

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ccf5050..85554cb 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -305,6 +305,7 @@ data ExtensionFlag
    | Opt_GADTs
    | Opt_RelaxedPolyRec
    | Opt_NPlusKPatterns
+   | Opt_DoAndIfThenElse
 
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
@@ -814,6 +815,7 @@ languageExtensions (Just Haskell2010)
        Opt_EmptyDataDecls,
        Opt_ForeignFunctionInterface,
        Opt_PatternGuards,
+       Opt_DoAndIfThenElse,
        Opt_RelaxedPolyRec]
 
 -- The DOpt class is a temporary workaround, to avoid having to do
@@ -1773,6 +1775,7 @@ xFlags = [
   ( "BangPatterns",                     Opt_BangPatterns, const Supported ),
   ( "MonomorphismRestriction",          Opt_MonomorphismRestriction, const Supported ),
   ( "NPlusKPatterns",                   Opt_NPlusKPatterns, const Supported ),
+  ( "DoAndIfThenElse",                  Opt_DoAndIfThenElse, const Supported ),
   ( "MonoPatBinds",                     Opt_MonoPatBinds, const Supported ),
   ( "ExplicitForAll",                   Opt_ExplicitForAll, const Supported ),
   ( "AlternativeLayoutRule",            Opt_AlternativeLayoutRule, const Supported ),
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index a2e2ff0..6f1b2e4 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1269,7 +1269,9 @@ exp10 :: { LHsExpr RdrName }
 							   	(unguardedGRHSs $6)
 							    ]) }
   	| 'let' binds 'in' exp			{ LL $ HsLet (unLoc $2) $4 }
-	| 'if' exp 'then' exp 'else' exp	{ LL $ HsIf $2 $4 $6 }
+	| 'if' exp optSemi 'then' exp optSemi 'else' exp
+                                        {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
+                                           return (LL $ HsIf $2 $5 $8) }
    	| 'case' exp 'of' altslist		{ LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
 	| '-' fexp				{ LL $ NegApp $2 noSyntaxExpr }
 
@@ -1296,6 +1298,10 @@ exp10 :: { LHsExpr RdrName }
 						    -- hdaume: core annotation
 	| fexp					{ $1 }
 
+optSemi :: { Bool }
+	: ';'         { True }
+	| {- empty -} { False }
+
 scc_annot :: { Located FastString }
 	: '_scc_' STRING			{% (addWarning Opt_WarnWarningsDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ ->
                                    ( do scc <- getSCC $2; return $ LL scc ) }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 90220d3..32f81a7 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -44,6 +44,7 @@ module RdrHsSyn (
 	checkMDo,	      -- [Stmt] -> P [Stmt]
 	checkValDef,	      -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
 	checkValSig,	      -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+	checkDoAndIfThenElse,
 	parseError,	    
 	parseErrorSDoc,	    
     ) where
@@ -815,6 +816,27 @@ checkValSig lhs@(L l _) ty
     looks_like_foreign _                   = False
 
     foreign_RDR = mkUnqual varName (fsLit "foreign")
+
+checkDoAndIfThenElse :: LHsExpr RdrName
+                     -> Bool
+                     -> LHsExpr RdrName
+                     -> Bool
+                     -> LHsExpr RdrName
+                     -> P ()
+checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
+ | semiThen || semiElse
+    = do pState <- getPState
+         unless (dopt Opt_DoAndIfThenElse (dflags pState)) $ do
+             parseErrorSDoc (combineLocs guardExpr elseExpr)
+                            (text "Unexpected semi-colons in conditional:"
+                          $$ nest 4 expr
+                          $$ text "Perhaps you meant to use -XDoAndIfThenElse?")
+ | otherwise            = return ()
+    where pprOptSemi True  = semi
+          pprOptSemi False = empty
+          expr = text "if"   <+> ppr guardExpr <> pprOptSemi semiThen <+>
+                 text "then" <+> ppr thenExpr  <> pprOptSemi semiElse <+>
+                 text "else" <+> ppr elseExpr
 \end{code}