lsp-bjolang/Scope.fs

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