/// <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()

/// <summary>
/// The Client is not the client process (the IDE host);
/// it is an object that can communicate with the host client by sending it messages.
/// This is in contrast to the Server which can only receive messages from the host client.
/// </summary>
type Client(notificationSender: Server.ClientNotificationSender, requestSender: Server.ClientRequestSender) =
    inherit LspClient()
    member this.ShowInfo(message) =
        this.WindowShowMessage(
            { Type = Types.MessageType.Info
              Message = message }
        )
    member this.ShowError(message) =
        this.WindowShowMessage(
            { Type = Types.MessageType.Error
              Message = message }
        )
    member this.LogDebug(message) =
        this.WindowLogMessage(
            { Type = Types.MessageType.Debug
              Message = message }
        )
    override this.WindowLogMessage p =
        match box p with
        | null -> async { }
        | value -> notificationSender "window/logMessage" value |> Async.Ignore
    override this.WindowShowMessage p =
        match box p with
        | null -> async { }
        | value -> notificationSender "window/showMessage" value |> Async.Ignore
    override this.WindowShowMessageRequest p =
        match box p with
        | null ->
            async { return Result.Error(Error.InternalError("Attempted to send message, but the parameter was null")) }
        | value -> requestSender.Send "window/showMessageRequest" value

/// 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.TextDocumentDidOpen) |> 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
    }

/// The entry point for the language server program.
/// The first couple definitions are mostly boilerplate and just help with converting to/from JsonRpc
/// which is the protocol used by the LSP.
module LspExample.LSP
open System
open System.Threading.Tasks
open Ionide.LanguageServerProtocol
open Ionide.LanguageServerProtocol.JsonUtils
open LspExample
open Newtonsoft.Json
open StreamJsonRpc
let private defaultJsonRpcFormatter () =
    let jsonRpcFormatter = new JsonMessageFormatter()
    jsonRpcFormatter.JsonSerializer.NullValueHandling <- NullValueHandling.Ignore
    jsonRpcFormatter.JsonSerializer.ConstructorHandling <- ConstructorHandling.AllowNonPublicDefaultConstructor
    jsonRpcFormatter.JsonSerializer.MissingMemberHandling <- MissingMemberHandling.Ignore
    jsonRpcFormatter.JsonSerializer.Converters.Add(StrictNumberConverter())
    jsonRpcFormatter.JsonSerializer.Converters.Add(StrictStringConverter())
    jsonRpcFormatter.JsonSerializer.Converters.Add(StrictBoolConverter())
    jsonRpcFormatter.JsonSerializer.Converters.Add(SingleCaseUnionConverter())
    jsonRpcFormatter.JsonSerializer.Converters.Add(OptionConverter())
    jsonRpcFormatter.JsonSerializer.Converters.Add(ErasedUnionConverter())
    jsonRpcFormatter.JsonSerializer.ContractResolver <- OptionAndCamelCasePropertyNamesContractResolver()
    jsonRpcFormatter
let private jsonRpcFormatter = defaultJsonRpcFormatter ()
let private createRpc (handler: IJsonRpcMessageHandler) : JsonRpc =
    let rec (|HandleableException|_|) (e: exn) =
        match e with
        | :? LocalRpcException -> Some()
        | :? TaskCanceledException -> Some()
        | :? OperationCanceledException -> Some()
        | :? Newtonsoft.Json.JsonSerializationException -> Some()
        | :? System.AggregateException as aex ->
            aex.InnerExceptions |> Seq.tryHead |> Option.bind (|HandleableException|_|)
        | _ -> None
    let (|Flatten|_|) (e: exn) =
        match e with
        | :? AggregateException as aex ->
            let aex = aex.Flatten()
            aex.InnerExceptions |> Seq.tryHead |> Option.defaultValue e |> Some
        | _ -> Some e
    let strategy = StreamJsonRpc.ActivityTracingStrategy()
    { new JsonRpc(handler, ActivityTracingStrategy = strategy) with
        member this.IsFatalException(ex: Exception) =
            match ex with
            | HandleableException -> false
            | _ -> true
        member this.CreateErrorDetails(request: Protocol.JsonRpcRequest, ex: Exception) =
            let isSerializable = this.ExceptionStrategy = ExceptionProcessing.ISerializable
            match ex with
            | Flatten(:? Newtonsoft.Json.JsonSerializationException as ex) ->
                let data: obj = if isSerializable then ex else Protocol.CommonErrorData(ex)
                Protocol.JsonRpcError.ErrorDetail(
                    Code = Protocol.JsonRpcErrorCode.ParseError,
                    Message = ex.Message,
                    Data = data
                )
            | _ -> base.CreateErrorDetails(request, ex) }
