Add rebindable syntax for if-then-else
authorsimonpj@microsoft.com <unknown>
Fri, 22 Oct 2010 14:34:00 +0000 (14:34 +0000)
committersimonpj@microsoft.com <unknown>
Fri, 22 Oct 2010 14:34:00 +0000 (14:34 +0000)
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:
compiler/cmm/CmmParse.y
compiler/deSugar/Coverage.lhs
compiler/deSugar/DsArrows.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsMeta.hs
compiler/deSugar/Match.lhs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsUtils.lhs
compiler/main/DynFlags.hs
compiler/parser/Parser.y.pp
compiler/rename/RnEnv.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnNames.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcArrows.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcRnTypes.lhs
docs/users_guide/flags.xml
docs/users_guide/glasgow_exts.xml

index 33a4b80..aaa7c42 100644 (file)
@@ -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
index 21ce13d..d894523 100644 (file)
@@ -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)
index c55d6a4..89c453f 100644 (file)
@@ -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),
index 03e009d..5df12f5 100644 (file)
@@ -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}
 
 
index 27f816d..a892349 100644 (file)
@@ -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] 
index 1775562..c952446 100644 (file)
@@ -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
index b5a185c..dcef02f 100644 (file)
@@ -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)   
index 0d7dd71..ee1aeca 100644 (file)
@@ -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
index ea24327..b2e981c 100644 (file)
@@ -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)
 
index ad68ed4..96037f4 100644 (file)
@@ -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)
 
index a45ad87..fd5b02c 100644 (file)
@@ -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 }
 
index 862e33f..3587093 100644 (file)
@@ -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 ->
index 4e82195..73dcfdb 100644 (file)
@@ -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 exp c1 c2)
+  = HsIf 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
index 720cadf..bc01bf6 100644 (file)
@@ -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 
index 225d2f3..3a419be 100644 (file)
@@ -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
index 227c6ce..53b3c97 100644 (file)
@@ -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')
     }
 
 -------------------------------------------
index 7205287..5790b6a 100644 (file)
@@ -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
index 7c12410..39e9ea9 100644 (file)
@@ -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') }
 
index 4abb408..641319f 100644 (file)
@@ -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)]
index e10e76a..b80ada7 100644 (file)
              <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>
index d3eba61..7bb33c6 100644 (file)
@@ -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>