Add DoAndIfThenElse support

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 ),

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 ) }

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}