add error recovery at block level

Author: pchalamet

src/Terrabuild.Common/Errors.fs

@@ -1,6 +1,8 @@
 module Errors
 open System
 open System.Runtime.ExceptionServices
+open System.Collections.Generic
+open System.Threading
 
 [<RequireQualifiedAccess>]
 type ErrorArea =
@@ -16,6 +18,52 @@ type TerrabuildException(msg, area, ?innerException: Exception) =
     inherit Exception(msg, innerException |> Option.toObj)
     member _.Area: ErrorArea = area
 
+type private ParseErrorCollector =
+    { Errors: ResizeArray<TerrabuildException>
+      PosProvider: (unit -> (int * int) option) option }
+
+let private parseErrorCollector = AsyncLocal<ParseErrorCollector option>()
+
+let beginParseErrorCollection (posProvider: unit -> (int * int) option) =
+    parseErrorCollector.Value <- Some { Errors = ResizeArray(); PosProvider = Some posProvider }
+
+let endParseErrorCollection () =
+    let errors =
+        match parseErrorCollector.Value with
+        | Some collector -> collector.Errors |> Seq.toList
+        | None -> []
+
+    parseErrorCollector.Value <- None
+    errors
+
+let private formatParseError (msg: string) (pos: (int * int) option) =
+    if msg.StartsWith("Parse error at", StringComparison.Ordinal) then
+        msg
+    else
+        match pos with
+        | Some (line, col) -> sprintf "Parse error at (%d,%d): %s" line col msg
+        | None -> msg
+
+let private tryCollectParseError (msg: string) (inner: Exception option) (pos: (int * int) option) =
+    match parseErrorCollector.Value with
+    | Some collector ->
+        let pos =
+            match pos with
+            | Some _ -> pos
+            | None ->
+                collector.PosProvider
+                |> Option.bind (fun provider -> provider())
+
+        let fullMsg = formatParseError msg pos
+        let ex =
+            match inner with
+            | Some inner -> TerrabuildException(fullMsg, ErrorArea.Parse, inner)
+            | None -> TerrabuildException(fullMsg, ErrorArea.Parse)
+
+        collector.Errors.Add(ex)
+        true
+    | None -> false
+
 
 let raiseInvalidArg(msg) =
     TerrabuildException(msg, ErrorArea.InvalidArg) |> raise
@@ -24,10 +72,23 @@ let forwardInvalidArg(msg, innerException) =
     TerrabuildException(msg, ErrorArea.InvalidArg, innerException) |> raise
 
 let raiseParseError(msg) =
-    TerrabuildException(msg, ErrorArea.Parse) |> raise
+    if not (tryCollectParseError msg None None) then
+        TerrabuildException(msg, ErrorArea.Parse) |> raise
+    Unchecked.defaultof<'T>
 
 let forwardParseError(msg, innerException) =
-    TerrabuildException(msg, ErrorArea.Parse, innerException) |> raise
+    if not (tryCollectParseError msg (Some innerException) None) then
+        TerrabuildException(msg, ErrorArea.Parse, innerException) |> raise
+    Unchecked.defaultof<'T>
+
+let reportParseError(msg) =
+    if not (tryCollectParseError msg None None) then
+        TerrabuildException(msg, ErrorArea.Parse) |> raise
+
+let reportParseErrorAt(line, col, msg) =
+    if not (tryCollectParseError msg None (Some (line, col))) then
+        let fullMsg = formatParseError msg (Some (line, col))
+        TerrabuildException(fullMsg, ErrorArea.Parse) |> raise
 
 let raiseTypeError(msg) =
     TerrabuildException(msg, ErrorArea.Type) |> raise
@@ -74,5 +135,3 @@ let tryInvoke action =
         None
     with
         exn -> ExceptionDispatchInfo.Capture(exn) |> Some
-
-

src/Terrabuild.Lang.Tests/Lang.fs

