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

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 33a4b80..aaa7c42 100644 (file)
--- 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      
         | '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 }
 
 opt_never_returns :: { CmmReturnInfo }
         :                               { CmmMayReturn }

@@ -947,7 +947,7 @@ data BoolExpr
 
 -- ToDo: smart constructors which simplify the boolean expression.
 
 
 -- 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
      then_id <- code newLabelC
      join_id <- code newLabelC
      c <- cond

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 21ce13d..d894523 100644 (file)
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -286,8 +286,8 @@ addTickHsExpr (HsCase e mgs) =
        liftM2 HsCase
                (addTickLHsExpr e) 
                (addTickMatchGroup 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)
                (addBinTickLHsExpr (BinBox CondBinBox) e1)
                (addTickLHsExprOptAlt True e2)
                (addTickLHsExprOptAlt True e3)

diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index c55d6a4..89c453f 100644 (file)
--- 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
 
 --                     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
     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
     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
 
         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),
     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 03e009d..5df12f5 100644 (file)
--- 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
 
   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}
 
 
 \end{code}
 
 

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 27f816d..a892349 100644 (file)
--- 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 (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
                              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)
 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] 
 
 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 1775562..c952446 100644 (file)
--- 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
         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
         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 b5a185c..dcef02f 100644 (file)
--- 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 }
                            ; 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)   
     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 0d7dd71..ee1aeca 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -132,7 +132,10 @@ data HsExpr id
   | HsCase      (LHsExpr id)
                 (MatchGroup 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
 
                 (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}
 
                                         -- 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
 
 \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
 
           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"),
   = 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
 
                 [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
                 (HsCmd id)      --  then part
                 (HsCmd id)      --  else part
                 SrcLoc

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index ea24327..b2e981c 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -18,7 +18,7 @@ module HsUtils(
   -- Terms
   mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
   mkSimpleMatch, unguardedGRHSs, unguardedRHS, 
   -- 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,
   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
 
 
 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
 
 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)
 
 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)
 
 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 ad68ed4..96037f4 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -325,6 +325,7 @@ data ExtensionFlag
    | Opt_GADTs
    | Opt_NPlusKPatterns
    | Opt_DoAndIfThenElse
    | Opt_GADTs
    | Opt_NPlusKPatterns
    | Opt_DoAndIfThenElse

+   | Opt_RebindableSyntax

 
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
 
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable

@@ -1595,6 +1596,7 @@ xFlags = [
   ( "MonomorphismRestriction",          Opt_MonomorphismRestriction, nop ),
   ( "NPlusKPatterns",                   Opt_NPlusKPatterns, nop ),
   ( "DoAndIfThenElse",                  Opt_DoAndIfThenElse, nop ),
   ( "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 ),
   ( "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_ExistentialQuantification, Opt_ExplicitForAll)
     , (Opt_PolymorphicComponents,     Opt_ExplicitForAll)
 

+    , (Opt_RebindableSyntax,          Opt_ImplicitPrelude)
+

     , (Opt_GADTs,                  Opt_MonoLocalBinds)
     , (Opt_TypeFamilies,           Opt_MonoLocalBinds)
 
     , (Opt_GADTs,                  Opt_MonoLocalBinds)
     , (Opt_TypeFamilies,           Opt_MonoLocalBinds)
 

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index a45ad87..fd5b02c 100644 (file)
--- 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 >>
        | '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 }
 
        | '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 862e33f..3587093 100644 (file)
--- 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 
 %*                                                                     *
                        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
 
        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
 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 ->
     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
 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 ->
     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 4e82195..73dcfdb 100644 (file)
--- 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"
 
   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) -> 
 
 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 (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)
 
 convertOpFormsCmd (HsLet binds cmd)
   = HsLet binds (convertOpFormsLCmd cmd)

@@ -487,7 +491,7 @@ methodNamesCmd (HsArrForm {}) = emptyFVs
 
 methodNamesCmd (HsPar c) = methodNamesLCmd c
 
 
 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
   = 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 720cadf..bc01bf6 100644 (file)
--- 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
    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 
    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 225d2f3..3a419be 100644 (file)
--- 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
 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. 
 
              -- 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
 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 227c6ce..53b3c97 100644 (file)
--- a/compiler/typecheck/TcArrows.lhs
+++ b/compiler/typecheck/TcArrows.lhs
@@ -7,7 +7,7 @@ Typecheck arrow notation
 \begin{code}
 module TcArrows ( tcProc ) where
 
 \begin{code}
 module TcArrows ( tcProc ) where
 

-import {-# SOURCE #-}  TcExpr( tcMonoExpr, tcInferRho )
+import {-# SOURCE #-}  TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp )

 
 import HsSyn
 import TcMatches
 
 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'
 
                       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 7205287..5790b6a 100644 (file)
--- 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 }
 
     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
 
 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 7c12410..39e9ea9 100644 (file)
--- 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)
 
     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) ->
 
 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
 
 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') }
 
        ; 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 4abb408..641319f 100644 (file)
--- 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
   | 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
 
   | 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 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)]
 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 e10e76a..b80ada7 100644 (file)
--- 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>-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>
              <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 d3eba61..7bb33c6 100644 (file)
--- 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.
             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:
             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></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>,
          <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>
                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>
 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>