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 = 
@@ -1399,6 +1402,47 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol
 
             Some(translatedCtxt callExpr)
 
+        | SynExpr.WhileBang (spWhile, guardExpr, innerComp, _) -> 
+            let mGuard = guardExpr.Range
+            let mWhile = match spWhile with DebugPointAtWhile.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.While) | _ -> mGuard
+
+            if isQuery then error(Error(FSComp.SR.tcNoWhileInQuery(), mWhile))
+
+            if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mWhile ad "While" builderTy) then
+                error(Error(FSComp.SR.tcRequireBuilderMethod("While"), mWhile))
+
+            if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mWhile ad "Delay" builderTy) then
+                error(Error(FSComp.SR.tcRequireBuilderMethod("Delay"), mWhile))
+
+            if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mWhile ad "Bind" builderTy) then
+                error(Error(FSComp.SR.tcRequireBuilderMethod("Bind"), mWhile))
+
+            // '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 range.Zero "$cond"
+                let pat = mkSynPatVar None id
+
+                let body =
+                    let id2 = mkSynId range.Zero "$condM"
+                    let pat2 = mkSynPatVar None id2
+                    let b = mkSynBinding (Xml.PreXmlDoc.Empty, pat2) (None, false, true, range.Zero, DebugPointAtBinding.NoneAtInvisible, None, SynExpr.Ident id, range.Zero, [], [], None, SynBindingTrivia.Zero)  
+                    let set = SynExpr.LongIdentSet (SynLongIdent.SynLongIdent ([ id2 ], [], []), SynExpr.Ident id, range.Zero)
+                    let bang = SynExpr.LetOrUseBang (DebugPointAtBinding.NoneAtInvisible, false, false, pat, guardExpr, [], set, range.Zero, SynExprLetOrUseBangTrivia.Zero)
+
+                    let body = SynExpr.While (spWhile, SynExpr.Ident id2, SynExpr.Sequential (DebugPointAtSequential.SuppressBoth, true, innerComp, bang, range.Zero), range.Zero)
+                    SynExpr.LetOrUse (false, false, [ b ], body, range.Zero, { InKeyword = None })
+
+                SynExpr.LetOrUseBang (DebugPointAtBinding.NoneAtInvisible, false, false, pat, guardExpr, [], body, range.Zero, SynExprLetOrUseBangTrivia.Zero)
+
+            tryTrans CompExprTranslationPass.Initial q varSpace body translatedCtxt
+
         | SynExpr.TryWith (innerComp, clauses, mTryToLast, spTry, spWith, trivia) ->
             let mTry = match spTry with DebugPointAtTry.Yes _ -> trivia.TryKeyword.NoteSourceConstruct(NotedSourceConstruct.Try) | _ -> trivia.TryKeyword
             let spWith2 = match spWith with DebugPointAtWith.Yes _ -> DebugPointAtBinding.Yes trivia.WithKeyword | _ -> DebugPointAtBinding.NoneAtInvisible
@@ -1733,14 +1777,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

@@ -856,6 +856,11 @@ type FSharpParseFileResults(diagnostics: FSharpDiagnostic[], input: ParsedInput,
                             for SynMatchClause (whenExpr = whenExpr; resultExpr = resExpr) in clauses do
                                 yield! walkExprOpt true whenExpr
                                 yield! walkExpr true resExpr
+
+                        | SynExpr.WhileBang (spWhile, e1, e2, _) ->
+                            yield! walkWhileSeqPt spWhile
+                            yield! walkExpr false e1
+                            yield! walkExpr true e2
                 ]
 
             // 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

@@ -766,6 +766,13 @@ module SyntaxTraversal =
 
                 | SynExpr.DoBang (synExpr, _range) -> traverseSynExpr synExpr
 
+                | SynExpr.WhileBang (_spWhile, synExpr, synExpr2, _range) ->
+                    [
+                        dive synExpr synExpr.Range traverseSynExpr
+                        dive synExpr2 synExpr2.Range traverseSynExpr
+                    ]
+                    |> pick expr
+
                 | 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

@@ -915,6 +915,8 @@ let rec synExprContainsError inpExpr =
                 ]
             || walkExpr e2
 
+        | SynExpr.WhileBang (_, e1, e2, _) -> walkExpr e1 || walkExpr e2
+
         | SynExpr.InterpolatedString (parts, _, _m) ->
             parts
             |> List.choose (function

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)

src/Compiler/pars.fsy

