Server.fs

namespace LspExample

open System
open System.Collections.Concurrent
open System.Collections.Generic
open System.IO
open Ionide.LanguageServerProtocol
open Ionide.LanguageServerProtocol.JsonRpc
open Ionide.LanguageServerProtocol.Types
open LspExample
open LspExample.Types

/// <summary>
/// The Server is the stateful object that handles LSP requests from the client process.
/// The individual capabilities are defined on the LspServer base class and overridden with real behavior if supported.
/// </summary>
/// <see href="https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#lifeCycleMessages"/>
type Server(client: Client) =
    inherit LspServer()

    /// Helper methods to catch errors to prevent the server from crashing
    let handleAnyError (exn: Exception) (memberName: string) =
        async {
            do!
                client.ShowError(
                    $"Internal error in %s{memberName}:\n%s{exn.Message}\n%s{exn.StackTrace}\nSource:\n%s{exn.Source}"
                )

            return Result.Error(Error.InternalError $"{memberName} failed due to an internal error")
        }

    /// Store of synced files from the client mapping the file Uri to the contents
    let fileContents = ConcurrentDictionary<string, FileContent>()

    /// Get the contents of a document from the cache if present. If not present then read it from disk.
    let documentContents documentUri =
        match fileContents.TryGetValue documentUri with
        | Success(FileContent(_, contents)) -> contents
        | Nothing -> uriToPath documentUri |> AbsolutePath.toString |> File.ReadAllText

    /// The supported capabilities of this server. These are communicated to the client process on startup.
    let capabilities: ServerCapabilities =
        { ServerCapabilities.Default with
            TextDocumentSync = Some(U2.C2 TextDocumentSyncKind.Full)
            HoverProvider = Some(U2.C1 true)
            DiagnosticProvider =
                Some(
                    U2.C1
                        { InterFileDependencies = false
                          Identifier = Some "DemoLang"
                          WorkspaceDiagnostics = false
                          WorkDoneProgress = None }
                )
            SemanticTokensProvider =
                Some(
                    U2.C1
                        { WorkDoneProgress = None
                          Legend =
                            { TokenTypes = SemanticTokens.tokenTypes
                              TokenModifiers = SemanticTokens.tokenModifiers }
                          Range = Some(U2.C1 true)
                          Full = Some(U2.C1 true) }
                ) }

    /// This is only run once on startup and is treated like a constructor.
    /// Certain things can be initialized here safely before they are used in other methods.
    override this.Initialize param =
        async {
            do!
                client.WindowShowMessage(
                    { Type = MessageType.Info
                      Message = "Initializing the language server" }
                )

            return
                Result.Ok
                    { InitializeResult.Capabilities = capabilities
                      ServerInfo =
                        Some
                            { InitializeResultServerInfo.Name = "Demo Language Server"
                              Version = Some "0.0.1" } }
        }

    override this.Initialized param =
        async { do! client.ShowInfo("Initialized") }

    override this.TextDocumentDidOpen param =
        async {
            try
                let textDoc = param.TextDocument

                if fileContents.TryAdd(textDoc.Uri, FileContent(textDoc.Version, textDoc.Text)) then
                    do! client.ShowInfo($"Opened {textDoc.Uri}")
                else
                    failwith "File already opened"
            with exn ->
                return! handleAnyError exn (nameof this.Initialized) |> Async.Ignore
        }

    override this.TextDocumentDidClose param =
        async {
            try
                let textDoc = param.TextDocument

                if fileContents.Remove(textDoc.Uri) |> fst then
                    do! client.ShowInfo($"Closed {textDoc.Uri}")
                else
                    failwith "Cannot close file that is not opened"
            with exn ->
                return! handleAnyError exn (nameof this.TextDocumentDidClose) |> Async.Ignore
        }

    override this.TextDocumentDidChange param =
        async {
            try
                let textDoc = param.TextDocument
                let changes = param.ContentChanges

                if changes.Length <> 1 then
                    failwith "Multiple changes not supported by server"

                let wholeDocumentChange = changes[0]

                match wholeDocumentChange with
                | U2.C1 _ -> failwith "Partial document changes not supported by server"
                | U2.C2 { Text = newText } ->
                    let newDocument = FileContent(textDoc.Version, newText)

                    let updateDocument =
                        Func<_, _, _>(fun uri (FileContent(oldVersion, _) as old) ->
                            if textDoc.Version > oldVersion then newDocument else old)

                    fileContents.AddOrUpdate(textDoc.Uri, newDocument, updateDocument) |> ignore
                    do! client.LogDebug($"Updated {textDoc.Uri}")

            with exn ->
                return! handleAnyError exn (nameof this.TextDocumentDidChange) |> Async.Ignore
        }

    override this.TextDocumentDiagnostic param =
        async {
            try
                do! client.LogDebug($"Diagnostics for {param.TextDocument.Uri}")

                let diagnostics =
                    param.TextDocument.Uri |> documentContents |> Diagnostics.DocumentDiagnostics

                do! client.LogDebug($"Diagnostic messages:\n%A{diagnostics}")

                let report =
                    { Kind = "full"
                      ResultId = None
                      Items = diagnostics
                      RelatedDocuments = None }

                return LspResult.success (U2.C1 report)
            with exn ->
                return! handleAnyError exn (nameof this.TextDocumentDiagnostic)
        }

    override this.TextDocumentHover param =
        async {
            try
                do! client.LogDebug($"Hover for {param.TextDocument.Uri} at {param.Position.DebuggerDisplay}")

                let hoverResult =
                    param.TextDocument.Uri
                    |> documentContents
                    |> Parser.ParseFile
                    |> Hover.LookupHover param.Position

                return Result.Ok(Some hoverResult)
            with exn ->
                return! handleAnyError exn (nameof this.TextDocumentHover)
        }

    override this.TextDocumentSemanticTokensRange param =
        async {
            try
                do! client.LogDebug($"Partial semantic tokens requested for {param.Range.DebuggerDisplay}")

                let tokens: uint32[] =
                    param.TextDocument.Uri
                    |> documentContents
                    |> Parser.ParseFile
                    |> SemanticTokens.SemanticTokenArray

                do! client.LogDebug($"Finished semantic tokens: Count={tokens.Length}")
                return Result.Ok(Some { Data = tokens; ResultId = None })
            with exn ->
                return! handleAnyError exn (nameof this.TextDocumentSemanticTokensRange)
        }

    override this.TextDocumentSemanticTokensFull param =
        async {
            do! client.LogDebug("Full semantic tokens requested")

            return!
                this.TextDocumentSemanticTokensRange
                    { WorkDoneToken = param.WorkDoneToken
                      SemanticTokensRangeParams.PartialResultToken = param.PartialResultToken
                      TextDocument = param.TextDocument
                      Range =
                        { Start = { Line = 0u; Character = 0u }
                          End =
                            { Line = UInt32.MaxValue - 1u // adjust for overflow
                              Character = 0u } } }
        }

    override this.Dispose() = ()