bjoli/lsp-bjolang
SHA256
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

A language server for Bjolang

Browse source 
Runs the compiler in-process against the Bjolang checkout beside it, and
answers diagnostics, an outline, go to definition, hover and completion,
plus a request of its own for macro expansion.

Diagnostics come from the compiler's own check of the editor's text,
saved or not: on open, on save, and 400 ms after typing pauses. The
outline, definitions, hovers and completions read only as far as the
reader, with no type checking, so they answer on every request: the
top-level names of the file, its imports and the prelude, local names
from the binding forms the parser knows, the declarations and docs as
written, and the builtins with their types. emacs/bjolang-lsp.el shows a
macro call's expansion, one step or all of it, in a buffer.

test/smoke.py drives the server as an editor would.

🤖 Generated with [ECA](https://eca.dev)

Co-Authored-By: eca-agent <git@eca.dev>
This commit is contained in:
Linus Björnstam 2026-10-15 22:38:22 +02:00
commit c6f357c6f8
13 changed files with 2776 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored Normal file
View file

@ -0,0 +1,2 @@
bin/
obj/

37
BjolangLsp.fsproj Normal file
View file

@ -0,0 +1,37 @@
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<OutputType>Exe</OutputType>
<TargetFramework>net10.0</TargetFramework>
<NuGetAudit>false</NuGetAudit>
<!-- The compiler's tokenizer recurses once per token and needs tail
calls, which F# turns off in Debug by default. -->
<Tailcalls>true</Tailcalls>
<!-- Where the Bjolang checkout is, beside this one. The server runs the
compiler in-process, and the compiler finds the standard library
and the runtime assemblies by walking up from its own binary, which
here is in this project's bin. So the checkout's path is baked in,
and BJOLANG_HOME overrides it. -->
<BjolangHome>$([System.IO.Path]::GetFullPath('$(MSBuildThisFileDirectory)../Bjolang'))</BjolangHome>
</PropertyGroup>
<ItemGroup>
<AssemblyMetadata Include="BjolangHome" Value="$(BjolangHome)" />
</ItemGroup>
<ItemGroup>
<Compile Include="Rpc.fs" />
<Compile Include="Expansion.fs" />
<Compile Include="Check.fs" />
<Compile Include="Symbols.fs" />
<Compile Include="Scope.fs" />
<Compile Include="Hover.fs" />
<Compile Include="Completion.fs" />
<Compile Include="Program.fs" />
</ItemGroup>
<ItemGroup>
<ProjectReference Include="$(BjolangHome)/Bjolang.fsproj" />
</ItemGroup>
</Project>

177
Check.fs Normal file
View file

@ -0,0 +1,177 @@
/// 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` or `at file.bjo:12:3`, as `Lexer.formatPos` and
/// `Lexer.formatAt` write a location into a message.
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 |}
/// 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 (file: string) (d: Diagnostics.Diagnostic) =
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 rest of
// its line.
if endLine = line && endColumn <= column then
Some {| Line = line; Column = column; EndLine = line + 1; EndColumn = 0 |}
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)
if m.Groups[3].Success then
let column = max 0 (int m.Groups[3].Value - 1)
Some {| Line = line; Column = column; EndLine = line + 1; EndColumn = 0 |}
else
Some(wholeLine line)
else
None
let private found (file: string) (d: Diagnostics.Diagnostic) : Found =
let isError = d.Severity = Diagnostics.Error
match placeIn 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 =
{ IsLibrary = false
Debug = false
Runtime = []
EmitCs = None
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
let collected = Diagnostics.snapshot () |> List.map (found 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) ]
)

110
Completion.fs Normal file
View file

@ -0,0 +1,110 @@
/// What can be written at a position: the top-level names of every module
/// the file sees, nearest first, the compiler's builtins, and the special
/// forms. The client filters them as the word is typed; the doc of one is
/// sent when the client asks for it, through `completionItem/resolve`.
module BjolangLsp.Completion
open System
open Bjolang
open BjolangLsp.Symbols
/// The heads the parsers recognise themselves, which no module defines. A
/// copy of the REPL's list in `Repl.fs`, which is private to it.
let private specialForms =
[ "->"; "and"; "begin"; "bjo"; "bjoroutine"; "by-colour"; "case"; "cast"; "def"; "def*"; "def/hash-extend"
"def/macro"; "def/mutable"; "def/pattern"; "def/trait"; "defbjo"; "defbjouble"; "defun"; "dyn"
"export"; "fun"; "if"; "impl"; "impl/extern"; "import"; "import/class"; "import/extern"; "include"
"let"; "let/mono"; "letrec"; "loop"; "match"; "module"; "not"; "or"; "parameterize"; "re-export"
"record"; "record-ref"; "record-set"; "record-set!"; "seq"; "seql"; "set!"; "spawn"; "spawn-evt"
"spawn/daemon"; "spawn/detached"; "struct"; "struct-ref"; "struct-set"; "struct-set!"; "task->event"
"try"; "type"; "type-rec"; "unless"; "when"; "with-open"; "with-return"; "yield"; "yield-from" ]
/// LSP's `CompletionItemKind`, the members of it used here.
type ItemKind =
| Method = 2
| Function = 3
| Field = 5
| Variable = 6
| Class = 7
| Interface = 8
| Keyword = 14
| EnumMember = 20
| Struct = 22
type Item =
{ Label: string
Kind: ItemKind
/// Where it comes from: a module's file name, `builtin`, `special form`.
From: string }
let private itemKind (k: Kind) =
match k with
| Kind.Function -> ItemKind.Function
| Kind.Variable -> ItemKind.Variable
| Kind.Class -> ItemKind.Class
| Kind.Interface -> ItemKind.Interface
| Kind.Method -> ItemKind.Method
| Kind.Field -> ItemKind.Field
| Kind.EnumMember -> ItemKind.EnumMember
| Kind.Struct -> ItemKind.Struct
| _ -> ItemKind.Variable
/// The word the cursor ends, as the start column of it on its line. A word
/// is what the lexer reads as one symbol, so `list-` and `string->` are
/// words and the item replaces all of it.
let wordStart (line: string) (column: int) : int =
let mutable i = min column line.Length
while i > 0 && Lexer.isSymbolChar line[i - 1] do
i <- i - 1
i
/// Whether `column` of `line` is in a comment or a string, where nothing is
/// offered. Read off the line alone, so a string that began on an earlier
/// line is not seen.
let inText (line: string) (column: int) : bool =
let mutable inString = false
let mutable inComment = false
let mutable i = 0
while i < min column line.Length && not inComment do
match line[i] with
| '\\' when inString -> i <- i + 1
| '#' when not inString && i + 1 < line.Length && line[i + 1] = '\\' -> i <- i + 2
| '"' -> inString <- not inString
| ';' when not inString -> inComment <- true
| _ -> ()
i <- i + 1
inString || inComment
/// Everything that can be written in the file of `text`, each name once, the
/// nearest definition of it winning.
let items (path: string) (text: string) : Item list =
let seen = Collections.Generic.HashSet<string>()
let fromModules =
[ for m in visible path text do
let from = IO.Path.GetFileName m.File
for s in m.Symbols do
// An `impl` is not a name, and a field is read with
// `record-ref` rather than written on its own.
if s.Kind <> Kind.Module && s.Kind <> Kind.Field && seen.Add s.Name then
yield { Label = s.Name; Kind = itemKind s.Kind; From = from } ]
let builtins =
[ for name in Prelude.builtinNames do
if seen.Add name then
// `Cons`, `None`, `Err`: the builtin constructors.
let kind = if Char.IsUpper name[0] then ItemKind.EnumMember else ItemKind.Function
yield { Label = name; Kind = kind; From = "builtin" } ]
let special =
[ for name in specialForms do
if seen.Add name then
yield { Label = name; Kind = ItemKind.Keyword; From = "special form" } ]
fromModules @ builtins @ special

218
Expansion.fs Normal file
View file

