Add while! (while bang)

src/Compiler/Checking/CheckComputationExpressions.fs

@@ -111,6 +111,7 @@ let YieldFree (cenv: cenv) expr =
             | SynExpr.TryFinally (tryExpr=body)
             | SynExpr.LetOrUse (body=body)
             | SynExpr.While (doExpr=body)
+            | SynExpr.WhileBang (doExpr=body)
             | SynExpr.ForEach (bodyExpr=body) ->
                 YieldFree body
 
@@ -142,6 +143,7 @@ let YieldFree (cenv: cenv) expr =
             | SynExpr.TryFinally (tryExpr=body)
             | SynExpr.LetOrUse (body=body)
             | SynExpr.While (doExpr=body)
+            | SynExpr.WhileBang (doExpr=body)
             | SynExpr.ForEach (bodyExpr=body) ->
                 YieldFree body
 
@@ -177,7 +179,8 @@ let (|SimpleSemicolonSequence|_|) cenv acceptDeprecated cexpr =
         | SynExpr.Do _ 
         | SynExpr.MatchBang _ 
         | SynExpr.LetOrUseBang _ 
-        | SynExpr.While _ -> false
+        | SynExpr.While _
+        | SynExpr.WhileBang _ -> false
         | _ -> true
 
     let rec TryGetSimpleSemicolonSequenceOfComprehension expr acc = 
@@ -1027,6 +1030,36 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol
                         [ mkSynDelay2 guardExpr; 
                           mkSynCall "Delay" mWhile [mkSynDelay innerComp.Range holeFill]])) )
 
+        | SynExpr.WhileBang (spWhile, guardExpr, innerComp, _) -> 
+            let mGuard = guardExpr.Range
+            let mWhile = match spWhile with DebugPointAtWhile.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.While) | _ -> mGuard
+
+            // 'while!' is hit just before each time the guard is called
+            let guardExpr = 
+                match spWhile with
+                | DebugPointAtWhile.Yes _ ->
+                    SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mWhile, false, guardExpr)
+                | DebugPointAtWhile.No -> guardExpr
+
+            // todo desugar directly instead of rewriting first
+            let body =
+                let id = mkSynId mGuard "$cond"
+                let pat = mkSynPatVar None id
+
+                let body =
+                    let id2 = mkSynId mGuard "$condM"
+                    let pat2 = mkSynPatVar None id2
+                    let b = mkSynBinding (Xml.PreXmlDoc.Empty, pat2) (None, false, true, mGuard, DebugPointAtBinding.NoneAtSticky, None, SynExpr.Ident id, mGuard, [], [], None, SynBindingTrivia.Zero)  
+                    let set = SynExpr.LongIdentSet (SynLongIdent ([ id2 ], [], []), SynExpr.Ident id, mGuard)
+                    let bang = SynExpr.LetOrUseBang (DebugPointAtBinding.NoneAtSticky, false, false, pat, guardExpr, [], set, mGuard, SynExprLetOrUseBangTrivia.Zero)
+
+                    let body = SynExpr.While (DebugPointAtWhile.No, SynExpr.Ident id2, SynExpr.Sequential (DebugPointAtSequential.SuppressBoth, true, innerComp, bang, mWhile), mWhile)
+                    SynExpr.LetOrUse (false, false, [ b ], body, mGuard, SynExprLetOrUseTrivia.Zero)
+
+                SynExpr.LetOrUseBang (DebugPointAtBinding.NoneAtSticky, false, false, pat, guardExpr, [], body, mGuard, SynExprLetOrUseBangTrivia.Zero)
+
+            tryTrans CompExprTranslationPass.Initial q varSpace body translatedCtxt
+
         | SynExpr.TryFinally (innerComp, unwindExpr, _mTryToLast, spTry, spFinally, trivia) ->
 
             let mTry = match spTry with DebugPointAtTry.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.Try) | _ -> trivia.TryKeyword
@@ -1733,14 +1766,15 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol
 
         | _ -> None
 
-    /// Check is an expression has no computation expression constructs
+    /// Check if an expression has no computation expression constructs
     and isSimpleExpr comp =
 
         match comp with 
         | ForEachThenJoinOrGroupJoinOrZipClause false _ -> false
         | SynExpr.ForEach _ -> false
         | SynExpr.For _ -> false
         | SynExpr.While _ -> false
