lsp-bjolang/Symbols.fs

/// The names a file defines at top level, read off its forms as the reader
/// gives them, before macro expansion or type checking. It costs a tokenize
/// and a read, so it can answer on every request; a name a user macro
/// defines is not seen, as nothing is expanded.
module BjolangLsp.Symbols

open System
open System.IO
open Bjolang
open Bjolang.Lexer
open Bjolang.Ast

/// LSP's `SymbolKind`, the members of it used here.
type Kind =
    | Function = 12
    | Variable = 13
    | Class = 5
    | Interface = 11
    | Method = 6
    | Field = 8
    | EnumMember = 22
    | Struct = 23
    | Module = 2

type Symbol =
    { Name: string
      Detail: string
      Kind: Kind
      /// The whole form.
      Range: Range
      /// The name in it.
      NameRange: Range
      /// The part of the form a hover shows: a function's head with its
      /// parameters, a constructor's case, a trait method's declaration.
      Signature: Range
      Children: Symbol list }

/// A form as text, for naming what has no name of its own: an `impl`.
let rec private show (s: SExpr) : string =
    match s with
    | SAtom { Token = Symbol n } -> n
    | SAtom { Token = TypeVar n } -> "%" + n.TrimStart '%'
    | SAtom { Token = QuotedSymbol n } -> "'" + n
    | SAtom { Token = Keyword k } -> "#:" + k
    | SAtom { Token = Colon } -> ":"
    | SAtom _ -> "…"
    | SList(items, _) -> "(" + (items |> List.map show |> String.concat " ") + ")"

let private symbol name detail kind range nameRange signature children =
    { Name = name
      Detail = detail
      Kind = kind
      Range = range
      NameRange = nameRange
      Signature = signature
      Children = children }

/// The name a binder form starts with: `name`, `(name args ...)`, or
/// `(: name Type)`.
let private binderName (s: SExpr) : (string * Range) option =
    match s with
    | SAtom { Token = Symbol n; Range = r } -> Some(n, r)
    | SList(SAtom { Token = Colon } :: SAtom { Token = Symbol n; Range = r } :: _, _) -> Some(n, r)
    | SList(SAtom { Token = Symbol n; Range = r } :: _, _) -> Some(n, r)
    | _ -> None

/// One `(: head body)` of a `type` form: the type, and its constructors or
/// fields.
let private typeDef (s: SExpr) : Symbol option =
    match s with
    | SList([ SAtom { Token = Colon }; head; body ], r) ->
        binderName head
        |> Option.map (fun (name, nr) ->
            let members, kind, detail =
                match body with
                | SList(SAtom { Token = Symbol "Union" } :: cases, _) ->
                    cases
                    |> List.choose (fun c ->
                        binderName c
                        |> Option.map (fun (n, cr) -> symbol n name Kind.EnumMember (getRange c) cr (getRange c) [])),
                    Kind.Class,
                    "union"
                | SList(SAtom { Token = Symbol "Record" } :: fields, _) ->
                    fields
                    |> List.choose (fun f ->
                        binderName f
                        |> Option.map (fun (n, fr) -> symbol n name Kind.Field (getRange f) fr (getRange f) [])),
                    Kind.Struct,
                    "record"
                | other -> [], Kind.Class, show other

            symbol name detail kind r nr r members)
    | _ -> None

