summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Simon Van Casteren <simonvancasteren@localhost.localdomain>2019-12-11 22:56:29 +0100
committerGravatar Simon Van Casteren <simonvancasteren@localhost.localdomain>2019-12-13 11:46:57 +0100
commit9b00dc724363ac7b0a31687f14cc3bb2f2460f9b (patch)
tree8a078a63394a2a6067c35324796fe32deb0f5438 /src
parent25b0685cefe772c73562665a4cc8d2d40e5ff600 (diff)
Integrated getInfo into LSP
Diffstat (limited to 'src')
-rw-r--r--src/getinfo.sig7
-rw-r--r--src/getinfo.sml353
-rw-r--r--src/lsp.sml69
-rw-r--r--src/main.mlton.sml6
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 <mod>" 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 <file:row:col>")
- | _ => P.PD.string "ERROR: Wrong typeOf input format, should be <file:row:col>"
+fun getInfo env str fileName {line = row, character = col} =
+ let
+ val () = U.mliftConInCon := E.mliftConInCon
+
+ (* Adding previous declarations in file to environment *)
+ (* "open <mod>" 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 ("<file>", printModuleOf),
SOME "print module name of <file> and exit"),
- ("getInfo", ONE ("<file:row:col>", getInfo),
- SOME "print info of expression at <file:row:col> and exit"),
("startLspServer", ZERO Lsp.startServer, SOME "Start Language Server Protocol server"),
("noEmacs", set_true Demo.noEmacs,
NONE),