@@ -140,3 +140,15 @@ let invalidScopeIdentifier() =
 let invalidScopedIdentifier() =
     let content = File.ReadAllText("TestFiles/Error_InvalidScopedIdentifier")
     (fun () -> FrontEnd.parse content |> ignore) |> should (throwWithMessage "Parse error at (2,21): invalid resource identifier '@value'") typeof<Errors.TerrabuildException>
+
+[<Test>]
+let errorRecoveryCollectsMultipleErrors() =
+    let content = File.ReadAllText("TestFiles/Error_RecoveryMultiple")
+    try
+        FrontEnd.parse content |> ignore
+        Assert.Fail("Expected parse errors")
+    with
+    | :? Errors.TerrabuildException as ex ->
+        ex.Message |> should contain "Parse errors:"
+        ex.Message |> should contain "Parse error at (2,"
+        ex.Message |> should contain "invalid attribute name '^badattr'"

src/Terrabuild.Lang.Tests/TestFiles/Error_RecoveryMultiple

@@ -0,0 +1,7 @@
+badblock {
+attribute1 "missing_equal"
+}
+
+goodblock {
+^badattr = 1
+}

src/Terrabuild.Lang/AST.fs

@@ -12,7 +12,8 @@ with
 
     static member Append (attributes: Attribute list) (attribute: Attribute) =
         if attributes |> List.exists (fun a -> a.Name = attribute.Name) then
-            Errors.raiseParseError $"duplicated attribute '{attribute.Name}'"
+            Errors.reportParseError $"duplicated attribute '{attribute.Name}'"
+            attributes
         else
             attributes @ [attribute]
 
@@ -35,4 +36,3 @@ type [<RequireQualifiedAccess>] File =
 with
     static member Build blocks =
         { File.Blocks = blocks }
-

src/Terrabuild.Lang/FrontEnd.fs

@@ -21,17 +21,32 @@ let parse txt =
         token
 
     let lexbuf = LexBuffer<_>.FromString txt
+    beginParseErrorCollection (fun () -> Some (lexbuf.StartPos.Line + 1, lexbuf.StartPos.Column + 1))
+    let mutable result = Unchecked.defaultof<_>
+    let mutable fatalException: exn option = None
     try
-        Parser.File switchableLexer lexbuf
+        result <- Parser.File switchableLexer lexbuf
     with
     | :? TerrabuildException as exn ->
-        let err = sprintf "Parse error at (%d,%d): %s"
-                        (lexbuf.StartPos.Line + 1) (lexbuf.StartPos.Column + 1)
-                        exn.Message
-        forwardParseError(err, exn)
+        fatalException <- Some exn
+        reportParseError exn.Message
     | exn ->
-        let err = sprintf "Unexpected token '%s' at (%d,%d): %s"
-                        (LexBuffer<_>.LexemeString lexbuf |> string) 
-                        (lexbuf.StartPos.Line + 1) (lexbuf.StartPos.Column + 1)
+        fatalException <- Some exn
+        let err = sprintf "Unexpected token '%s': %s"
+                        (LexBuffer<_>.LexemeString lexbuf |> string)
                         exn.Message
-        forwardParseError(err, exn)
+        reportParseError err
+
+    let errors = endParseErrorCollection()
+    match errors with
+    | [] ->
+        match fatalException with
+        | Some exn -> raise exn
+        | None -> result
+    | [single] ->
+        TerrabuildException(single.Message, ErrorArea.Parse, single.InnerException) |> raise
+    | errors ->
+        let msg =
+            "Parse errors:\n"
+            + (errors |> List.map (fun e -> e.Message) |> String.concat "\n")
+        TerrabuildException(msg, ErrorArea.Parse) |> raise

src/Terrabuild.Lang/Gen/Lexer.fs