+        | SynExpr.WhileBang _ -> false
         | SynExpr.TryFinally _ -> false
         | SynExpr.ImplicitZero _ -> false
         | OptionalSequential (JoinOrGroupJoinOrZipClause _, _) -> false

src/Compiler/Checking/CheckExpressions.fs

@@ -5700,6 +5700,9 @@ and TcExprUndelayed (cenv: cenv) (overallTy: OverallTy) env tpenv (synExpr: SynE
     | SynExpr.MatchBang (range=m) ->
         error(Error(FSComp.SR.tcConstructRequiresComputationExpression(), m))
 
+    | SynExpr.WhileBang (range=m) ->
+        error(Error(FSComp.SR.tcConstructRequiresComputationExpression(), m))
+
     // Part of 'T.Ident
     | SynExpr.Typar (typar, m) ->
         TcTyparExprThen cenv overallTy env tpenv typar m []
@@ -8678,6 +8681,7 @@ and TcImplicitOpItemThen (cenv: cenv) overallTy env id sln tpenv mItem delayed =
         | SynExpr.MatchBang _
         | SynExpr.LetOrUseBang _
         | SynExpr.DoBang _
+        | SynExpr.WhileBang _
         | SynExpr.TraitCall _
         | SynExpr.IndexFromEnd _
         | SynExpr.IndexRange _

src/Compiler/Driver/CompilerDiagnostics.fs

@@ -1180,6 +1180,7 @@ type Exception with
                 | Parser.TOKEN_INLINE -> SR.GetString("Parser.TOKEN.INLINE")
                 | Parser.TOKEN_WHEN -> SR.GetString("Parser.TOKEN.WHEN")
                 | Parser.TOKEN_WHILE -> SR.GetString("Parser.TOKEN.WHILE")
+                | Parser.TOKEN_WHILE_BANG -> SR.GetString("Parser.TOKEN.WHILE.BANG")
                 | Parser.TOKEN_WITH -> SR.GetString("Parser.TOKEN.WITH")
                 | Parser.TOKEN_IF -> SR.GetString("Parser.TOKEN.IF")
                 | Parser.TOKEN_DO -> SR.GetString("Parser.TOKEN.DO")

src/Compiler/FSComp.txt

@@ -1463,6 +1463,7 @@ keywordDescriptionVal,"Used in a signature to indicate a value, or in a type to
 keywordDescriptionVoid,"Indicates the .NET void type. Used when interoperating with other .NET languages."
 keywordDescriptionWhen,"Used for Boolean conditions (when guards) on pattern matches and to introduce a constraint clause for a generic type parameter."
 keywordDescriptionWhile,"Introduces a looping construct."
+keywordDescriptionWhileBang,"Used in computation expressions to introduce a looping construct where the condition is the result of another computation expression."
 keywordDescriptionWith,"Used together with the match keyword in pattern matching expressions. Also used in object expressions, record copying expressions, and type extensions to introduce member definitions, and to introduce exception handlers."
 keywordDescriptionYield,"Used in a sequence expression to produce a value for a sequence."
 keywordDescriptionYieldBang,"Used in a computation expression to append the result of a given computation expression to a collection of results for the containing computation expression."

src/Compiler/FSStrings.resx

@@ -112,10 +112,10 @@
     <value>2.0</value>
   </resheader>
   <resheader name="reader">
-    <value>System.Resources.ResXResourceReader, System.Windows.Forms, Version=2.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
+    <value>System.Resources.ResXResourceReader, System.Windows.Forms, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
   </resheader>
   <resheader name="writer">
-    <value>System.Resources.ResXResourceWriter, System.Windows.Forms, Version=2.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
+    <value>System.Resources.ResXResourceWriter, System.Windows.Forms, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
   </resheader>
   <data name="SeeAlso" xml:space="preserve">
     <value>. See also {0}.</value>
@@ -1113,4 +1113,7 @@
   <data name="ErrorFromAddingTypeEquationTuples" xml:space="preserve">
     <value>Type mismatch. Expecting a tuple of length {0} of type\n    {1}    \nbut given a tuple of length {2} of type\n    {3}    {4}\n</value>
   </data>
+  <data name="Parser.TOKEN.WHILE.BANG" xml:space="preserve">
+    <value>keyword 'while!'</value>
+  </data>
 </root>

src/Compiler/Service/FSharpParseFileResults.fs

@@ -734,7 +734,8 @@ type FSharpParseFileResults(diagnostics: FSharpDiagnostic[], input: ParsedInput,
                             for SynInterfaceImpl (bindings = bs) in is do
                                 yield! walkBinds bs
 
-                        | SynExpr.While (spWhile, e1, e2, _) ->
+                        | SynExpr.While (spWhile, e1, e2, _)
+                        | SynExpr.WhileBang (spWhile, e1, e2, _) ->
                             yield! walkWhileSeqPt spWhile
                             yield! walkExpr false e1
                             yield! walkExpr true e2
@@ -766,7 +767,8 @@ type FSharpParseFileResults(diagnostics: FSharpDiagnostic[], input: ParsedInput,
 
                         | SynExpr.Lambda (body = bodyExpr) -> yield! walkExpr true bodyExpr
 
-                        | SynExpr.Match (matchDebugPoint = spBind; expr = inpExpr; clauses = cl) ->
+                        | SynExpr.Match (matchDebugPoint = spBind; expr = inpExpr; clauses = cl)
+                        | SynExpr.MatchBang (matchDebugPoint = spBind; expr = inpExpr; clauses = cl) ->
                             yield! walkBindSeqPt spBind
                             yield! walkExpr false inpExpr
 
@@ -848,14 +850,6 @@ type FSharpParseFileResults(diagnostics: FSharpDiagnostic[], input: ParsedInput,
                                 yield! walkExpr true eAndBang
 
                             yield! walkExpr true bodyExpr
-
-                        | SynExpr.MatchBang (matchDebugPoint = spBind; expr = inpExpr; clauses = clauses) ->
-                            yield! walkBindSeqPt spBind
-                            yield! walkExpr false inpExpr
-
-                            for SynMatchClause (whenExpr = whenExpr; resultExpr = resExpr) in clauses do
-                                yield! walkExprOpt true whenExpr
-                                yield! walkExpr true resExpr
                 ]
 
             // Process a class declaration or F# type declaration

src/Compiler/Service/ServiceLexing.fs

@@ -383,6 +383,7 @@ module internal TokenClassifications =
         | INLINE
         | WHEN
         | WHILE
+        | WHILE_BANG
         | WITH
         | IF
         | THEN
@@ -1310,6 +1311,7 @@ type FSharpTokenKind =
     | ColonEquals
     | When
     | While
+    | WhileBang
     | With
     | Hash
     | Ampersand
@@ -1520,6 +1522,7 @@ type FSharpToken =
         | SEMICOLON -> FSharpTokenKind.SemicolonSemicolon
         | WHEN -> FSharpTokenKind.When
         | WHILE -> FSharpTokenKind.While
+        | WHILE_BANG -> FSharpTokenKind.WhileBang
         | WITH -> FSharpTokenKind.With
         | HASH -> FSharpTokenKind.Hash
         | AMP -> FSharpTokenKind.Ampersand

src/Compiler/Service/ServiceLexing.fsi

@@ -438,6 +438,7 @@ type public FSharpTokenKind =
     | ColonEquals
     | When
     | While
+    | WhileBang
     | With
     | Hash
     | Ampersand

src/Compiler/Service/ServiceParseTreeWalk.fs

@@ -505,7 +505,8 @@ module SyntaxTraversal =
                         ]
                         |> pick expr
 
-                | SynExpr.While (_spWhile, synExpr, synExpr2, _range) ->
+                | SynExpr.While (_spWhile, synExpr, synExpr2, _range)
+                | SynExpr.WhileBang (_spWhile, synExpr, synExpr2, _range) ->
                     [
                         dive synExpr synExpr.Range traverseSynExpr
                         dive synExpr2 synExpr2.Range traverseSynExpr
@@ -561,7 +562,8 @@ module SyntaxTraversal =
                     |> List.map (fun x -> dive x x.Range (traverseSynMatchClause path))
                     |> pick expr
 
-                | SynExpr.Match (expr = synExpr; clauses = synMatchClauseList) ->
+                | SynExpr.Match (expr = synExpr; clauses = synMatchClauseList)
+                | SynExpr.MatchBang (expr = synExpr; clauses = synMatchClauseList) ->
                     [
                         yield dive synExpr synExpr.Range traverseSynExpr
                         yield!
@@ -570,7 +572,8 @@ module SyntaxTraversal =
                     ]
                     |> pick expr
 
-                | SynExpr.Do (synExpr, _range) -> traverseSynExpr synExpr
+                | SynExpr.Do (synExpr, _)
+                | SynExpr.DoBang (synExpr, _) -> traverseSynExpr synExpr
 
                 | SynExpr.Assert (synExpr, _range) -> traverseSynExpr synExpr
 
@@ -755,17 +758,6 @@ module SyntaxTraversal =
                     ]
                     |> pick expr
 
-                | SynExpr.MatchBang (expr = synExpr; clauses = synMatchClauseList) ->
-                    [
-                        yield dive synExpr synExpr.Range traverseSynExpr
-                        yield!
-                            synMatchClauseList
-                            |> List.map (fun x -> dive x x.Range (traverseSynMatchClause path))
-                    ]
-                    |> pick expr
-
-                | SynExpr.DoBang (synExpr, _range) -> traverseSynExpr synExpr
-
                 | SynExpr.LibraryOnlyILAssembly _ -> None
 
                 | SynExpr.LibraryOnlyStaticOptimization _ -> None

src/Compiler/Service/ServiceStructure.fs

@@ -442,7 +442,8 @@ module Structure =
                         parseExpr elseExpr
                 | None -> ()
 
-            | SynExpr.While (_, _, e, r) ->
+            | SynExpr.While (_, _, e, r)
+            | SynExpr.WhileBang (_, _, e, r) ->
                 rcheck Scope.While Collapse.Below r r
                 parseExpr e
 

src/Compiler/SyntaxTree/LexFilter.fs

@@ -1247,7 +1247,7 @@ type LexFilterImpl (
             | EOF _ -> false
             | _ -> 
                 not (isSameLine()) ||  
-                (match peekNextToken() with TRY | MATCH | MATCH_BANG | IF | LET _ | FOR | WHILE -> true | _ -> false) 
+                (match peekNextToken() with TRY | MATCH | MATCH_BANG | IF | LET _ | FOR | WHILE | WHILE_BANG -> true | _ -> false) 
 
         // Look for '=' or '.Id.id.id = ' after an identifier
         let rec isLongIdentEquals token = 
@@ -2325,7 +2325,7 @@ type LexFilterImpl (
             pushCtxt tokenTup (CtxtFor tokenStartPos)
             returnToken tokenLexbufState token
 
-        | WHILE, _ -> 
+        | (WHILE | WHILE_BANG), _ -> 
             if debug then dprintf "WHILE, pushing CtxtWhile(%a)\n" outputPos tokenStartPos
             pushCtxt tokenTup (CtxtWhile tokenStartPos)
             returnToken tokenLexbufState token

src/Compiler/SyntaxTree/PrettyNaming.fs

@@ -238,6 +238,7 @@ let keywordsWithDescription: (string * string) list =
         "void", FSComp.SR.keywordDescriptionVoid ()
         "when", FSComp.SR.keywordDescriptionWhen ()
         "while", FSComp.SR.keywordDescriptionWhile ()
+        "while!", FSComp.SR.keywordDescriptionWhileBang ()
         "with", FSComp.SR.keywordDescriptionWith ()
         "yield", FSComp.SR.keywordDescriptionYield ()
         "yield!", FSComp.SR.keywordDescriptionYieldBang ()

src/Compiler/SyntaxTree/SyntaxTree.fs

@@ -679,6 +679,8 @@ type SynExpr =
 
     | DoBang of expr: SynExpr * range: range
 
+    | WhileBang of whileDebugPoint: DebugPointAtWhile * whileExpr: SynExpr * doExpr: SynExpr * range: range
+
     | LibraryOnlyILAssembly of
         ilCode: obj *  // this type is ILInstr[]  but is hidden to avoid the representation of AbstractIL being public
         typeArgs: SynType list *
@@ -777,6 +779,7 @@ type SynExpr =
         | SynExpr.LetOrUseBang (range = m)
         | SynExpr.MatchBang (range = m)
         | SynExpr.DoBang (range = m)
+        | SynExpr.WhileBang (range = m)
         | SynExpr.Fixed (range = m)
         | SynExpr.InterpolatedString (range = m)
         | SynExpr.Dynamic (range = m) -> m

src/Compiler/SyntaxTree/SyntaxTree.fsi

@@ -871,6 +871,9 @@ type SynExpr =
     /// Computation expressions only
     | DoBang of expr: SynExpr * range: range
 
+    /// F# syntax: 'while! ... do ...'
+    | WhileBang of whileDebugPoint: DebugPointAtWhile * whileExpr: SynExpr * doExpr: SynExpr * range: range
+
     /// Only used in FSharp.Core
     | LibraryOnlyILAssembly of
         ilCode: obj *  // this type is ILInstr[]  but is hidden to avoid the representation of AbstractIL being public

src/Compiler/SyntaxTree/SyntaxTreeOps.fs

@@ -866,15 +866,17 @@ let rec synExprContainsError inpExpr =
             walkBinds bs || walkBinds binds
 
         | SynExpr.ForEach (_, _, _, _, _, e1, e2, _)
-        | SynExpr.While (_, e1, e2, _) -> walkExpr e1 || walkExpr e2
+        | SynExpr.While (_, e1, e2, _)
+        | SynExpr.WhileBang (_, e1, e2, _) -> walkExpr e1 || walkExpr e2
 
         | SynExpr.For (identBody = e1; toBody = e2; doBody = e3) -> walkExpr e1 || walkExpr e2 || walkExpr e3
 
         | SynExpr.MatchLambda (_, _, cl, _, _) -> walkMatchClauses cl
 
         | SynExpr.Lambda (body = e) -> walkExpr e
 
-        | SynExpr.Match (expr = e; clauses = cl) -> walkExpr e || walkMatchClauses cl
+        | SynExpr.Match (expr = e; clauses = cl)
+        | SynExpr.MatchBang (expr = e; clauses = cl) -> walkExpr e || walkMatchClauses cl
 
         | SynExpr.LetOrUse (bindings = bs; body = e) -> walkBinds bs || walkExpr e
 
@@ -904,8 +906,6 @@ let rec synExprContainsError inpExpr =
 
         | SynExpr.DotNamedIndexedPropertySet (e1, _, e2, e3, _) -> walkExpr e1 || walkExpr e2 || walkExpr e3
 
-        | SynExpr.MatchBang (expr = e; clauses = cl) -> walkExpr e || walkMatchClauses cl
-
         | SynExpr.LetOrUseBang (rhs = e1; body = e2; andBangs = es) ->
             walkExpr e1
             || walkExprs

src/Compiler/SyntaxTree/SyntaxTrivia.fs

@@ -76,7 +76,12 @@ type SynExprLambdaTrivia =
     static member Zero: SynExprLambdaTrivia = { ArrowRange = None }
 
 [<NoEquality; NoComparison>]
-type SynExprLetOrUseTrivia = { InKeyword: range option }
+type SynExprLetOrUseTrivia =
+    {
+        InKeyword: range option
+    }
+
+    static member Zero: SynExprLetOrUseTrivia = { InKeyword = None }
 
 [<NoEquality; NoComparison>]
 type SynExprLetOrUseBangTrivia =

src/Compiler/SyntaxTree/SyntaxTrivia.fsi

@@ -127,6 +127,8 @@ type SynExprLetOrUseTrivia =
         InKeyword: range option
     }
 
+    static member Zero: SynExprLetOrUseTrivia
+
 /// Represents additional information for SynExpr.LetOrUseBang
 [<NoEquality; NoComparison>]
 type SynExprLetOrUseBangTrivia =

src/Compiler/lex.fsl

@@ -360,6 +360,9 @@ rule token args skip = parse
 
  | "and!"
      { AND_BANG(false) }
+
+ | "while!"
+     { WHILE_BANG }
 
  | ident '!'
      { let tok = Keywords.KeywordOrIdentifierToken args lexbuf (lexemeTrimRight lexbuf 1)