lsp-bjolang/Check.fs

/// Checking one file with the compiler's frontend, and turning what it
/// collected into LSP diagnostics.
module BjolangLsp.Check

open System
open System.IO
open System.Text.Json.Nodes
open System.Text.RegularExpressions
open Bjolang

/// A diagnostic as the client gets it: 0-based lines and columns, end
/// exclusive.
type Found =
    { Line: int
      Column: int
      EndLine: int
      EndColumn: int
      IsError: bool
      Message: string }

/// `at file.bjo:12:3`, as `Lexer.formatPos` and `Lexer.formatAt` write a
/// location into a message, the column counted from 1, or `at file.bjo:12`.
let private location = Regex(@"\n?\s*\bat (\S+?):(\d+)(?::(\d+))?\s*$", RegexOptions.Multiline)

let private firstLocation = Regex(@"\bat (\S+?):(\d+)(?::(\d+))?")

/// The message with the location lines the compiler appends taken off, since
/// the client shows the location as the diagnostic's range.
let private withoutLocations (message: string) = location.Replace(message, "").TrimEnd()

let private wholeLine (line: int) =
    {| Line = line; Column = 0; EndLine = line + 1; EndColumn = 0 |}

let private isBreak (c: char) =
    Char.IsWhiteSpace c || "()[]{}\"';".Contains c

/// What to mark of the form that starts at `line` and `column`, both from 0:
/// a string or an atom whole, a bracketed form to its closing bracket. A form
/// over several lines is marked as far as its head, `(defun` or `(match`, so
/// that an error in a definition does not mark all of it. `None` where the
/// text has no form there.
let private formAt (text: string) (line: int) (column: int) =
    let lines = text.Replace("\r\n", "\n").Split('\n')

    if line >= lines.Length || column >= lines[line].Length then
        None
    else
        let here = lines[line]

        // The end of the atom that starts at `i` on line `l`.
        let atomEnd (l: string) (i: int) =
            let mutable j = i

            while j < l.Length && not (isBreak l[j]) do
                j <- j + 1

            j

        let single (endColumn: int) =
            Some {| Line = line; Column = column; EndLine = line; EndColumn = max (column + 1) endColumn |}

        match here[column] with
        | '"' ->
            // To the closing quote, past escapes; to the end of the line when
            // the string goes on.
            let mutable j = column + 1

            while j < here.Length && here[j] <> '"' do
                if here[j] = '\\' then j <- j + 1
                j <- j + 1

            single (min here.Length (j + 1))
        | '('
        | '['
        | '{' ->
            // The closing bracket, counting brackets outside strings, comments
            // and character literals.
            let mutable depth = 0
            let mutable l = line
            let mutable i = column
            let mutable closedAt = None

            while closedAt.IsNone && l < lines.Length do
                let s = lines[l]
                let mutable inString = false

                while closedAt.IsNone && i < s.Length do
                    let c = s[i]

                    if inString then
                        if c = '\\' then i <- i + 1
                        elif c = '"' then inString <- false
                    elif c = '"' then
                        inString <- true
                    elif c = ';' then
                        i <- s.Length
                    elif c = '#' && i + 1 < s.Length && s[i + 1] = '\\' then
                        i <- i + 2
                    elif "([{".Contains c then
                        depth <- depth + 1
                    elif ")]}".Contains c then
                        depth <- depth - 1
                        if depth = 0 then closedAt <- Some(l, i + 1)

                    i <- i + 1

                if closedAt.IsNone then
                    l <- l + 1
                    i <- 0

            match closedAt with
            | Some(endLine, endColumn) when endLine = line -> single endColumn
            | _ ->
                // Over several lines, or never closed: the bracket and the
                // head after it.
                let mutable j = column + 1

                while j < here.Length && Char.IsWhiteSpace here[j] do
                    j <- j + 1

                single (if j < here.Length && not (isBreak here[j]) then atomEnd here j else column + 1)
        | c when Char.IsWhiteSpace c -> None
        | _ -> single (atomEnd here column)