/// The symbols one top-level form defines.
let rec private ofForm (form: SExpr) : Symbol list =
    match form with
    | SList(SAtom { Token = Symbol("begin" | "module") } :: rest, _) -> rest |> List.collect ofForm

    | SList(SAtom { Token = Symbol("type" | "type-rec") } :: defs, _) -> defs |> List.choose typeDef

    | SList(SAtom { Token = Symbol "def/trait" } :: head :: members, r) ->
        match binderName head with
        | Some(name, nr) ->
            let methods =
                members
                |> List.choose (function
                    | SList(SAtom { Token = Colon } :: SAtom { Token = Symbol n; Range = mr } :: _, rr) ->
                        Some(symbol n name Kind.Method rr mr rr [])
                    | _ -> None)

            [ symbol name "trait" Kind.Interface r nr (getRange head) methods ]
        | None -> []

    | SList(SAtom { Token = Symbol("import/extern" | "import/class" as head) } :: clauses, _) ->
        clauses
        |> List.choose (fun c ->
            match c with
            | SList(binder :: rest, cr) ->
                binderName binder
                |> Option.map (fun (n, nr) ->
                    let detail =
                        match rest with
                        | SList(SAtom { Token = Colon } :: target :: _, _) :: _ -> show target
                        | _ -> head

                    let kind = if head = "import/class" then Kind.Class else Kind.Function
                    symbol n detail kind cr nr cr [])
            | _ -> None)

    | SList(SAtom { Token = Symbol "impl" } :: head :: body, r) ->
        [ symbol $"impl %s{show head}" "" Kind.Module r (getRange head) (getRange head) (body |> List.collect ofForm) ]

    | SList(SAtom { Token = Symbol("def" | "def/mutable" as head) } :: binder :: _, r) ->
        match binder with
        // `(def (a b) expr)`: every name in the destructuring list.
        | SList(items, br) when (match items with
                                 | SAtom { Token = Colon } :: _ -> false
                                 | _ -> true) ->
            items
            |> List.choose (function
                | SAtom { Token = Symbol n; Range = nr } -> Some(symbol n head Kind.Variable r nr br [])
                | _ -> None)
        | _ ->
            binderName binder
            |> Option.map (fun (n, nr) -> symbol n head Kind.Variable r nr (getRange binder) [])
            |> Option.toList

    // `defun`, `defbjo`, `defbjouble`, `def/macro`, `def/pattern`, and any
    // other `def…` form a library adds, which all put the name first.
    | SList(SAtom { Token = Symbol head } :: binder :: _, r) when head.StartsWith "def" ->
        binderName binder
        |> Option.map (fun (n, nr) -> symbol n head Kind.Function r nr (getRange binder) [])
        |> Option.toList

    | _ -> []

/// The forms of `text`, read as the compiler reads them. `None` if it does
/// not read, such as while a form is half typed.
let forms (path: string) (text: string) : SExpr list option =
    let read (t: string) =
        try
            Session.isolated (fun () -> Lexer.tokenize path t |> Pipeline.read |> fst |> Some)
        with _ ->
            None

    match read text with
    | Some fs -> Some fs
    | None ->
        // While a form is being typed it is not closed yet, and the file does
        // not read. Closed, it does, and the forms before it are what was
        // wanted.
        let rec closing (n: int) =
            if n > 16 then None
            else
                match read (text + String(')', n)) with
                | Some fs -> Some fs
                | None -> closing (n + 1)

        closing 1

/// The symbols `text` defines at top level.
let ofText (path: string) (text: string) : Symbol list option =
    forms path text |> Option.map (List.collect ofForm)

/// Every symbol, its members included.
let rec flatten (symbols: Symbol list) : Symbol list =
    symbols |> List.collect (fun s -> s :: flatten s.Children)

/// The name at `line` (1-based) and `column` (0-based) in `text`, and where it
/// is.
let nameAt (path: string) (text: string) (line: int) (column: int) : (string * Range) option =
    let tokens =
        try
            Session.isolated (fun () -> Lexer.tokenize path text)
        with _ ->
            []

    let contains (r: Range) =
        (line > r.Start.Line || (line = r.Start.Line && column >= r.Start.Column))
        && (line < r.End.Line || (line = r.End.Line && column <= r.End.Column))

    tokens
    |> List.tryPick (fun t ->
        match t.Token with
        | Symbol n when contains t.Range -> Some(n, t.Range)
        | _ -> None)

/// The `.bjo` files the module of `forms` imports, as far as they exist: a
/// module only there as a `.dll` has no source to point at.
let private importedFiles (forms: SExpr list) : string list =
    let rec modulePaths (s: SExpr) : string list list =
        match s with
        | SList(items, _) when
            not items.IsEmpty
            && items
               |> List.forall (function
                   | SAtom { Token = Symbol _ } -> true
                   | _ -> false)
            ->
            [ items
              |> List.map (function
                  | SAtom { Token = Symbol n } -> n
                  | _ -> "") ]
        | SList(items, _) -> items |> List.collect modulePaths
        | _ -> []

    let resolve (parts: string list) =
        match Paths.findModule parts with
        | Paths.ModuleFile(_, file) when File.Exists file -> Some file
        | _ -> None

    forms
    |> List.collect (fun form ->
        match form with
        | SList(SAtom { Token = Symbol("import" | "re-export") } :: specs, _) ->
            specs |> List.collect modulePaths |> List.choose resolve
        | _ -> [])

/// A file on disk read once per change, keyed by its write time: the standard
/// library is searched on every lookup and does not change between them.
let private onDisk = Collections.Generic.Dictionary<string, DateTime * string * SExpr list>()

let private readOnDisk (path: string) : string * SExpr list =
    let full = Path.GetFullPath path
    let written = File.GetLastWriteTimeUtc full

    match onDisk.TryGetValue full with
    | true, (w, text, fs) when w = written -> text, fs
    | _ ->
        let text = File.ReadAllText full
        let fs = forms full text |> Option.defaultValue []
        onDisk[full] <- (written, text, fs)
        text, fs

