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