/// Where a diagnostic is, if it is in `file`. Anywhere else, such as in an
/// imported module, it is `None`, and the caller puts it at the top of `file`
/// with the location left in the message.
let private placeIn (text: string option) (file: string) (d: Diagnostics.Diagnostic) =
    let markFrom (line: int) (column: int) =
        text |> Option.bind (fun t -> formAt t line column)

    let sameFile (other: string) =
        // A range carries the full path; a location read from a message only
        // the file name, which is all `Lexer.formatPos` writes.
        if Path.IsPathRooted other then
            Path.GetFullPath other = Path.GetFullPath file
        else
            other = Path.GetFileName file

    match d.Where with
    | Some r when sameFile r.File ->
        // The lexer's lines are 1-based and its columns 0-based, as LSP's are.
        let line = max 0 (r.Start.Line - 1)
        let column = r.Start.Column
        let endLine = max line (r.End.Line - 1)
        let endColumn = r.End.Column

        // A range with no width is still something to underline: the form
        // there, else the rest of its line. A range over several lines, which
        // is a whole declaration's, is marked as far as the form's head.
        if endLine = line && endColumn <= column then
            match markFrom line column with
            | Some mark -> Some mark
            | None -> Some {| Line = line; Column = column; EndLine = line + 1; EndColumn = 0 |}
        elif endLine > line then
            match markFrom line column with
            | Some mark -> Some mark
            | None -> Some {| Line = line; Column = column; EndLine = endLine; EndColumn = endColumn |}
        else
            Some {| Line = line; Column = column; EndLine = endLine; EndColumn = endColumn |}
    | Some _ -> None
    | None ->
        let m = firstLocation.Match d.Message

        if m.Success && sameFile m.Groups[1].Value then
            let line = max 0 (int m.Groups[2].Value - 1)

            // The column counts from 1, as `Lexer.formatPos` writes it.
            if m.Groups[3].Success then
                let column = max 0 (int m.Groups[3].Value - 1)

                match markFrom line column with
                | Some mark -> Some mark
                | None -> Some {| Line = line; Column = column; EndLine = line + 1; EndColumn = 0 |}
            else
                Some(wholeLine line)
        else
            None

let private found (text: string option) (file: string) (d: Diagnostics.Diagnostic) : Found =
    let isError = d.Severity = Diagnostics.Error

    match placeIn text file d with
    | Some p ->
        { Line = p.Line
          Column = p.Column
          EndLine = p.EndLine
          EndColumn = p.EndColumn
          IsError = isError
          Message = withoutLocations d.Message }
    | None ->
        let where =
            match d.Where with
            | Some r -> $"\n  at %s{Lexer.formatPos r}"
            | None -> ""

        let p = wholeLine 0

        { Line = p.Line
          Column = p.Column
          EndLine = p.EndLine
          EndColumn = p.EndColumn
          IsError = isError
          Message = d.Message + where }

let private options: Build.Options = { Build.dependencyOptions with IsLibrary = false; Check = true }

/// Checks `file` as `bjolang --check` does, reading every file in `buffers`,
/// by full path, from there rather than from disk: the editor's unsaved text,
/// of the file and of any include or doc file that is open too.
///
/// In `Session.isolated`, so that one check leaves nothing behind for the
/// next, and in `Diagnostics.captured`, so that what the compiler prints goes
/// to a buffer rather than into the protocol. The buffer is only read when the
/// check failed with nothing collected: a failure the compiler printed rather
/// than recorded, such as a bug in it, which would otherwise fail silently.
let file (buffers: Map<string, string>) (path: string) : Found list =
    Diagnostics.verbose <- false
    Diagnostics.reset ()
    Paths.sourceOverrides <- buffers

    let status, printed =
        try
            Diagnostics.captured (fun () ->
                try
                    Expansion.recording path (fun () -> Session.isolated (fun () -> Build.compile options path))
                with ex ->
                    printfn "%s" (Diagnostics.humanize ex.Message)
                    1)
        finally
            Paths.sourceOverrides <- Map.empty

    // With BJOLANG_TIMING set, where the check's time went, to the log.
    if Timing.enabled then
        let _, report = Diagnostics.captured Timing.report
        Rpc.log report

    // The text the check read, for what to mark at a column.
    let text =
        match buffers.TryFind(Path.GetFullPath path) with
        | Some t -> Some t
        | None when File.Exists path -> Some(File.ReadAllText path)
        | None -> None

    let collected = Diagnostics.snapshot () |> List.map (found text path)

    if status <> 0 && not (collected |> List.exists (fun f -> f.IsError)) then
        let message =
            match printed.Trim() with
            | "" -> "The check failed and said nothing about why."
            | text -> text

        collected
        @ [ { Line = 0
              Column = 0
              EndLine = 1
              EndColumn = 0
              IsError = true
              Message = message } ]
    else
        collected

/// The `textDocument/publishDiagnostics` parameters for `uri`.
let publishParams (uri: string) (found: Found list) : JsonNode =
    let position (line: int) (character: int) =
        JsonObject(dict [ "line", JsonValue.Create line :> JsonNode; "character", JsonValue.Create character ])

    let diagnostic (f: Found) =
        JsonObject(
            dict
                [ "range",
                  JsonObject(dict [ "start", position f.Line f.Column :> JsonNode; "end", position f.EndLine f.EndColumn ])
                  :> JsonNode
                  "severity", JsonValue.Create(if f.IsError then 1 else 2)
                  "source", JsonValue.Create "bjolang"
                  "message", JsonValue.Create f.Message ]
        )
        :> JsonNode

    JsonObject(
        dict
            [ "uri", JsonValue.Create uri :> JsonNode
              "diagnostics", JsonArray(found |> List.map diagnostic |> Array.ofList) ]
    )