@ -0,0 +1,218 @@
/// The macro expansions of the last check of each file, and the expansion of
/// one call, printed: one step, or all the way down.
///
/// The compiler hands each expansion to `Macro.observe` while it checks. A
/// call is found again by its range, which is its call site; a template's own
/// nodes carry that range too, so a call whose expansion is another macro
/// call expands again at the same site, and the form expanded is what tells
/// those steps apart.
module BjolangLsp.Expansion
open System
open System.Text
open Bjolang
open Bjolang.Lexer
open Bjolang.Ast
type Record =
{ Macro: string
Site: Range
Input: SExpr
Output: SExpr }
// ---------------------------------------------------------------------------
// Printing
// ---------------------------------------------------------------------------
let private punctuation =
Map.ofList
[ Colon, ":"
Dot, "."
Comma, ","
CommaAt, ",@"
Quote, "'"
SynQuote, "#'"
Spread, "..."
Hash, "#" ]
let private escaped (s: string) =
let b = StringBuilder("\"")
for c in s do
match c with
| '"' -> b.Append "\\\"" |> ignore
| '\\' -> b.Append "\\\\" |> ignore
| '\n' -> b.Append "\\n" |> ignore
| '\t' -> b.Append "\\t" |> ignore
| c -> b.Append c |> ignore
b.Append('"').ToString()
let private character (c: int) =
match c with
| 32 -> @"#\space"
| 10 -> @"#\newline"
| 9 -> @"#\tab"
| c -> @"#\" + Char.ConvertFromUtf32 c
/// An atom as source. `name` spells a symbol, so that a hygiene renaming can
/// be shown as the template wrote it. A keyword at the head of a list is a
/// clause's, `:for`; anywhere else an argument's, `#:when`.
let private atom (name: string -> string) (atHead: bool) (t: Token) =
match t with
| Symbol s
| ResolvedSymbol s -> name s
| Keyword k -> if atHead then ":" + k else "#:" + k
| QuotedSymbol s -> "'" + s
| TypeVar v -> "%" + v.TrimStart '%'
| NumberLit n -> n
| StringLit s -> escaped s
| CharLit c -> character c
| BoolLit b -> if b then "#t" else "#f"
| other -> Map.tryFind other punctuation |> Option.defaultValue "?"
/// A form on one line.
let rec private flat (name: string -> string) (atHead: bool) (s: SExpr) : string =
match s with
| SAtom t -> atom name atHead t.Token
| SList(items, _) -> "(" + (items |> List.mapi (fun i x -> flat name (i = 0) x) |> String.concat " ") + ")"
/// The heads whose first argument stays on their line and whose body is
/// indented by two: a binding form or a definition, as Emacs indents them.
let private bodyForms =
set
[ "let"; "let*"; "letrec"; "let/mono"; "when"; "unless"; "fun"; "bjoroutine"; "defun"; "defbjo"
"def"; "match"; "case"; "with-open"; "with-return"; "loop"; "seql"; "if"; "begin"; "parameterize"
"try"; "def/macro" ]
let private width = 78
/// A form, indented as a reader of Lisp expects: on one line if it fits, else
/// its head and first argument on the first line and the rest beneath, two in
/// for a body form and under the first argument for a call.
let rec private pretty (name: string -> string) (indent: int) (atHead: bool) (s: SExpr) : string =
let one = flat name atHead s
match s with
| SList(head :: args, _) when indent + one.Length > width && not args.IsEmpty ->
let headText = flat name true head
// A template's `match` arrives as `match__12`, which is still a match.
let isBody =
match head with
| SAtom { Token = Symbol h } -> bodyForms.Contains(RegularExpressions.Regex.Replace(h, @"__\d+$", ""))
| _ -> false
let first = pretty name (indent + headText.Length + 2) false args.Head
let restIndent =
match head with
| SAtom _ when not isBody -> indent + headText.Length + 2
| _ -> indent + 2
let rest =
args.Tail
|> List.map (fun a -> "\n" + String(' ', restIndent) + pretty name restIndent false a)
|> String.concat ""
// A list headed by a list, such as a `let`'s bindings or a `match`
// arm, keeps its items in a column.
match head with
| SList _ ->
let inner = indent + 1
"("
+ pretty name inner true head
+ (args |> List.map (fun a -> "\n" + String(' ', inner) + pretty name inner false a) |> String.concat "")
+ ")"
| _ -> "(" + headText + " " + first + rest + ")"
| _ -> one
// ---------------------------------------------------------------------------
// What the last checks expanded
// ---------------------------------------------------------------------------
/// Each file's expansions, from its last check, in the order they were made.
let private byFile = Collections.Generic.Dictionary<string, Record list>()
/// Each name hygiene made, and the spelling the template wrote.
let private renamed = Collections.Generic.Dictionary<string, string>()
/// Runs `check` with the compiler reporting its expansions, and keeps those
/// made in `path` as the file's.
let recording (path: string) (check: unit -> 'a) : 'a =
let seen = ResizeArray<Record>()
Macro.observe <-
Some(fun macro site input output names ->
for KeyValue(fresh, original) in names do
renamed[fresh] <- original
seen.Add
{ Macro = macro
Site = site
Input = input
Output = output })
try
check ()
finally
Macro.observe <- None
let full = IO.Path.GetFullPath path
// A form can be expanded more than once in one check, as a
// declaration is checked again in a copy; the first is kept.
byFile[full] <-
seen
|> Seq.filter (fun r -> r.Site.File <> "" && IO.Path.GetFullPath r.Site.File = full)
|> Seq.distinctBy (fun r -> r.Site, flat id false r.Input)
|> List.ofSeq
let private holds (line: int) (column: int) (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))
let private size (r: Range) = (r.End.Line - r.Start.Line) * 100000 + (r.End.Column - r.Start.Column)
/// The expansion of the innermost macro call at `line` (1-based) and
/// `column` (0-based) of `path`, from its last check: the macro's name and
/// the expansion as text. One step is what the macro made; `full` expands
/// every macro call in that too, as the compiler went on to.
///
/// `hygienic` keeps the names hygiene made, `tmp__37`, rather than showing
/// them as the template wrote them, which is what tells a template's name
/// from the caller's of the same spelling.
let at (path: string) (line: int) (column: int) (full: bool) (hygienic: bool) : (string * string) option =
match byFile.TryGetValue(IO.Path.GetFullPath path) with
| false, _ -> None
| true, records ->
let calls = records |> List.filter (fun r -> holds line column r.Site)
match calls |> List.sortBy (fun r -> size r.Site) |> List.tryHead with
| None -> None
| Some innermost ->
// The first expansion at a site is of the call as written; any
// after it are of what that made.
let call = records |> List.find (fun r -> r.Site = innermost.Site)
let name (s: string) =
if hygienic then s
else
match renamed.TryGetValue s with
| true, original -> original
| _ -> s
/// Every macro call in `s` replaced by its expansion, again and
/// again, as far as the check went.
let rec expand (depth: int) (s: SExpr) : SExpr =
match s with
| SList(items, r) when depth < 200 ->
let key = flat id false s
match records |> List.tryFind (fun x -> x.Site = r && flat id false x.Input = key) with
| Some x -> expand (depth + 1) x.Output
| None -> SList(items |> List.map (expand depth), r)
| _ -> s
let result = if full then expand 0 call.Output else call.Output
Some(call.Macro, pretty name 0 false result)

273
Hover.fs Normal file
View file