/// Start the LSP server
let private startCore () =
    // The LSP protocol takes over stdio. DO NOT read from or write to stdio under ANY circumstances.
    // The process will terminate if you do. To send messages to the user, use the Client type.
    let input = Console.OpenStandardInput()
    let output = Console.OpenStandardOutput()
    /// Create the handlers that we can work with. Custom extensions can be added here if desired.
    /// See the F# Ionide language server (FsAutoComplete) for examples on how to add custom request types
    /// https://github.com/ionide/FsAutoComplete/blob/9b8de8c575faaa6016ffe69236686d83fe7e0e56/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs#L3206
    let requestHandlings: Map<string, Mappings.ServerRequestHandling<_>> =
        Ionide.LanguageServerProtocol.Server.defaultRequestHandlings ()
    use jsonRpcHandler =
        new HeaderDelimitedMessageHandler(output, input, defaultJsonRpcFormatter ())
    // Start the server process
    // Do some bootstrapping by injecting the dependencies
    Server.start
        requestHandlings
        input
        output
        // Create the client. It is provided notifier and requester which are used to send messages to the actual separate client process.
        (fun (notifier, requester) -> new Client(notifier, requester))
        // The created client will be provided to the server initializer here which is where the LSP logic happens.
        (fun client -> new Server(client))
        createRpc
let private StartLanguageServer () =
    try
        let result = startCore ()
        int result
    with ex ->
        eprintfn $"Language server crashed with: %A{ex}"
        raise ex
[<EntryPoint>]
let main args = StartLanguageServer()

/// <summary>
/// An absolute path on the file system. Should be a real file or directory.
/// </summary>
type AbsolutePath = AbsolutePath of string
/// Functions for working with AbsolutePaths
module AbsolutePath =
    /// Handle windows path separators
    let private deDOS (path: string) =
        if Path.DirectorySeparatorChar = '\\' then
            path.Replace('\\', '/')
        else
            path
            
    let ofUri (uri: Uri) =
        uri.AbsolutePath |> Uri.UnescapeDataString |> deDOS |> AbsolutePath
    let toString (AbsolutePath path) = path
    let toUri (AbsolutePath path) =
        if Environment.OSVersion.Platform = PlatformID.Win32NT then
            $"file:///%s{path}"
        else
            $"file://%s{path}"
/// <summary>
/// Convert a file URI from the client to an absolute file path for the local file system.
/// </summary>
/// <remarks>Removes the schema and unescapes any specially encoded characters because the LSP spec does not specify if characters are encoded.</remarks>
/// <param name="uri">The file URI to convert</param>
let uriToPath (uri: string) =
    uri |> Uri.UnescapeDataString |> Uri |> AbsolutePath.ofUri

/// Active pattern to make working with .NET BCL Try* functions nicer 
let (|Success|Nothing|) (valueFound: bool, value: 'a) =
    if valueFound then Success value else Nothing
/// Construct an LSP range record
let range (startLine: int, startColumn: int) (endLine: int, endColumn: int) : Range =
    { Start =
        { Line = uint32 startLine
          Character = uint32 startColumn }
      End =
        { Line = uint32 endLine
          Character = uint32 endColumn } }

/// Define the abstract types of the simple demo language
module DemoLang =
    type Value =
        | Number of float
        | Text of string
        | Empty of string
    type Line =
        { Line: int
          Contents: string
          Value: Value }

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)
    }

let private diagnostic severity range message =
    { Range = range
      Severity = Some severity
      Code = None
      CodeDescription = None
      Source = Some "demolang"
      Message = message
      Tags = None
      RelatedInformation = None
      Data = None }
