Add rebindable syntax for if-then-else

There are two main changes

 * New LANGUAGE option RebindableSyntax, which implies NoImplicitPrelude

 * if-the-else becomes rebindable, with function name "ifThenElse"
   (but case expressions are unaffected)

Thanks to Sam Anklesaria for doing most of the work here

21 files changed, 133 insertions, 69 deletions

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 33a4b809d8..aaa7c42813 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -411,7 +411,7 @@ stmt	:: { ExtCode }
         | 'return' maybe_actuals ';'
 		{ do e <- sequence $2; stmtEC (CmmReturn e) }
 	| 'if' bool_expr '{' body '}' else 	
-		{ ifThenElse $2 $4 $6 }
+		{ cmmIfThenElse $2 $4 $6 }
 
 opt_never_returns :: { CmmReturnInfo }
         :                               { CmmMayReturn }
@@ -947,7 +947,7 @@ data BoolExpr
 
 -- ToDo: smart constructors which simplify the boolean expression.
 
-ifThenElse cond then_part else_part = do
+cmmIfThenElse cond then_part else_part = do
      then_id <- code newLabelC
      join_id <- code newLabelC
      c <- cond
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 21ce13dbe3..d894523de3 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -286,8 +286,8 @@ addTickHsExpr (HsCase e mgs) =
 	liftM2 HsCase
 		(addTickLHsExpr e) 
 		(addTickMatchGroup mgs)
-addTickHsExpr (HsIf	 e1 e2 e3) = 
-	liftM3 HsIf
+addTickHsExpr (HsIf cnd e1 e2 e3) = 
+	liftM3 (HsIf cnd)
 		(addBinTickLHsExpr (BinBox CondBinBox) e1)
 		(addTickLHsExprOptAlt True e2)
 		(addTickLHsExprOptAlt True e3)
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index c55d6a4828..89c453fd73 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -404,7 +404,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
 --			if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
 --		     c1 ||| c2
 
-dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd) = do
+dsCmd ids local_vars env_ids stack res_ty (HsIf mb_fun cond then_cmd else_cmd) = do
     core_cond <- dsLExpr cond
     (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd
     (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack res_ty else_cmd
@@ -412,20 +412,26 @@ dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd) = do
     either_con <- dsLookupTyCon eitherTyConName
     left_con   <- dsLookupDataCon leftDataConName
     right_con  <- dsLookupDataCon rightDataConName
-    let
-        left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]
-        right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]
+
+    let mk_left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]
+        mk_right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]
 
         in_ty = envStackType env_ids stack
         then_ty = envStackType then_ids stack
         else_ty = envStackType else_ids stack
         sum_ty = mkTyConApp either_con [then_ty, else_ty]
         fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars
-    
-    core_if <- matchEnvStack env_ids stack_ids
-                (mkIfThenElse core_cond
-                    (left_expr  then_ty else_ty (buildEnvStack then_ids stack_ids))
-                    (right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)))
+        
+        core_left  = mk_left_expr  then_ty else_ty (buildEnvStack then_ids stack_ids)
+        core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)
+
+    core_if <- case mb_fun of 
+       Just fun -> do { core_fun <- dsExpr fun
+                      ; matchEnvStack env_ids stack_ids $
+                        mkCoreApps core_fun [core_cond, core_left, core_right] }
+       Nothing  -> matchEnvStack env_ids stack_ids $
+                   mkIfThenElse core_cond core_left core_right
+
     return (do_map_arrow ids in_ty sum_ty res_ty
                 core_if
                 (do_choice ids then_ty else_ty res_ty core_then core_else),
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 03e009d83f..5df12f592d 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -345,8 +345,14 @@ dsExpr (HsDo PArrComp stmts body result_ty)
   where
     [elt_ty] = tcTyConAppArgs result_ty
 
-dsExpr (HsIf guard_expr then_expr else_expr)
-  = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
+dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
+  = do { pred <- dsLExpr guard_expr
+       ; b1 <- dsLExpr then_expr
+       ; b2 <- dsLExpr else_expr
+       ; case mb_fun of
+           Just fun -> do { core_fun <- dsExpr fun
+                          ; return (mkCoreApps core_fun [pred,b1,b2]) }
+           Nothing  -> return $ mkIfThenElse pred b1 b2 }
 \end{code}
 
 
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 27f816dc5d..a8923494d9 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -706,7 +706,7 @@ repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
 				       ; ms2 <- mapM repMatchTup ms
 				       ; repCaseE arg (nonEmptyCoreList ms2) }