/// A module's forms, with what `(include "x")` and `(:doc #:file "x")` name
/// spliced in where they stand, as the compiler splices them. Every range
/// keeps the file it was read from.
let rec private spliced (path: string) (fs: SExpr list) : SExpr list =
    fs
    |> List.collect (fun form ->
        let inner (file: string) =
            let full = Path.GetFullPath(Path.Combine(Path.GetDirectoryName path, file))

            if File.Exists full then
                spliced full (snd (readOnDisk full))
            else
                []

        match form with
        | SList([ SAtom { Token = Symbol "include" }; SAtom { Token = StringLit file } ], _) -> inner file
        | _ ->
            match Docs.fileForm form with
            | Some(file, _) -> inner file
            | None -> [ form ])

/// The source `r` covers in `text`.
let sliceOf (text: string) (r: Range) : string =
    let text = text.Replace("\r\n", "\n")

    // The offset of a 1-based line and 0-based column.
    let offsetOf (p: Position) =
        let mutable line = 1
        let mutable i = 0

        while line < p.Line && i < text.Length do
            if text[i] = '\n' then line <- line + 1
            i <- i + 1

        min text.Length (i + p.Column)

    let start = offsetOf r.Start
    let stop = offsetOf r.End
    if stop > start then text.Substring(start, stop - start) else ""

/// A module, read: its forms spliced, and the text of each file they came
/// from, so that a range can be shown as written.
type Module =
    { /// The module's own source file.
      File: string
      Forms: SExpr list
      /// Every symbol its forms define, members included.
      Symbols: Symbol list
      Texts: Map<string, string> }

    /// The source a range covers, in whichever of the module's files it is.
    member m.Slice(r: Range) : string =
        match m.Texts.TryFind r.File with
        | None -> ""
        | Some text -> sliceOf text r

let private moduleOf (path: string) (text: string) (own: SExpr list) : Module =
    let fs = spliced path own

    let files =
        fs
        |> List.map (fun f -> (getRange f).File)
        |> List.distinct
        |> List.filter (fun f -> f <> path)

    { File = path
      Forms = fs
      Symbols = fs |> List.collect ofForm |> flatten
      Texts =
        files
        |> List.map (fun f -> f, (if File.Exists f then fst (readOnDisk f) else ""))
        |> Map.ofList
        |> Map.add path text }

/// A module on disk, read again only when one of its files has been written
/// since: completion reads every module a file can see, on every request.
let private modulesOnDisk = Collections.Generic.Dictionary<string, (string * DateTime) list * Module>()

let private moduleOnDisk (path: string) : Module =
    let stamps (files: string seq) =
        files
        |> Seq.map (fun f -> f, (if File.Exists f then File.GetLastWriteTimeUtc f else DateTime.MinValue))
        |> List.ofSeq

    match modulesOnDisk.TryGetValue path with
    | true, (seen, m) when stamps (seen |> List.map fst) = seen -> m
    | _ ->
        let text, fs = readOnDisk path
        let m = moduleOf path text fs
        modulesOnDisk[path] <- (stamps m.Texts.Keys, m)
        m

/// The prelude's source, which every module sees.
let preludeFile () : string option =
    match Paths.findModule [ "std"; "prelude" ] with
    | Paths.ModuleFile(_, f) when File.Exists f -> Some(Path.GetFullPath f)
    | _ -> None

/// The prelude, read.
let prelude () : Module option = preludeFile () |> Option.map moduleOnDisk

/// The modules a file sees, nearest first: its own, with `text` as its
/// source; then what it imports, and what those import, breadth first; and
/// the prelude last. Lazy, so a search that finds what it wants early reads
/// no further.
let visible (path: string) (text: string) : Module seq =
    seq {
        let path = Path.GetFullPath path
        let own = moduleOf path text (forms path text |> Option.defaultValue [])
        yield own

        let visited = Collections.Generic.HashSet<string>([ path ])
        let queue = Collections.Generic.Queue<string>(importedFiles own.Forms @ Option.toList (preludeFile ()))

        while queue.Count > 0 do
            let file = queue.Dequeue()

            if visited.Add file then
                let m = moduleOnDisk file
                yield m

                for next in importedFiles m.Forms do
                    queue.Enqueue next
    }

/// A definition, and the module it is in.
type Found = { Symbol: Symbol; Module: Module }

/// Where `name` is defined, in the nearest module that defines it.
let definition (path: string) (text: string) (name: string) : Found option =
    visible path text
    |> Seq.tryPick (fun m ->
        m.Symbols
        |> List.tryFind (fun s -> s.Name = name)
        |> Option.map (fun s -> { Symbol = s; Module = m }))