From 94c5c5a2f6e296125940af1946d888e53b8c82f0 Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 2 Apr 2002 13:56:34 +0000 Subject: [PATCH] [project @ 2002-04-02 13:56:32 by simonmar] Allow the use of 'let' for implcit bindings. Support for 'with' is left in place for the time being, but on seeing a 'with' we emit a non-suppressible warning about 'with' being deprecated in favour of 'let'. --- ghc/compiler/deSugar/DsExpr.lhs | 2 +- ghc/compiler/hsSyn/HsExpr.lhs | 7 +++++-- ghc/compiler/parser/Parser.y | 38 ++++++++++++++++++++++++------------ ghc/compiler/rename/RnExpr.lhs | 13 +++++++++--- ghc/compiler/typecheck/TcExpr.lhs | 4 ++-- ghc/compiler/typecheck/TcHsSyn.lhs | 4 ++-- 6 files changed, 46 insertions(+), 22 deletions(-) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 72b799a..b0e5e0a 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -254,7 +254,7 @@ dsExpr (HsLet binds body) = dsExpr body `thenDs` \ body' -> dsLet binds body' -dsExpr (HsWith expr binds) +dsExpr (HsWith expr binds is_with) = dsExpr expr `thenDs` \ expr' -> foldlDs dsIPBind expr' binds where diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index f006a38..40c97ff 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -84,6 +84,8 @@ data HsExpr id pat | HsWith (HsExpr id pat) -- implicit parameter binding [(IPName id, HsExpr id pat)] + Bool -- True <=> this was a 'with' binding + -- (tmp, until 'with' is removed) | HsDo HsDoContext [Stmt id pat] -- "do":one or more stmts @@ -304,8 +306,9 @@ ppr_expr (HsLet binds expr) = sep [hang (ptext SLIT("let")) 2 (pprBinds binds), hang (ptext SLIT("in")) 2 (ppr expr)] -ppr_expr (HsWith expr binds) - = hsep [ppr expr, ptext SLIT("with"), pp_ipbinds binds] +ppr_expr (HsWith expr binds is_with) + = sep [hang (ptext SLIT("let")) 2 (pp_ipbinds binds), + hang (ptext SLIT("in")) 2 (ppr expr)] ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 35b8854..39f3335 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.94 2002/03/28 09:59:03 simonmar Exp $ +$Id: Parser.y,v 1.95 2002/04/02 13:56:32 simonmar Exp $ Haskell grammar. @@ -60,6 +60,11 @@ Conflicts: 21 shift/reduce, -=chak[4Feb2] (don't know whether to reduce 'a' as a btype or shift the '->'. conclusion: bogus expression anyway, doesn't matter) +1 for ambiguity in '{-# RULES "name" [ ... #-} + we don't know whether the '[' starts the activation or not: it + might be the start of the declaration with the activation being + empty. --SDM 1/4/2002 + 1 for ambiguity in '{-# RULES "name" forall = ... #-}' since 'forall' is a valid variable name, we don't know whether to treat a forall on the input as the beginning of a quantifier @@ -68,9 +73,10 @@ Conflicts: 21 shift/reduce, -=chak[4Feb2] This saves explicitly defining a grammar for the rule lhs that doesn't include 'forall'. -1 for ambiguity in 'x @ Rec{..}'. - Only sensible parse is 'x @ (Rec{..})', which is what resolving - to shift gives us. +1 for ambiguity in 'let ?x ...' + the parser can't tell whether the ?x is the lhs of a normal binding or + an implicit binding. Fortunately resolving as shift gives it the only + sensible meaning, namely the lhs of an implicit binding. 6 for conflicts between `fdecl' and `fdeclDEPRECATED', which are resolved correctly, and moreover, should go away when `fdeclDEPRECATED' is removed. @@ -502,6 +508,11 @@ decllist :: { [RdrBinding] } : '{' decls '}' { $2 } | layout_on decls close { $2 } +letbinds :: { RdrNameHsExpr -> RdrNameHsExpr } + : decllist { HsLet (cvBinds cvValSig (groupBindings $1)) } + | '{' dbinds '}' { \e -> HsWith e $2 False{-not with-} } + | layout_on dbinds close { \e -> HsWith e $2 False{-not with-} } + fixdecl :: { RdrBinding } : srcloc infix prec ops { foldr1 RdrAndBindings [ RdrSig (FixSig (FixitySig n @@ -938,7 +949,7 @@ gdrh :: { RdrNameGRHS } exp :: { RdrNameHsExpr } : infixexp '::' sigtype { (ExprWithTySig $1 $3) } - | infixexp 'with' dbinding { HsWith $1 $3 } + | infixexp 'with' dbinding { HsWith $1 $3 True{-not a let-} } | infixexp { $1 } infixexp :: { RdrNameHsExpr } @@ -952,7 +963,7 @@ exp10 :: { RdrNameHsExpr } returnP (HsLam (Match ps $5 (GRHSs (unguardedRHS $8 $7) EmptyBinds placeHolderType))) } - | 'let' declbinds 'in' exp { HsLet $2 $4 } + | 'let' letbinds 'in' exp { $2 $4 } | 'if' srcloc exp 'then' exp 'else' exp { HsIf $3 $5 $7 $2 } | 'case' srcloc exp 'of' altslist { HsCase $3 $5 $2 } | '-' fexp { mkHsNegApp $2 } @@ -990,16 +1001,21 @@ aexps :: { [RdrNameHsExpr] } | {- empty -} { [] } aexp :: { RdrNameHsExpr } + : qvar '@' aexp { EAsPat $1 $3 } + | '~' aexp { ELazyPat $2 } + | aexp1 { $1 } + +aexp1 :: { RdrNameHsExpr } : var_or_con '{|' gentype '|}' { (HsApp $1 (HsType $3)) } - | aexp '{' fbinds '}' {% (mkRecConstrOrUpdate $1 + | aexp1 '{' fbinds '}' {% (mkRecConstrOrUpdate $1 (reverse $3)) } - | aexp1 { $1 } + | aexp2 { $1 } var_or_con :: { RdrNameHsExpr } : qvar { HsVar $1 } | gcon { HsVar $1 } -aexp1 :: { RdrNameHsExpr } +aexp2 :: { RdrNameHsExpr } : ipvar { HsIPVar $1 } | var_or_con { $1 } | literal { HsLit $1 } @@ -1012,9 +1028,7 @@ aexp1 :: { RdrNameHsExpr } | '[:' parr ':]' { $2 } | '(' infixexp qop ')' { (SectionL $2 (HsVar $3)) } | '(' qopm infixexp ')' { (SectionR $2 $3) } - | qvar '@' aexp { EAsPat $1 $3 } | '_' { EWildPat } - | '~' aexp1 { ELazyPat $2 } texps :: { [RdrNameHsExpr] } : texps ',' exp { $3 : $1 } @@ -1176,7 +1190,7 @@ dbinds :: { [(IPName RdrName, RdrNameHsExpr)] } : dbinds ';' dbind { $3 : $1 } | dbinds ';' { $1 } | dbind { [$1] } - | {- empty -} { [] } +-- | {- empty -} { [] } dbind :: { (IPName RdrName, RdrNameHsExpr) } dbind : ipvar '=' exp { ($1, $3) } diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 74381a1..f72b0db 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -376,10 +376,11 @@ rnExpr (HsLet binds expr) rnExpr expr `thenRn` \ (expr',fvExpr) -> returnRn (HsLet binds' expr', fvExpr) -rnExpr (HsWith expr binds) - = rnExpr expr `thenRn` \ (expr',fvExpr) -> +rnExpr (HsWith expr binds is_with) + = warnCheckRn (not is_with) withWarning `thenRn_` + rnExpr expr `thenRn` \ (expr',fvExpr) -> rnIPBinds binds `thenRn` \ (binds',fvBinds) -> - returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds) + returnRn (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds) rnExpr e@(HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ @@ -969,4 +970,10 @@ doStmtListErr e bogusCharError c = ptext SLIT("character literal out of range: '\\") <> int c <> char '\'' + +withWarning + = sep [quotes (ptext SLIT("with")), + ptext SLIT("is deprecated, use"), + quotes (ptext SLIT("let")), + ptext SLIT("instead")] \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 32f687f..a31eeb4 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -604,7 +604,7 @@ tcMonoExpr (PArrSeqIn _) _ %************************************************************************ \begin{code} -tcMonoExpr (HsWith expr binds) res_ty +tcMonoExpr (HsWith expr binds is_with) res_ty = tcMonoExpr expr res_ty `thenTc` \ (expr', expr_lie) -> mapAndUnzip3Tc tcIPBind binds `thenTc` \ (avail_ips, binds', bind_lies) -> @@ -614,7 +614,7 @@ tcMonoExpr (HsWith expr binds) res_ty let expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr' in - returnTc (HsWith expr'' binds', expr_lie' `plusLIE` plusLIEs bind_lies) + returnTc (HsWith expr'' binds' is_with, expr_lie' `plusLIE` plusLIEs bind_lies) tcIPBind (ip, expr) = newTyVarTy openTypeKind `thenTc` \ ty -> diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 8c23d8a..05cd88c 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -470,11 +470,11 @@ zonkExpr (HsLet binds expr) zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsLet new_binds new_expr) -zonkExpr (HsWith expr binds) +zonkExpr (HsWith expr binds is_with) = zonkIPBinds binds `thenNF_Tc` \ new_binds -> tcExtendGlobalValEnv (map (ipNameName . fst) new_binds) $ zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (HsWith new_expr new_binds) + returnNF_Tc (HsWith new_expr new_binds is_with) where zonkIPBinds = mapNF_Tc zonkIPBind zonkIPBind (n, e) -- 1.7.10.4