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

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

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)

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

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}
 
 

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] 

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

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)   

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

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)
 

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)
 

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 }
 

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

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

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 

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

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

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

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

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

docs/users_guide/flags.xml

@@ -712,6 +712,12 @@
 	      <entry>dynamic</entry>
 	      <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>