let private generateDiagnosticsForLine
    { Contents = contents
      Line = line
      Value = value }
    : Diagnostic seq =
    seq {
        if contents.Length > 80 then
            diagnostic
                DiagnosticSeverity.Warning
                (range (line, 0) (line, contents.Length - 1))
                $"Line too long: {contents.Length} columns"
        if String.IsNullOrWhiteSpace contents && contents.Length > 0 then
            diagnostic
                DiagnosticSeverity.Warning
                (range (line, 0) (line, contents.Length))
                "Line is non-empty and contains whitespace"
        else
            let noLeadingSpaces = contents.TrimStart()
            if noLeadingSpaces <> contents then
                diagnostic
                    DiagnosticSeverity.Error
                    (range (line, 0) (line, contents.Length - noLeadingSpaces.Length))
                    "Line has leading whitespace"
            let noTrailingSpaces = contents.TrimEnd()
            if noTrailingSpaces <> contents then
                diagnostic
                    DiagnosticSeverity.Warning
                    (range (line, noTrailingSpaces.Length) (line, contents.Length))
                    "Line has trailing whitespace"
        match value with
        | Number number when number < 0 ->
            diagnostic
                DiagnosticSeverity.Error
                (range (line, 0) (line, contents.Length))
                "Negative numbers are not supported"
        | _ -> ()
    }
/// <summary>
/// Generate diagnostics for file contents: info, warnings, and errors
/// </summary>
/// <param name="contents">The file contents to generate diagnostics for</param>
let DocumentDiagnostics (contents: string) : Diagnostic[] =
    let documentLines = Parser.ParseFile contents
    documentLines |> Seq.collect generateDiagnosticsForLine |> Seq.toArray

let private parseLine (line: string) =
    match Double.TryParse(line.AsSpan()) with
    | Success parsedNumber -> Value.Number parsedNumber
    | Nothing when String.IsNullOrWhiteSpace line -> Value.Empty line
    | Nothing -> Value.Text line
/// <summary>
/// Parse an entire file into structured data.
/// </summary>
/// <param name="contents">The entire contents of a file</param>
/// <remarks>For large files and complex languages you should consider caching AST results and using incremental updated
/// instead of reparsing the full file update from the client every time something changes.</remarks>
let ParseFile (contents: string) : Line[] =
    contents.Split('\n')
    |> Array.mapi (fun line contents ->
        { Line = line
          Contents = contents
          Value = parseLine contents })

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)
    }

/// <summary>
/// The hover capability shows a tooltip when you hover over something of interest.
/// </summary>
/// <see href="https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#textDocument_hover"/>
module LspExample.Hover
open Ionide.LanguageServerProtocol.Types
open LspExample.Types
open LspExample.Types.DemoLang
/// <summary>
/// Generate hover information: the type of the value and some information about it
/// </summary>
/// <param name="hoverLocation">Where the hover is requested</param>
/// <param name="contents">The parsed file to lookup within</param>
let LookupHover (hoverLocation: Position) (contents: Line[]) : Hover =
    match contents |> Array.tryItem (int hoverLocation.Line) with
    | Some { Value = Number number
             Contents = contents
             Line = line } ->
        { Contents =
            U3.C1
                { MarkupContent.Kind = MarkupKind.PlainText
                  Value = $"(Number) {number}" }
          Range = range (line, 0) (line, contents.Length) |> Some }
    | Some { Value = Text text
             Contents = contents
             Line = line } ->
        let leading = text.TrimStart()
        let trailing = text.TrimEnd()
        { Contents =
            U3.C1
                { MarkupContent.Kind = MarkupKind.PlainText
                  Value = $"(Text) Length={text.Trim().Length}" }
          Range = range (line, contents.Length - leading.Length) (line, trailing.Length) |> Some }
    | _ ->
        { Contents =
            U3.C1
                { MarkupContent.Kind = MarkupKind.PlainText
                  Value = "No hover information to display here" }
          Range = None }

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 } } }
    }