@ -0,0 +1,273 @@
/// What a hover shows for a name: its signature as written, and its doc from
/// the module's `(:doc ...)` forms, the `.bjodoc` files included, as Markdown.
module BjolangLsp.Hover
open System
open System.Text
open Bjolang
open Bjolang.Lexer
open Bjolang.Ast
open BjolangLsp.Symbols
/// A doc text's markup as Markdown. The texts use `@code{...}`, `@strong`,
/// `@em`, `@sup` and `@itemlist{@item{...} ...}`, which nest; anything else
/// after an `@` is left as it is.
let markdown (text: string) : string =
let out = StringBuilder()
// The index after the brace that closes the one at `start`.
let closing (start: int) =
let mutable depth = 0
let mutable i = start
let mutable found = -1
while found < 0 && i < text.Length do
match text[i] with
| '{' -> depth <- depth + 1
| '}' ->
depth <- depth - 1
if depth = 0 then found <- i
| _ -> ()
i <- i + 1
found
let rec go (from: int) (until: int) =
let mutable i = from
while i < until do
let c = text[i]
if c = '@' then
let mutable j = i + 1
while j < until && Char.IsLetter text[j] do
j <- j + 1
let command = text.Substring(i + 1, j - i - 1)
if j < until && text[j] = '{' && command <> "" then
let close = closing j
if close < 0 then
out.Append c |> ignore
i <- i + 1
else
let wrap (before: string) (after: string) =
out.Append before |> ignore
go (j + 1) close
out.Append after |> ignore
match command with
| "code" -> wrap "`" "`"
| "strong" -> wrap "**" "**"
| "em" -> wrap "*" "*"
| "sup" -> wrap "^" ""
| "item" -> wrap "\n- " ""
| "itemlist" -> wrap "" "\n"
| _ -> wrap ("@" + command + "{") "}"
i <- close + 1
else
out.Append c |> ignore
i <- i + 1
else
out.Append c |> ignore
i <- i + 1
go 0 text.Length
// The space between two `@item`s is left at the end of a line.
RegularExpressions.Regex.Replace(out.ToString(), " +\n", "\n")
/// The `(: name Type)` declaration of `name` among `forms`, if it has one.
let rec private declaration (name: string) (forms: SExpr list) : SExpr option =
forms
|> List.tryPick (fun form ->
match form with
| SList(SAtom { Token = Colon } :: SAtom { Token = Symbol n } :: _, _) when n = name -> Some form
| SList(SAtom { Token = Symbol("begin" | "module") } :: rest, _) -> declaration name rest
| _ -> None)
/// The `(:doc ...)` entries among `forms`. One that does not read is left
/// out: the compiler reports it, and a hover has nothing to say about it.
let private entries (forms: SExpr list) : Docs.Entry list =
forms
|> List.filter Docs.isDocForm
|> List.choose (fun f ->
try
Some(Docs.parseEntry f)
with _ ->
None)
let private longest = 20
/// At most `longest` lines of `text`.
let private clip (text: string) =
let lines = text.Split('\n')
if lines.Length <= longest then
text
else
String.Join("\n", Array.truncate longest lines) + "\n…"
let private fence (code: string) = $"```lisp\n%s{code}\n```"
/// The signature: the `(: name Type)` declaration if there is one, and the
/// form's head with its parameters, as written.
let private signature (found: Found) : string =
let s = found.Symbol
let m = found.Module
let declared = declaration s.Name m.Forms |> Option.map (fun d -> m.Slice(getRange d))
let shape = m.Slice s.Signature
let head =
match s.Kind with
| Kind.Function when s.Detail.StartsWith "def" -> $"(%s{s.Detail} %s{shape})"
| Kind.Variable -> $"(%s{s.Detail} %s{shape})"
| _ -> shape
[ yield! Option.toList declared; yield clip head ] |> String.concat "\n" |> fence
let private docText (entry: Docs.Entry) (member': string option) : string =
let clauses = entry.Clauses |> List.map fst
let section (title: string) (items: string list) =
if items.IsEmpty then [] else [ $"**%s{title}**\n\n" + String.concat "\n" items ]
let item (name: string) (text: string) = $"- `%s{name}`: %s{markdown text}"
[ for c in clauses do
match c with
| Docs.Summary t -> yield markdown t
| _ -> ()
// The member hovered over, documented in its type's doc.
match member' with
| Some name ->
for c in clauses do
match c with
| Docs.Case(n, t)
| Docs.Field(n, t) when n = name -> yield $"`%s{name}`: %s{markdown t}"
| _ -> ()
| None -> ()
yield!
section
"Parameters"
(clauses
|> List.choose (function
| Docs.Arg(n, t) -> Some(item n t)
| Docs.Rest(n, t) -> Some(item $". %s{n}" t)
| Docs.Key(n, t) -> Some(item $"#:%s{n}" t)
| Docs.TParam(n, t) -> Some(item $"%%%s{n}" t)
| _ -> None))
if member'.IsNone then
yield!
section
"Cases"
(clauses
|> List.choose (function
| Docs.Case(n, t) -> Some(item n t)
| _ -> None))
yield!
section
"Fields"
(clauses
|> List.choose (function
| Docs.Field(n, t) -> Some(item n t)
| _ -> None))
for c in clauses do
match c with
| Docs.Returns t -> yield $"**Returns** %s{markdown t}"
| _ -> ()
yield!
section
"Raises"
(clauses
|> List.choose (function
| Docs.Raises(n, t) -> Some(item n t)
| _ -> None))
for c in clauses do
match c with
| Docs.Example t -> yield fence (t.Trim())
| _ -> ()
for c in clauses do
match c with
| Docs.Reference t -> yield markdown t
| _ -> ()
for c in clauses do
match c with
| Docs.See names -> yield "See " + (names |> List.map (fun n -> $"`%s{n}`") |> String.concat ", ") + "."
| _ -> () ]
|> String.concat "\n\n"
/// The doc of what `found` is: its own, or for a constructor or field, its
/// type's, with the member's line picked out.
let private doc (found: Found) : string option =
let all = entries found.Module.Forms
let named (n: string) = all |> List.tryFind (fun e -> e.Subject = Docs.Named n)
match named found.Symbol.Name with
| Some entry -> Some(docText entry None)
| None ->
match found.Symbol.Kind with
| Kind.EnumMember
| Kind.Field ->
named found.Symbol.Detail
|> Option.map (fun entry -> docText entry (Some found.Symbol.Name))
| _ -> None
/// The hover for a local name: its binding as written, and what binds it.
let local (b: Scope.Binder) (shown: string) : string =
let what = b.Description
let sentence = string (Char.ToUpperInvariant what[0]) + what.Substring 1
[ fence (clip shown); $"*%s{sentence}.*" ]
|> String.concat "\n\n"
/// The type of a builtin, one the compiler defines rather than a module, as a
/// declaration: `(: seq-unfold (-> ...))`. `None` for a name that is not one.
let builtinDeclaration (name: string) : string option =
Prelude.prelude.Bindings
|> Map.tryFind name
|> Option.map (fun b ->
let (TypedAST.Scheme(_, _, t)) = b.Scheme
$"(: %s{name} %s{DotNetInterop.showType t})")
/// The hover for a builtin: its type, and its doc, which the prelude's docs
/// hold although the prelude does not define it.
let builtin (name: string) : string option =
builtinDeclaration name
|> Option.map (fun declared ->
let entry =
Symbols.prelude ()
|> Option.bind (fun m -> entries m.Forms |> List.tryFind (fun e -> e.Subject = Docs.Named name))
[ yield fence declared
yield! entry |> Option.map (fun e -> docText e None) |> Option.toList
yield "*Built into the compiler.*" ]
|> String.concat "\n\n")
/// The hover for `found`: its signature, where it is, and its doc.
let text (found: Found) : string =
let where =
let file = IO.Path.GetFileName found.Symbol.NameRange.File
match found.Symbol.Kind with
| Kind.EnumMember -> $"A case of `%s{found.Symbol.Detail}`, in %s{file}."
| Kind.Field -> $"A field of `%s{found.Symbol.Detail}`, in %s{file}."
| Kind.Method -> $"A method of the trait `%s{found.Symbol.Detail}`, in %s{file}."
| _ -> $"In %s{file}."
[ yield signature found
yield! Option.toList (doc found)
yield $"*%s{where}*" ]
|> String.concat "\n\n"

424
Program.fs Normal file
View file

@ -0,0 +1,424 @@
/// A language server for Bjolang. It answers diagnostics, from the compiler's
/// own frontend, when a file is opened or saved.
module BjolangLsp.Program
open System
open System.Reflection
open System.Text.Json.Nodes
/// Points the compiler at the Bjolang checkout this server was built against,
/// unless BJOLANG_HOME already names one. Done before anything touches
/// `Bjolang.Paths`, whose locations are computed once, when it is first used.
let private setBjolangHome () =
match Environment.GetEnvironmentVariable "BJOLANG_HOME" with
| null
| "" ->
Assembly.GetExecutingAssembly().GetCustomAttributes<AssemblyMetadataAttribute>()
|> Seq.tryFind (fun a -> a.Key = "BjolangHome")
|> Option.iter (fun a -> Environment.SetEnvironmentVariable("BJOLANG_HOME", a.Value))
| _ -> ()
/// Makes the checks the installed compiler's: staleness judged against
/// `bin/compiler/Bjolang.dll` rather than this server's copy of the compiler,
/// and a stale import built by running that compiler. Built here, an import's
/// build record would name this server, and the command line would build it
/// again.
///
/// The variable is only read while the backend is installed, and is cleared
/// again so that the compiler it starts builds its own imports as usual.
let private useInstalledCompiler () =
let installed = IO.Path.Combine(Bjolang.Paths.root, "bin", "compiler", "Bjolang.dll")
if IO.File.Exists installed then
Bjolang.Paths.compilerAssembly <- installed
Environment.SetEnvironmentVariable("BJOLANG_OUT_OF_PROCESS_DEPS", "1")
Bjolang.Build.installDependencyBackend ()
Environment.SetEnvironmentVariable("BJOLANG_OUT_OF_PROCESS_DEPS", null)
else
Rpc.log $"no compiler at %s{installed}; run build_compiler.sh there. Files that import a stale module will fail to check."
let private uriToPath (uri: string) = Uri(uri).LocalPath
let private str (node: JsonNode) (path: string list) =
path |> List.fold (fun (n: JsonNode) key -> if isNull n then null else n[key]) node
|> fun n -> if isNull n then None else Some(n.GetValue<string>())
/// The text of each open file as the editor has it, saved or not. Symbols,
/// definitions, completions and checks are all read from it, so that they
/// follow the buffer.
let private texts = Collections.Generic.Dictionary<string, string>()
let private publish (uri: string) =
let buffers =
texts |> Seq.map (fun kv -> IO.Path.GetFullPath(uriToPath kv.Key), kv.Value) |> Map.ofSeq
let found =
try
Check.file buffers (uriToPath uri)
with ex ->
Rpc.log $"check of %s{uri} failed: %O{ex}"
[]
Rpc.notify "textDocument/publishDiagnostics" (Check.publishParams uri found)
/// When each changed file is next to be checked. A check waits for typing to
/// pause, as one per keystroke would queue up behind each other.
let private dueChecks = Collections.Generic.Dictionary<string, DateTime>()
let private pause = TimeSpan.FromMilliseconds 400.0
let private textOf (uri: string) =
match texts.TryGetValue uri with
| true, text -> text
| _ -> IO.File.ReadAllText(uriToPath uri)
/// A compiler range as an LSP one. Lines are 1-based in the compiler and
/// 0-based in LSP; columns are 0-based in both.
let private range (r: Bjolang.Lexer.Range) : JsonNode =
let position (p: Bjolang.Lexer.Position) =
JsonObject(dict [ "line", JsonValue.Create(max 0 (p.Line - 1)) :> JsonNode; "character", JsonValue.Create p.Column ])
:> JsonNode
JsonObject(dict [ "start", position r.Start; "end", position r.End ])
let rec private documentSymbol (s: Symbols.Symbol) : JsonNode =
JsonObject(
dict
[ "name", JsonValue.Create s.Name :> JsonNode
"detail", JsonValue.Create s.Detail
"kind", JsonValue.Create(int s.Kind)
"range", range s.Range
"selectionRange", range s.NameRange
"children", JsonArray(s.Children |> List.map documentSymbol |> Array.ofList) ]
)
/// The last symbols each file read to, kept for while it does not read: a
/// half-typed form would otherwise empty the outline on every keystroke.
let private lastSymbols = Collections.Generic.Dictionary<string, Symbols.Symbol list>()
let private symbolsOf (uri: string) : JsonNode =
let symbols =
match Symbols.ofText (uriToPath uri) (textOf uri) with
| Some symbols ->
lastSymbols[uri] <- symbols
symbols
| None ->
match lastSymbols.TryGetValue uri with
| true, symbols -> symbols
| _ -> []
JsonArray(symbols |> List.map documentSymbol |> Array.ofList)
/// The name at an LSP position, where it is, and its definition.
let private lookup (uri: string) (line: int) (character: int) =
let path = uriToPath uri
let text = textOf uri
Symbols.nameAt path text (line + 1) character
|> Option.bind (fun (name, at) -> Symbols.definition path text name |> Option.map (fun found -> at, found))
/// The local binding the name at an LSP position refers to, if it is one, and
/// where the name is.
let private localAt (uri: string) (line: int) (character: int) : (Scope.Binder * Bjolang.Lexer.Range) option =
let path = uriToPath uri
let text = textOf uri
match Symbols.nameAt path text (line + 1) character, Symbols.forms path text with
| Some(name, at), Some forms -> Scope.find forms (line + 1) character name |> Option.map (fun b -> b, at)
| _ -> None
let private location (r: Bjolang.Lexer.Range) : JsonNode =
JsonObject(dict [ "uri", JsonValue.Create(Uri(r.File).AbsoluteUri) :> JsonNode; "range", range r ])
let private definitionAt (uri: string) (line: int) (character: int) : JsonNode =
match localAt uri line character with
| Some(b, _) -> location b.Range
| None ->
match lookup uri line character with
| None -> null
| Some(_, found) -> location found.Symbol.NameRange
let private markdownContent (text: string) : JsonNode =
JsonObject(dict [ "kind", JsonValue.Create "markdown" :> JsonNode; "value", JsonValue.Create text ])
/// What a hover says about `name`: of its definition, or of the builtin it
/// is.
let private describe (uri: string) (name: string) : string option =
match Symbols.definition (uriToPath uri) (textOf uri) name with
| Some found -> Some(Hover.text found)
| None -> Hover.builtin name
let private hoverAt (uri: string) (line: int) (character: int) : JsonNode =
let answer (text: string) (at: Bjolang.Lexer.Range) =
JsonObject(dict [ "contents", markdownContent text; "range", range at ]) :> JsonNode
match localAt uri line character with
| Some(b, at) -> answer (Hover.local b (Symbols.sliceOf (textOf uri) b.Shown)) at
| None ->
match Symbols.nameAt (uriToPath uri) (textOf uri) (line + 1) character with
| None -> null
| Some(name, at) ->
match describe uri name with
| None -> null
| Some text -> answer text at
/// The completions at a position. Each replaces the whole word before the
/// cursor. Only names that start with the word's first character are sent,
/// as the client filters the rest of the way itself, and every name at once
/// is two thousand of them.
let private completionAt (uri: string) (line: int) (character: int) : JsonNode =
let text = textOf uri
let lines = text.Replace("\r\n", "\n").Split('\n')
let lineText = if line < lines.Length then lines[line] else ""
let column = min character lineText.Length
let start = Completion.wordStart lineText column
let word = lineText.Substring(start, column - start)
let own = IO.Path.GetFileName(uriToPath uri)
let position (c: int) =
JsonObject(dict [ "line", JsonValue.Create line :> JsonNode; "character", JsonValue.Create c ]) :> JsonNode
let replace = JsonObject(dict [ "start", position start; "end", position column ])
let rank (item: Completion.Item) =
match item.From with
| "local" -> 0
| f when f = own -> 1
| "builtin" -> 3
| "special form" -> 4
| _ -> 2
// The locals in scope, innermost first and each name once: an inner
// binding hides an outer one, and both hide a top-level name.
let locals =
match Symbols.forms (uriToPath uri) text with
| Some forms ->
Scope.at forms (line + 1) column
|> List.rev
|> List.distinctBy (fun b -> b.Name)
// The word being typed is not yet a name in scope, unless it is
// the binder itself, which is not worth offering either.
|> List.filter (fun b -> not (b.Range.Start.Line = line + 1 && b.Range.Start.Column = start))
| None -> []
let localNames = locals |> List.map (fun b -> b.Name) |> Set.ofList
let candidates =
if Completion.inText lineText column then
[]
else
(locals |> List.map (fun b -> ({ Label = b.Name; Kind = Completion.ItemKind.Variable; From = "local" }: Completion.Item)))
@ (Completion.items (uriToPath uri) text |> List.filter (fun item -> not (localNames.Contains item.Label)))
let localDoc =
locals
|> List.map (fun b -> b.Name, Hover.local b (Symbols.sliceOf text b.Shown))
|> Map.ofList
let items =
candidates
|> List.filter (fun item -> word = "" || Char.ToLowerInvariant item.Label[0] = Char.ToLowerInvariant word[0])
|> List.map (fun item ->
let fields =
[ "label", JsonValue.Create item.Label :> JsonNode
"kind", JsonValue.Create(int item.Kind)
"labelDetails", JsonObject(dict [ "description", JsonValue.Create item.From :> JsonNode ])
"sortText", JsonValue.Create($"%d{rank item}%s{item.Label}")
"textEdit",
JsonObject(dict [ "range", replace.DeepClone(); "newText", JsonValue.Create item.Label :> JsonNode ]) ]
// A local's doc is at hand; anything else's is found when the
// client asks for it.
let more =
match item.From, Map.tryFind item.Label localDoc with
| "local", Some doc -> [ "documentation", markdownContent doc ]
| _ -> [ "data", JsonObject(dict [ "uri", JsonValue.Create uri :> JsonNode; "name", JsonValue.Create item.Label ]) :> JsonNode ]
JsonObject(dict (fields @ more)) :> JsonNode)
JsonObject(dict [ "isIncomplete", JsonValue.Create false :> JsonNode; "items", JsonArray(Array.ofList items) ])
/// A completion item with its doc, which is the hover of its name.
let private resolve (item: JsonNode) : JsonNode =
let data = item["data"]
if not (isNull data) then
let uri = data["uri"].GetValue<string>()
let name = data["name"].GetValue<string>()
match describe uri name with
| Some text -> item["documentation"] <- markdownContent text
| None -> ()
item.DeepClone()
let private capabilities () : JsonNode =
JsonNode.Parse
"""
{ "capabilities":
{ "textDocumentSync": { "openClose": true, "change": 1, "save": { "includeText": false } },
"documentSymbolProvider": true,
"definitionProvider": true,
"hoverProvider": true,
"completionProvider": { "resolveProvider": true, "triggerCharacters": [ "(" ] } },
"serverInfo": { "name": "bjolang-lsp", "version": "0.4.0" } }
"""
[<EntryPoint>]
let main _ =
setBjolangHome ()
useInstalledCompiler ()
let mutable shutdownAsked = false
// Messages are read on a thread of their own and handled on this one.
// Compiler work has to stay on one thread, as `Session` swaps the
// compiler's global state around each piece of it; reading apart from it
// is what lets this one notice that typing has paused.
let inbox = new Collections.Concurrent.BlockingCollection<JsonNode option>()
let reader =
Threading.Thread(
(fun () ->
let rec go () =
match Rpc.read () with
| Some m ->
inbox.Add(Some m)
go ()
| None -> inbox.Add None
try
go ()
with ex ->
Rpc.log $"reading failed: %O{ex}"
inbox.Add None),
IsBackground = true
)
reader.Start()
/// The next message, running every check that falls due while waiting
/// for it.
let rec next () : JsonNode option =
if dueChecks.Count = 0 then
inbox.Take()
else
let soonest = dueChecks.Values |> Seq.min
let untilDue = soonest - DateTime.UtcNow
let wait = if untilDue < TimeSpan.Zero then TimeSpan.Zero else untilDue
let mutable message: JsonNode option = None
if inbox.TryTake(&message, wait) then
message
else
let due =
dueChecks |> Seq.filter (fun kv -> kv.Value <= DateTime.UtcNow) |> Seq.map (fun kv -> kv.Key) |> List.ofSeq
for uri in due do
dueChecks.Remove uri |> ignore
publish uri
next ()
let rec serve () =
match next () with
| None -> if shutdownAsked then 0 else 1
| Some message ->
let id = message["id"]
let methodName = str message [ "method" ] |> Option.defaultValue ""
let uri () = str message [ "params"; "textDocument"; "uri" ]
match methodName with
| "exit" -> if shutdownAsked then 0 else 1
| _ ->
try
match methodName with
| "initialize" -> Rpc.respond id (capabilities ())
| "shutdown" ->
shutdownAsked <- true
Rpc.respond id null
| "textDocument/didOpen" ->
uri ()
|> Option.iter (fun u ->
str message [ "params"; "textDocument"; "text" ] |> Option.iter (fun t -> texts[u] <- t)
publish u)
// Full sync: the one change is the whole text.
| "textDocument/didChange" ->
match uri (), message["params"]["contentChanges"] with
| Some u, (:? JsonArray as changes) when changes.Count > 0 ->
let last = changes[changes.Count - 1]
texts[u] <- last["text"].GetValue<string>()
dueChecks[u] <- DateTime.UtcNow + pause
| _ -> ()
| "textDocument/didSave" ->
uri ()
|> Option.iter (fun u ->
dueChecks.Remove u |> ignore
publish u)
// A closed file's diagnostics are the client's to forget,
// and an empty list is how it is told to.
| "textDocument/didClose" ->
uri ()
|> Option.iter (fun u ->
texts.Remove u |> ignore
dueChecks.Remove u |> ignore
lastSymbols.Remove u |> ignore
Rpc.notify "textDocument/publishDiagnostics" (Check.publishParams u []))
| "textDocument/documentSymbol" ->
Rpc.respond id (uri () |> Option.map symbolsOf |> Option.defaultValue (JsonArray()))
| "textDocument/definition"
| "textDocument/hover" ->
let position = message["params"]["position"]
let line = position["line"].GetValue<int>()
let character = position["character"].GetValue<int>()
let answer = if methodName = "textDocument/hover" then hoverAt else definitionAt
Rpc.respond id (uri () |> Option.map (fun u -> answer u line character) |> Option.defaultValue null)
| "textDocument/completion" ->
let position = message["params"]["position"]
let line = position["line"].GetValue<int>()
let character = position["character"].GetValue<int>()
Rpc.respond id (uri () |> Option.map (fun u -> completionAt u line character) |> Option.defaultValue null)
| "completionItem/resolve" -> Rpc.respond id (resolve message["params"])
// Not part of LSP: the expansion of the macro call at a
// position, from the file's last check. A check that is
// due runs first, so that the expansion is of the text as
// it stands.
| "bjolang/expandMacro" ->
let p = message["params"]
let position = p["position"]
let flag (key: string) (otherwise: bool) =
match p[key] with
| null -> otherwise
| v -> v.GetValue<bool>()
let answer =
uri ()
|> Option.bind (fun u ->
if dueChecks.Remove u then publish u
Expansion.at
(uriToPath u)
(position["line"].GetValue<int>() + 1)
(position["character"].GetValue<int>())
(flag "full" true)
(flag "hygienic" false))
|> Option.map (fun (macro, text) ->
JsonObject(dict [ "macro", JsonValue.Create macro :> JsonNode; "text", JsonValue.Create text ])
:> JsonNode)
|> Option.defaultValue null
Rpc.respond id answer
| _ when not (isNull id) -> Rpc.respondError id -32601 $"%s{methodName} is not supported"
// Any other notification, `initialized` included, needs no
// answer.
| _ -> ()
with ex ->
Rpc.log $"%s{methodName} failed: %O{ex}"
if not (isNull id) then
Rpc.respondError id -32603 ex.Message
serve ()
serve ()

128
README.md Normal file
View file

@ -0,0 +1,128 @@
# BjolangLsp
A language server for Bjolang. It does five things:
- Diagnostics: it checks a file with the compiler's frontend, as
`bjolang --check` does, and sends the errors and warnings to the editor.
It checks the editor's text, saved or not: when a file is opened or
saved, and 400 ms after typing pauses. Every open file is read from its
buffer, so an unsaved include or `.bjodoc` counts too.
- An outline (`textDocument/documentSymbol`): the file's top-level
definitions, with a type's constructors or fields, a trait's methods and an
`impl`'s functions under them.
- Go to definition (`textDocument/definition`): a local name goes to where
it is bound, the innermost binding of it; a top-level name to the file's
own definition, else one in a module it imports or includes, searched
nearest first, and then the prelude.
- Hover (`textDocument/hover`) for the same names. A top-level name shows
the `(: name Type)` declaration and the definition's head as written, then
its doc from the module's `(:doc ...)` forms and `.bjodoc` files, with the
doc markup (`@code`, `@strong`, `@em`, `@itemlist`) as Markdown. A
constructor or a field shows its type's doc, with its own `case` or
`field` line. A builtin, which the compiler defines rather than a module,
shows its type and its doc from the prelude's docs. A local name shows
its binding as written, a typed parameter with its type, and what binds
it.
- Completion (`textDocument/completion`): the local names in scope, then
the top-level names of the file and of every module it sees, the
builtins, and the special forms, each name once and the nearest first. An
item replaces the whole word before the cursor, as the lexer reads a word,
so `string->` is one. Its doc is the hover's, sent along for a local and
when the client asks for anything else (`completionItem/resolve`).
Nothing is offered in a comment or a string.
And one request of its own, `bjolang/expandMacro`: the expansion of the
macro call at a position, one step or all the way down, from the last check
of the file, which runs first if a change is waiting for it. The compiler
reports each expansion it makes through `Macro.observe` while it checks, so
an expansion costs nothing beyond the check. Names hygiene renamed are shown
as the template wrote them, unless `hygienic` asks for the renamed ones.
`loop`, `seql`, `->`, `defun` and the parser's other forms are not macros,
and have no expansion.
The outline, definitions, hovers and completions read only as far as the
reader: no macro is expanded and nothing is type checked, so they answer on
every request. A form being typed is read as if it were closed; text that
does not read even so leaves the last outline in place.
Local names are the ones the parser's own forms bind: parameters of a
`defun`, `fun` and the other `def…` heads, `let`, `let*`, `letrec`,
`let/mono`, named `let` and `with-open` bindings, `with-return`, `match`
patterns, the clauses of `loop`, `seql` and a comprehension, and `def` or
`defun` inside a body, for the forms after it.
## Building
It expects the Bjolang checkout beside this one, at `../Bjolang`, and runs
that compiler in-process through a project reference.
```
(cd ../Bjolang && ./build_compiler.sh && ./build_std.sh)
dotnet build -c Release
test/smoke.py
```
The server is `bin/Release/net10.0/BjolangLsp.dll`, started as
`dotnet bin/Release/net10.0/BjolangLsp.dll`. It talks LSP on stdin and
stdout, and logs to stderr.
## How it finds things
- The standard library and the runtime: through the checkout path baked in
at build time. `BJOLANG_HOME` overrides it.
- Staleness: an imported module is judged against the installed compiler,
`../Bjolang/bin/compiler/Bjolang.dll`, not against the server's own copy of
the compiler, and a stale import is built by running that compiler. Built
by the server, its build record would name the server, and the command line
would build it again.
- Unsaved text: the compiler reads a source file through
`Paths.readSource`, and the server hands it the open buffers in
`Paths.sourceOverrides` for the length of a check.
## Emacs (Doom, lsp-mode)
```elisp
(after! lsp-mode
(add-to-list 'lsp-language-id-configuration '(bjo-mode . "bjolang"))
(lsp-register-client
(make-lsp-client
:new-connection (lsp-stdio-connection
'("dotnet" "/home/linis/Programmering/BjolangLsp/bin/Release/net10.0/BjolangLsp.dll"))
:activation-fn (lsp-activate-on "bjolang")
:server-id 'bjolang-lsp)))
(add-hook 'bjo-mode-hook #'lsp)
```
With eglot instead:
```elisp
(add-to-list 'eglot-server-programs
'(bjo-mode . ("dotnet" "/home/linis/Programmering/BjolangLsp/bin/Release/net10.0/BjolangLsp.dll")))
```
## What it does not do yet
- Columns. Most diagnostics carry only a line, and the whole line is marked.
- A check of a large file waits for the requests before it, and they for it:
everything that touches the compiler runs on one thread, because the
compiler's state is global.
- Names a macro binds, at top level or locally. A loop variable is taken to
be in scope across its whole loop, which is wider than the loop allows.
- Which definition. A name defined in two imported modules goes to the
nearer one, which is not always the one the compiler would pick, and a
module the file does not export from is searched like one it does.
- Errors in another file. A diagnostic located in an imported or included
file is shown on the first line of the file being checked, with its
location in the message.
- Hover for a special form (`record-ref`, `loop`, `match`), which has no
definition to find and no doc.
- Types that are inferred rather than written. A hover shows the
declaration if there is one, and nothing about a name without it.
- Completion of record fields after `record-ref`, of module paths in an
`import`, or of keyword arguments. A string that began on an earlier line
is not seen as one, so a multi-line string gets completions.
- Find references, rename.
- Packages: no `--roots` is passed, so only the standard library resolves.
- Stale imports are built by the installed compiler, which was tested only
for the standard library being current, not for a stale import.

89
Rpc.fs Normal file
View file

@ -0,0 +1,89 @@
/// JSON-RPC over stdin and stdout, framed as the Language Server Protocol
/// frames it: a `Content-Length` header, a blank line, and that many bytes of
/// UTF-8 JSON.
///
/// The streams are the process's raw ones, opened once. The compiler redirects
/// `Console.Out` while it checks, and a message written through `Console`
/// then would land in its capture buffer instead of with the client.
module BjolangLsp.Rpc
open System
open System.IO
open System.Text
open System.Text.Json.Nodes
let private input = Console.OpenStandardInput()
let private output = Console.OpenStandardOutput()
let private writeLock = obj ()
/// One header line, without its line ending. `None` at end of input.
let private readHeaderLine () : string option =
let line = StringBuilder()
let rec go () =
match input.ReadByte() with
| -1 -> if line.Length = 0 then None else Some(line.ToString())
| 10 -> Some(line.ToString().TrimEnd '\r')
| b ->
line.Append(char b) |> ignore
go ()
go ()
/// The next message. `None` when the client has closed stdin.
let read () : JsonNode option =
let rec headers (length: int option) =
match readHeaderLine () with
| None -> None
| Some "" ->
// A blank line without a length is a malformed frame. There is no
// way to find the next one, so it ends the session like end of input.
length
| Some line ->
match line.Split(':', 2) with
| [| name; value |] when name.Trim().Equals("Content-Length", StringComparison.OrdinalIgnoreCase) ->
headers (Some(int (value.Trim())))
| _ -> headers length
headers None
|> Option.bind (fun length ->
let body = Array.zeroCreate<byte> length
let mutable got = 0
while got < length do
match input.Read(body, got, length - got) with
| 0 -> raise (EndOfStreamException "stdin closed inside a message")
| n -> got <- got + n
Some(JsonNode.Parse(Encoding.UTF8.GetString body)))
let private write (message: JsonObject) =
message["jsonrpc"] <- "2.0"
let body = Encoding.UTF8.GetBytes(message.ToJsonString())
let header = Encoding.ASCII.GetBytes($"Content-Length: %d{body.Length}\r\n\r\n")
lock writeLock (fun () ->
output.Write(header, 0, header.Length)
output.Write(body, 0, body.Length)
output.Flush())
/// The answer to request `id`.
let respond (id: JsonNode) (result: JsonNode) =
write (JsonObject(dict [ "id", id.DeepClone(); "result", result ]))
/// An error answer to request `id`.
let respondError (id: JsonNode) (code: int) (message: string) =
let error = JsonObject(dict [ "code", JsonValue.Create code :> JsonNode; "message", JsonValue.Create message ])
write (JsonObject(dict [ "id", id.DeepClone(); "error", error :> JsonNode ]))
/// A notification to the client.
let notify (methodName: string) (parameters: JsonNode) =
write (JsonObject(dict [ "method", JsonValue.Create methodName :> JsonNode; "params", parameters ]))
/// A line for the server's log, which is stderr: the client shows it, and it
/// never mixes with the protocol on stdout.
let log (message: string) =
let err = Console.OpenStandardError()
let bytes = Encoding.UTF8.GetBytes(message + "\n")
err.Write(bytes, 0, bytes.Length)
err.Flush()

216
Scope.fs Normal file
View file

@ -0,0 +1,216 @@
/// The local names in scope at a position: parameters, `let` bindings,
/// pattern variables, loop variables, and definitions inside a body.
///
/// Read off the forms as the reader gives them, as `Symbols` reads the
/// top-level names, with the scoping rules of the forms the parser knows. A
/// macro's binding forms are not known, so a name a macro binds is not seen;
/// the parser's own forms cover most of what is written.
module BjolangLsp.Scope
open System
open Bjolang.Lexer
open Bjolang.Ast
type Binder =
{ Name: string
/// Where the name is written in its binding form.
Range: Range
/// What a hover shows of the binding: the parameter with its type, the
/// `let` binding with its value, the pattern.
Shown: Range
/// What binds it, for a hover: "a parameter of `f`", "bound by `let`".
Description: string }
/// Whether `r` holds the position. The end is included, so a cursor right
/// after a name is in it, as it is while the name is being typed.
let private holds (line: int) (column: int) (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))
let private binder name range shown description =
{ Name = name
Range = range
Shown = shown
Description = description }
/// The names a pattern binds: every lowercase symbol that is not the head of
/// a list, as the head is the constructor.
let rec private patternNames (description: string) (shown: Range) (s: SExpr) : Binder list =
match s with
| SAtom { Token = Symbol n; Range = r } when n <> "_" && n <> "else" && not (Char.IsUpper n[0]) ->
[ binder n r shown description ]
| SList(SAtom { Token = Symbol _ } :: args, _) -> args |> List.collect (patternNames description shown)
| SList(items, _) -> items |> List.collect (patternNames description shown)
| _ -> []
/// The parameters of an argument list: `x`, `(: x Type)`, `#:rest xs`, and a
/// keyword parameter `(#:key default)` or `#:key default`, which binds `key`.
let private parameters (owner: string) (args: SExpr list) : Binder list =
let description = if owner = "" then "a parameter" else $"a parameter of `%s{owner}`"
let rec go (args: SExpr list) =
match args with
| [] -> []
| SAtom { Token = Symbol n; Range = r } :: rest -> binder n r r description :: go rest
| (SList([ SAtom { Token = Colon }; SAtom { Token = Symbol n; Range = r }; _ ], whole)) :: rest ->
binder n r whole description :: go rest
| SList([ SAtom { Token = Keyword k; Range = r }; _ ], whole) :: rest ->
binder k r whole (description + ", by keyword") :: go rest
| SAtom { Token = Keyword "rest" } :: SAtom { Token = Symbol n; Range = r } :: rest ->
binder n r r (description + ", the rest of the arguments") :: go rest
| SAtom { Token = Keyword k; Range = r } :: value :: rest ->
binder k r (getRange value) (description + ", by keyword") :: go rest
| _ :: rest -> go rest
go args
/// What a body form defines for the forms after it: `(def x ...)`,
/// `(def (: x T) ...)`, `(defun (f ...) ...)` and their kin.
let private definedBy (form: SExpr) : Binder list =
match form with
| SList(SAtom { Token = Symbol("def" | "def/mutable") } :: target :: _, whole) ->
match target with
| SAtom { Token = Symbol n; Range = r } -> [ binder n r whole "defined in this body" ]
| SList(SAtom { Token = Colon } :: SAtom { Token = Symbol n; Range = r } :: _, _) ->
[ binder n r whole "defined in this body" ]
| SList(names, _) -> names |> List.collect (patternNames "defined in this body" whole)
| _ -> []
| SList(SAtom { Token = Symbol head } :: SList(SAtom { Token = Symbol n; Range = r } :: _, sig') :: _, _) when
head = "defun" || head = "defbjo" || head = "defbjouble"
->
[ binder n r sig' $"a `%s{head}` in this body" ]
| _ -> []
/// The bindings of a `let`'s list, each as its names and its value.
let private letBindings (description: string) (bindings: SExpr list) : (Binder list * SExpr option) list =
bindings
|> List.map (fun b ->
match b with
| SList([ SAtom { Token = Symbol n; Range = r }; value ], whole) -> [ binder n r whole description ], Some value
| SList([ SList(SAtom { Token = Colon } :: SAtom { Token = Symbol n; Range = r } :: _, _); value ], whole) ->
[ binder n r whole description ], Some value
| SList([ pattern; value ], whole) -> patternNames description whole pattern, Some value
| other -> [], Some other)
/// The names a loop's clauses bind, which its other clauses, its `=>` and,
/// in a comprehension, the expression before them see. A loop variable is in
/// scope across the whole form rather than only after its clause; that is
/// more than the loop allows, and enough to find a name by.
let rec private loopNames (items: SExpr list) : Binder list =
items
|> List.collect (fun item ->
match item with
| SList(SAtom { Token = Keyword("for" | "with" | "let" | "when-let" | "finish-let" | "break-let" as k) }
:: pattern
:: _,
whole) -> patternNames $"bound by a `:%s{k}` clause" whole pattern
| SList(SAtom { Token = Keyword "acc" } :: SAtom { Token = Symbol n; Range = r } :: _, whole) ->
[ binder n r whole "a loop accumulator" ]
| SList(SAtom { Token = Keyword "subloop" } :: inner, _) -> loopNames inner
| SList([ SAtom { Token = Symbol n; Range = r }; _ ], whole) when
// A `:subloop`'s `=> (name expr)`, the only bare list among clauses.
not (Char.IsUpper n[0])
->
[ binder n r whole "a subloop's result" ]
| _ -> [])
/// The names in scope at the position, innermost last, inside `s`; `None`
/// if the position is not in it.
let rec private inForm (line: int) (column: int) (env: Binder list) (s: SExpr) : Binder list option =
if not (holds line column (getRange s)) then
None
else
match s with
| SAtom _ -> Some env
| SList(items, _) -> Some(inList line column env items)
and private inList (line: int) (column: int) (env: Binder list) (items: SExpr list) : Binder list =
let body env forms = inBody line column env forms
match items with
| SAtom { Token = Symbol head } :: SList(SAtom { Token = Symbol name } :: args, _) :: _ when
head.StartsWith "def" && head <> "def" && head <> "def/mutable"
->
// `(defun (f x y) body...)`: the parameters over the whole form, the
// head included, so that a parameter is found where it is written.
body (env @ parameters name args) items
| SAtom { Token = Symbol("fun" | "bjoroutine") } :: SList(args, _) :: _ -> body (env @ parameters "" args) items
| SAtom { Token = Symbol("let" | "let*" | "letrec" | "let/mono" | "with-open" as head) } :: rest ->
let named, bindingList, bodyForms =
match rest with
| SAtom { Token = Symbol n; Range = r } :: SList(bs, _) :: forms ->
[ binder n r r "the name of a named `let`, called to loop" ], bs, forms
| SList(bs, _) :: forms -> [], bs, forms
| forms -> [], [], forms
let bindings = letBindings $"bound by `%s{head}`" bindingList
let all = named @ (bindings |> List.collect fst)
// A value sees what is around the `let`, and in a `let*` or a
// `letrec` the bindings before it, or all of them.
let inValue =
bindings
|> List.indexed
|> List.tryPick (fun (i, (_, value)) ->
value
|> Option.bind (fun v ->
let seen =
match head with
| "letrec" -> env @ all
| "let*" -> env @ named @ (bindings |> List.take i |> List.collect fst)
| _ -> env
inForm line column seen v))
match inValue with
| Some found -> found
| None ->
let inBinders = all |> List.exists (fun b -> holds line column b.Range)
if inBinders then env @ all else body (env @ all) bodyForms
| SAtom { Token = Symbol "with-return" } :: SAtom { Token = Symbol n; Range = r } :: forms ->
body (env @ [ binder n r r "the escape of a `with-return`, called to return" ]) forms
| SAtom { Token = Symbol "match" } :: scrutinee :: arms ->
match inForm line column env scrutinee with
| Some found -> found
| None ->
arms
|> List.tryPick (fun arm ->
match arm with
| SList(pattern :: _, _) ->
let bound = patternNames "bound by a `match` pattern" (getRange pattern) pattern
inForm line column (env @ bound) arm
| _ -> inForm line column env arm)
|> Option.defaultValue env
| SAtom { Token = Symbol("loop" | "seql" | "comprehension") } :: rest -> body (env @ loopNames rest) items
| _ -> body env items
/// The names in scope in a body at the position: a definition scopes over
/// the forms after it.
and private inBody (line: int) (column: int) (env: Binder list) (forms: SExpr list) : Binder list =
let rec go (env: Binder list) (forms: SExpr list) =
match forms with
| [] -> env
| form :: rest ->
match inForm line column env form with
| Some found -> found
| None -> go (env @ definedBy form) rest
go env forms
/// The local names in scope at `line` (1-based) and `column` (0-based) among
/// a file's top-level forms, innermost last. A top-level definition is not
/// among them: `Symbols` has those.
let at (forms: SExpr list) (line: int) (column: int) : Binder list =
forms |> List.tryPick (inForm line column []) |> Option.defaultValue []
/// The binding `name` refers to at the position, if it is a local one: the
/// innermost of that name.
let find (forms: SExpr list) (line: int) (column: int) (name: string) : Binder option =
at forms line column |> List.tryFindBack (fun b -> b.Name = name)

390
Symbols.fs Normal file
View file

@ -0,0 +1,390 @@
/// 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 }))

83
emacs/bjolang-lsp.el Normal file
View file

@ -0,0 +1,83 @@
;;; bjolang-lsp.el --- Commands for the parts of BjolangLsp that LSP has no request for -*- lexical-binding: t; -*-
;;; Commentary:
;; Macro expansion: `bjo-expand-macro' shows the expansion of the macro call
;; at point all the way down, and `bjo-expand-macro-1' one step of it, in a
;; buffer of their own. With a prefix argument they keep the names hygiene
;; made, such as `tmp__37', which is what tells a template's name from the
;; caller's of the same spelling.
;;
;; The expansion is the compiler's, from its last check of the buffer; a
;; change not yet checked is checked first. `loop', `seql', `->' and the
;; other forms the parser turns into code itself are not macros, and have
;; no expansion to show.
;;; Code:
(require 'lsp-mode)
(defvar bjo-mode-map)
(defvar bjo-mode-hook)
(declare-function bjo-mode "bjomode")
(defun bjo--field (result key)
"The field KEY, a string, of RESULT as `lsp-mode' decoded it.
A hash table or a plist, as `lsp-use-plists' says, which can differ from
how this file was compiled."
(if (hash-table-p result)
(gethash key result)
(plist-get result (intern (concat ":" key)))))
(defun bjo--expand-macro (full hygienic)
"Show the expansion of the macro call at point.
FULL expands the macro calls in the expansion too; HYGIENIC keeps the
names hygiene made."
(let* ((params (append (lsp--text-document-position-params)
(list :full (if full t :json-false)
:hygienic (if hygienic t :json-false))))
(result (lsp-request "bjolang/expandMacro" params)))
(if (null result)
(message "No macro call at point.")
(let ((macro (bjo--field result "macro"))
(text (bjo--field result "text"))
(buffer (get-buffer-create "*bjo expansion*")))
(with-current-buffer buffer
(let ((inhibit-read-only t)
;; The expansion is not a file, and must not start a server.
(bjo-mode-hook nil))
(erase-buffer)
(bjo-mode)
(insert (format ";; (%s ...), %s%s\n\n"
macro
(if full "expanded all the way" "one step")
(if hygienic ", with hygiene's names" ""))
text
"\n")
(font-lock-ensure)
(goto-char (point-min)))
;; Read only, and `q' to leave, without binding `q' in the mode's
;; own map, which every Bjolang buffer shares.
(view-mode 1))
(display-buffer buffer)))))
(defun bjo-expand-macro (&optional hygienic)
"Show the macro call at point expanded all the way down.
With a prefix argument HYGIENIC, keep the names hygiene made."
(interactive "P")
(bjo--expand-macro t hygienic))
(defun bjo-expand-macro-1 (&optional hygienic)
"Show one step of the expansion of the macro call at point.
With a prefix argument HYGIENIC, keep the names hygiene made."
(interactive "P")
(bjo--expand-macro nil hygienic))
;; As SLIME binds its macroexpanders.
(with-eval-after-load 'bjo-mode
(define-key bjo-mode-map (kbd "C-c C-m") #'bjo-expand-macro-1)
(define-key bjo-mode-map (kbd "C-c M-m") #'bjo-expand-macro))
(provide 'bjolang-lsp)
;;; bjolang-lsp.el ends here

629
test/smoke.py Executable file
View file

@ -0,0 +1,629 @@
#!/usr/bin/env python3
"""Talks to the server as an editor would, over stdin and stdout, and checks
what it answers. One server process for every case, so that a second check
in the same process is tested too.
test/smoke.py # builds nothing; run `dotnet build -c Release` first
"""
import json
import os
import subprocess
import sys
import tempfile
ROOT = os.path.dirname(os.path.dirname(os.path.abspath(__file__)))
SERVER = os.path.join(ROOT, "bin", "Release", "net10.0", "BjolangLsp.dll")
def frame(message):
body = json.dumps(message).encode()
return b"Content-Length: %d\r\n\r\n" % len(body) + body
def read(stream):
length = None
while True:
line = stream.readline()
if not line:
raise EOFError("server closed stdout")
line = line.strip()
if not line:
break
name, _, value = line.decode().partition(":")
if name.lower() == "content-length":
length = int(value)
return json.loads(stream.read(length))
class Server:
def __init__(self):
self.proc = subprocess.Popen(
["dotnet", SERVER], stdin=subprocess.PIPE, stdout=subprocess.PIPE
)
self.next_id = 0
# Notifications read while waiting for something else: a check that
# fell due can publish between a request and its answer.
self.pending = []
def send(self, method, params=None, request=False):
message = {"jsonrpc": "2.0", "method": method, "params": params or {}}
if request:
self.next_id += 1
message["id"] = self.next_id
self.proc.stdin.write(frame(message))
self.proc.stdin.flush()
if not request:
return None
while True:
answer = read(self.proc.stdout)
if answer.get("id") == self.next_id:
return answer
self.pending.append(answer)
def change(self, uri, text, version):
self.send(
"textDocument/didChange",
{"textDocument": {"uri": uri, "version": version}, "contentChanges": [{"text": text}]},
)
def published(self, uri):
"""The diagnostics for `uri` among the notifications already read, as
a list of their diagnostics lists, and takes them out."""
mine = [
m for m in self.pending
if m.get("method") == "textDocument/publishDiagnostics" and m["params"]["uri"] == uri
]
self.pending = [m for m in self.pending if m not in mine]
return [m["params"]["diagnostics"] for m in mine]
def next_diagnostics(self, uri):
"""The next diagnostics published for `uri`, waiting for them if
none has come yet."""
earlier = self.published(uri)
if earlier:
return earlier[0]
while True:
message = read(self.proc.stdout)
if message.get("method") == "textDocument/publishDiagnostics" and message["params"]["uri"] == uri:
return message["params"]["diagnostics"]
self.pending.append(message)
def diagnostics_after(self, method, uri, text=None):
doc = {"uri": uri}
if text is not None:
doc.update(languageId="bjolang", version=1, text=text)
self.published(uri) # anything older is not the answer to this
self.send(method, {"textDocument": doc})
return self.next_diagnostics(uri)
failures = 0
def expect(name, ok, detail=""):
global failures
print(("ok: " if ok else "FAIL: ") + name + ("" if ok else f"\n {detail}"))
if not ok:
failures += 1
BROKEN = """(import (std prelude))
(: main (-> (Vec string) int))
(defun (main args)
(+ 1 "two"))
"""
FIXED = """(import (std prelude))
(: main (-> (Vec string) int))
(defun (main args)
(+ 1 2))
"""
UNCLOSED = """(import (std prelude))
(defun (main args)
(+ 1 2)
"""
SYMBOLS = """(import (std prelude))
(type (: Shape (Union (Circle int) (Square int) Empty)))
(type (: Point (Record (: x int) (: y int))))
(def/trait (Area %a)
(: area (-> %a int)))
(impl (Area Shape)
(defun (area s)
(match s
((Circle r) (* 3 (* r r)))
((Square a) (* a a))
(Empty 0))))
(def unit-size 1)
(: double (-> int int))
(defun (double n) (* 2 n))
(: main (-> (Vec string) int))
(defun (main args)
(double (area (Circle unit-size)))
(list-map double (list 1 2 3))
0)
"""
def position_of(text, needle, nth=0, offset=1):
"""The LSP position `offset` characters into the `nth` occurrence of
`needle` in `text`."""
at = -1
for _ in range(nth + 1):
at = text.index(needle, at + 1)
at += offset
line = text.count("\n", 0, at)
return {"line": line, "character": at - (text.rfind("\n", 0, at) + 1)}
def line_of(text, needle):
return text.count("\n", 0, text.index(needle))
def names(symbols):
return [(s["name"], names(s.get("children", []))) for s in symbols]
def symbols_and_definitions(server, tmp):
path = os.path.join(tmp, "symbols.bjo")
uri = "file://" + path
with open(path, "w") as f:
f.write(SYMBOLS)
server.diagnostics_after("textDocument/didOpen", uri, SYMBOLS)
found = server.send("textDocument/documentSymbol", {"textDocument": {"uri": uri}}, request=True)["result"]
expect(
"the outline",
names(found)
== [
("Shape", [("Circle", []), ("Square", []), ("Empty", [])]),
("Point", [("x", []), ("y", [])]),
("Area", [("area", [])]),
("impl (Area Shape)", [("area", [])]),
("unit-size", []),
("double", []),
("main", []),
],
names(found),
)
def definition(text, needle, offset=1):
answer = server.send(
"textDocument/definition",
{"textDocument": {"uri": uri}, "position": position_of(text, needle, 0, offset)},
request=True,
)
return answer["result"]
d = definition(SYMBOLS, "(double (area")
expect(
"a name defined in the file",
d and d["uri"] == uri and d["range"]["start"]["line"] == line_of(SYMBOLS, "(defun (double"),
d,
)
d = definition(SYMBOLS, "(Circle unit-size")
expect(
"a constructor",
d and d["range"]["start"]["line"] == line_of(SYMBOLS, "(type (: Shape"),
d,
)
d = definition(SYMBOLS, "(list-map")
expect("a name from the prelude", d and d["uri"].endswith("/lib/std/prelude.bjo"), d)
# `n` is a parameter: it goes to where the parameter is written.
d = definition(SYMBOLS, "(* 2 n)", 5)
expect(
"a parameter goes to the parameter",
d and d["range"]["start"] == position_of(SYMBOLS, "(defun (double n)", 0, 15),
d,
)
def hover(text, needle, offset=1):
answer = server.send(
"textDocument/hover",
{"textDocument": {"uri": uri}, "position": position_of(text, needle, 0, offset)},
request=True,
)
result = answer["result"]
return result["contents"]["value"] if result else None
h = hover(SYMBOLS, "(double (area")
expect(
"hover: the declaration and the head",
h and "(: double (-> int int))" in h and "(defun (double n))" in h,
h,
)
h = hover(SYMBOLS, "(Circle unit-size")
expect("hover: a constructor's case and type", h and "(Circle int)" in h and "A case of `Shape`" in h, h)
h = hover(SYMBOLS, "(list-map")
expect(
"hover: the prelude's doc",
h and "Applies a function to each element of a list." in h and "**Parameters**" in h,
h,
)
h = hover(SYMBOLS, "(* 2 n)", 5)
expect("hover: a parameter says whose", h and "*A parameter of `double`.*" in h, h)
# Unsaved: the buffer gains a definition the file on disk does not have.
changed = SYMBOLS + "\n(defun (triple n) (* 3 n))\n(def nine (triple 3))\n"
server.send(
"textDocument/didChange",
{"textDocument": {"uri": uri, "version": 2}, "contentChanges": [{"text": changed}]},
)
d = definition(changed, "(triple 3)")
expect(
"the buffer, not the file",
d and d["range"]["start"]["line"] == line_of(changed, "(defun (triple"),
d,
)
found = server.send("textDocument/documentSymbol", {"textDocument": {"uri": uri}}, request=True)["result"]
expect("the outline follows the buffer", [n for n, _ in names(found)][-2:] == ["triple", "nine"], names(found))
# Half typed: the outline stays as it was rather than emptying.
server.send(
"textDocument/didChange",
{"textDocument": {"uri": uri, "version": 3}, "contentChanges": [{"text": changed + "(defun (half"}]},
)
found = server.send("textDocument/documentSymbol", {"textDocument": {"uri": uri}}, request=True)["result"]
expect(
"a half-typed form is read as if closed",
[n for n, _ in names(found)][-3:] == ["triple", "nine", "half"],
names(found),
)
# A stray closer cannot be mended by closing: the last outline stays.
server.send(
"textDocument/didChange",
{"textDocument": {"uri": uri, "version": 4}, "contentChanges": [{"text": changed + ")"}]},
)
found = server.send("textDocument/documentSymbol", {"textDocument": {"uri": uri}}, request=True)["result"]
expect(
"text that does not read keeps the last outline",
[n for n, _ in names(found)][-3:] == ["triple", "nine", "half"],
names(found),
)
server.diagnostics_after("textDocument/didClose", uri)
DOCUMENTED = """(import (std prelude))
(:doc #:file "documented.bjodoc")
(: squeeze (-> int int int int))
(defun (squeeze lo hi x) (max lo (min hi x)))
(: main (-> (Vec string) int))
(defun (main args) (squeeze 0 10 12))
"""
DOCUMENTED_DOC = '''(:doc squeeze
(summary "@code{x}, kept @strong{between} @em{lo} and hi.")
(arg lo "The least.")
(arg hi "The most.")
(arg x "The value.")
(returns "One of: @itemlist{@item{@code{lo}} @item{@code{hi}} @item{x}}")
(example """
(squeeze 0 10 12) ; 10
"""))
'''
def documented(server, tmp):
path = os.path.join(tmp, "documented.bjo")
uri = "file://" + path
with open(path, "w") as f:
f.write(DOCUMENTED)
with open(os.path.join(tmp, "documented.bjodoc"), "w") as f:
f.write(DOCUMENTED_DOC)
found = server.diagnostics_after("textDocument/didOpen", uri, DOCUMENTED)
expect("the documented file checks", found == [], found)
answer = server.send(
"textDocument/hover",
{"textDocument": {"uri": uri}, "position": position_of(DOCUMENTED, "(squeeze 0")},
request=True,
)
h = answer["result"]["contents"]["value"] if answer["result"] else None
expect(
"hover: a doc from a .bjodoc, its markup as Markdown",
h
and "`x`, kept **between** *lo* and hi." in h
and "- `lo`: The least." in h
and "**Returns** One of:\n- `lo`\n- `hi`\n- x" in h
and "(squeeze 0 10 12) ; 10" in h,
h,
)
server.diagnostics_after("textDocument/didClose", uri)
COMPLETING = """(import (std prelude))
(defun (list-unwind xs) xs)
(: main (-> (Vec string) int))
(defun (main args)
;; list-u
(list-u
"""
def completing(server, tmp):
path = os.path.join(tmp, "completing.bjo")
uri = "file://" + path
with open(path, "w") as f:
f.write(COMPLETING)
server.diagnostics_after("textDocument/didOpen", uri, COMPLETING)
def complete(needle, nth=0):
at = position_of(COMPLETING, needle, nth, len(needle))
answer = server.send(
"textDocument/completion", {"textDocument": {"uri": uri}, "position": at}, request=True
)
return at, answer["result"]["items"]
at, items = complete("(list-u", 0)
labels = {i["label"]: i for i in items}
expect(
"completion: the file's own name and the prelude's",
"list-unwind" in labels and "list-unfold" in labels,
sorted(labels)[:20],
)
expect(
"completion: only names starting with the word's first letter, in either case",
all(l[0] in "lL" for l in labels),
sorted(labels)[:20],
)
own = labels.get("list-unwind", {})
expect(
"completion: the item replaces the whole word",
own.get("textEdit", {}).get("range", {}).get("start") == {"line": at["line"], "character": at["character"] - 6},
own,
)
expect(
"completion: the file's own names sort first",
own.get("sortText", "").startswith("1") and labels["list-unfold"]["sortText"].startswith("2"),
(own.get("sortText"), labels.get("list-unfold", {}).get("sortText")),
)
resolved = server.send("completionItem/resolve", labels["list-unfold"], request=True)["result"]
doc = resolved.get("documentation", {}).get("value", "")
expect("completion: resolve adds the doc", "A list generated from a state." in doc, doc)
_, items = complete(";; list-u")
expect("completion: none in a comment", items == [], [i["label"] for i in items][:10])
# A builtin: no source to define it, but a type and a doc.
seq_text = COMPLETING.replace("(list-u\n", "(seq-unfold\n")
server.send(
"textDocument/didChange",
{"textDocument": {"uri": uri, "version": 2}, "contentChanges": [{"text": seq_text}]},
)
answer = server.send(
"textDocument/hover",
{"textDocument": {"uri": uri}, "position": position_of(seq_text, "(seq-unfold")},
request=True,
)
h = answer["result"]["contents"]["value"] if answer["result"] else None
expect(
"hover: a builtin's type and doc",
h and "(: seq-unfold (->" in h and "A sequence generated from a state, lazily." in h,
h,
)
server.diagnostics_after("textDocument/didClose", uri)
LOCALS = """(import (std prelude))
(: total (-> (List int) int int))
(defun (total xs (: bonus int))
(def base 10)
(let ((doubled (list-map (fun (x) (* 2 x)) xs))
(count 0))
(match doubled
((Cons first rest) (+ first bonus base count))
(Nil (loop (:for y xs)
(:acc sum (summing (+ y bonus)))
=> sum)))))
(: shadow (-> int int))
(defun (shadow v)
(let ((v (+ v 1)))
v))
(: typing (-> int int))
(defun (typing amount)
(let ((amplified (* amount 2)))
(+ am
"""
def locals_(server, tmp):
path = os.path.join(tmp, "locals.bjo")
uri = "file://" + path
with open(path, "w") as f:
f.write(LOCALS)
server.diagnostics_after("textDocument/didOpen", uri, LOCALS)
def ask(method, needle, offset=1, nth=0):
at = position_of(LOCALS, needle, nth, offset)
return server.send(method, {"textDocument": {"uri": uri}, "position": at}, request=True)["result"]
def goes_to(needle, target, target_offset, offset=1, nth=0):
d = ask("textDocument/definition", needle, offset, nth)
return d and d["range"]["start"] == position_of(LOCALS, target, 0, target_offset), d
cases = [
("a parameter", "bonus base", "(: bonus int)", 3),
("a def in the body", "base count", "(def base", 5),
("a let binding", "doubled\n", "(doubled (list-map", 1),
("a fun's parameter", "x)) xs", "(fun (x)", 6),
("a match pattern's variable", "first bonus", "(Cons first", 6),
("a loop variable, from its :acc", "y bonus", "(:for y", 6),
("an accumulator, from =>", "sum)))))", "(:acc sum", 6),
("the inner of two of a name", "v))\n", "((v (+ v 1)))", 2),
("the outer, in the inner's value", "v 1)", "(shadow v)", 8),
]
for name, needle, target, target_offset in cases:
ok, d = goes_to(needle, target, target_offset, 0)
expect("local definition: " + name, ok, d)
h = ask("textDocument/hover", "bonus base", 0)
h = h and h["contents"]["value"]
expect("local hover: a typed parameter shows its type", h and "(: bonus int)" in h and "A parameter of `total`" in h, h)
h = ask("textDocument/hover", "first bonus", 0)
h = h and h["contents"]["value"]
expect("local hover: a pattern shows the pattern", h and "(Cons first rest)" in h and "`match` pattern" in h, h)
# Completion while the form is being typed: the locals of `typing`, and
# nothing of `total`'s.
at = position_of(LOCALS, "(+ am", 0, 5)
items = server.send("textDocument/completion", {"textDocument": {"uri": uri}, "position": at}, request=True)["result"]["items"]
labels = {i["label"]: i for i in items}
expect(
"local completion: what is in scope, first",
labels.get("amount", {}).get("sortText", "").startswith("0")
and labels.get("amplified", {}).get("sortText", "").startswith("0"),
sorted((l, i["sortText"]) for l, i in labels.items())[:10],
)
expect("local completion: another function's locals are not", "doubled" not in labels and "bonus" not in labels, sorted(labels)[:10])
doc = labels.get("amplified", {}).get("documentation", {}).get("value", "")
expect("local completion: its doc comes along", "(amplified (* amount 2))" in doc, doc)
server.diagnostics_after("textDocument/didClose", uri)
CHAIN_MACROS = """;; Two macros, one expanding to the other.
(import (std syntax-match))
(def/macro (twice form inject compare)
(syntax-match form
((_ e) #'(both ,e ,e))))
(def/macro (both form inject compare)
(syntax-match form
((_ a b) #'(let ((tmp ,a)) (+ tmp ,b)))))
"""
CHAIN = """(import "chain-macros.bjo")
(: main (-> (Vec string) int))
(defun (main args)
(twice 21))
"""
def expanding(server, tmp):
with open(os.path.join(tmp, "chain-macros.bjo"), "w") as f:
f.write(CHAIN_MACROS)
path = os.path.join(tmp, "chain.bjo")
uri = "file://" + path
with open(path, "w") as f:
f.write(CHAIN)
found = server.diagnostics_after("textDocument/didOpen", uri, CHAIN)
expect("expansion: a file with an imported macro module checks", found == [], found)
expect(
"expansion: the import was built by the installed compiler",
os.path.exists(os.path.join(tmp, "chain-macros.dll")),
os.listdir(tmp),
)
def expand(needle, **flags):
at = position_of(CHAIN, needle, 0, 2)
answer = server.send(
"bjolang/expandMacro", dict(textDocument={"uri": uri}, position=at, **flags), request=True
)
return answer["result"]
r = expand("(twice", full=False)
expect("expansion: one step", r and r["macro"] == "twice" and r["text"] == "(both 21 21)", r)
r = expand("(twice")
expect("expansion: all the way", r and r["text"] == "(let ((tmp 21)) (+ tmp 21))", r)
r = expand("(twice", hygienic=True)
expect("expansion: hygienic names kept", r and "tmp__" in r["text"], r)
r = expand("(defun (main", full=False)
expect("expansion: none where there is no macro call", r is None, r)
# An unsaved change is expanded as it stands, without waiting for the pause.
changed = CHAIN.replace("(twice 21)", "(twice (twice 1))")
server.change(uri, changed, 2)
at = position_of(changed, "(twice (twice", 0, 2)
r = server.send("bjolang/expandMacro", {"textDocument": {"uri": uri}, "position": at}, request=True)["result"]
expect(
"expansion: of the buffer, nested calls expanded too",
r and r["text"].count("(+ tmp") == 3 and "twice" not in r["text"] and "both" not in r["text"],
r,
)
server.diagnostics_after("textDocument/didClose", uri)
with tempfile.TemporaryDirectory() as tmp:
path = os.path.join(tmp, "smoke.bjo")
uri = "file://" + path
server = Server()
answer = server.send("initialize", {"processId": None, "rootUri": None, "capabilities": {}}, request=True)
expect("initialize answers capabilities", "capabilities" in answer.get("result", {}), answer)
server.send("initialized")
with open(path, "w") as f:
f.write(BROKEN)
found = server.diagnostics_after("textDocument/didOpen", uri, BROKEN)
expect("a type error is reported", len(found) >= 1 and found[0]["severity"] == 1, found)
expect(
"on the line it is on",
any(d["range"]["start"]["line"] == 4 for d in found),
json.dumps(found, indent=1),
)
for d in found:
print(" ", d["range"]["start"], d["message"].splitlines()[0])
# Saved: the editor sends the change, writes the file, and says so.
server.change(uri, FIXED, 2)
with open(path, "w") as f:
f.write(FIXED)
found = server.diagnostics_after("textDocument/didSave", uri)
expect("the fixed file has none", found == [], json.dumps(found, indent=1))
# Not saved: the check follows the buffer once typing pauses, while the
# file on disk stays fixed.
server.change(uri, UNCLOSED, 3)
found = server.next_diagnostics(uri)
expect("a parse error in an unsaved buffer is reported", len(found) >= 1, found)
for d in found:
print(" ", d["range"]["start"], d["message"].splitlines()[0])
# A burst of typing is checked once, after it, not once per change.
for version in range(4, 9):
server.change(uri, FIXED if version % 2 else BROKEN, version)
found = server.next_diagnostics(uri)
expect("a burst is checked as its last text", len(found) >= 1, found)
import time
time.sleep(1.0)
server.send("textDocument/documentSymbol", {"textDocument": {"uri": uri}}, request=True)
expect("and only once", server.published(uri) == [], "more than one check published")
found = server.diagnostics_after("textDocument/didClose", uri)
expect("closing clears them", found == [], found)
symbols_and_definitions(server, tmp)
documented(server, tmp)
completing(server, tmp)
locals_(server, tmp)
expanding(server, tmp)
answer = server.send("shutdown", request=True)
expect("shutdown answers", "result" in answer, answer)
server.send("exit")
expect("exit ends the process with 0", server.proc.wait(timeout=10) == 0)
sys.exit(1 if failures else 0)