[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'.

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 72b799a..b0e5e0a 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)