@@ -370,84 +370,91 @@ and token lexerMode lexbuf =
           )
   | 32 -> ( 
 # 99 "Lexer.fsl"
-                         Errors.raiseParseError $"unrecognized input: '{lexeme lexbuf}'" 
-# 374 "Gen/Lexer.fs"
+                        
+                       Errors.reportParseError $"unrecognized input: '{lexeme lexbuf}'"
+                       token lexerMode lexbuf
+                   
+# 377 "Gen/Lexer.fs"
           )
   | _ -> failwith "token"
 // Rule singleLineComment
 and singleLineComment lexerMode lexbuf =
   match _fslex_tables.Interpret(13,lexbuf) with
   | 0 -> ( 
-# 102 "Lexer.fsl"
+# 105 "Lexer.fsl"
                                lexbuf.EndPos <- lexbuf.EndPos.NextLine; token lexerMode lexbuf 
-# 383 "Gen/Lexer.fs"
+# 386 "Gen/Lexer.fs"
           )
   | 1 -> ( 
-# 103 "Lexer.fsl"
+# 106 "Lexer.fsl"
                            EOF 
-# 388 "Gen/Lexer.fs"
+# 391 "Gen/Lexer.fs"
           )
   | 2 -> ( 
-# 104 "Lexer.fsl"
+# 107 "Lexer.fsl"
                          singleLineComment lexerMode lexbuf 
-# 393 "Gen/Lexer.fs"
+# 396 "Gen/Lexer.fs"
           )
   | _ -> failwith "singleLineComment"
 // Rule interpolatedString
 and interpolatedString (acc: StringBuilder) lexerMode lexbuf =
   match _fslex_tables.Interpret(0,lexbuf) with
   | 0 -> ( 
-# 107 "Lexer.fsl"
-                               raiseParseError "newline encountered in string" 
-# 402 "Gen/Lexer.fs"
+# 110 "Lexer.fsl"
+                              
+                       Errors.reportParseError "newline encountered in string"
+                       lexbuf.EndPos <- lexbuf.EndPos.NextLine
+                       interpolatedString acc lexerMode lexbuf
+                   
+# 409 "Gen/Lexer.fs"
           )
   | 1 -> ( 
-# 108 "Lexer.fsl"
+# 115 "Lexer.fsl"
 
                        acc.Append("\"") |> ignore
                        interpolatedString acc lexerMode lexbuf
 
-# 410 "Gen/Lexer.fs"
+# 417 "Gen/Lexer.fs"
           )
   | 2 -> ( 
-# 112 "Lexer.fsl"
+# 119 "Lexer.fsl"
 
                        acc.Append("{") |> ignore
                        interpolatedString acc lexerMode lexbuf
 
-# 418 "Gen/Lexer.fs"
+# 425 "Gen/Lexer.fs"
           )
   | 3 -> ( 
-# 116 "Lexer.fsl"
+# 123 "Lexer.fsl"
 
                        acc.Append("}") |> ignore
                        interpolatedString acc lexerMode lexbuf
 
-# 426 "Gen/Lexer.fs"
+# 433 "Gen/Lexer.fs"
           )
   | 4 -> ( 
-# 120 "Lexer.fsl"
+# 127 "Lexer.fsl"
 
                        lexerMode |> pop |> ignore
                        STRING_END (acc.ToString())
 
-# 434 "Gen/Lexer.fs"
+# 441 "Gen/Lexer.fs"
           )
   | 5 -> ( 
-# 124 "Lexer.fsl"
+# 131 "Lexer.fsl"
 
                        lexerMode |> push LexerMode.Default
                        EXPRESSION_START (acc.ToString())
 
-# 442 "Gen/Lexer.fs"
+# 449 "Gen/Lexer.fs"
           )
   | 6 -> ( 
-# 128 "Lexer.fsl"
+# 135 "Lexer.fsl"
 
                        lexbuf |> lexeme |> acc.Append |> ignore
                        interpolatedString acc lexerMode lexbuf
 
-# 450 "Gen/Lexer.fs"
+# 457 "Gen/Lexer.fs"
           )
   | _ -> failwith "interpolatedString"