/// <summary>
/// Generation of semantic tokens
/// </summary>
/// <see href="https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#textDocument_semanticTokens"/>
module LspExample.SemanticTokens
open System
open LspExample.Types.DemoLang
/// <summary>
/// Unit of measure for semantic token types
/// </summary>
[<Measure>]
type private Type
/// <summary>
/// Semantic tokens used by this server
/// </summary>
/// <remarks>Types should have integral values starting from 0 and increasing</remarks>
[<RequireQualifiedAccess>]
module Type =
    let String = 0u<Type>
    let Number = 1u<Type>
/// <summary>
/// The string names of the semantic token types that are used by this server. Communicated to the client on startup
/// </summary>
/// <remarks>The index of the names must match the numbers assigned in the Type module</remarks>
let tokenTypes = [| "string"; "number" |]
/// <summary>
/// Unit of measure for semantic tokens modifiers
/// </summary>
[<Measure>]
type private Modifier
/// <summary>
/// Semantic token modifiers used by this server
/// </summary>
/// <remarks>Modifiers should have numerical values based on powers of 2 because they are packed into a bit array (uint32)</remarks>
[<RequireQualifiedAccess>]
module Modifier =
    let ReadOnly = 1u<Modifier>
let private packModifiers (modifiers: uint32<Modifier>[]) = Array.sum modifiers
/// <summary>
/// The string names of the semantic token modifiers that are used by this server. Communicated to the client on startup
/// </summary>
/// <remarks>The index of the names must match the numbers assigned in the Modifier module</remarks>
let tokenModifiers = [| "readonly" |]
/// <summary>
/// A token is a range in the source code that has some semantic meaning (function/variable name, or keyword, or type for example).
/// Tokens may overlap, but they must be ordered when sent over the wire because the packed format uses relative positioning.
/// </summary>
[<Struct>]
type private Token =
    { Line: uint32
      StartChar: uint32
      Length: uint32
      TokenType: uint32<Type>
      TokenModifiers: uint32<Modifier> }
    static member create
        (line: int, column: int, length: int, tokenType: uint32<Type>, [<ParamArray>] tokenModifiers: uint32<Modifier>[]) =
        { Line = uint32 line
          StartChar = uint32 column
          Length = uint32 length
          TokenType = tokenType
          TokenModifiers = packModifiers tokenModifiers }
let private packToken (token: Token) =
    [| token.Line
       token.StartChar
       token.Length
       uint32 token.TokenType
       uint32 token.TokenModifiers |]
    
/// <summary>
/// Convert tokens from absolute to relative positioning
/// </summary>
/// <param name="tokens">The tokens to transform</param>
let private makeTokensRelative (tokens: #seq<Token>) : Token seq =
    if Seq.isEmpty tokens then
        Seq.empty
    else
        seq {
            yield Seq.head tokens
            yield!
                tokens
                |> Seq.pairwise
                |> Seq.map (fun (predecessor, current) ->
                    assert (predecessor.Line <= current.Line)
                    assert (predecessor.Line = current.Line || predecessor.StartChar <= current.StartChar)
                    { Token.Line = current.Line - predecessor.Line
                      Length = current.Length
                      TokenModifiers = current.TokenModifiers
                      TokenType = current.TokenType
                      StartChar =
                        if current.Line = predecessor.Line then
                            current.StartChar - predecessor.StartChar
                        else
                            current.StartChar })

let private packAllTokens (tokens: #seq<Token>) : uint32[] =
    tokens |> makeTokensRelative |> Seq.collect packToken |> Seq.toArray
/// <summary>
/// Generate semantic tokens for a series of lines
/// </summary>
/// <param name="lines">Lines to generate tokens from</param>
let SemanticTokenArray (lines: #seq<Line>) : uint32[]=
    lines
    |> Seq.choose (fun line ->
        match line with
        | { Value = Empty _ } -> None
        | { Value = Number _
            Contents = contents
            Line = line } -> Some <| Token.create (line, 0, contents.Length, Type.Number, Modifier.ReadOnly)
        | { Value = Text text; Line = line } ->
            Some <| Token.create (line, 0, text.Length, Type.String, Modifier.ReadOnly))
    |> packAllTokens