From a37678c2cf668b4837cdf5d147f4c2f26b2634e9 Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Sat, 3 Aug 2019 10:37:07 +0200 Subject: Added comments and extracted typeOf/getInfo into seperate module --- src/getinfo.sig | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 src/getinfo.sig (limited to 'src/getinfo.sig') diff --git a/src/getinfo.sig b/src/getinfo.sig new file mode 100644 index 00000000..317b7e79 --- /dev/null +++ b/src/getinfo.sig @@ -0,0 +1,31 @@ +(* Copyright (c) 2012, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature GET_INFO = sig + val getInfo: string (* file:row:col *) -> Print.PD.pp_desc +end + -- cgit v1.2.3 From 9b00dc724363ac7b0a31687f14cc3bb2f2460f9b Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 11 Dec 2019 22:56:29 +0100 Subject: Integrated getInfo into LSP --- src/getinfo.sig | 7 +- src/getinfo.sml | 353 ++++++++++++++++++++++++----------------------------- src/lsp.sml | 69 ++++++++++- src/main.mlton.sml | 6 - 4 files changed, 230 insertions(+), 205 deletions(-) (limited to 'src/getinfo.sig') diff --git a/src/getinfo.sig b/src/getinfo.sig index 317b7e79..334e19f1 100644 --- a/src/getinfo.sig +++ b/src/getinfo.sig @@ -26,6 +26,11 @@ *) signature GET_INFO = sig - val getInfo: string (* file:row:col *) -> Print.PD.pp_desc + val getInfo: + ElabEnv.env -> + Elab.str' -> + string (* fileName *) -> + { line: int , character: int} -> + Print.PD.pp_desc end diff --git a/src/getinfo.sml b/src/getinfo.sml index 37c50928..7925aba3 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -73,198 +73,163 @@ fun getSpan (f: item * E.env) = | Str s => #2 s | Decl d => #2 d -fun getInfo' file row col = - if not (!Elaborate.incremental) - then P.PD.string "ERROR: urweb daemon is needed to use typeOf command" - else - case ModDb.lookupModAndDepsIncludingErrored (Compiler.moduleOf file) of - NONE => P.PD.string ("ERROR: No module found: " ^ Compiler.moduleOf file) - | SOME (modDecl, deps) => - let - val () = U.mliftConInCon := E.mliftConInCon - - (* Adding signature of dependencies to environment *) - val env = List.foldl (fn (d, e) => E.declBinds e d) E.empty deps - - (* Adding previous declarations in file to environment *) - (* "open " statements are already translated during elaboration *) - (* They get added to the env here "unprefixed" *) - val env = - case #1 modDecl of - L.DStr (name, _, sgn, str) => - (case #1 str of - L.StrConst decls => - List.foldl (fn (d, env) => - if #line (#first (#2 d)) <= row - andalso #char (#first (#2 d)) <= col - then E.declBinds env d - else env) env decls - | _ => env) - | L.DFfiStr _ => env - | _ => env - - (* Basis and Top need to be added to the env explicitly *) - val env = - case ModDb.lookupModAndDepsIncludingErrored "Top" of - NONE => raise Fail "ERROR: Top module not found in ModDb" - | SOME ((L.DStr (_, top_n, topSgn, topStr), _), _) => - #2 (Elaborate.dopen env {str = top_n, strs = [], sgn = topSgn}) - | _ => raise Fail "ERROR: Impossible" - val env = - case ModDb.lookupModAndDepsIncludingErrored "Basis" of - NONE => raise Fail "ERROR: Top module not found in ModDb" - | SOME ((L.DFfiStr (_, basis_n, sgn), _), _) => - #2 (Elaborate.dopen env {str = basis_n, strs = [], sgn = sgn}) - | _ => raise Fail "ERROR: Impossible" - - (* Just use ElabPrint functions. *) - (* These are better for compiler error message, but it's better than nothing *) - fun printLiterally {span = span, item = item, env = env} = - P.box [ case item of - Kind k => P.box [P.PD.string "KIND: ", ElabPrint.p_kind env k] - | Con c => P.box [P.PD.string "CON: ", ElabPrint.p_con env c] - | Exp e => P.box [P.PD.string "EXP: ", ElabPrint.p_exp env e] - | Sgn_item si => P.box [P.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] - | Sgn s => P.box [P.PD.string "SGN: ", ElabPrint.p_sgn env s] - | Str s => P.box [P.PD.string "STR: ", ElabPrint.p_str env s] - | Decl d => P.box [P.PD.string "DECL: ", ElabPrint.p_decl env d] - ] - - (* TODO We lose some really useful information, like eg. inferred parameters, *) - (* which we do have in the actual items (L.Decl, L.Exp, etc) *) - (* but not when we do a lookup into the Env *) - (* TODO Rename? *) - fun printGoodPart env f span = - (case f of - Exp (L.EPrim p, _) => - SOME (P.box [Prim.p_t p, - P.PD.string ": ", - P.PD.string (case p of - Prim.Int _ => "int" - | Prim.Float _ => "float" - | Prim.String _ => "string" - | Prim.Char _ => "char")]) - | Exp (L.ERel n, _) => - SOME ((let val found = E.lookupERel env n - in - P.box [ P.PD.string (#1 found) - , P.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) - | Exp (L.ENamed n, _) => - SOME ((let val found = E.lookupENamed env n - in - P.box [ P.PD.string (#1 found) - , P.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle E.UnboundNamed _ => P.PD.string ("UNBOUND_NAMED" ^ Int.toString n)) - | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) - , ms (* names of submodules - possibly none *) - , x (* identifier *)), loc) => - SOME (let - val (m1name, m1sgn) = E.lookupStrNamed env m1 - val (str, sgn) = foldl (fn (m, (str, sgn)) => - case E.projectStr env {sgn = sgn, str = str, field = m} of - NONE => raise Fail ("Couldn't find Structure: " ^ m) - | SOME sgn => ((L.StrProj (str, m), loc), sgn)) - ((L.StrVar m1, loc), m1sgn) - ms - val t = case E.projectVal env {sgn = sgn, str = str, field = x} of - NONE => raise Fail ("Couldn't find identifier: " ^ x) - | SOME t => t - in - P.box [ P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) - , P.PD.string ": " - , ElabPrint.p_con env t - ] - end - handle E.UnboundNamed _ => P.PD.string ("Module not found: " ^ Int.toString m1)) - | Exp e => NONE - | Kind k => NONE - | Con c => NONE - | Sgn_item si => NONE - | Sgn s => NONE - | Str s => NONE - | Decl d => NONE) - - fun add env item span acc = - if not (isPosIn file row col span) - then - acc - else - let - val smallest = - if isSmallerThan span (#span (#smallest acc)) - then {span = span, item = item, env = env} - else #smallest acc - val smallestgoodpart = - case #smallestgoodpart acc of - NONE => - (case printGoodPart env item span of - NONE => NONE - | SOME desc => SOME (desc, span)) - | SOME (desc', span') => - if isSmallerThan span span' - then - (case printGoodPart env item span of - NONE => SOME (desc', span') - | SOME desc => SOME (desc, span)) - else SOME (desc', span') - in - {smallest = smallest, smallestgoodpart = smallestgoodpart} - end - - (* Look for item at input position *) - (* We're looking for two things simultaneously: *) - (* 1. The "smallest" part, ie. the one of which the source span is the smallest *) - (* 2. The "smallestgoodpart" part, ie. the one of which the source span is the smallest AND has a special case in printGoodPart *) - (* If we end up with a smallestgoodpart, we'll show that one since that one is probably more useful *) - (* TODO source spans of XML and SQL sources are weird and you end *) - (* up with eg: a span from eg 1-5 and another from 2-6, makes no sense? *) - (* That's one of the reasons why we're searching for the two things mentioned above *) - val result = - U.Decl.foldB - { kind = fn (env, (k, span), acc) => add env (Kind (k, span)) span acc, - con = fn (env, (k, span), acc) => add env (Con (k, span)) span acc, - exp = fn (env, (k, span), acc) => add env (Exp (k, span)) span acc, - sgn_item = fn (env, (k, span), acc) => add env (Sgn_item (k, span)) span acc, - sgn = fn (env, (k, span), acc) => add env (Sgn (k, span)) span acc, - str = fn (env, (k, span), acc) => add env (Str (k, span)) span acc, - decl = fn (env, (k, span), acc) => add env (Decl (k, span)) span acc, - bind = fn (env, binder) => - case binder of - U.Decl.RelK x => E.pushKRel env x - | U.Decl.RelC (x, k) => E.pushCRel env x k - | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co - | U.Decl.RelE (x, c) => E.pushERel env x c - | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) - | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) - | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) - } - env - { smallestgoodpart = NONE - , smallest = { item = Decl (#1 modDecl, { file = file - , first = { line = 0, char = 0} - , last = { line = 99999, char = 0} }) - , span = { file = file - , first = { line = 0, char = 0} - , last = { line = 99999, char = 0} } - , env = env } - } - modDecl - in - case #smallestgoodpart result of - NONE => printLiterally (#smallest result) - | SOME (desc, span) => desc - end - -fun getInfo loc = - case String.tokens (fn ch => ch = #":") loc of - file :: rowStr :: colStr :: nil => - (case (Int.fromString rowStr, Int.fromString colStr) of - (SOME row, SOME col) => getInfo' file row col - | _ => P.PD.string "ERROR: Wrong typeOf input format, should be ") - | _ => P.PD.string "ERROR: Wrong typeOf input format, should be " +fun getInfo env str fileName {line = row, character = col} = + let + val () = U.mliftConInCon := E.mliftConInCon + + (* Adding previous declarations in file to environment *) + (* "open " statements are already translated during elaboration *) + (* They get added to the env here "unprefixed" *) + val env = (case str of + L.StrConst decls => + List.foldl (fn (d, env) => + if #line (#first (#2 d)) <= row + andalso #char (#first (#2 d)) <= col + then E.declBinds env d + else env) env decls + | _ => env) + + (* Just use ElabPrint functions. *) + (* These are better for compiler error messages, but it's better than nothing *) + fun printLiterally {span = span, item = item, env = env} = + P.box [ case item of + Kind k => P.box [P.PD.string "KIND: ", ElabPrint.p_kind env k] + | Con c => P.box [P.PD.string "CON: ", ElabPrint.p_con env c] + | Exp e => P.box [P.PD.string "EXP: ", ElabPrint.p_exp env e] + | Sgn_item si => P.box [P.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] + | Sgn s => P.box [P.PD.string "SGN: ", ElabPrint.p_sgn env s] + | Str s => P.box [P.PD.string "STR: ", ElabPrint.p_str env s] + | Decl d => P.box [P.PD.string "DECL: ", ElabPrint.p_decl env d] + ] + + (* TODO We lose some really useful information, like eg. inferred parameters, *) + (* which we do have in the actual items (L.Decl, L.Exp, etc) *) + (* but not when we do a lookup into the Env *) + (* TODO Rename? *) + fun printGoodPart env f span = + (case f of + Exp (L.EPrim p, _) => + SOME (P.box [Prim.p_t p, + P.PD.string ": ", + P.PD.string (case p of + Prim.Int _ => "int" + | Prim.Float _ => "float" + | Prim.String _ => "string" + | Prim.Char _ => "char")]) + | Exp (L.ERel n, _) => + SOME ((let val found = E.lookupERel env n + in + P.box [ P.PD.string (#1 found) + , P.PD.string ": " + , ElabPrint.p_con env (#2 found)] + end) + handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) + | Exp (L.ENamed n, _) => + SOME ((let val found = E.lookupENamed env n + in + P.box [ P.PD.string (#1 found) + , P.PD.string ": " + , ElabPrint.p_con env (#2 found)] + end) + handle E.UnboundNamed _ => P.PD.string ("UNBOUND_NAMED" ^ Int.toString n)) + | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) + , ms (* names of submodules - possibly none *) + , x (* identifier *)), loc) => + SOME (let + val (m1name, m1sgn) = E.lookupStrNamed env m1 + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail ("Couldn't find Structure: " ^ m) + | SOME sgn => ((L.StrProj (str, m), loc), sgn)) + ((L.StrVar m1, loc), m1sgn) + ms + val t = case E.projectVal env {sgn = sgn, str = str, field = x} of + NONE => raise Fail ("Couldn't find identifier: " ^ x) + | SOME t => t + in + P.box [ P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) + , P.PD.string ": " + , ElabPrint.p_con env t + ] + end + handle E.UnboundNamed _ => P.PD.string ("Module not found: " ^ Int.toString m1)) + | Exp e => NONE + | Kind k => NONE + | Con c => NONE + | Sgn_item si => NONE + | Sgn s => NONE + | Str s => NONE + | Decl d => NONE) + + fun add env item span acc = + if not (isPosIn fileName row col span) + then + acc + else + let + val smallest = + if isSmallerThan span (#span (#smallest acc)) + then {span = span, item = item, env = env} + else #smallest acc + val smallestgoodpart = + case #smallestgoodpart acc of + NONE => + (case printGoodPart env item span of + NONE => NONE + | SOME desc => SOME (desc, span)) + | SOME (desc', span') => + if isSmallerThan span span' + then + (case printGoodPart env item span of + NONE => SOME (desc', span') + | SOME desc => SOME (desc, span)) + else SOME (desc', span') + in + {smallest = smallest, smallestgoodpart = smallestgoodpart} + end + + (* Look for item at input position *) + (* We're looking for two things simultaneously: *) + (* 1. The "smallest" part, ie. the one of which the source span is the smallest *) + (* 2. The "smallestgoodpart" part, ie. the one of which the source span is the smallest AND has a special case in printGoodPart *) + (* If we end up with a smallestgoodpart, we'll show that one since that one is probably more useful *) + (* TODO source spans of XML and SQL sources are weird and you end *) + (* up with eg: a span from eg 1-5 and another from 2-6, makes no sense? *) + (* That's one of the reasons why we're searching for the two things mentioned above *) + val result = + U.Decl.foldB + { kind = fn (env, (k, span), acc) => add env (Kind (k, span)) span acc, + con = fn (env, (k, span), acc) => add env (Con (k, span)) span acc, + exp = fn (env, (k, span), acc) => add env (Exp (k, span)) span acc, + sgn_item = fn (env, (k, span), acc) => add env (Sgn_item (k, span)) span acc, + sgn = fn (env, (k, span), acc) => add env (Sgn (k, span)) span acc, + str = fn (env, (k, span), acc) => add env (Str (k, span)) span acc, + decl = fn (env, (k, span), acc) => add env (Decl (k, span)) span acc, + bind = fn (env, binder) => + case binder of + U.Decl.RelK x => E.pushKRel env x + | U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co + | U.Decl.RelE (x, c) => E.pushERel env x c + | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) + | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) + | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) + } + env + { smallestgoodpart = NONE + , smallest = { item = Str (str, { file = fileName + , first = { line = 0, char = 0} + , last = { line = 99999, char = 0} }) + , span = { file = fileName + , first = { line = 0, char = 0} + , last = { line = 99999, char = 0} } + , env = env } + } + ( L.DStr (Compiler.moduleOf "fileName", 0, (L.SgnError, ErrorMsg.dummySpan), (str, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos})) + , {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) + in + case #smallestgoodpart result of + NONE => printLiterally (#smallest result) + | SOME (desc, span) => desc + end end diff --git a/src/lsp.sml b/src/lsp.sml index b5a92683..cfdec863 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -417,7 +417,8 @@ end structure SM = BinaryMapFn(SK) type fileState = - { decls : Elab.decl list } + { envBeforeThisModule: ElabEnv.env + , decls : Elab.decl list } type state = { urpPath : string , fileStates : fileState SM.map @@ -572,10 +573,17 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls (* Parsing of .ur succeeded *) let val loc = {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos} + val envBeforeThisModule = ref ElabEnv.empty val res = Elaborate.elabFile parsedBasisUrs tm1 parsedTopUr parsedTopUrs tm2 ElabEnv.empty (* Adding urs's of previous modules to env *) - (fn envB => List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envB parsedUrss) + (fn envB => + let + val newEnv = List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envB parsedUrss + in + (envBeforeThisModule := newEnv; newEnv) + end + ) [( Source.DStr (C.moduleOf fileName, parsedUrs, NONE, (Source.StrConst parsedUr, loc), false) , loc )] (* report back errors (as Diagnostics) *) @@ -584,7 +592,7 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls (Elab.DStr (_, _, _, (Elab.StrConst decls, _)), _) => decls | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") in - (SOME { decls = decls }, + (SOME { envBeforeThisModule = !envBeforeThisModule, decls = decls }, List.map errorToDiagnostic errors) end end @@ -605,6 +613,59 @@ fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res} end +fun scanDir (f: string -> bool) (path: string) = + let + val dir = OS.FileSys.openDir path + fun doScanDir acc = + case OS.FileSys.readDir dir of + NONE => (OS.FileSys.closeDir dir; acc) + | SOME fname => + (if f fname + then doScanDir (fname :: acc) + else doScanDir acc) + in + doScanDir [] + end + +fun readFile (fileName: string): string = + let + val str = TextIO.openIn fileName + fun doReadFile acc = + case TextIO.inputLine str of + NONE => acc + | SOME str => (str ^ "\n" ^ acc) + val res = doReadFile "" + in + (TextIO.closeIn str; res) + end + + +fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec.result = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => LspSpec.Success NONE + | SOME s => + let + val env = #envBeforeThisModule s + val decls = #decls s + val loc = #position p + val pp = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line loc + 1 + , character = #character loc + 1} + (* TODO I couldn't figure out how to print just to a string, so writing to a temp file, then reading it, then deleting it, ... *) + val tempfile = OS.FileSys.tmpName () + val outStr = TextIO.openOut tempfile + val outDev = TextIOPP.openOut {dst = outStr, wid = 70} + val () = Print.fprint outDev pp + val res = readFile tempfile + val () = TextIO.closeOut outStr + in + LspSpec.Success (SOME {contents = res}) + end + end + fun serverLoop () = let val requestMessage = @@ -653,7 +714,7 @@ fun serverLoop () = m { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn ctx => fn _ => LspSpec.Success NONE + , textDocument_hover = fn ctx => fn p => handleHover state p }) handle LspError e => handleLspErrorInRequest (#id m) e | ex => handleLspErrorInRequest (#id m) (InternalError (General.exnMessage ex))) diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 1747d702..9042307a 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -141,10 +141,6 @@ fun oneRun args = fun printModuleOf fname = print_and_exit (Compiler.moduleOf fname) () - fun getInfo loc = - (Print.print (GetInfo.getInfo loc); - raise Code OS.Process.success) - fun add_class (class, num) = case Int.fromString num of NONE => raise Fail ("Invalid limit number '" ^ num ^ "'") @@ -251,8 +247,6 @@ fun oneRun args = NONE), ("moduleOf", ONE ("", printModuleOf), SOME "print module name of and exit"), - ("getInfo", ONE ("", getInfo), - SOME "print info of expression at and exit"), ("startLspServer", ZERO Lsp.startServer, SOME "Start Language Server Protocol server"), ("noEmacs", set_true Demo.noEmacs, NONE), -- cgit v1.2.3 From faff2d8ac927fd49f13fbaf9b84ffc99bbb6f9b8 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Thu, 12 Dec 2019 22:44:50 +0100 Subject: Added tracking of text of source files and autocomplete --- derivation.nix | 4 +- shell.nix | 8 +- src/elab_env.sig | 4 + src/elab_env.sml | 9 +- src/elab_print.sig | 1 + src/getinfo.sig | 20 ++- src/getinfo.sml | 51 ++++--- src/json.sml | 11 +- src/lsp.sml | 399 +++++++++++++++++++++++++++++++++++++++++++++++------ 9 files changed, 438 insertions(+), 69 deletions(-) (limited to 'src/getinfo.sig') diff --git a/derivation.nix b/derivation.nix index f956a619..19582948 100644 --- a/derivation.nix +++ b/derivation.nix @@ -1,6 +1,6 @@ { stdenv, lib, fetchFromGitHub, file, openssl, mlton , mysql, postgresql, sqlite, gcc -, automake, autoconf, libtool, icu +, automake, autoconf, libtool, icu, nix-gitignore }: stdenv.mkDerivation rec { @@ -18,7 +18,7 @@ stdenv.mkDerivation rec { # rev = "e52ce9f542f64750941cfd84efdb6d993ee20ff0"; # sha256 = "19ba5n7g1dxy7q9949aakqplchsyzwrrnxv8v604vx5sg7fdfn3b"; # }; - src = ./.; + src = nix-gitignore.gitignoreSource [] ./.; buildInputs = [ openssl mlton mysql.connector-c postgresql sqlite automake autoconf libtool icu.dev openssl.dev]; diff --git a/shell.nix b/shell.nix index 95da550b..e9b047ee 100644 --- a/shell.nix +++ b/shell.nix @@ -1 +1,7 @@ -import ./default.nix +let + pkgs = import {}; + def = import ./default.nix; +in +pkgs.mkShell { + buildInputs = def.buildInputs; +} diff --git a/src/elab_env.sig b/src/elab_env.sig index 47b31c08..55909b53 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -85,6 +85,8 @@ signature ELAB_ENV = sig val pushENamedAs : env -> string -> int -> Elab.con -> env val lookupENamed : env -> int -> string * Elab.con val checkENamed : env -> int -> bool + val matchNamedEByPrefix: env -> string -> (string * Elab.con) list + val matchRelEByPrefix: env -> string -> (string * Elab.con) list val lookupE : env -> string -> Elab.con var @@ -100,6 +102,8 @@ signature ELAB_ENV = sig val lookupStrNamed : env -> int -> string * Elab.sgn val lookupStr : env -> string -> (int * Elab.sgn) option + val matchStrByPrefix: env -> string -> (string * (int * Elab.sgn)) list + val edeclBinds : env -> Elab.edecl -> env val declBinds : env -> Elab.decl -> env diff --git a/src/elab_env.sml b/src/elab_env.sml index a2097aa9..e79b665d 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -932,6 +932,12 @@ fun lookupENamed (env : env) n = NONE => raise UnboundNamed n | SOME x => x +fun matchNamedEByPrefix (env: env) (str: string) = + List.filter (fn (name,con) => String.isPrefix str name) (IM.listItems (#namedE env)) + +fun matchRelEByPrefix (env: env) (str: string) = + List.filter (fn (name,con) => String.isPrefix str name) (#relE env) + fun checkENamed (env : env) n = Option.isSome (IM.find (#namedE env, n)) @@ -985,7 +991,8 @@ fun lookupStrNamed (env : env) n = | SOME x => x fun lookupStr (env : env) x = SM.find (#renameStr env, x) - +fun matchStrByPrefix (env: env) prefix = + List.filter (fn (name,_) => String.isPrefix prefix name) (SM.listItemsi (#renameStr env)) fun sgiSeek (sgi, (sgns, strs, cons)) = case sgi of diff --git a/src/elab_print.sig b/src/elab_print.sig index 1eb832b3..84715b9d 100644 --- a/src/elab_print.sig +++ b/src/elab_print.sig @@ -38,6 +38,7 @@ signature ELAB_PRINT = sig val p_sgn : ElabEnv.env -> Elab.sgn Print.printer val p_str : ElabEnv.env -> Elab.str Print.printer val p_file : ElabEnv.env -> Elab.file Print.printer + val debug : bool ref end diff --git a/src/getinfo.sig b/src/getinfo.sig index 334e19f1..50eee70a 100644 --- a/src/getinfo.sig +++ b/src/getinfo.sig @@ -26,11 +26,29 @@ *) signature GET_INFO = sig + + datatype item = + Kind of Elab.kind + | Con of Elab.con + | Exp of Elab.exp + | Sgn_item of Elab.sgn_item + | Sgn of Elab.sgn + | Str of Elab.str + | Decl of Elab.decl + val getInfo: ElabEnv.env -> Elab.str' -> string (* fileName *) -> { line: int , character: int} -> - Print.PD.pp_desc + { smallest : { span : ErrorMsg.span + , item : item + , env : ElabEnv.env } + , smallestgoodpart : { span : ErrorMsg.span + , desc : Print.PD.pp_desc + , env : ElabEnv.env + , item : item + } option +} end diff --git a/src/getinfo.sml b/src/getinfo.sml index 7925aba3..1d657637 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -73,6 +73,19 @@ fun getSpan (f: item * E.env) = | Str s => #2 s | Decl d => #2 d +(* Just use ElabPrint functions. *) +(* These are better for compiler error messages, but it's better than nothing *) +fun printLiterally {span = span, item = item, env = env} = + P.box [ case item of + Kind k => P.box [P.PD.string "KIND: ", ElabPrint.p_kind env k] + | Con c => P.box [P.PD.string "CON: ", ElabPrint.p_con env c] + | Exp e => P.box [P.PD.string "EXP: ", ElabPrint.p_exp env e] + | Sgn_item si => P.box [P.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] + | Sgn s => P.box [P.PD.string "SGN: ", ElabPrint.p_sgn env s] + | Str s => P.box [P.PD.string "STR: ", ElabPrint.p_str env s] + | Decl d => P.box [P.PD.string "DECL: ", ElabPrint.p_decl env d] + ] + fun getInfo env str fileName {line = row, character = col} = let val () = U.mliftConInCon := E.mliftConInCon @@ -89,19 +102,6 @@ fun getInfo env str fileName {line = row, character = col} = else env) env decls | _ => env) - (* Just use ElabPrint functions. *) - (* These are better for compiler error messages, but it's better than nothing *) - fun printLiterally {span = span, item = item, env = env} = - P.box [ case item of - Kind k => P.box [P.PD.string "KIND: ", ElabPrint.p_kind env k] - | Con c => P.box [P.PD.string "CON: ", ElabPrint.p_con env c] - | Exp e => P.box [P.PD.string "EXP: ", ElabPrint.p_exp env e] - | Sgn_item si => P.box [P.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] - | Sgn s => P.box [P.PD.string "SGN: ", ElabPrint.p_sgn env s] - | Str s => P.box [P.PD.string "STR: ", ElabPrint.p_str env s] - | Decl d => P.box [P.PD.string "DECL: ", ElabPrint.p_decl env d] - ] - (* TODO We lose some really useful information, like eg. inferred parameters, *) (* which we do have in the actual items (L.Decl, L.Exp, etc) *) (* but not when we do a lookup into the Env *) @@ -161,7 +161,16 @@ fun getInfo env str fileName {line = row, character = col} = | Str s => NONE | Decl d => NONE) - fun add env item span acc = + fun add (env: ElabEnv.env) (item: item) (span: ErrorMsg.span) (acc: { smallest : { span : ErrorMsg.span + , item : item + , env : ElabEnv.env } + , smallestgoodpart : { span : ErrorMsg.span + , desc : P.PD.pp_desc + , env : ElabEnv.env + , item : item + } option + } + ) = if not (isPosIn fileName row col span) then acc @@ -176,14 +185,14 @@ fun getInfo env str fileName {line = row, character = col} = NONE => (case printGoodPart env item span of NONE => NONE - | SOME desc => SOME (desc, span)) - | SOME (desc', span') => + | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) + | SOME (prev as {desc = desc', span = span', env = env', item = item'}) => if isSmallerThan span span' then (case printGoodPart env item span of - NONE => SOME (desc', span') - | SOME desc => SOME (desc, span)) - else SOME (desc', span') + NONE => SOME prev + | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) + else SOME prev in {smallest = smallest, smallestgoodpart = smallestgoodpart} end @@ -228,8 +237,6 @@ fun getInfo env str fileName {line = row, character = col} = ( L.DStr (Compiler.moduleOf "fileName", 0, (L.SgnError, ErrorMsg.dummySpan), (str, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos})) , {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) in - case #smallestgoodpart result of - NONE => printLiterally (#smallest result) - | SOME (desc, span) => desc + result end end diff --git a/src/json.sml b/src/json.sml index 656d28ff..4f604cc4 100644 --- a/src/json.sml +++ b/src/json.sml @@ -113,13 +113,20 @@ struct and parseChars () = let + val escapedchars = ["n", "r", "b", "f", "t"] fun pickChars s = - if peek () = #"\"" (* " *) + if peek () = #"\"" (* " = end of string *) then s else if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"\"" then (consume "\\\""; pickChars (s ^ "\"")) - else pickChars (s ^ String.str (take ())) + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"n" + then (consume "\\n"; pickChars (s ^ "\n")) + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"r" + then (consume "\\r"; pickChars (s ^ "\r")) + else pickChars (s ^ String.str (take ())) in pickChars "" end diff --git a/src/lsp.sml b/src/lsp.sml index cfdec863..aaef422c 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -11,13 +11,17 @@ fun joinStr (sep: string) (strs: string list): string = List.foldl (fn (str, acc) => if acc = "" then str else acc ^ sep ^ str) "" strs structure FromJson = struct +fun getO (s: string) (l: Json.json): Json.json option = + case l of + Json.Obj pairs => + (case List.find (fn tup => #1 tup = s) pairs of + NONE => NONE + | SOME tup => SOME (#2 tup)) + | _ => raise Fail ("Expected JSON object, got: " ^ Json.print l) fun get (s: string) (l: Json.json): Json.json = - case l of - Json.Obj pairs => - (case List.find (fn tup => #1 tup = s) pairs of - NONE => raise Fail ("Failed to find JSON object key " ^ s ^ " in " ^ Json.print l) - | SOME tup => #2 tup) - | _ => raise Fail ("Expected JSON object, got: " ^ Json.print l) + (case getO s l of + NONE => raise Fail ("Failed to find JSON object key " ^ s ^ " in " ^ Json.print l) + | SOME a => a) fun asInt (j: Json.json): int = case j of @@ -161,6 +165,10 @@ structure LspSpec (* :> LSPSPEC *) = struct type range = { start: position , end_: position } + fun parseRange (j: Json.json): range = + { start = parsePosition (FromJson.get "start" j) + , end_ = parsePosition (FromJson.get "end" j) + } fun printRange (r: range): Json.json = Json.Obj [ ("start", printPosition (#start r)) , ("end", printPosition (#end_ r))] @@ -194,10 +202,23 @@ structure LspSpec (* :> LSPSPEC *) = struct fun parseDidOpenParams (params: Json.json): didOpenParams = { textDocument = parseTextDocumentItem (FromJson.get "textDocument" params) } - type didChangeParams = { textDocument: versionedTextDocumentIdentifier } + type contentChange = { range: range option + , rangeLength: int option + , text: string } + type didChangeParams = + { textDocument: versionedTextDocumentIdentifier + , contentChanges: contentChange list + } fun parseDidChangeParams (params: Json.json): didChangeParams = { textDocument = parseVersionedTextDocumentIdentifier (FromJson.get "textDocument" params) - (* , contentChanges = ... *) + , contentChanges = case FromJson.get "contentChanges" params of + Json.Array js => + List.map (fn j => { range = Option.map parseRange (FromJson.getO "range" j) + , rangeLength = Option.map FromJson.asInt (FromJson.getO "rangeLength" j) + , text = FromJson.asString (FromJson.get "text" j) + } + ) js + | j => raise Fail ("Expected JSON array, got: " ^ Json.print j) } type didSaveParams = { textDocument: textDocumentIdentifier } @@ -232,11 +253,77 @@ structure LspSpec (* :> LSPSPEC *) = struct fun printPublishDiagnosticsParams (p: publishDiagnosticsParams): Json.json = Json.Obj [ ("uri", Json.String (printDocumentUri (#uri p))) , ("diagnostics", Json.Array (List.map printDiagnostic (#diagnostics p)))] - + + type completionReq = + { textDocument: textDocumentIdentifier + , position: position + , context: { triggerCharacter: string option + , triggerKind: int (* 1 = Invoked = typing an identifier or manual invocation or API + 2 = TriggerCharacter + 3 = TriggerForIncompleteCompletions*)} option + } + fun parseCompletionReq (j: Json.json): completionReq = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" j) + , position = parsePosition (FromJson.get "position" j) + , context = case FromJson.getO "context" j of + NONE => NONE + | SOME ctx => SOME { triggerCharacter = Option.map FromJson.asString (FromJson.getO "triggerCharacter" ctx) + , triggerKind = FromJson.asInt (FromJson.get "triggerKind" ctx) + } + } + + datatype completionItemKind = Text | Method | Function | Constructor | Field | Variable | Class | Interface | Module | Property | Unit | Value | Enum | Keyword | Snippet | Color | File | Reference | Folder | EnumMember | Constant | Struct | Event | Operator | TypeParameter + fun completionItemKindToInt (a: completionItemKind) = + case a of + Text => 1 + | Method => 2 + | Function => 3 + | Constructor => 4 + | Field => 5 + | Variable => 6 + | Class => 7 + | Interface => 8 + | Module => 9 + | Property => 10 + | Unit => 11 + | Value => 12 + | Enum => 13 + | Keyword => 14 + | Snippet => 15 + | Color => 16 + | File => 17 + | Reference => 18 + | Folder => 19 + | EnumMember => 20 + | Constant => 21 + | Struct => 22 + | Event => 23 + | Operator => 24 + | TypeParameter => 25 + + type completionItem = { label: string + , kind: completionItemKind + , detail: string + } + type completionResp = { isIncomplete: bool + , items: completionItem list + } + + fun printCompletionItem (a: completionItem): Json.json = + Json.Obj [ ("label", Json.String (#label a)) + , ("kind", Json.Int (completionItemKindToInt (#kind a))) + , ("detail", Json.String (#detail a)) + ] + fun printCompletionResp (a: completionResp): Json.json = + Json.Obj [ ("isIncomplete", Json.Bool (#isIncomplete a)) + , (("items", Json.Array (List.map printCompletionItem (#items a))))] + type initializeResponse = { capabilities: { hoverProvider: bool + , completionProvider: {triggerCharacters: string list} option , textDocumentSync: { openClose: bool + , change: int (* 0 = None, 1 = Full, 2 = Incremental *) , save: { includeText: bool } option } }} @@ -246,11 +333,16 @@ structure LspSpec (* :> LSPSPEC *) = struct val capabilities = #capabilities res in Json.Obj [ ("hoverProvider", Json.Bool (#hoverProvider capabilities)) + , ("completionProvider", case #completionProvider capabilities of + NONE => Json.Null + | SOME cp => Json.Obj [("triggerCharacters", Json.Array (List.map Json.String (#triggerCharacters cp)))] + ) , ("textDocumentSync", let val textDocumentSync = #textDocumentSync capabilities in Json.Obj [ ("openClose", Json.Bool (#openClose textDocumentSync )) + , ("change", Json.Int (#change textDocumentSync)) , ("save", case #save textDocumentSync of NONE => Json.Null | SOME save => Json.Obj [("includeText", Json.Bool (#includeText save) )])] @@ -273,6 +365,7 @@ structure LspSpec (* :> LSPSPEC *) = struct { initialize: initializeParams -> initializeResponse result , shutdown: unit -> unit result , textDocument_hover: toclient -> hoverReq -> hoverResp result + , textDocument_completion: completionReq -> completionResp result } fun showMessage str typ = @@ -316,13 +409,19 @@ structure LspSpec (* :> LSPSPEC *) = struct ((#textDocument_hover handlers) toclient (parseHoverReq (#params requestMessage))) + | "textDocument/completion" => + mapResult + printCompletionResp + ((#textDocument_completion handlers) + (parseCompletionReq (#params requestMessage))) | "shutdown" => mapResult (fn () => Json.Null) ((#shutdown handlers) ()) | "exit" => OS.Process.exit OS.Process.success - | method => Error (~32601, "Method not supported: " ^ method) + | method => (debug ("Method not supported: " ^ method); + Error (~32601, "Method not supported: " ^ method)) (* val () = (TextIO.output (TextIO.stdErr, "Got result: " ^ (case result of Success _ => "success\n" *) (* | Error _ => "error\n")); TextIO.flushOut TextIO.stdErr) *) in @@ -418,13 +517,21 @@ structure SM = BinaryMapFn(SK) type fileState = { envBeforeThisModule: ElabEnv.env - , decls : Elab.decl list } + , decls: Elab.decl list + , text: string} type state = { urpPath : string , fileStates : fileState SM.map } val stateRef = ref (NONE: state option) +fun insertFileState (state: state) (fileName: string) (fs: fileState) = + stateRef := SOME { urpPath = #urpPath state + , fileStates = SM.insert ( #fileStates state + , fileName + , fs) + } + fun scanDir (f: string -> bool) (path: string) = let val dir = OS.FileSys.openDir path @@ -491,12 +598,12 @@ fun errorToDiagnostic (err: { span: ErrorMsg.span , message: string }): LspSpec. (* TODO FFI modules ? Check compiler.sml -> parse -> parseFfi *) (* TODO Optim: cache parsed urp file? *) -fun calculateFileState (state: state) (fileName: string): (fileState option * LspSpec.diagnostic list) = +fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBeforeThisModule: ElabEnv.env} option * LspSpec.diagnostic list) = let val () = if (OS.Path.ext fileName = SOME "ur") then () else raise Fail ("Can only handle .ur files for now") - val () = Elaborate.unifyMore := true + (* val () = Elaborate.unifyMore := true *) (* To reuse Basis and Top *) val () = Elaborate.incremental := true (* Parsing .urp *) @@ -597,20 +704,29 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls end end -fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) = +fun handleDocumentSavedOrOpened (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) (textO: string option) = let - val path = #path documentUri - val res = calculateFileState state path + val fileName = #path documentUri + val res = elabFile state fileName + val text = case textO of + NONE => (case SM.find (#fileStates state, fileName) of + NONE => ((#showMessage toclient) ("No previous state for file " ^ fileName) 2; NONE) + | SOME previousState => SOME (#text previousState)) + | SOME text => SOME text in - (case #1 res of - NONE => () - | SOME fs => - stateRef := SOME { urpPath = #urpPath state - , fileStates = SM.insert ( #fileStates state - , path - , fs) - }) ; - #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res} + case text of + NONE => () + | SOME text => + (case #1 res of + NONE => + insertFileState state fileName { text = text + , envBeforeThisModule = ElabEnv.empty + , decls = [] } + | SOME fs => + (insertFileState state fileName { text = text + , envBeforeThisModule = #envBeforeThisModule fs + , decls = #decls fs }); + #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res}) end fun scanDir (f: string -> bool) (path: string) = @@ -640,6 +756,19 @@ fun readFile (fileName: string): string = end +(* TODO I couldn't figure out how to print just to a string, so writing to a temp file, then reading it, then deleting it, ... *) +fun ppToString (pp: Print.PD.pp_desc) (width: int): string = + let + val tempfile = OS.FileSys.tmpName () + val outStr = TextIO.openOut tempfile + val outDev = TextIOPP.openOut {dst = outStr, wid = width} + val () = Print.fprint outDev pp + val res = readFile tempfile + val () = TextIO.closeOut outStr + in + res + end + fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec.result = let val fileName = #path (#uri (#textDocument p)) @@ -652,17 +781,203 @@ fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec. val env = #envBeforeThisModule s val decls = #decls s val loc = #position p - val pp = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line loc + 1 - , character = #character loc + 1} - (* TODO I couldn't figure out how to print just to a string, so writing to a temp file, then reading it, then deleting it, ... *) - val tempfile = OS.FileSys.tmpName () - val outStr = TextIO.openOut tempfile - val outDev = TextIOPP.openOut {dst = outStr, wid = 70} - val () = Print.fprint outDev pp - val res = readFile tempfile - val () = TextIO.closeOut outStr + val result = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line loc + 1 + , character = #character loc + 1} + in + case #smallestgoodpart result of + NONE => LspSpec.Success NONE + | SOME {desc = desc, ...} => + LspSpec.Success (SOME {contents = ppToString desc 70}) + end + end + +fun getCompletionsFromFields (env: ElabEnv.env) (prefix: string) (searchStr: string) (fields: (Elab.con * Elab.con) list): LspSpec.completionItem list = + let + fun mapF (c1, c2) = + case c1 of + (Elab.CName fieldName, _) => + if String.isPrefix searchStr fieldName + then SOME { label = prefix ^ fieldName + , kind = LspSpec.Field + , detail = ppToString (ElabPrint.p_con env c2) 150 + } + else NONE + | _ => NONE + in + List.mapPartial mapF fields + end + +fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (searchStr: string) (items: Elab.sgn_item list): LspSpec.completionItem list = + let + fun mapF item = + case item of + (Elab.SgiVal (name, _, con), _) => + if String.isPrefix searchStr name + then [{ label = prefix ^ name + , kind = LspSpec.Value + , detail = ppToString (ElabPrint.p_con env con) 150 + }] + else [] + | (Elab.SgiCon (name, _, _, con), _) => + if String.isPrefix searchStr name + then [{ label = prefix ^ name + , kind = LspSpec.Variable + , detail = ppToString (ElabPrint.p_con env con) 150 + }] + else [] + | (Elab.SgiDatatype cs, _) => + (List.concat + (List.map (fn (constr as (dtName, n, xs, constrs)) => + (* Copied from elab_print *) + let + val k = (Elab.KType, ErrorMsg.dummySpan) + val env = ElabEnv.pushCNamedAs env dtName n k NONE + val env = List.foldl (fn (x, env) => ElabEnv.pushCRel env dtName k) env xs + in + List.mapPartial (fn (constrName, _, conO) => + if String.isPrefix searchStr constrName + then SOME { label = prefix ^ constrName + , kind = LspSpec.Function + , detail = case conO of + NONE => "Datatype " ^ dtName + | SOME con => "Datatype " ^ dtName ^ " - " ^ ppToString (ElabPrint.p_con env con) 150 + } + else NONE) constrs + end) + cs)) + | (Elab.SgiDatatypeImp _, _) => + (* TODO ??? no idea what this is *) + [] + | (Elab.SgiStr (_, name, _, _), _) => + if String.isPrefix searchStr name + then [{ label = prefix ^ name + , kind = LspSpec.Module + , detail = "" + }] + else [] + | (Elab.SgiClass (name, _, _, con), _) => + if String.isPrefix searchStr name + then [{ label = prefix ^ name + , kind = LspSpec.Class + , detail = ppToString (ElabPrint.p_con env con) 150 + }] + else [] + | _ => [] + in + List.concat (List.map mapF items) + end + +fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completionItem list = + let + val splitted = Substring.fields (fn c => c = #".") (Substring.full str) + in + case splitted of + (_ :: []) => + if str = "" + then [] + else (List.map (fn (name,con) => + { label = name + , kind = LspSpec.Variable + , detail = ppToString (ElabPrint.p_con env con) 150 + }) + (ElabEnv.matchRelEByPrefix env str + @ ElabEnv.matchNamedEByPrefix env str)) + | (r :: str :: []) => + if Char.isUpper (Substring.sub (r, 0)) + then (* r should be a structure *) + let + (* TODO Perf: first match and then equal is not perfect *) + val foundStrs = ElabEnv.matchStrByPrefix env (Substring.string r) + val filteredStrs = List.filter (fn (name,_) => name = Substring.string r) foundStrs + in + (case List.map (fn (name, (i, sgn)) => (name, ElabEnv.hnormSgn env sgn)) filteredStrs of + [] => [] + | (name, (Elab.SgnConst sgis, _)) :: _ => + getCompletionsFromSignatureItems env (name ^ ".") (Substring.string str) sgis + | _ => []) + end + else (* r should be a record *) + (* TODO is it correct to first try RelE and then NamedE? *) + let + (* TODO Perf: first match and then equal is not perfect *) + val foundRelEs = ElabEnv.matchRelEByPrefix env (Substring.string r) + val foundNamedEs = ElabEnv.matchNamedEByPrefix env (Substring.string r) + val filteredEs = List.filter (fn (name,_) => name = Substring.string r) (foundRelEs @ foundNamedEs) + in + (case List.map (fn (name, c) => (name, ElabOps.reduceCon env c)) filteredEs of + [] => [] + | (name, (Elab.TRecord (Elab.CRecord (_, fields), _), _)) :: _ => + getCompletionsFromFields env (name ^ ".") (Substring.string str) fields + | _ => []) + end + | _ => [] + end + +(* TODO can we use the real parser to figure out what we're typing (exp, con, field, etc) to predict better? *) +fun handleCompletion (state: state) (p: LspSpec.completionReq) = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => LspSpec.Success { isIncomplete = false, items = []} + | SOME s => + let + val pos = #position p + val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full (#text s)), #line pos) + val () = debug ("line" ^ Substring.string line) + val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":" + , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] + val lineUntilPos = Substring.slice (line, 0, SOME (#character pos)) + val () = debug ("lineUntilPos: \"" ^ Substring.string lineUntilPos ^ "\"") + val searchStr = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilPos) + val () = debug ("Looking for completions for: \"" ^ searchStr ^ "\"") + val env = #envBeforeThisModule s + val decls = #decls s + val getInfoRes = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line pos + 1 + , character = #character pos + 1} + val envOfSmallest = #env (#smallest getInfoRes) + in + LspSpec.Success { isIncomplete = false + , items = findMatchingStringInEnv envOfSmallest searchStr} + end + end + +fun applyContentChange ((c, s): LspSpec.contentChange * string): string = + case (#range c, #rangeLength c) of + (SOME range, SOME _) => + let + val lines = Substring.fields (fn c => c = #"\n") (Substring.full s) + val linesBefore = List.take (lines, #line (#start range)) + val linesAfter = List.drop (lines, #line (#end_ range) + 1) + val startLine = List.nth (lines, #line (#start range)) + val startText = Substring.slice (startLine, 0, SOME (#character (#start range))) + val endLine = List.nth (lines, #line (#end_ range)) + val endText = Substring.triml (#character (#end_ range)) endLine + in + Substring.concatWith "\n" (linesBefore + @ [Substring.full (Substring.concat [startText, Substring.full (#text c), endText])] + @ linesAfter) + end + | _ => + #text c + +fun handleDocumentDidChange (state: state) (toclient: LspSpec.toclient) (p: LspSpec.didChangeParams): unit = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => + (debug ("Got change event for file that isn't open: " ^ fileName); + (#showMessage toclient) ("Got change event for file that isn't open: " ^ fileName) 1) + | SOME s => + let + val newtext = List.foldl applyContentChange (#text s) (#contentChanges p) in - LspSpec.Success (SOME {contents = res}) + insertFileState state fileName { text = newtext + , decls = #decls s + , envBeforeThisModule = #envBeforeThisModule s} end end @@ -686,14 +1001,17 @@ fun serverLoop () = LspSpec.Success { capabilities = { hoverProvider = true + , completionProvider = SOME { triggerCharacters = ["."]} , textDocumentSync = { openClose = true + , change = 2 , save = SOME { includeText = false } }} } end) handle (Fail str) => LspSpec.Error (~32602, str) , shutdown = fn () => LspSpec.Error (~32002, "Server not initialized") - , textDocument_hover = fn ctx => fn _ => LspSpec.Error (~32002, "Server not initialized") + , textDocument_hover = fn toclient => fn _ => LspSpec.Error (~32002, "Server not initialized") + , textDocument_completion = fn _ => LspSpec.Error (~32002, "Server not initialized") } | LspSpec.Notification n => ()) | SOME state => @@ -702,9 +1020,9 @@ fun serverLoop () = ((LspSpec.handleNotification n { initialized = fn () => () - , textDocument_didOpen = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) - , textDocument_didChange = fn ctx => fn didChangeParams => () - , textDocument_didSave = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) + , textDocument_didOpen = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) (SOME (#text (#textDocument p))) + , textDocument_didChange = handleDocumentDidChange state + , textDocument_didSave = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) NONE }) handle LspError e => handleLspErrorInNotification e | ex => handleLspErrorInNotification (InternalError (General.exnMessage ex))) @@ -714,7 +1032,8 @@ fun serverLoop () = m { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn ctx => fn p => handleHover state p + , textDocument_hover = fn toclient => handleHover state + , textDocument_completion = handleCompletion state }) handle LspError e => handleLspErrorInRequest (#id m) e | ex => handleLspErrorInRequest (#id m) (InternalError (General.exnMessage ex))) -- cgit v1.2.3 From ce6bae891c6d1e22e61a1fb54ce3ecd08ca31891 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 10 Jan 2020 02:25:45 +0100 Subject: Refactor to do all matching on strings, more precise and faster --- src/elab_env.sig | 6 +- src/elab_env.sml | 28 ++- src/getinfo.sig | 34 ++-- src/getinfo.sml | 511 ++++++++++++++++++++++--------------------------------- src/lsp.sml | 229 ++++++------------------- 5 files changed, 291 insertions(+), 517 deletions(-) (limited to 'src/getinfo.sig') diff --git a/src/elab_env.sig b/src/elab_env.sig index fb95d68e..4f994221 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -61,7 +61,6 @@ signature ELAB_ENV = sig val lookupCNamed : env -> int -> string * Elab.kind * Elab.con option val lookupC : env -> string -> Elab.kind var - val matchCByPrefix: env -> string -> (string * Elab.kind) list val pushDatatype : env -> int -> string list -> (string * int * Elab.con option) list -> env type datatyp @@ -86,7 +85,6 @@ signature ELAB_ENV = sig val pushENamedAs : env -> string -> int -> Elab.con -> env val lookupENamed : env -> int -> string * Elab.con val checkENamed : env -> int -> bool - val matchEByPrefix: env -> string -> (string * Elab.con) list val lookupE : env -> string -> Elab.con var @@ -102,8 +100,10 @@ signature ELAB_ENV = sig val lookupStrNamed : env -> int -> string * Elab.sgn val lookupStr : env -> string -> (int * Elab.sgn) option - val matchStrByPrefix: env -> string -> (string * (int * Elab.sgn)) list + val dumpCs: env -> (string * Elab.kind) list + val dumpEs: env -> (string * Elab.con) list + val dumpStrs: env -> (string * (int * Elab.sgn)) list val edeclBinds : env -> Elab.edecl -> env val declBinds : env -> Elab.decl -> env diff --git a/src/elab_env.sml b/src/elab_env.sml index f492bc94..5fa32cd2 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -404,14 +404,6 @@ fun lookupC (env : env) x = | SOME (Rel' x) => Rel x | SOME (Named' x) => Named x -fun matchCByPrefix (env: env) (prefix: string): (string * kind) list = - List.mapPartial (fn (name, value) => if String.isPrefix prefix name - then case value of - Rel' (_, x) => SOME (name, x) - | Named' (_, x) => SOME (name, x) - else NONE) - (SM.listItemsi (#renameC env)) - fun pushDatatype (env : env) n xs xncs = let val dk = U.classifyDatatype xncs @@ -940,13 +932,6 @@ fun lookupENamed (env : env) n = NONE => raise UnboundNamed n | SOME x => x -(* TODO Why does this work better than using #renameE? *) -fun matchEByPrefix (env: env) (prefix: string): (string * con) list = - List.mapPartial (fn (name, value) => if String.isPrefix prefix name - then SOME (name, value) - else NONE) - (#relE env @ IM.listItems (#namedE env)) - fun checkENamed (env : env) n = Option.isSome (IM.find (#namedE env, n)) @@ -1000,8 +985,17 @@ fun lookupStrNamed (env : env) n = | SOME x => x fun lookupStr (env : env) x = SM.find (#renameStr env, x) -fun matchStrByPrefix (env: env) prefix = - List.filter (fn (name,_) => String.isPrefix prefix name) (SM.listItemsi (#renameStr env)) + +fun dumpCs (env: env): (string * kind) list = + List.map (fn (name, value) => case value of + Rel' (_, x) => (name, x) + | Named' (_, x) => (name, x)) + (SM.listItemsi (#renameC env)) +(* TODO try again with #renameE *) +fun dumpEs (env: env): (string * con) list = + #relE env @ IM.listItems (#namedE env) +fun dumpStrs (env: env) = + SM.listItemsi (#renameStr env) fun sgiSeek (sgi, (sgns, strs, cons)) = case sgi of diff --git a/src/getinfo.sig b/src/getinfo.sig index 50eee70a..663a9a81 100644 --- a/src/getinfo.sig +++ b/src/getinfo.sig @@ -27,28 +27,24 @@ signature GET_INFO = sig - datatype item = - Kind of Elab.kind - | Con of Elab.con - | Exp of Elab.exp - | Sgn_item of Elab.sgn_item - | Sgn of Elab.sgn - | Str of Elab.str - | Decl of Elab.decl + datatype foundInEnv = FoundStr of (string * Elab.sgn) + | FoundCon of (string * Elab.kind) + | FoundExp of (string * Elab.con) - val getInfo: + val findStringInEnv: ElabEnv.env -> Elab.str' -> string (* fileName *) -> - { line: int , character: int} -> - { smallest : { span : ErrorMsg.span - , item : item - , env : ElabEnv.env } - , smallestgoodpart : { span : ErrorMsg.span - , desc : Print.PD.pp_desc - , env : ElabEnv.env - , item : item - } option -} + {line: int, char: int} -> + string (* query *) -> + (ElabEnv.env * string (* prefix *) * foundInEnv option) + + val matchStringInEnv: + ElabEnv.env -> + Elab.str' -> + string (* fileName *) -> + {line: int, char: int} -> + string (* query *) -> + (ElabEnv.env * string (* prefix *) * foundInEnv list) end diff --git a/src/getinfo.sml b/src/getinfo.sml index 5a0fe752..f18d0638 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -30,21 +30,19 @@ structure GetInfo :> GET_INFO = struct structure U = ElabUtilPos structure E = ElabEnv structure L = Elab -structure P = Print -fun isPosIn (file: string) (row: int) (col: int) (span: ErrorMsg.span) = +fun isPosIn (file: string) (line: int) (char: int) (span: ErrorMsg.span) = let val start = #first span val end_ = #last span in OS.Path.base file = OS.Path.base (#file span) andalso - (#line start < row orelse - #line start = row andalso #char start <= col) + (#line start < line orelse + #line start = line andalso #char start <= char) andalso - (#line end_ > row orelse - #line end_ = row andalso #char end_ >= col) - + (#line end_ > line orelse + #line end_ = line andalso #char end_ >= char) end fun isSmallerThan (s1: ErrorMsg.span) (s2: ErrorMsg.span) = @@ -63,8 +61,8 @@ datatype item = | Str of L.str | Decl of L.decl -fun getSpan (f: item * E.env) = - case #1 f of +fun getSpan (f: item) = + case f of Kind k => #2 k | Con c => #2 c | Exp e => #2 e @@ -73,310 +71,215 @@ fun getSpan (f: item * E.env) = | Str s => #2 s | Decl d => #2 d -(* Just use ElabPrint functions. *) -(* These are better for compiler error messages, but it's better than nothing *) -fun printLiterally {span = span, item = item, env = env} = - P.box [ case item of - Kind k => P.box [P.PD.string "KIND: ", ElabPrint.p_kind env k] - | Con c => P.box [P.PD.string "CON: ", ElabPrint.p_con env c] - | Exp e => P.box [P.PD.string "EXP: ", ElabPrint.p_exp env e] - | Sgn_item si => P.box [P.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] - | Sgn s => P.box [P.PD.string "SGN: ", ElabPrint.p_sgn env s] - | Str s => P.box [P.PD.string "STR: ", ElabPrint.p_str env s] - | Decl d => P.box [P.PD.string "DECL: ", ElabPrint.p_decl env d] - ] -fun getInfo env str fileName {line = row, character = col} = +fun findInStr (f: ElabEnv.env -> item (* curr *) -> item (* prev *) -> bool) + (init: item) + env str fileName {line = line, char = char}: {item: item, env: ElabEnv.env} = let val () = U.mliftConInCon := E.mliftConInCon + val {env: ElabEnv.env, found: Elab.decl option} = + (case str of + L.StrConst decls => + List.foldl (fn (d, acc as {env, found}) => + if #line (#last (#2 d)) < line + then {env = E.declBinds env d, found = found} + else + if #line (#first (#2 d)) <= line andalso line <= #line (#last (#2 d)) + then {env = env, found = SOME d} + else {env = env, found = found}) + {env = env, found = NONE} decls + | _ => { env = env, found = NONE }) + val dummyResult = (init, env) + val result = + case found of + NONE => dummyResult + | SOME d => + U.Decl.foldB + { kind = fn (env, i, acc as (prev, env')) => if f env (Kind i) prev then (Kind i, env) else acc, + con = fn (env, i, acc as (prev, env')) => if f env (Con i) prev then (Con i, env) else acc, + exp = fn (env, i, acc as (prev, env')) => if f env (Exp i) prev then (Exp i, env) else acc, + sgn_item = fn (env, i, acc as (prev, env')) => if f env (Sgn_item i) prev then (Sgn_item i, env) else acc, + sgn = fn (env, i, acc as (prev, env')) => if f env (Sgn i) prev then (Sgn i, env) else acc, + str = fn (env, i, acc as (prev, env')) => if f env (Str i) prev then (Str i, env) else acc, + decl = fn (env, i, acc as (prev, env')) => if f env (Decl i) prev then (Decl i, env) else acc, + bind = fn (env, binder) => + case binder of + U.Decl.RelK x => E.pushKRel env x + | U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co + | U.Decl.RelE (x, c) => E.pushERel env x c + | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) + | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) + | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) + } + env dummyResult d + in + {item = #1 result, env = #2 result} + end - (* Adding previous declarations in file to environment *) - (* "open " statements are already translated during elaboration *) - (* They get added to the env here "unprefixed" *) - val env = (case str of - L.StrConst decls => - List.foldl (fn (d, env) => - if #line (#first (#2 d)) <= row - andalso #char (#first (#2 d)) <= col - then E.declBinds env d - else env) env decls - | _ => env) +fun findSmallestSpan env str fileName {line = line, char = char} = + let + fun fitsAndIsSmaller (env: ElabEnv.env) (curr: item) (prev: item) = + isPosIn fileName line char (getSpan curr) andalso isSmallerThan (getSpan curr) (getSpan prev) + val init = Str (str, { file = fileName + , first = { line = 0, char = 0} + , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} }) + in + findInStr fitsAndIsSmaller init env str fileName {line = line, char = char} + end - (* This isn't very precise since we use the span of the parent exp/decl/etc *) - (* to find the "smallest part" *) - fun printPat env (pat: L.pat) = - if isPosIn fileName row col (#2 pat) - then - case #1 pat of - L.PVar (str, c) => SOME (P.box [ P.PD.string str - , P.PD.string " : " - , ElabPrint.p_con env c]) - | L.PCon (_, _, _, SOME p) => printPat env p - | L.PRecord fields => (case List.mapPartial (fn field => printPat env (#2 field)) fields of - [] => NONE - | first :: _ => SOME first) - | _ => NONE - else NONE +fun findFirstExpAfter env str fileName {line = line, char = char} = + let + fun currIsAfterPosAndBeforePrev (env: ElabEnv.env) (curr: item) (prev: item) = + (* curr is an exp *) + (case curr of Exp _ => true | _ => false) + andalso + (* curr is after input pos *) + ( line < #line (#first (getSpan curr)) + orelse ( line = #line (#first (getSpan curr)) + andalso char < #char (#first (getSpan curr)))) + andalso + (* curr is before prev *) + (#line (#first (getSpan curr)) < #line (#first (getSpan prev)) + orelse + (#line (#first (getSpan curr)) = #line (#first (getSpan prev)) + andalso #char (#first (getSpan curr)) < #char (#first (getSpan prev)))) + val init = Exp (Elab.EPrim (Prim.Int 0), + { file = fileName + , first = { line = Option.getOpt (Int.maxInt, 99999), char = Option.getOpt (Int.maxInt, 99999)} + , last = { line = Option.getOpt (Int.maxInt, 99999), char = Option.getOpt (Int.maxInt, 99999)} }) + in + findInStr currIsAfterPosAndBeforePrev init env str fileName {line = line, char = char} + end - fun isXmlTag env c = - case c of - L.CApp - ((L.CApp - ((L.CApp - (( L.CApp - (( L.CApp - ((L.CNamed n, _) , _) - , _) - , _) - , _) - , _) - , _) - , _) - , _) - , _) => - (case E.lookupCNamed env n of - ("tag", _, _) => true - | _ => false) - | _ => false - fun formatTypeBox (a: P.PD.pp_desc, b: P.PD.pp_desc) = - P.PD.hvBox (P.PD.PPS.Rel 0, [a, - P.PD.string ": ", - P.PD.break {nsp = 0, offset = 2}, - b]) - - (* TODO We lose some really useful information, like eg. inferred parameters, *) - (* which we do have in the actual items (L.Decl, L.Exp, etc) *) - (* but not when we do a lookup into the Env *) - (* TODO Rename? *) - fun printGoodPart env f span = - (case f of - Exp (L.EPrim p, _) => - let - val rendered = formatTypeBox ( Prim.p_t p - , P.PD.string (case p of - Prim.Int _ => "int" - | Prim.Float _ => "float" - | Prim.String _ => "string" - | Prim.Char _ => "char")) - in - case p of - Prim.String (_, str) => - if Substring.foldl (fn (c, acc) => acc andalso c = #" ") true (Substring.full str) - then NONE - else SOME rendered - | _ => SOME (rendered) - end - | Exp (L.ERel n, _) => - SOME ((let val found = E.lookupERel env n - in - formatTypeBox ( P.PD.string (#1 found) - , ElabPrint.p_con env (#2 found)) - end) - handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) - | Exp (L.ENamed n, span) => - ((let - val found = E.lookupENamed env n - val rendered = formatTypeBox ( P.PD.string (#1 found) - , ElabPrint.p_con env (#2 found)) - (* val () = if #1 found = "body" *) - (* then Print.eprint (ElabPrint.p_con env (#2 found)) *) - (* else () *) - in - (* case #2 found of *) - (* (L.TFun ((L.CUnit, _), (c, _)), _) => *) - (* (if isXmlTag env c *) - (* then SOME (P.box [ P.PD.string "<" *) - (* , P.PD.string ( #1 found) *) - (* , P.PD.string ">" *) - (* ]) *) - (* else SOME rendered) *) - (* | _ => *) SOME rendered - end) - handle E.UnboundNamed _ => SOME (P.PD.string ("UNBOUND_NAMED" ^ Int.toString n))) - | Exp (L.EAbs (varName, domain, _, _), _) => - if isPosIn fileName row col (#2 domain) - then - SOME (formatTypeBox ( P.PD.string varName - , ElabPrint.p_con env domain) - ) - else NONE - | Exp (L.EField (e, c, {field, ...}), loc) => - SOME (formatTypeBox ( P.box [ElabPrint.p_exp env e, - P.PD.string ".", - ElabPrint.p_con env c] - , ElabPrint.p_con env field)) - | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) - , ms (* names of submodules - possibly none *) - , x (* identifier *)), loc) => - (let - val (m1name, m1sgn) = E.lookupStrNamed env m1 - val (str, sgn) = foldl (fn (m, (str, sgn)) => - case E.projectStr env {sgn = sgn, str = str, field = m} of - NONE => raise Fail ("Couldn't find Structure: " ^ m) - | SOME sgn => ((L.StrProj (str, m), loc), sgn)) - ((L.StrVar m1, loc), m1sgn) - ms - val t = case E.projectVal env {sgn = sgn, str = str, field = x} of - NONE => raise Fail ("Couldn't find identifier: " ^ x) - | SOME t => t - in - case (m1name, x) of - (* Stripping these because XML desugaring adds these with small spans and crowd out the stuff you want to see *) - ("Basis", "cdata") => NONE - | ("Top", "txt") => NONE - | ("Basis", "join") => NONE - | ("Basis", "bind") => NONE - | ("Basis", "sql_subset") => NONE - | ("Basis", "sql_subset_all") => NONE - | ("Basis", "sql_query") => NONE - | ("Basis", "sql_query1") => NONE - | ("Basis", "sql_eq") => NONE - | ("Basis", "sql_inner_join") => NONE - (* | ("Basis", "sql_field") => NONE *) - | ("Basis", "sql_binary") => NONE - | _ => - SOME (formatTypeBox ( P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) - , ElabPrint.p_con env t)) - end - handle E.UnboundNamed _ => SOME (P.PD.string ("Module not found: " ^ Int.toString m1))) - | Exp (L.ELet (edecls, _, _), _) => - let - val found = List.mapPartial - (fn (edecl, loc) => - if isPosIn fileName row col loc - then - case edecl of - L.EDVal (pat, _, _) => printPat env pat - | L.EDValRec ((x, c, _) :: _) => - SOME (formatTypeBox ( P.PD.string x - , ElabPrint.p_con env c)) - | _ => NONE - else NONE) - edecls - in - if List.length found > 0 - then SOME (List.hd found) - else NONE - end - | Exp (L.ECase (_, pats, _), _) => - (case List.find (fn ((pat', loc), exp) => isPosIn fileName row col loc) pats of - NONE => NONE - | SOME (pat, _) => printPat env pat) - | Exp e => NONE - | Kind k => NONE - | Con c => NONE - | Sgn_item si => NONE - | Sgn s => NONE - | Str s => NONE - | Decl (L.DVal (x, _, con, _), _) => - SOME (formatTypeBox ( P.PD.string x - , ElabPrint.p_con env con )) - | Decl (L.DValRec decls, _) => - (* valrecs don't have nice spans per declaration so we find the *) - (* declaration for which the con starts closest *) - let - val res = - List.foldl (fn (decl, accO) => - let - val distanceFromRow = Int.abs (#line (#first (#2 (#3 decl))) - row) - val accDistanceFromRow = case accO of - NONE => Option.getOpt (Int.maxInt, 99999) - | SOME acc => Int.abs (#line (#first (#2 (#3 acc))) - row) - in - if distanceFromRow < accDistanceFromRow andalso distanceFromRow <= 1 - then SOME decl - else accO - end) - NONE - decls - in - case res of - NONE => NONE - | SOME (x, _, con, _) => - SOME (formatTypeBox ( P.PD.string x - , ElabPrint.p_con env con)) - end - | Decl d => NONE - ) +datatype foundInEnv = FoundStr of (string * Elab.sgn) + | FoundCon of (string * Elab.kind) + | FoundExp of (string * Elab.con) - fun add (env: ElabEnv.env) (item: item) (span: ErrorMsg.span) (acc: { smallest : { span : ErrorMsg.span - , item : item - , env : ElabEnv.env } - , smallestgoodpart : { span : ErrorMsg.span - , desc : P.PD.pp_desc - , env : ElabEnv.env - , item : item - } option - } - ) = - if not (isPosIn fileName row col span) - then - acc - else - let - val smallest = - if isSmallerThan span (#span (#smallest acc)) - then {span = span, item = item, env = env} - else #smallest acc - val smallestgoodpart = - case #smallestgoodpart acc of - NONE => - (case printGoodPart env item span of - NONE => NONE - | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) - | SOME (prev as {desc = desc', span = span', env = env', item = item'}) => - if - isSmallerThan span span' - then - (case printGoodPart env item span of - NONE => SOME prev - | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) - else SOME prev - in - {smallest = smallest, smallestgoodpart = smallestgoodpart} - end +fun getNameOfFoundInEnv (f: foundInEnv) = + case f of + FoundStr (x, _) => x + | FoundCon (x, _) => x + | FoundExp (x, _) => x - (* Look for item at input position *) - (* We're looking for two things simultaneously: *) - (* 1. The "smallest" part, ie. the one of which the source span is the smallest *) - (* 2. The "smallestgoodpart" part, ie. the one of which the source span is the smallest AND has a special case in printGoodPart *) - (* If we end up with a smallestgoodpart, we'll show that one since that one is probably more useful *) - (* TODO source spans of XML and SQL sources are weird and you end *) - (* up with eg: a span from eg 1-5 and another from 2-6, makes no sense? *) - (* That's one of the reasons why we're searching for the two things mentioned above *) - val result = - U.Decl.foldB - { kind = fn (env, (k, span), acc) => add env (Kind (k, span)) span acc, - con = fn (env, (k, span), acc) => add env (Con (k, span)) span acc, - exp = fn (env, (k, span), acc) => add env (Exp (k, span)) span acc, - sgn_item = fn (env, (k, span), acc) => add env (Sgn_item (k, span)) span acc, - sgn = fn (env, (k, span), acc) => add env (Sgn (k, span)) span acc, - str = fn (env, (k, span), acc) => add env (Str (k, span)) span acc, - decl = fn (env, (k, span), acc) => add env (Decl (k, span)) span acc, - bind = fn (env, binder) => - case binder of - U.Decl.RelK x => E.pushKRel env x - | U.Decl.RelC (x, k) => E.pushCRel env x k - | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co - | U.Decl.RelE (x, c) => E.pushERel env x c - | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) - | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) - | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) - } - env - { smallestgoodpart = NONE - , smallest = { item = Str (str, { file = fileName - , first = { line = 0, char = 0} - , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} }) - , span = { file = fileName - , first = { line = 0, char = 0} - , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} } - , env = env } - } - ( L.DStr (Compiler.moduleOf "fileName", 0, (L.SgnError, ErrorMsg.dummySpan), (str, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos})) - , {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) +fun filterSgiItems (items: Elab.sgn_item list) : foundInEnv list = + let + fun mapF item = + case item of + (Elab.SgiVal (name, _, c), _) => [FoundExp (name, c)] + | (Elab.SgiCon (name, _, k, _), _) => [FoundCon (name, k)] + | (Elab.SgiDatatype ds, loc) => + List.concat (List.map (fn (dtx, i, _, cs) => + FoundExp (dtx, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs) ds) + | (Elab.SgiDatatypeImp (x, i, _, _, _, _, cs), loc) => + FoundExp (x, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs + | (Elab.SgiStr (_, name, _, sgn), _) => + [FoundStr (name, sgn)] + | (Elab.SgiSgn (name, _, sgn), _) => + [FoundStr (name, sgn)] + | _ => [] + in + List.concat (List.map mapF items) + end + +fun resolvePrefixes + (env: ElabEnv.env) + (prefixes: string list) + (items : foundInEnv list) + : foundInEnv list + = + case prefixes of + [] => items + | first :: rest => + (case List.find (fn item => getNameOfFoundInEnv item = first) items of + NONE => [] + | SOME (FoundStr (name, sgn)) => (case ElabEnv.hnormSgn env sgn of + (Elab.SgnConst sgis, _) => resolvePrefixes env rest (filterSgiItems sgis) + | _ => []) + | SOME (FoundExp (name, c)) => + let + val fields = case ElabOps.reduceCon env c of + (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_) => + fields + | ( ( Elab.CApp + ( ( (Elab.CApp + ( ( Elab.CModProj (_, _, "sql_table") , l4_) + , ( Elab.CRecord (_, fields) , l3_))) + , l2_) + , _)) + , l1_) => fields + | _ => [] + val items = + List.mapPartial (fn (c1, c2) => case c1 of + (Elab.CName fieldName, _) => SOME (FoundExp (fieldName, c2)) + | _ => NONE) fields + in + resolvePrefixes env rest items + end + | SOME (FoundCon (_, _)) => []) + + +fun findStringInEnv' (env: ElabEnv.env) (preferCon: bool) (str: string): (string (* prefix *) * foundInEnv option) = + let + val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) + val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) + ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) + @ List.map FoundCon (ElabEnv.dumpCs env) + @ List.map FoundExp (ElabEnv.dumpEs env)) + val query = List.last splitted + val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) + in + (prefix, List.find (fn i => getNameOfFoundInEnv i = query) afterResolve) + end + +fun matchStringInEnv' (env: ElabEnv.env) (str: string): (string (* prefix *) * foundInEnv list) = + let + val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) + val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) + ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) + @ List.map FoundCon (ElabEnv.dumpCs env) + @ List.map FoundExp (ElabEnv.dumpEs env)) + val query = List.last splitted + val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) + in + (prefix, List.filter (fn i => String.isPrefix query (getNameOfFoundInEnv i)) afterResolve) + end + +fun getDesc item = + case item of + Kind (_, s) => "Kind " ^ ErrorMsg.spanToString s + | Con (_, s) => "Con " ^ ErrorMsg.spanToString s + | Exp (_, s) => "Exp " ^ ErrorMsg.spanToString s + | Sgn_item (_, s) => "Sgn_item " ^ ErrorMsg.spanToString s + | Sgn (_, s) => "Sgn " ^ ErrorMsg.spanToString s + | Str (_, s) => "Str " ^ ErrorMsg.spanToString s + | Decl (_, s) => "Decl " ^ ErrorMsg.spanToString s + +fun matchStringInEnv env str fileName pos query: (ElabEnv.env * string (* prefix *) * foundInEnv list) = + let + val {item = _, env} = findSmallestSpan env str fileName pos + val (prefix, matches) = matchStringInEnv' env query + in + (env, prefix, matches) + end + +fun findStringInEnv env str fileName pos (query: string): (ElabEnv.env * string (* prefix *) * foundInEnv option) = + let + val {item, env} = findSmallestSpan env str fileName pos + val env = case item of + Exp (L.ECase _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp (L.ELet _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp (L.EAbs _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp e => env + | Con _ => #env (findFirstExpAfter env str fileName pos) + | _ => #env (findFirstExpAfter env str fileName pos) + val preferCon = case item of Con _ => true + | _ => false + val (prefix, found) = findStringInEnv' env preferCon query in - result + (env, prefix, found) end end diff --git a/src/lsp.sml b/src/lsp.sml index 856b7ab8..e29589c2 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,7 +1,8 @@ -structure C = Compiler - structure Lsp :> LSP = struct +structure C = Compiler +structure P = Print + val debug = LspSpec.debug structure SK = struct @@ -317,6 +318,35 @@ fun ppToString (pp: Print.PD.pp_desc) (width: int): string = res end +fun getStringAtCursor + (stopAtCursor: bool) + (text: string) + (pos: LspSpec.position) + : string + = + let + val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full text), #line pos) + val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":" + , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] + val lineUntilCursor = Substring.slice (line, 0, SOME (#character pos)) + val beforeCursor = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilCursor) + val afterCursor = if stopAtCursor + then "" + else let + val lineAfterCursor = Substring.slice (line, #character pos, NONE) + in + Substring.string (Substring.takel (fn c => not (List.exists (fn c' => c = c') (#"." :: chars))) lineAfterCursor) + end + in + beforeCursor ^ afterCursor + end + +fun formatTypeBox (a: P.PD.pp_desc, b: P.PD.pp_desc) = + P.PD.hvBox (P.PD.PPS.Rel 0, [a, + P.PD.string ": ", + P.PD.break {nsp = 0, offset = 2}, + b]) + fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec.result = let val fileName = #path (#uri (#textDocument p)) @@ -326,177 +356,27 @@ fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec. NONE => LspSpec.Success NONE | SOME s => let + val searchString = getStringAtCursor false (#text s) (#position p) val env = #envBeforeThisModule s val decls = #decls s val loc = #position p - val result = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line loc + 1 - , character = #character loc + 1} + val (env, prefix, found) = GetInfo.findStringInEnv env (Elab.StrConst decls) fileName { line = #line loc + 1 + , char = #character loc + 1} searchString in - case #smallestgoodpart result of + case found of NONE => LspSpec.Success NONE - | SOME {desc = desc, ...} => - LspSpec.Success (SOME {contents = ppToString desc 50}) + | SOME f => + let + val desc = case f of + GetInfo.FoundStr (x, (_, sgn)) => formatTypeBox (P.PD.string (prefix ^ x), P.PD.string "module") + | GetInfo.FoundCon (x, kind) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_kind env kind) + | GetInfo.FoundExp (x, con) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_con env con) + in + LspSpec.Success (SOME {contents = ppToString desc 50}) + end end end -fun getCompletionsFromFields (env: ElabEnv.env) (prefix: string) (searchStr: string) (fields: (Elab.con * Elab.con) list): LspSpec.completionItem list = - let - fun mapF (c1, c2) = - case c1 of - (Elab.CName fieldName, _) => - if String.isPrefix searchStr fieldName - then SOME { label = prefix ^ fieldName - , kind = LspSpec.Field - , detail = ppToString (ElabPrint.p_con env c2) 200 - } - else NONE - | _ => NONE - in - List.mapPartial mapF fields - end - -fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (searchStr: string) (items: Elab.sgn_item list): LspSpec.completionItem list = - let - fun mapF item = - case item of - (Elab.SgiVal (name, _, con), _) => - if String.isPrefix searchStr name - then [{ label = prefix ^ name - , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 200 - }] - else [] - | (Elab.SgiCon (name, _, _, con), _) => - if String.isPrefix searchStr name - then [{ label = prefix ^ name - , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 200 - }] - else [] - | (Elab.SgiDatatype cs, _) => - (List.concat - (List.map (fn (constr as (dtName, n, xs, constrs)) => - (* Copied from elab_print *) - let - val k = (Elab.KType, ErrorMsg.dummySpan) - val env = ElabEnv.pushCNamedAs env dtName n k NONE - val env = List.foldl (fn (x, env) => ElabEnv.pushCRel env x k) env xs - val typeVarsString = List.foldl (fn (x, acc) => acc ^ " " ^ x) "" xs - in - List.mapPartial (fn (constrName, _, conO) => - if String.isPrefix searchStr constrName - then SOME { label = prefix ^ constrName - , kind = LspSpec.Function - , detail = case conO of - NONE => dtName ^ typeVarsString - | SOME con => ppToString (ElabPrint.p_con env con) 200 ^ " -> " ^ dtName ^ typeVarsString - } - else NONE) constrs - end) - cs)) - | (Elab.SgiDatatypeImp _, _) => - (* TODO ??? no idea what this is *) - [] - | (Elab.SgiStr (_, name, _, _), _) => - if String.isPrefix searchStr name - then [{ label = prefix ^ name - , kind = LspSpec.Module - , detail = "" - }] - else [] - | (Elab.SgiClass (name, _, _, con), _) => - if String.isPrefix searchStr name - then [{ label = prefix ^ name - , kind = LspSpec.Class - , detail = ppToString (ElabPrint.p_con env con) 200 - }] - else [] - | _ => [] - in - List.concat (List.map mapF items) - end - -(* TODO TOCHECK look at con's to specify "kind" more accurately *) -fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completionItem list = - let - val splitted = Substring.fields (fn c => c = #".") (Substring.full str) - in - case splitted of - (_ :: []) => - if str = "" - then [] - else - let - val matchingEs = ElabEnv.matchEByPrefix env str (* function params, let bindings and top-level bindings. Should we discern between Rel and Named? *) - val expressionCompletions = List.map (fn (name,con) => - { label = name - , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 200 - }) matchingEs - val matchingStrs = ElabEnv.matchStrByPrefix env str - val structureCompletions = List.map (fn (name,(_,sgn)) => - { label = name - , kind = LspSpec.Module - , detail = "" - }) matchingStrs - val matchingCons = ElabEnv.matchCByPrefix env str - val conCompletions = List.map (fn (name,kind) => - { label = name - , kind = LspSpec.Constructor (* TODO probably wrong... *) - , detail = ppToString (ElabPrint.p_kind env kind) 200 - }) matchingCons - in - expressionCompletions @ structureCompletions @ conCompletions - end - | (r :: str :: []) => - if Char.isUpper (Substring.sub (r, 0)) - then - (* Completing STRUCTURE *) - let - (* TODO PERF SMALL: first match and then equal is not perfect *) - val foundStrs = ElabEnv.matchStrByPrefix env (Substring.string r) - val filteredStrs = List.filter (fn (name,_) => name = Substring.string r) foundStrs - in - (case List.map (fn (name, (i, sgn)) => (name, ElabEnv.hnormSgn env sgn)) filteredStrs of - [] => [] - | (name, (Elab.SgnConst sgis, _)) :: _ => - getCompletionsFromSignatureItems env (name ^ ".") (Substring.string str) sgis - | _ => []) - end - else - (* Completing RECORD *) - (* TODO TOCHECK is it correct to first try RelE and then NamedE? *) - let - (* TODO PERF SMALL: first match and then equal is not perfect *) - val foundEs = ElabEnv.matchEByPrefix env (Substring.string r) - val filteredEs = List.filter (fn (name,_) => name = Substring.string r) foundEs - val reduced = List.map (fn (name, c) => - (name, ElabOps.reduceCon env c) - handle ex => (name, (Elab.CUnit, ErrorMsg.dummySpan))) - filteredEs - in - case reduced of - [] => [] - | (name, (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_)) :: _ => - getCompletionsFromFields env (name ^ ".") (Substring.string str) fields - | (name, - ( ( Elab.CApp - ( ( (Elab.CApp - ( ( Elab.CModProj (_, _, "sql_table") - , l4_) - , ( Elab.CRecord (_, fields) - , l3_))) - , l2_) - , _)) - , l1_)) :: _ => - getCompletionsFromFields env (name ^ ".") (Substring.string str) fields - | _ => [] - end - | _ => - (* TODO NOTIMPLEMENTED submodules / nested records *) - [] - end - (* TODO IDEA can we use the real parser to figure out what we're typing (exp, con, field, etc) to predict better? *) fun handleCompletion (state: state) (p: LspSpec.completionReq) = let @@ -508,19 +388,20 @@ fun handleCompletion (state: state) (p: LspSpec.completionReq) = | SOME s => let val pos = #position p - val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full (#text s)), #line pos) - val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":" - , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] - val lineUntilPos = Substring.slice (line, 0, SOME (#character pos)) - val searchStr = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilPos) + val searchStr = getStringAtCursor true (#text s) pos val env = #envBeforeThisModule s val decls = #decls s - val getInfoRes = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line pos + 1 - , character = #character pos + 1} - val envOfSmallest = #env (#smallest getInfoRes) + val (env, prefix, foundItems) = GetInfo.matchStringInEnv env (Elab.StrConst decls) fileName { line = #line pos + 1, char = #character pos + 1} searchStr + val completions = List.map + (fn f => case f of + GetInfo.FoundStr (x, _) => {label = prefix ^ x, kind = LspSpec.Module, detail = ""} + | GetInfo.FoundCon (x, k) => {label = prefix ^ x, kind = LspSpec.Constructor, detail = ppToString (ElabPrint.p_kind env k) 200} + | GetInfo.FoundExp (x, c) => {label = prefix ^ x, kind = LspSpec.Value, detail = ppToString (ElabPrint.p_con env c) 200} + ) + foundItems in LspSpec.Success { isIncomplete = false - , items = findMatchingStringInEnv envOfSmallest searchStr} + , items = completions } end end -- cgit v1.2.3 From 0e6ae5392121aa2163199292963f0f98776b6790 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sat, 11 Jan 2020 21:51:21 +0100 Subject: Fixed review changes: Better foundInEnv naming, correct interpretation of SgiSgn, fix uniq --- src/getinfo.sig | 4 ++-- src/getinfo.sml | 35 +++++++++++++++++------------------ src/lsp.sml | 14 +++++++------- 3 files changed, 26 insertions(+), 27 deletions(-) (limited to 'src/getinfo.sig') diff --git a/src/getinfo.sig b/src/getinfo.sig index 663a9a81..63850ef2 100644 --- a/src/getinfo.sig +++ b/src/getinfo.sig @@ -28,8 +28,8 @@ signature GET_INFO = sig datatype foundInEnv = FoundStr of (string * Elab.sgn) - | FoundCon of (string * Elab.kind) - | FoundExp of (string * Elab.con) + | FoundKind of (string * Elab.kind) + | FoundCon of (string * Elab.con) val findStringInEnv: ElabEnv.env -> diff --git a/src/getinfo.sml b/src/getinfo.sml index 760a4d90..6adfbdcf 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -163,32 +163,31 @@ fun findFirstExpAfter env str fileName {line = line, char = char} = datatype foundInEnv = FoundStr of (string * Elab.sgn) - | FoundCon of (string * Elab.kind) - | FoundExp of (string * Elab.con) + | FoundKind of (string * Elab.kind) + | FoundCon of (string * Elab.con) fun getNameOfFoundInEnv (f: foundInEnv) = case f of FoundStr (x, _) => x + | FoundKind (x, _) => x | FoundCon (x, _) => x - | FoundExp (x, _) => x fun filterSgiItems (items: Elab.sgn_item list) : foundInEnv list = let fun mapF item = case item of - (Elab.SgiVal (name, _, c), _) => [FoundExp (name, c)] - | (Elab.SgiCon (name, _, k, _), _) => [FoundCon (name, k)] + (Elab.SgiVal (name, _, c), _) => [FoundCon (name, c)] + | (Elab.SgiCon (name, _, k, _), _) => [FoundKind (name, k)] | (Elab.SgiDatatype ds, loc) => List.concat (List.map (fn (dtx, i, _, cs) => - FoundExp (dtx, (Elab.CNamed i, loc)) - :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs) ds) + FoundCon (dtx, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundCon (x, (Elab.CRel i, loc))) cs) ds) | (Elab.SgiDatatypeImp (x, i, _, _, _, _, cs), loc) => - FoundExp (x, (Elab.CNamed i, loc)) - :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs + FoundCon (x, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundCon (x, (Elab.CRel i, loc))) cs | (Elab.SgiStr (_, name, _, sgn), _) => [FoundStr (name, sgn)] - | (Elab.SgiSgn (name, _, sgn), _) => - [FoundStr (name, sgn)] + | (Elab.SgiSgn (name, _, sgn), _) => [] | _ => [] in List.concat (List.map mapF items) @@ -208,7 +207,7 @@ fun resolvePrefixes | SOME (FoundStr (name, sgn)) => (case ElabEnv.hnormSgn env sgn of (Elab.SgnConst sgis, _) => resolvePrefixes env rest (filterSgiItems sgis) | _ => []) - | SOME (FoundExp (name, c)) => + | SOME (FoundCon (name, c)) => let val fields = case ElabOps.reduceCon env c of (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_) => @@ -223,12 +222,12 @@ fun resolvePrefixes | _ => [] val items = List.mapPartial (fn (c1, c2) => case c1 of - (Elab.CName fieldName, _) => SOME (FoundExp (fieldName, c2)) + (Elab.CName fieldName, _) => SOME (FoundCon (fieldName, c2)) | _ => NONE) fields in resolvePrefixes env rest items end - | SOME (FoundCon (_, _)) => []) + | SOME (FoundKind (_, _)) => []) fun findStringInEnv' (env: ElabEnv.env) (preferCon: bool) (str: string): (string (* prefix *) * foundInEnv option) = @@ -236,8 +235,8 @@ fun findStringInEnv' (env: ElabEnv.env) (preferCon: bool) (str: string): (string val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) - @ List.map FoundCon (ElabEnv.dumpCs env) - @ List.map FoundExp (ElabEnv.dumpEs env)) + @ List.map FoundKind (ElabEnv.dumpCs env) + @ List.map FoundCon (ElabEnv.dumpEs env)) val query = List.last splitted val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) in @@ -249,8 +248,8 @@ fun matchStringInEnv' (env: ElabEnv.env) (str: string): (string (* prefix *) * f val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) - @ List.map FoundCon (ElabEnv.dumpCs env) - @ List.map FoundExp (ElabEnv.dumpEs env)) + @ List.map FoundKind (ElabEnv.dumpCs env) + @ List.map FoundCon (ElabEnv.dumpEs env)) val query = List.last splitted val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) in diff --git a/src/lsp.sml b/src/lsp.sml index e29589c2..c99a6f2e 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -257,10 +257,10 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef end end -fun uniq (comp: 'b -> 'b -> bool) (bs: 'b list) = +fun uniq (eq: 'b -> 'b -> bool) (bs: 'b list) = case bs of [] => [] - | (l as b :: bs') => b :: uniq comp (List.filter (comp b) bs') + | (l as b :: bs') => b :: uniq eq (List.filter (fn a => not (eq a b)) bs') fun elabFileAndSendDiags (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri): unit = let @@ -326,7 +326,7 @@ fun getStringAtCursor = let val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full text), #line pos) - val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":" + val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":", #"@" , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] val lineUntilCursor = Substring.slice (line, 0, SOME (#character pos)) val beforeCursor = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilCursor) @@ -369,8 +369,8 @@ fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec. let val desc = case f of GetInfo.FoundStr (x, (_, sgn)) => formatTypeBox (P.PD.string (prefix ^ x), P.PD.string "module") - | GetInfo.FoundCon (x, kind) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_kind env kind) - | GetInfo.FoundExp (x, con) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_con env con) + | GetInfo.FoundKind (x, kind) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_kind env kind) + | GetInfo.FoundCon (x, con) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_con env con) in LspSpec.Success (SOME {contents = ppToString desc 50}) end @@ -395,8 +395,8 @@ fun handleCompletion (state: state) (p: LspSpec.completionReq) = val completions = List.map (fn f => case f of GetInfo.FoundStr (x, _) => {label = prefix ^ x, kind = LspSpec.Module, detail = ""} - | GetInfo.FoundCon (x, k) => {label = prefix ^ x, kind = LspSpec.Constructor, detail = ppToString (ElabPrint.p_kind env k) 200} - | GetInfo.FoundExp (x, c) => {label = prefix ^ x, kind = LspSpec.Value, detail = ppToString (ElabPrint.p_con env c) 200} + | GetInfo.FoundKind (x, k) => {label = prefix ^ x, kind = LspSpec.Constructor, detail = ppToString (ElabPrint.p_kind env k) 200} + | GetInfo.FoundCon (x, c) => {label = prefix ^ x, kind = LspSpec.Value, detail = ppToString (ElabPrint.p_con env c) 200} ) foundItems in -- cgit v1.2.3