-repE (HsIf x y z)         = do
+repE (HsIf _ x y z)         = do
 			      a <- repLE x
 			      b <- repLE y
 			      c <- repLE z
@@ -1298,7 +1298,7 @@ repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
 repTup (MkC es) = rep2 tupEName [es]
 
 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
-repCond (MkC x) (MkC y) (MkC z) =  rep2 condEName [x,y,z] 
+repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] 
 
 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] 
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 17755627c3..c9524466eb 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -886,7 +886,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
         lexp e1 e1' && lexp e2 e2'
     exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
         eq_list tup_arg es1 es2
-    exp (HsIf e e1 e2) (HsIf e' e1' e2') =
+    exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
         lexp e e' && lexp e1 e1' && lexp e2 e2'
 
     -- Enhancement: could implement equality for more expressions
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index b5a185ca86..dcef02f798 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -464,8 +464,8 @@ cvtl e = wrapL (cvt e)
 			    ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
     cvt (TupE [e])     = cvt e	-- Singleton tuples treated like nothing (just parens)
     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
-    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
-			    ; return $ HsIf x' y' z' }
+    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
+			    ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
                             ; e' <- cvtl e; return $ HsLet ds' e' }
     cvt (CaseE e ms)   
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 0d7dd719e7..ee1aeca8db 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -132,7 +132,10 @@ data HsExpr id
   | HsCase      (LHsExpr id)
                 (MatchGroup id)
 
-  | HsIf        (LHsExpr id)    --  predicate
+  | HsIf        (Maybe (SyntaxExpr id)) -- cond function
+    		       		        -- Nothing => use the built-in 'if'
+					-- See Note [Rebindable if]
+                (LHsExpr id)    --  predicate
                 (LHsExpr id)    --  then part
                 (LHsExpr id)    --  else part
 
@@ -297,11 +300,18 @@ type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be
                                         -- pasted back in by the desugarer
 \end{code}
 
-A @Dictionary@, unless of length 0 or 1, becomes a tuple.  A
-@ClassDictLam dictvars methods expr@ is, therefore:
-\begin{verbatim}
-\ x -> case x of ( dictvars-and-methods-tuple ) -> expr
-\end{verbatim}
+Note [Rebindable if]
+~~~~~~~~~~~~~~~~~~~~
+The rebindable syntax for 'if' is a bit special, because when
+rebindable syntax is *off* we do not want to treat
+   (if c then t else e)
+as if it was an application (ifThenElse c t e).  Why not?
+Because we allow an 'if' to return *unboxed* results, thus 
+  if blah then 3# else 4#
+whereas that would not be possible using a all to a polymorphic function
+(because you can't call a polymorphic function at an unboxed type).
+
+So we use Nothing to mean "use the old built-in typing rule".
 
 \begin{code}
 instance OutputableBndr id => Outputable (HsExpr id) where
@@ -414,7 +424,7 @@ ppr_expr exprType@(HsCase expr matches)
           nest 2 (pprMatches (CaseAlt `asTypeOf` idType exprType) matches <+> char '}') ]
  where idType :: HsExpr id -> HsMatchContext id; idType = undefined
 
-ppr_expr (HsIf e1 e2 e3)
+ppr_expr (HsIf _ e1 e2 e3)
   = sep [hsep [ptext (sLit "if"), nest 2 (ppr e1), ptext (sLit "then")],
          nest 4 (ppr e2),
          ptext (sLit "else"),
@@ -619,7 +629,8 @@ The legal constructors for commands are:
                 [Match id]      -- bodies are HsCmd's
                 SrcLoc
 
-  | HsIf        (HsExpr id)     --  predicate
+  | HsIf        (Maybe (SyntaxExpr id)) --  cond function
+  					 (HsExpr id)     --  predicate
                 (HsCmd id)      --  then part
                 (HsCmd id)      --  else part
                 SrcLoc
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index ea24327028..b2e981c860 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -18,7 +18,7 @@ module HsUtils(
   -- Terms
   mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
   mkSimpleMatch, unguardedGRHSs, unguardedRHS, 
-  mkMatchGroup, mkMatch, mkHsLam,
+  mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
   mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
   coiToHsWrapper, mkHsDictLet,
   mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI,
@@ -205,6 +205,9 @@ noRebindableInfo = error "noRebindableInfo" 	-- Just another placeholder;
 
 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 
+mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
+mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
+
 mkNPat lit neg     = NPat lit neg noSyntaxExpr
 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 
@@ -329,7 +332,7 @@ nlList   :: [LHsExpr id] -> LHsExpr id
 
 nlHsLam	match		= noLoc (HsLam (mkMatchGroup [match]))
 nlHsPar e		= noLoc (HsPar e)
-nlHsIf cond true false	= noLoc (HsIf cond true false)
+nlHsIf cond true false	= noLoc (mkHsIf cond true false)
 nlHsCase expr matches	= noLoc (HsCase expr (mkMatchGroup matches))
 nlList exprs		= noLoc (ExplicitList placeHolderType exprs)
 
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ad68ed48ea..96037f4af4 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -325,6 +325,7 @@ data ExtensionFlag
    | Opt_GADTs
    | Opt_NPlusKPatterns
    | Opt_DoAndIfThenElse
+   | Opt_RebindableSyntax
 
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
@@ -1595,6 +1596,7 @@ xFlags = [
   ( "MonomorphismRestriction",          Opt_MonomorphismRestriction, nop ),
   ( "NPlusKPatterns",                   Opt_NPlusKPatterns, nop ),
   ( "DoAndIfThenElse",                  Opt_DoAndIfThenElse, nop ),
+  ( "RebindableSyntax",                 Opt_RebindableSyntax, nop ),
   ( "MonoPatBinds",                     Opt_MonoPatBinds, nop ),
   ( "ExplicitForAll",                   Opt_ExplicitForAll, nop ),
   ( "AlternativeLayoutRule",            Opt_AlternativeLayoutRule, nop ),
@@ -1664,6 +1666,8 @@ impliedFlags
     , (Opt_ExistentialQuantification, Opt_ExplicitForAll)
     , (Opt_PolymorphicComponents,     Opt_ExplicitForAll)
 
+    , (Opt_RebindableSyntax,          Opt_ImplicitPrelude)
+
     , (Opt_GADTs,                  Opt_MonoLocalBinds)
     , (Opt_TypeFamilies,           Opt_MonoLocalBinds)
 
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index a45ad87f0f..fd5b02c83b 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1277,7 +1277,7 @@ exp10 :: { LHsExpr RdrName }
   	| 'let' binds 'in' exp			{ LL $ HsLet (unLoc $2) $4 }
 	| 'if' exp optSemi 'then' exp optSemi 'else' exp
                                         {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
-                                           return (LL $ HsIf $2 $5 $8) }
+                                           return (LL $ mkHsIf $2 $5 $8) }
    	| 'case' exp 'of' altslist		{ LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
 	| '-' fexp				{ LL $ NegApp $2 noSyntaxExpr }
 
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 862e33ff13..3587093cb9 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -730,7 +730,7 @@ lookupTyFixityRn (L _ n) = lookupFixityRn n
 %*									*
 			Rebindable names
 	Dealing with rebindable syntax is driven by the 
-	Opt_NoImplicitPrelude dynamic flag.
+	Opt_RebindableSyntax dynamic flag.
 
 	In "deriving" code we don't want to use rebindable syntax
 	so we switch off the flag locally
@@ -769,8 +769,8 @@ checks the type of the user thing against the type of the standard thing.
 lookupSyntaxName :: Name 				-- The standard name
 	         -> RnM (SyntaxExpr Name, FreeVars)	-- Possibly a non-standard name
 lookupSyntaxName std_name
-  = xoptM Opt_ImplicitPrelude		`thenM` \ implicit_prelude -> 
-    if implicit_prelude then normal_case
+  = xoptM Opt_RebindableSyntax		`thenM` \ rebindable_on -> 
+    if not rebindable_on then normal_case 
     else
 	-- Get the similarly named thing from the local environment
     lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name ->
@@ -781,8 +781,8 @@ lookupSyntaxName std_name
 lookupSyntaxTable :: [Name]				-- Standard names
 		  -> RnM (SyntaxTable Name, FreeVars)	-- See comments with HsExpr.ReboundNames
 lookupSyntaxTable std_names
-  = xoptM Opt_ImplicitPrelude		`thenM` \ implicit_prelude -> 
-    if implicit_prelude then normal_case 
+  = xoptM Opt_RebindableSyntax		`thenM` \ rebindable_on -> 
+    if not rebindable_on then normal_case 
     else
     	-- Get the similarly named thing from the local environment
     mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names 	`thenM` \ usr_names ->
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 4e8219555e..73dcfdb92f 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -262,11 +262,15 @@ rnExpr (ExprWithTySig expr pty)
   where 
     doc = text "In an expression type signature"
 
-rnExpr (HsIf p b1 b2)
-  = rnLExpr p		`thenM` \ (p', fvP) ->
-    rnLExpr b1		`thenM` \ (b1', fvB1) ->
-    rnLExpr b2		`thenM` \ (b2', fvB2) ->
-    return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
+rnExpr (HsIf _ p b1 b2)
+  = do { (p', fvP) <- rnLExpr p
+    ; (b1', fvB1) <- rnLExpr b1
+    ; (b2', fvB2) <- rnLExpr b2
+    ; rebind <- xoptM Opt_RebindableSyntax
+    ; if not rebind
+       then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2])
+       else do { c <- liftM HsVar (lookupOccRn (mkVarUnqual (fsLit "ifThenElse")))
+               ; return (HsIf (Just c) p' b1' b2', plusFVs [fvP, fvB1, fvB2]) }}
 
 rnExpr (HsType a)
   = rnHsTypeFVs doc a	`thenM` \ (t, fvT) -> 
@@ -430,8 +434,8 @@ convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
 convertOpFormsCmd (HsCase exp matches)
   = HsCase exp (convertOpFormsMatch matches)
 
-convertOpFormsCmd (HsIf exp c1 c2)
-  = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
+convertOpFormsCmd (HsIf f exp c1 c2)
+  = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
 
 convertOpFormsCmd (HsLet binds cmd)
   = HsLet binds (convertOpFormsLCmd cmd)
@@ -487,7 +491,7 @@ methodNamesCmd (HsArrForm {}) = emptyFVs
 
 methodNamesCmd (HsPar c) = methodNamesLCmd c
 
-methodNamesCmd (HsIf _ c1 c2)
+methodNamesCmd (HsIf _ _ c1 c2)
   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
 
 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 720cadf4af..bc01bf6e3a 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -1154,7 +1154,7 @@ a) It might be a WiredInName; in that case we may not load
    its interface (although we could).
 
 b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger
-   These are seen as "used" by the renamer (if -XNoImplicitPrelude) 
+   These are seen as "used" by the renamer (if -XRebindableSyntax) 
    is on), but the typechecker may discard their uses 
    if in fact the in-scope fromRational is GHC.Read.fromRational,
    (see tcPat.tcOverloadedLit), and the typechecker sees that the type 
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 225d2f36ed..3a419be8f8 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -88,7 +88,7 @@ newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
 newMethodFromName origin name inst_ty
   = do { id <- tcLookupId name
  	      -- Use tcLookupId not tcLookupGlobalId; the method is almost
-	      -- always a class op, but with -XNoImplicitPrelude GHC is
+	      -- always a class op, but with -XRebindableSyntax GHC is
 	      -- meant to find whatever thing is in scope, and that may
 	      -- be an ordinary function. 
 
@@ -294,7 +294,7 @@ mkOverLit (HsIsString s) = return (HsString s)
 %*									*
 %************************************************************************
 
-Suppose we are doing the -XNoImplicitPrelude thing, and we encounter
+Suppose we are doing the -XRebindableSyntax thing, and we encounter
 a do-expression.  We have to find (>>) in the current environment, which is
 done by the rename. Then we have to check that it has the same type as
 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs
index 227c6ce923..53b3c97215 100644
--- a/compiler/typecheck/TcArrows.lhs
+++ b/compiler/typecheck/TcArrows.lhs
@@ -7,7 +7,7 @@ Typecheck arrow notation
 \begin{code}
 module TcArrows ( tcProc ) where
 
-import {-# SOURCE #-}	TcExpr( tcMonoExpr, tcInferRho )
+import {-# SOURCE #-}	TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp )
 
 import HsSyn
 import TcMatches
@@ -125,11 +125,17 @@ tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
                       mc_body = mc_body }
     mc_body body res_ty' = tcGuardedCmd env body stk res_ty'
 
-tc_cmd env (HsIf pred b1 b2) res_ty
-  = do 	{ pred' <- tcMonoExpr pred boolTy
-	; b1'   <- tcCmd env b1 res_ty
-	; b2'   <- tcCmd env b2 res_ty
-	; return (HsIf pred' b1' b2')
+tc_cmd env (HsIf mb_fun pred b1 b2) (stack_ty,res_ty)
+  = do 	{ pred_ty <- newFlexiTyVarTy openTypeKind
+	; b_ty <- newFlexiTyVarTy openTypeKind
+        ; let if_ty = mkFunTys [pred_ty, b_ty, b_ty] res_ty
+	; mb_fun' <- case mb_fun of 
+              Nothing  -> return Nothing
+              Just fun -> liftM Just (tcSyntaxOp IfOrigin fun if_ty)
+  	; pred' <- tcMonoExpr pred pred_ty
+	; b1'   <- tcCmd env b1 (stack_ty,b_ty)
+	; b2'   <- tcCmd env b2 (stack_ty,b_ty)
+	; return (HsIf mb_fun' pred' b1' b2')
     }
 
 -------------------------------------------
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 72052876f9..5790b6a3be 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -392,11 +392,21 @@ tcExpr (HsCase scrut matches) exp_ty
     match_ctxt = MC { mc_what = CaseAlt,
 		      mc_body = tcBody }
 
-tcExpr (HsIf pred b1 b2) res_ty
-  = do	{ pred' <- tcMonoExpr pred boolTy
-	; b1' <- tcMonoExpr b1 res_ty
-	; b2' <- tcMonoExpr b2 res_ty
-	; return (HsIf pred' b1' b2') }
+tcExpr (HsIf Nothing pred b1 b2) res_ty	   -- Ordinary 'if'
+  = do { pred' <- tcMonoExpr pred boolTy
+       ; b1' <- tcMonoExpr b1 res_ty
+       ; b2' <- tcMonoExpr b2 res_ty
+       ; return (HsIf Nothing pred' b1' b2') }
+
+tcExpr (HsIf (Just fun) pred b1 b2) res_ty   -- Rebindable syntax
+  = do { pred_ty <- newFlexiTyVarTy openTypeKind
+       ; b_ty <- newFlexiTyVarTy openTypeKind
+       ; let if_ty = mkFunTys [pred_ty, b_ty, b_ty] res_ty
+       ; fun' <- tcSyntaxOp IfOrigin fun if_ty
+       ; pred' <- tcMonoExpr pred pred_ty
+       ; b1' <- tcMonoExpr b1 b_ty
+       ; b2' <- tcMonoExpr b2 b_ty
+       ; return (HsIf (Just fun') pred' b1' b2') }
 
 tcExpr (HsDo do_or_lc stmts body _) res_ty
   = tcDoStmts do_or_lc stmts body res_ty
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 7c12410556..39e9ea91e2 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -565,11 +565,12 @@ zonkExpr env (HsCase expr ms)
     zonkMatchGroup env ms	`thenM` \ new_ms ->
     returnM (HsCase new_expr new_ms)
 
-zonkExpr env (HsIf e1 e2 e3)
-  = zonkLExpr env e1	`thenM` \ new_e1 ->
-    zonkLExpr env e2	`thenM` \ new_e2 ->
-    zonkLExpr env e3	`thenM` \ new_e3 ->
-    returnM (HsIf new_e1 new_e2 new_e3)
+zonkExpr env (HsIf e0 e1 e2 e3)
+  = do { new_e0 <- fmapMaybeM (zonkExpr env) e0
+       ; new_e1 <- zonkLExpr env e1
+       ; new_e2 <- zonkLExpr env e2
+       ; new_e3 <- zonkLExpr env e3
+       ; returnM (HsIf new_e0 new_e1 new_e2 new_e3) }
 
 zonkExpr env (HsLet binds expr)
   = zonkLocalBinds env binds	`thenM` \ (new_env, new_binds) ->
@@ -908,10 +909,7 @@ zonk_pat env (SigPatOut pat ty)
 
 zonk_pat env (NPat lit mb_neg eq_expr)
   = do	{ lit' <- zonkOverLit env lit
- 	; mb_neg' <- case mb_neg of
-			Nothing  -> return Nothing
-			Just neg -> do { neg' <- zonkExpr env neg
-				       ; return (Just neg') }
+ 	; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg
  	; eq_expr' <- zonkExpr env eq_expr
 	; return (env, NPat lit' mb_neg' eq_expr') }
 
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 4abb40836f..641319fce3 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -916,6 +916,7 @@ data CtOrigin
   | StandAloneDerivOrigin -- Typechecking stand-alone deriving
   | DefaultOrigin	-- Typechecking a default decl
   | DoOrigin		-- Arising from a do expression
+  | IfOrigin      -- Arising from an if statement
   | ProcOrigin		-- Arising from a proc expression
   | AnnOrigin           -- An annotation
 
@@ -937,6 +938,7 @@ pprO ExprSigOrigin         = ptext (sLit "an expression type signature")
 pprO PatSigOrigin          = ptext (sLit "a pattern type signature")
 pprO PatOrigin             = ptext (sLit "a pattern")
 pprO ViewPatOrigin         = ptext (sLit "a view pattern")
+pprO IfOrigin              = ptext (sLit "an if statement")
 pprO (LiteralOrigin lit)   = hsep [ptext (sLit "the literal"), quotes (ppr lit)]
 pprO (ArithSeqOrigin seq)  = hsep [ptext (sLit "the arithmetic sequence"), quotes (ppr seq)]
 pprO (PArrSeqOrigin seq)   = hsep [ptext (sLit "the parallel array sequence"), quotes (ppr seq)]
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index e10e76ac50..b80ada7e14 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -713,6 +713,12 @@
 	      <entry><option>-XImplicitPrelude</option></entry>
 	    </row>
 	    <row>
+	      <entry><option>-XRebindableSyntax</option></entry>
+	      <entry>Employ <link linkend="rebindable-syntax">rebindable syntax</link></entry>
+	      <entry>dynamic</entry>
+	      <entry><option>-XNoRebindableSyntax</option></entry>
+	    </row>
+	    <row>
 	      <entry><option>-XNoMonomorphismRestriction</option></entry>
 	      <entry>Disable the <link linkend="monomorphism">monomorphism restriction</link></entry>
 	      <entry>dynamic</entry>
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index d3eba61502..7bb33c666f 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -1258,8 +1258,8 @@ output = [ x
             hierarchy.  It completely defeats that purpose if the
             literal "1" means "<literal>Prelude.fromInteger
             1</literal>", which is what the Haskell Report specifies.
-            So the <option>-XNoImplicitPrelude</option> 
-	      flag <emphasis>also</emphasis> causes
+            So the <option>-XRebindableSyntax</option> 
+	      flag causes
             the following pieces of built-in syntax to refer to
             <emphasis>whatever is in scope</emphasis>, not the Prelude
             versions:
@@ -1291,6 +1291,11 @@ output = [ x
 	      </para></listitem>
 
 	      <listitem>
+		<para>Conditionals (e.g. "<literal>if</literal> e1 <literal>then</literal> e2 <literal>else</literal> e3")
+		means "<literal>ifThenElse</literal> e1 e2 e3".  However <literal>case</literal> expressions are unaffected.
+	      </para></listitem>
+
+	      <listitem>
 	  <para>"Do" notation is translated using whatever
 	      functions <literal>(>>=)</literal>,
 	      <literal>(>>)</literal>, and <literal>fail</literal>,
@@ -1310,6 +1315,9 @@ output = [ x
 		to use this, ask!
 	      </para></listitem>
 	    </itemizedlist>
+<option>-XRebindableSyntax</option> implies <option>-XNoImplicitPrelude</option>.
+</para>
+<para>
 In all cases (apart from arrow notation), the static semantics should be that of the desugared form,
 even if that is a little unexpected. For example, the 
 static semantics of the literal <literal>368</literal>