From 4e0c994eb1613c62e94069642d7acdb2e69b773b Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 22 Oct 2010 14:34:00 +0000 Subject: [PATCH] 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 | 4 ++-- compiler/deSugar/Coverage.lhs | 4 ++-- compiler/deSugar/DsArrows.lhs | 24 +++++++++++++++--------- compiler/deSugar/DsExpr.lhs | 10 ++++++++-- compiler/deSugar/DsMeta.hs | 4 ++-- compiler/deSugar/Match.lhs | 2 +- compiler/hsSyn/Convert.lhs | 4 ++-- compiler/hsSyn/HsExpr.lhs | 27 +++++++++++++++++++-------- compiler/hsSyn/HsUtils.lhs | 7 +++++-- compiler/main/DynFlags.hs | 4 ++++ compiler/parser/Parser.y.pp | 2 +- compiler/rename/RnEnv.lhs | 10 +++++----- compiler/rename/RnExpr.lhs | 20 ++++++++++++-------- compiler/rename/RnNames.lhs | 2 +- compiler/typecheck/Inst.lhs | 4 ++-- compiler/typecheck/TcArrows.lhs | 18 ++++++++++++------ compiler/typecheck/TcExpr.lhs | 20 +++++++++++++++----- compiler/typecheck/TcHsSyn.lhs | 16 +++++++--------- compiler/typecheck/TcRnTypes.lhs | 2 ++ docs/users_guide/flags.xml | 6 ++++++ docs/users_guide/glasgow_exts.xml | 12 ++++++++++-- 21 files changed, 133 insertions(+), 69 deletions(-) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 33a4b80..aaa7c42 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 21ce13d..d894523 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 c55d6a4..89c453f 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 03e009d..5df12f5 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 27f816d..a892349 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 1775562..c952446 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 b5a185c..dcef02f 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 0d7dd71..ee1aeca 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 ea24327..b2e981c 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 ad68ed4..96037f4 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 a45ad87..fd5b02c 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 862e33f..3587093 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 4e82195..73dcfdb 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 720cadf..bc01bf6 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 225d2f3..3a419be 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 227c6ce..53b3c97 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 7205287..5790b6a 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 7c12410..39e9ea9 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 4abb408..641319f 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 e10e76a..b80ada7 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -713,6 +713,12 @@ + + Employ rebindable syntax + dynamic + + + Disable the monomorphism restriction dynamic diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index d3eba61..7bb33c6 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 "Prelude.fromInteger 1", which is what the Haskell Report specifies. - So the - flag also causes + So the + flag causes the following pieces of built-in syntax to refer to whatever is in scope, not the Prelude versions: @@ -1291,6 +1291,11 @@ output = [ x + Conditionals (e.g. "if e1 then e2 else e3") + means "ifThenElse e1 e2 e3". However case expressions are unaffected. + + + "Do" notation is translated using whatever functions (>>=), (>>), and fail, @@ -1310,6 +1315,9 @@ output = [ x to use this, ask! + implies . + + 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 368 -- 1.7.10.4