@@ -83,7 +83,7 @@ let parse_error_rich = Some (fun (ctxt: ParseErrorContext<_>) ->
 %token EXCEPTION FALSE FOR FUN FUNCTION IF IN JOIN_IN FINALLY DO_BANG 
 %token LAZY OLAZY  MATCH MATCH_BANG  MUTABLE NEW OF 
 %token OPEN OR REC THEN TO TRUE TRY TYPE VAL INLINE INTERFACE INSTANCE CONST
-%token WHEN WHILE WITH HASH AMP AMP_AMP QUOTE LPAREN RPAREN RPAREN_COMING_SOON RPAREN_IS_HERE STAR COMMA RARROW GREATER_BAR_RBRACK LPAREN_STAR_RPAREN
+%token WHEN WHILE WHILE_BANG WITH HASH AMP AMP_AMP QUOTE LPAREN RPAREN RPAREN_COMING_SOON RPAREN_IS_HERE STAR COMMA RARROW GREATER_BAR_RBRACK LPAREN_STAR_RPAREN
 %token QMARK QMARK_QMARK DOT COLON COLON_COLON COLON_GREATER  COLON_QMARK_GREATER COLON_QMARK COLON_EQUALS SEMICOLON 
 %token SEMICOLON_SEMICOLON LARROW EQUALS  LBRACK  LBRACK_BAR  LBRACE_BAR  LBRACK_LESS 
 %token BAR_RBRACK BAR_RBRACE UNDERSCORE
@@ -3641,6 +3641,47 @@ declExpr:
         let mWhileAll = unionRanges (rhs parseState 1) (rhs parseState 3)
         exprFromParseError (SynExpr.While (spWhile, arbExpr("whileGuard1", mWhileHeader), arbExpr("whileBody3", mWhileBodyArb), mWhileAll))  }
 
+  | WHILE_BANG declExpr doToken typedSequentialExprBlock doneDeclEnd 
+      { let mWhileHeader = unionRanges (rhs parseState 1) $2.Range
+        let spWhile = DebugPointAtWhile.Yes mWhileHeader 
+        let mWhileAll = unionRanges (rhs parseState 1) $4.Range
+        SynExpr.WhileBang (spWhile, $2, $4, mWhileAll) }
+
+  | WHILE_BANG declExpr doToken typedSequentialExprBlock recover 
+      { if not $5 then reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsUnexpectedEndOfFileWhile())
+        let mWhileHeader = unionRanges (rhs parseState 1) $2.Range
+        let spWhile = DebugPointAtWhile.Yes mWhileHeader 
+        let mWhileAll = unionRanges (rhs parseState 1) $4.Range
+        exprFromParseError (SynExpr.WhileBang (spWhile, $2, $4, mWhileAll)) }
+
+  | WHILE_BANG declExpr doToken error doneDeclEnd 
+      { // silent recovery 
+        let mWhileHeader = unionRanges (rhs parseState 1) $2.Range
+        let spWhile = DebugPointAtWhile.Yes mWhileHeader 
+        let mWhileBodyArb = unionRanges (rhs parseState 4) (rhs parseState 5)
+        let mWhileAll = unionRanges (rhs parseState 1) (rhs parseState 5)
+        SynExpr.WhileBang (spWhile, $2, arbExpr("whileBody1", mWhileBodyArb), mWhileAll) }
+
+  | WHILE_BANG declExpr recover 
+      { reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsWhileDoExpected())
+        let mWhileHeader = unionRanges (rhs parseState 1) $2.Range
+        let spWhile = DebugPointAtWhile.Yes mWhileHeader 
+        let mWhileBodyArb = rhs parseState 3
+        let mWhileAll = unionRanges (rhs parseState 1) (rhs parseState 3)
+        exprFromParseError (SynExpr.WhileBang (spWhile, $2, arbExpr("whileBody2", mWhileBodyArb), mWhileAll))  }
+
+  | WHILE_BANG recover 
+      { if not $2 then reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsUnexpectedEndOfFileWhile())
+        arbExpr("whileLoop1", rhs parseState 1)  }
+
+  | WHILE_BANG error doneDeclEnd 
+      { //silent recovery
+        let mWhileHeader = rhs parseState 1
+        let spWhile = DebugPointAtWhile.Yes mWhileHeader 
+        let mWhileBodyArb = rhs parseState 3
+        let mWhileAll = unionRanges (rhs parseState 1) (rhs parseState 3)
+        exprFromParseError (SynExpr.WhileBang (spWhile, arbExpr("whileGuard1", mWhileHeader), arbExpr("whileBody3", mWhileBodyArb), mWhileAll))  }
+
   | FOR forLoopBinder doToken typedSequentialExprBlock doneDeclEnd 
       { let mFor = rhs parseState 1
         let mDo = rhs parseState 3