From 80e7bb6165a5ad6517b35f301228f56b58eef39c Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Wed, 31 Jul 2019 15:13:18 +0200 Subject: first iteration of "typeOf" command --- src/sources | 3 +++ 1 file changed, 3 insertions(+) (limited to 'src/sources') diff --git a/src/sources b/src/sources index 851cdc16..e25ccd2e 100644 --- a/src/sources +++ b/src/sources @@ -69,6 +69,9 @@ $(SRC)/elab.sml $(SRC)/elab_util.sig $(SRC)/elab_util.sml +$(SRC)/elab_util_pos.sig +$(SRC)/elab_util_pos.sml + $(SRC)/elab_env.sig $(SRC)/elab_env.sml -- cgit v1.2.3 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/compiler.sig | 1 - src/compiler.sml | 233 ------------------------------------------- src/elab_util_pos.sig | 3 + src/errormsg.sig | 1 + src/getinfo.sig | 31 ++++++ src/getinfo.sml | 270 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/main.mlton.sml | 8 +- src/mod_db.sig | 3 +- src/mod_db.sml | 38 +++---- src/sources | 3 + 10 files changed, 329 insertions(+), 262 deletions(-) create mode 100644 src/getinfo.sig create mode 100644 src/getinfo.sml (limited to 'src/sources') diff --git a/src/compiler.sig b/src/compiler.sig index 7f724b0f..6ed2f9a6 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -215,7 +215,6 @@ signature COMPILER = sig val addModuleRoot : string * string -> unit val moduleOf : string -> string - val typeOf : string -> Print.PD.pp_desc val setStop : string -> unit (* Stop compilation after this phase. *) diff --git a/src/compiler.sml b/src/compiler.sml index 2e6cf312..0aba3a40 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1781,237 +1781,4 @@ fun moduleOf fname = end end -fun isPosIn file row col span = - let - val start = #first span - val end_ = #last span - in - String.isSuffix file (#file span) - andalso - (#line start < row orelse - #line start = row andalso #char start <= col) - andalso - (#line end_ > row orelse - #line end_ = row andalso #char end_ >= col) - - end - -fun isSmallerThan (s1: ErrorMsg.span) (s2: ErrorMsg.span) = - (#line (#first s1) > #line (#first s2) orelse - (#line (#first s1) = #line (#first s2) andalso (#char (#first s1) >= #char (#first s2)))) - andalso - (#line (#last s1) < #line (#last s2) orelse - (#line (#last s1) = #line (#last s2) andalso (#char (#last s1) <= #char (#last s2)))) - -datatype foundStuff = - 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 - -fun getSpan (f: foundStuff * ElabEnv.env) = - case #1 f of - Kind k => #2 k - | Con c => #2 c - | Exp e => #2 e - | Sgn_item si => #2 si - | Sgn s => #2 s - | Str s => #2 s - | Decl d => #2 d - -fun getTypeAt file row col = - if not (!Elaborate.incremental) - then Print.PD.string "ERROR: urweb daemon is needed to use typeOf command" - else - case ModDb.lookupForTooling (moduleOf file) of - NONE => Print.PD.string ("ERROR: No module found: " ^ moduleOf file) - | SOME (modDecl, deps) => - let - val () = ElabUtilPos.mliftConInCon := ElabEnv.mliftConInCon - - (* Adding dependencies to environment *) - val env = List.foldl (fn (d, e) => ElabEnv.declBinds e d) - ElabEnv.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 - Elab.DStr (name, _, sgn, str) => - (case #1 str of - Elab.StrConst decls => - List.foldl (fn (d, env) => - if #line (#first (#2 d)) <= row - andalso #char (#first (#2 d)) <= col - then ElabEnv.declBinds env d - else env) env decls - | _ => env) - | Elab.DFfiStr _ => env - | _ => env - - (* Basis and Top need to be added to the env explicitly *) - val env = - case ModDb.lookupForTooling "Top" of - NONE => raise Fail "ERROR: Top module not found in ModDb" - | SOME ((Elab.DStr (_, top_n, topSgn, topStr), _), _) => - #2 (Elaborate.dopen env {str = top_n, strs = [], sgn = topSgn}) - | _ => raise Fail "ERROR: Impossible" - - val env = - case ModDb.lookupForTooling "Basis" of - NONE => raise Fail "ERROR: Top module not found in ModDb" - | SOME ((Elab.DFfiStr (_, basis_n, sgn), _), _) => - #2 (Elaborate.dopen env {str = basis_n, strs = [], sgn = sgn}) - | _ => raise Fail "ERROR: Impossible" - - fun printLiterally {span = span, item = item, env = env} = - Print.box [ Print.PD.string "Nothing good found, printing literally: \n" - , Print.PD.cut - , case item of - Kind k => Print.box [Print.PD.string "KIND: ", ElabPrint.p_kind env k] - | Con c => Print.box [Print.PD.string "CON: ", ElabPrint.p_con env c] - | Exp e => Print.box [Print.PD.string "EXP: ", ElabPrint.p_exp env e] - | Sgn_item si => Print.box [Print.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] - | Sgn s => Print.box [Print.PD.string "SGN: ", ElabPrint.p_sgn env s] - | Str s => Print.box [Print.PD.string "STR: ", ElabPrint.p_str env s] - | Decl d => Print.box [Print.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 (Elab.Decl, Elab.Exp, etc) *) - (* but not when we do a lookup into the Env *) - (* TODO Rename *) - fun printGoodPart env f span = - (case f of - Exp (Elab.EPrim p, _) => - SOME (Print.box [Prim.p_t p, - Print.PD.string ": ", - Print.PD.string (case p of - Prim.Int _ => "int" - | Prim.Float _ => "float" - | Prim.String _ => "string" - | Prim.Char _ => "char")]) - | Exp (Elab.ERel n, _) => - SOME ((let val found = ElabEnv.lookupERel env n - in - - Print.box [ Print.PD.string (#1 found) - , Print.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle ElabEnv.UnboundRel _ => Print.PD.string ("UNBOUND_REL" ^ Int.toString n)) - | Exp (Elab.ENamed n, _) => - SOME ((let val found = ElabEnv.lookupENamed env n - in - Print.box [ Print.PD.string (#1 found) - , Print.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle ElabEnv.UnboundNamed _ => Print.PD.string ("UNBOUND_NAMED" ^ Int.toString n)) - | Exp (Elab.EModProj ( m1 (* number (= "name") of top level module *) - , ms (* names of submodules - possibly none *) - , x (* identifier *)), loc) => - SOME (let - val (m1name, m1sgn) = ElabEnv.lookupStrNamed env m1 - val (str, sgn) = foldl (fn (m, (str, sgn)) => - case ElabEnv.projectStr env {sgn = sgn, str = str, field = m} of - NONE => raise Fail ("Couldn't find Structure: " ^ m) - | SOME sgn => ((Elab.StrProj (str, m), loc), sgn)) - ((Elab.StrVar m1, loc), m1sgn) - ms - val t = case ElabEnv.projectVal env {sgn = sgn, str = str, field = x} of - NONE => raise Fail ("Couldn't find identifier: " ^ x) - | SOME t => t - in - Print.box [ Print.p_list_sep (Print.PD.string ".") Print.PD.string (m1name :: ms @ [x]) - , Print.PD.string ": " - , ElabPrint.p_con env t - ] - end - handle ElabEnv.UnboundNamed _ => Print.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 under cursor *) - val result = - ElabUtilPos.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 - ElabUtilPos.Decl.RelK x => ElabEnv.pushKRel env x - | ElabUtilPos.Decl.RelC (x, k) => ElabEnv.pushCRel env x k - | ElabUtilPos.Decl.NamedC (x, n, k, co) => ElabEnv.pushCNamedAs env x n k co - | ElabUtilPos.Decl.RelE (x, c) => ElabEnv.pushERel env x c - | ElabUtilPos.Decl.NamedE (x, c) => #1 (ElabEnv.pushENamed env x c) - | ElabUtilPos.Decl.Str (x, n, sgn) => #1 (ElabEnv.pushStrNamed env x sgn) - | ElabUtilPos.Decl.Sgn (x, n, sgn) => #1 (ElabEnv.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 typeOf 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) => getTypeAt file row col - | _ => Print.PD.string "ERROR: Wrong typeOf input format, should be ") - | _ => Print.PD.string "ERROR: Wrong typeOf input format, should be " end diff --git a/src/elab_util_pos.sig b/src/elab_util_pos.sig index f616f7f3..95d8b591 100644 --- a/src/elab_util_pos.sig +++ b/src/elab_util_pos.sig @@ -25,6 +25,9 @@ * POSSIBILITY OF SUCH DAMAGE. *) +(* This is identical to ELAB_UTIL, but keeps source spans around *) +(* Maybe these modules can be unified? *) + signature ELAB_UTIL_POS = sig val mliftConInCon : (int -> Elab.con -> Elab.con) ref diff --git a/src/errormsg.sig b/src/errormsg.sig index b4a508d9..4cf8b50a 100644 --- a/src/errormsg.sig +++ b/src/errormsg.sig @@ -48,6 +48,7 @@ signature ERROR_MSG = sig val posOf : int -> pos val spanOf : int * int -> span + (* To monitor in which modules the elaboration phase finds errors *) val startElabStructure : string -> unit val stopElabStructureAndGetErrored : string -> bool (* Did the module elab encounter errors? *) 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 + diff --git a/src/getinfo.sml b/src/getinfo.sml new file mode 100644 index 00000000..37c50928 --- /dev/null +++ b/src/getinfo.sml @@ -0,0 +1,270 @@ +(* 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. + *) + +structure GetInfo :> GET_INFO = struct + +structure U = ElabUtilPos +structure E = ElabEnv +structure L = Elab +structure P = Print + +fun isPosIn file row col span = + let + val start = #first span + val end_ = #last span + in + String.isSuffix file (#file span) + andalso + (#line start < row orelse + #line start = row andalso #char start <= col) + andalso + (#line end_ > row orelse + #line end_ = row andalso #char end_ >= col) + + end + +fun isSmallerThan (s1: ErrorMsg.span) (s2: ErrorMsg.span) = + (#line (#first s1) > #line (#first s2) orelse + (#line (#first s1) = #line (#first s2) andalso (#char (#first s1) >= #char (#first s2)))) + andalso + (#line (#last s1) < #line (#last s2) orelse + (#line (#last s1) = #line (#last s2) andalso (#char (#last s1) <= #char (#last s2)))) + +datatype item = + Kind of L.kind + | Con of L.con + | Exp of L.exp + | Sgn_item of L.sgn_item + | Sgn of L.sgn + | Str of L.str + | Decl of L.decl + +fun getSpan (f: item * E.env) = + case #1 f of + Kind k => #2 k + | Con c => #2 c + | Exp e => #2 e + | Sgn_item si => #2 si + | Sgn s => #2 s + | 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 " +end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index bb5d2166..bbee8c90 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -139,8 +139,8 @@ fun oneRun args = fun printModuleOf fname = print_and_exit (Compiler.moduleOf fname) () - fun typeOf loc = - (Print.print (Compiler.typeOf loc); + fun getInfo loc = + (Print.print (GetInfo.getInfo loc); raise Code OS.Process.success) fun add_class (class, num) = @@ -249,8 +249,8 @@ fun oneRun args = NONE), ("moduleOf", ONE ("", printModuleOf), SOME "print module name of and exit"), - ("typeOf", ONE ("", typeOf), - SOME "print type of expression at and exit"), + ("getInfo", ONE ("", getInfo), + SOME "print info of expression at and exit"), ("noEmacs", set_true Demo.noEmacs, NONE), ("limit", TWO ("", "", add_class), diff --git a/src/mod_db.sig b/src/mod_db.sig index 40cd52e2..fb396603 100644 --- a/src/mod_db.sig +++ b/src/mod_db.sig @@ -36,7 +36,8 @@ signature MOD_DB = sig val lookup : Source.decl -> Elab.decl option - val lookupForTooling : string -> (Elab.decl * Elab.decl list) option + val lookupModAndDepsIncludingErrored: + string -> (Elab.decl * Elab.decl list) option (* Allow undoing to snapshots after failed compilations. *) val snapshot : unit -> unit diff --git a/src/mod_db.sml b/src/mod_db.sml index 57d85195..c821a0bb 100644 --- a/src/mod_db.sml +++ b/src/mod_db.sml @@ -43,7 +43,7 @@ structure IM = IntBinaryMap type oneMod = {Decl : decl, When : Time.time, Deps : SS.set, - HasErrors: bool + HasErrors: bool (* We're saving modules with errors so tooling can find them *) } val byName = ref (SM.empty : oneMod SM.map) @@ -52,6 +52,7 @@ val byId = ref (IM.empty : string IM.map) fun reset () = (byName := SM.empty; byId := IM.empty) +(* For debug purposes *) fun printByName (bn: oneMod SM.map): unit = (TextIO.print ("Contents of ModDb.byName: \n"); List.app (fn tup => @@ -70,17 +71,6 @@ fun printByName (bn: oneMod SM.map): unit = end) (SM.listItemsi bn)) -fun printById (bi: string IM.map): unit = - (TextIO.print ("Contents of ModDb.byId: \n"); - List.app (fn tup => - let - val i = #1 tup - val name = #2 tup - in - TextIO.print (" " ^ Int.toString i ^": "^ name ^"\n") - end) - (IM.listItemsi bi)) - fun dContainsUndeterminedUnif d = ElabUtil.Decl.exists {kind = fn _ => false, @@ -112,6 +102,9 @@ fun insert (d, tm, hasErrors) = NONE => false | SOME r => #When r = tm andalso not (#HasErrors r) + (* We save results of error'd compiler passes *) + (* so modules that still have undetermined unif variables *) + (* should not be reused since those are unsuccessfully compiled *) andalso not (dContainsUndeterminedUnif (#Decl r)) in if skipIt then @@ -182,7 +175,6 @@ fun insert (d, tm, hasErrors) = }); byId := IM.insert (!byId, n, x) (* printByName (!byName) *) - (* printById (!byId) *) end end end @@ -207,19 +199,19 @@ fun lookup (d : Source.decl) = NONE) | _ => NONE -fun lookupForTooling name = +fun lookupModAndDepsIncludingErrored name = case SM.find (!byName, name) of NONE => NONE | SOME m => - SOME (#Decl m, List.map (fn a => #Decl a) - (List.mapPartial - (fn d => SM.find (!byName, d)) - (* Clumsy way of adding Basis and Top without adding doubles *) - (["Basis", "Top"] - @ - (List.filter - (fn x => x <> "Basis" andalso x <> "Top") - (SS.listItems (#Deps m)))))) + let + val deps = SS.listItems (#Deps m) + (* Clumsy way of adding Basis and Top without adding doubles *) + val deps = List.filter (fn x => x <> "Basis" andalso x <> "Top") deps + val deps = ["Basis", "Top"] @ deps + val foundDepModules = List.mapPartial (fn d => SM.find (!byName, d)) deps + in + SOME (#Decl m, List.map (fn a => #Decl a) foundDepModules) + end val byNameBackup = ref (!byName) val byIdBackup = ref (!byId) diff --git a/src/sources b/src/sources index e25ccd2e..20d77483 100644 --- a/src/sources +++ b/src/sources @@ -274,6 +274,9 @@ $(SRC)/checknest.sml $(SRC)/compiler.sig $(SRC)/compiler.sml +$(SRC)/getinfo.sig +$(SRC)/getinfo.sml + $(SRC)/demo.sig $(SRC)/demo.sml -- cgit v1.2.3 From f5bfb7ab3a23485230a97b87ac5839eea8c79486 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sun, 8 Dec 2019 20:50:40 +0100 Subject: Added initial version of lsp --- src/json.sig | 13 +++ src/json.sml | 275 +++++++++++++++++++++++++++++++++++++++++++++++++++++ src/lsp.sig | 3 + src/lsp.sml | 159 +++++++++++++++++++++++++++++++ src/main.mlton.sml | 1 + src/sources | 6 ++ 6 files changed, 457 insertions(+) create mode 100644 src/json.sig create mode 100644 src/json.sml create mode 100644 src/lsp.sig create mode 100644 src/lsp.sml (limited to 'src/sources') diff --git a/src/json.sig b/src/json.sig new file mode 100644 index 00000000..f92ef495 --- /dev/null +++ b/src/json.sig @@ -0,0 +1,13 @@ +signature JSON = sig + datatype json = + Array of json list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Obj of (string * json) list + + val parse: string -> json + val print: json -> string +end diff --git a/src/json.sml b/src/json.sml new file mode 100644 index 00000000..fab15a6c --- /dev/null +++ b/src/json.sml @@ -0,0 +1,275 @@ +(******************************************************************************* +* Standard ML JSON parser +* Copyright (C) 2010 Gian Perrone +* +* This program is free software: you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation, either version 3 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program. If not, see . +******************************************************************************) + +signature JSON_CALLBACKS = +sig + type json_data + + val json_object : json_data list -> json_data + val json_pair : string * json_data -> json_data + val json_array : json_data list -> json_data + val json_value : json_data -> json_data + val json_string : string -> json_data + val json_int : int -> json_data + val json_real : real -> json_data + val json_bool : bool -> json_data + val json_null : unit -> json_data + + val error_handle : string * int * string -> json_data +end + +functor JSONParser (Callbacks : JSON_CALLBACKS) = +struct + type json_data = Callbacks.json_data + + exception JSONParseError of string * int + + val inputData = ref "" + val inputPosition = ref 0 + + fun isDigit () = Char.isDigit (String.sub (!inputData,0)) + + fun ws () = while (String.isPrefix " " (!inputData) orelse + String.isPrefix "\n" (!inputData) orelse + String.isPrefix "\t" (!inputData) orelse + String.isPrefix "\r" (!inputData)) + do (inputData := String.extract (!inputData, 1, NONE)) + + fun peek () = String.sub (!inputData,0) + fun take () = + String.sub (!inputData,0) before + inputData := String.extract (!inputData, 1, NONE) + + fun matches s = (ws(); String.isPrefix s (!inputData)) + fun consume s = + if matches s then + (inputData := String.extract (!inputData, size s, NONE); + inputPosition := !inputPosition + size s) + else + raise JSONParseError ("Expected '"^s^"'", !inputPosition) + + fun parseObject () = + if not (matches "{") then + raise JSONParseError ("Expected '{'", !inputPosition) + else + (consume "{"; ws (); + if matches "}" then Callbacks.json_object [] before consume "}" + else + (Callbacks.json_object (parseMembers ()) + before (ws (); consume "}"))) + + and parseMembers () = + parsePair () :: + (if matches "," then (consume ","; parseMembers ()) else []) + + and parsePair () = + Callbacks.json_pair (parseString (), + (ws(); consume ":"; parseValue ())) + + and parseArray () = + if not (matches "[") then + raise JSONParseError ("Expected '['", !inputPosition) + else + (consume "["; + if matches "]" then + Callbacks.json_array [] before consume "]" + else + Callbacks.json_array (parseElements ()) before (ws (); consume "]")) + + and parseElements () = + parseValue () :: + (if matches "," then (consume ","; parseElements ()) else []) + + and parseValue () = + Callbacks.json_value ( + if matches "\"" then Callbacks.json_string (parseString ()) else + if matches "-" orelse isDigit () then parseNumber () else + if matches "true" then Callbacks.json_bool true before consume "true" else + if matches "false" then Callbacks.json_bool false before consume "false" else + if matches "null" then Callbacks.json_null () before consume "null" else + if matches "[" then parseArray () else + if matches "{" then parseObject () else + raise JSONParseError ("Expected value", !inputPosition)) + + and parseString () = + (ws () ; + consume ("\"") ; + parseChars () before consume "\"") + + and parseChars () = + let + fun pickChars s = + if peek () = #"\"" (* " *) then s else + pickChars (s ^ String.str (take ())) + in + pickChars "" + end + + and parseNumber () = + let + val i = parseInt () + in + if peek () = #"e" orelse peek () = #"E" then + Callbacks.json_int (valOf (Int.fromString (i^parseExp()))) + else if peek () = #"." then + let + val f = parseFrac() + + val f' = if peek() = #"e" orelse peek() = #"E" then + i ^ f ^ parseExp () + else i ^ f + in + Callbacks.json_real (valOf (Real.fromString f')) + end + else Callbacks.json_int (valOf (Int.fromString i)) + end + + and parseInt () = + let + val f = + if peek () = #"0" then + raise JSONParseError ("Invalid number", !inputPosition) + else if peek () = #"-" then (take (); "~") + else String.str (take ()) + in + f ^ parseDigits () + end + + and parseDigits () = + let + val r = ref "" + in + (while Char.isDigit (peek ()) do + r := !r ^ String.str (take ()); + !r) + end + + and parseFrac () = + (consume "." ; + "." ^ parseDigits ()) + + and parseExp () = + let + val _ = + if peek () = #"e" orelse + peek () = #"E" then take () + else + raise JSONParseError ("Invalid number", !inputPosition) + + val f = if peek () = #"-" then (take (); "~") + else if peek () = #"+" then (take (); "") + else "" + in + "e" ^ f ^ parseDigits () + end + + fun parse s = + (inputData := s ; + inputPosition := 0 ; + parseObject ()) handle JSONParseError (m,p) => + Callbacks.error_handle (m,p,!inputData) +end + +structure JsonIntermAst = +struct +datatype ast = + Array of ast list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Pair of (string * ast) + | Obj of ast list +end + +structure Json :> JSON = struct +datatype json = + Array of json list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Obj of (string * json) list + +fun fromInterm (interm: JsonIntermAst.ast): json = + case interm of + JsonIntermAst.Array l => Array (List.map fromInterm l) + | JsonIntermAst.Null => Null + | JsonIntermAst.Float r => Float r + | JsonIntermAst.String s => String s + | JsonIntermAst.Bool b => Bool b + | JsonIntermAst.Int i => Int i + | JsonIntermAst.Pair (k,v) => + raise Fail ("JSON Parsing error. Pair of JSON found where it shouldn't. Key = " ^ k) + | JsonIntermAst.Obj l => + Obj + (List.foldl + (fn (a, acc) => + case a of + JsonIntermAst.Pair (k, v) => (k, fromInterm v) :: acc + | JsonIntermAst.Array _ => raise Fail ("JSON Parsing error. Found Array in object instead of key-value pair") + | JsonIntermAst.Null => raise Fail ("JSON Parsing error. Found Null in object instead of key-value pair") + | JsonIntermAst.Float _ => raise Fail ("JSON Parsing error. Found Float in object instead of key-value pair") + | JsonIntermAst.String _ => raise Fail ("JSON Parsing error. Found String in object instead of key-value pair") + | JsonIntermAst.Bool _ => raise Fail ("JSON Parsing error. Found Bool in object instead of key-value pair") + | JsonIntermAst.Int _ => raise Fail ("JSON Parsing error. Found Int in object instead of key-value pair") + | JsonIntermAst.Obj _ => raise Fail ("JSON Parsing error. Found Obj in object instead of key-value pair") + ) [] l) + +structure StandardJsonParserCallbacks = +struct + type json_data = JsonIntermAst.ast + fun json_object l = JsonIntermAst.Obj l + fun json_pair (k,v) = JsonIntermAst.Pair (k,v) + fun json_array l = JsonIntermAst.Array l + fun json_value x = x + fun json_string s = JsonIntermAst.String s + fun json_int i = JsonIntermAst.Int i + fun json_real r = JsonIntermAst.Float r + fun json_bool b = JsonIntermAst.Bool b + fun json_null () = JsonIntermAst.Null + fun error_handle (msg,pos,data) = + raise Fail ("Error: " ^ msg ^ " near " ^ Int.toString pos ^ " data: " ^ + data) +end + +structure MyJsonParser = JSONParser (StandardJsonParserCallbacks) + +fun parse (str: string): json = + fromInterm (MyJsonParser.parse str) +fun print (ast: json): string = + case ast of + Array l => "[" + ^ List.foldl (fn (a, acc) => acc ^ "," ^ print a) "" l + ^ "]" + | Null => "null" + | Float r => Real.toString r + | String s => + "\"" ^ + String.translate + (fn c => if c = #"\"" then "\\\"" else Char.toString c) + s ^ + "\"" + | Bool b => if b then "true" else "false" + | Int i => Int.toString i + | Obj l => "{" + ^ List.foldl (fn ((k, v), acc) => k ^ ": " ^ print v ) "" l + ^ "}" +end diff --git a/src/lsp.sig b/src/lsp.sig new file mode 100644 index 00000000..0dc95801 --- /dev/null +++ b/src/lsp.sig @@ -0,0 +1,3 @@ +signature LSP = sig + val startServer : unit -> unit +end diff --git a/src/lsp.sml b/src/lsp.sml new file mode 100644 index 00000000..1fd50109 --- /dev/null +++ b/src/lsp.sml @@ -0,0 +1,159 @@ +structure Lsp :> LSP = struct + +fun trim (s: substring): substring = + Substring.dropr + (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") + (Substring.dropl (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") s) + +fun readHeader (): (string * string) option = + let + val line = TextIO.inputLine TextIO.stdIn + in + case line of + NONE => OS.Process.exit OS.Process.success + | SOME str => + let + val (key, value) = Substring.splitl (fn c => c <> #":") (Substring.full str) + in + if Substring.isEmpty (trim value) + then NONE + else SOME ( Substring.string (trim key) + , Substring.string (trim (Substring.dropl (fn c => c = #":") (trim value)))) + end + end + +fun readAllHeaders (l: (string * string) list): (string * string) list = + case readHeader () of + NONE => l + | SOME tup => tup :: readAllHeaders l + +fun getJsonObjectValue (s: string) (l: (string * Json.json) list): Json.json option = + case List.find (fn tup => #1 tup = s ) l of + NONE => NONE + | SOME tup => SOME (#2 tup) + +fun getJsonObjectValue' (s: string) (l: Json.json): Json.json = + case l of + Json.Obj l => + (case getJsonObjectValue s l of + NONE => raise Fail ("Failed to find JSON object key " ^ s) + | SOME v => v) + | a => raise Fail ("Expected JSON object, got: " ^ Json.print a) + +fun parseInt (j: Json.json): int = + case j of + Json.Int i => i + | _ => raise Fail ("Expected JSON int, got: " ^ Json.print j) + +fun parseString (j: Json.json): string = + case j of + Json.String s => s + | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) + + +fun parseRequest (j: Json.json): {id: Json.json, method: string, params: Json.json} = + let + val id = getJsonObjectValue' "id" j + val method = parseString (getJsonObjectValue' "method" j) + val params = getJsonObjectValue' "params" j + in + {id = id, method = method, params = params} + end + + +type textDocumentIdentifier = + { scheme: string + , authority: string + , path: string + , query: string + , fragment: string + } +fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = + let + val str = Substring.full (parseString (getJsonObjectValue' "uri" j)) + val (scheme, rest) = Substring.splitl (fn c => c <> #":") str + val (authority, rest) = Substring.splitl (fn c => c <> #"/") (Substring.triml 3 rest (* :// *)) + val (path, rest) = Substring.splitl (fn c => c <> #"?" orelse c <> #"#") (Substring.triml 1 rest (* / *)) + val (query, rest) = if Substring.first rest = SOME #"?" + then Substring.splitl (fn c => c <> #"#") (Substring.triml 1 rest (* ? *)) + else (Substring.full "", rest) + val fragment = if Substring.first rest = SOME #"#" + then (Substring.triml 1 rest (* # *)) + else Substring.full "" + + in + { scheme = Substring.string scheme + , authority = Substring.string authority + , path = Substring.string path + , query = Substring.string query + , fragment = Substring.string fragment + } + end + +type position = { line: int + , character: int + } +fun parsePosition (j: Json.json) = + { line = parseInt (getJsonObjectValue' "line" j) + , character = parseInt (getJsonObjectValue' "character" j) + } + +datatype result = Success of Json.json + | Error of (int * string) + +fun handleHover (params: Json.json): result = + let + val textDocument = parseTextDocumentIdentifier (getJsonObjectValue' "textDocument" params) + val position = parsePosition (getJsonObjectValue' "position" params) + val answer = "" + in + Success (Json.Obj (("contents", Json.String answer) :: [])) + end + +fun serverLoop () = + let + val headers = readAllHeaders [] + val lengthO = List.find (fn (k,v) => k = "Content-Length") headers + val request = case lengthO of + NONE => raise Fail "No header with Content-Length found" + | SOME (k, v) => + case Int.fromString v of + NONE => raise Fail ("Couldn't parse content-length from string: " ^ v) + | SOME i => TextIO.inputN (TextIO.stdIn, i) + (* val parsed = Json.parse (Substring.string (Substring.trimr 1 (Substring.full request))) (* Trimming last newline *) *) + val parsed = Json.parse request + val requestMessage = parseRequest parsed + fun fail (err: (int * string)) = + Json.print (Json.Obj (("id", #id requestMessage) + :: ("error", Json.Obj (("code", Json.Int (#1 err)) + :: ("message", Json.String (#2 err)) + :: [])) + :: [] + )) + val result: result = + case #method requestMessage of + "initialize" => Success (Json.Obj (("capabilities", Json.Obj (("hoverProvider", Json.Bool true) :: [])) :: [])) + | "textDocument/hover" => handleHover (#params requestMessage) + | "shutdown" => Success (Json.Null) + | "exit" => OS.Process.exit OS.Process.success + | method => Error (~32601, "Method not supported: " ^ method) + in + case result of + Success j => TextIO.output (TextIO.stdOut, + Json.print (Json.Obj (("id", #id requestMessage) + :: ("result", j) + :: []))) + | Error (i, err) => + TextIO.output (TextIO.stdOut, + Json.print (Json.Obj (("id", #id requestMessage) + :: ("error", Json.Obj (("code", Json.Int i) + :: ("message", Json.String err) + :: [])) + :: [] + ))) + end + +fun startServer () = + while (1 < 2) do + serverLoop () +end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 7f8540f2..1747d702 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -253,6 +253,7 @@ fun oneRun args = 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), ("limit", TWO ("", "", add_class), diff --git a/src/sources b/src/sources index 20d77483..c407ea2a 100644 --- a/src/sources +++ b/src/sources @@ -277,6 +277,12 @@ $(SRC)/compiler.sml $(SRC)/getinfo.sig $(SRC)/getinfo.sml +$(SRC)/json.sig +$(SRC)/json.sml + +$(SRC)/lsp.sig +$(SRC)/lsp.sml + $(SRC)/demo.sig $(SRC)/demo.sml -- cgit v1.2.3 From be644b0be6acd3cdeb957d46e9477ea3e16599ba Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 11:32:02 +0100 Subject: Moved json and lsp code into seperate modules --- src/fromjson.sig | 8 + src/fromjson.sml | 35 ++++ src/lsp.sml | 537 ++----------------------------------------------------- src/lspspec.sml | 447 +++++++++++++++++++++++++++++++++++++++++++++ src/sources | 5 + 5 files changed, 506 insertions(+), 526 deletions(-) create mode 100644 src/fromjson.sig create mode 100644 src/fromjson.sml create mode 100644 src/lspspec.sml (limited to 'src/sources') diff --git a/src/fromjson.sig b/src/fromjson.sig new file mode 100644 index 00000000..3fdc1a89 --- /dev/null +++ b/src/fromjson.sig @@ -0,0 +1,8 @@ +signature FROMJSON = sig + val getO: string -> Json.json -> Json.json option + val get: string -> Json.json -> Json.json + val asInt: Json.json -> int + val asString: Json.json -> string + val asOptionalInt: Json.json -> int option + val asOptionalString: Json.json -> string option +end diff --git a/src/fromjson.sml b/src/fromjson.sml new file mode 100644 index 00000000..6a9bd71b --- /dev/null +++ b/src/fromjson.sml @@ -0,0 +1,35 @@ +structure FromJson :> 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 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 + Json.Int i => i + | _ => raise Fail ("Expected JSON int, got: " ^ Json.print j) + +fun asString (j: Json.json): string = + case j of + Json.String s => s + | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) + +fun asOptionalInt (j: Json.json): int option = + case j of + Json.Null => NONE + | Json.Int i => SOME i + | _ => raise Fail ("Expected JSON int or null, got: " ^ Json.print j) + +fun asOptionalString (j: Json.json): string option = + case j of + Json.Null => NONE + | Json.String s => SOME s + | _ => raise Fail ("Expected JSON string or null, got: " ^ Json.print j) +end diff --git a/src/lsp.sml b/src/lsp.sml index 920f9f35..d902fed4 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,519 +1,8 @@ structure C = Compiler -fun debug (str: string): unit = - (TextIO.output (TextIO.stdErr, str ^ "\n\n"); TextIO.flushOut TextIO.stdErr) - -fun trim (s: substring): substring = - Substring.dropr - (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") - (Substring.dropl (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") s) - -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 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 - Json.Int i => i - | _ => raise Fail ("Expected JSON int, got: " ^ Json.print j) - -fun asString (j: Json.json): string = - case j of - Json.String s => s - | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) - -fun asOptionalInt (j: Json.json): int option = - case j of - Json.Null => NONE - | Json.Int i => SOME i - | _ => raise Fail ("Expected JSON int or null, got: " ^ Json.print j) - -fun asOptionalString (j: Json.json): string option = - case j of - Json.Null => NONE - | Json.String s => SOME s - | _ => raise Fail ("Expected JSON string or null, got: " ^ Json.print j) -end - -structure LspSpec (* :> LSPSPEC *) = struct - fun readHeader (): (string * string) option = - let - val line = TextIO.inputLine TextIO.stdIn - in - case line of - NONE => OS.Process.exit OS.Process.success - | SOME str => - if Substring.isEmpty (trim (Substring.full str)) - then NONE - else - let - val (key, value) = Substring.splitl (fn c => c <> #":") (Substring.full str) - in - if Substring.isEmpty (trim value) - then raise Fail ("Failed to parse LSP header: Line is not empty but is also not a valid header: " ^ str) - else SOME ( Substring.string (trim key) - , Substring.string (trim (Substring.dropl (fn c => c = #":") (trim value)))) - end - end - - fun readAllHeaders (): (string * string) list = - let - fun doReadAllHeaders (l: (string * string) list): (string * string) list = - case readHeader () of - NONE => l - | SOME tup => tup :: doReadAllHeaders l - - in - doReadAllHeaders [] - end - datatype message = - RequestMessage of { id: Json.json, method: string, params: Json.json} - | Notification of { method: string, params: Json.json} - fun parseMessage (j: Json.json): message = - let - val id = SOME (FromJson.get "id" j) - handle ex => NONE - val method = FromJson.asString (FromJson.get "method" j) - val params = FromJson.get "params" j - in - case id of - NONE => Notification {method = method, params = params} - | SOME id => RequestMessage {id = id, method = method, params = params} - end - - type documentUri = - { scheme: string - , authority: string - , path: string - , query: string - , fragment: string - } - fun parseDocumentUri (str: string): documentUri = - let - val str = Substring.full str - val (scheme, rest) = Substring.splitl (fn c => c <> #":") str - val (authority, rest) = Substring.splitl (fn c => c <> #"/") (Substring.triml 3 rest (* :// *)) - val (path, rest) = Substring.splitl (fn c => c <> #"?" orelse c <> #"#") rest - val (query, rest) = if Substring.first rest = SOME #"?" - then Substring.splitl (fn c => c <> #"#") (Substring.triml 1 rest (* ? *)) - else (Substring.full "", rest) - val fragment = if Substring.first rest = SOME #"#" - then (Substring.triml 1 rest (* # *)) - else Substring.full "" - - in - { scheme = Substring.string scheme - , authority = Substring.string authority - , path = Substring.string path - , query = Substring.string query - , fragment = Substring.string fragment - } - end - fun printDocumentUri (d: documentUri) = - (#scheme d) ^ "://" ^ - (#authority d) ^ - (#path d) ^ - (if #query d <> "" then "?" ^ #query d else "") ^ - (if #fragment d <> "" then "#" ^ #fragment d else "") - - type textDocumentIdentifier = { uri: documentUri} - fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = - { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j))} - - type versionedTextDocumentIdentifier = - { uri: documentUri - , version: int option - } - fun parseVersionedTextDocumentIdentifier (j: Json.json): versionedTextDocumentIdentifier = - { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) - , version = FromJson.asOptionalInt (FromJson.get "version" j) - } - - type textDocumentItem = { - uri: documentUri, - languageId: string, - version: int, (* The version number of this document (it will increase after each change, including undo/redo). *) - text: string - } - fun parseTextDocumentItem (j: Json.json) = - { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) - , languageId = FromJson.asString (FromJson.get "languageId" j) - , version = FromJson.asInt (FromJson.get "version" j) - , text = FromJson.asString (FromJson.get "text" j) - } - - type position = { line: int - , character: int - } - fun parsePosition (j: Json.json) = - { line = FromJson.asInt (FromJson.get "line" j) - , character = FromJson.asInt (FromJson.get "character" j) - } - fun printPosition (p: position): Json.json = Json.Obj [ ("line", Json.Int (#line p)) - , ("character", Json.Int (#character p))] - - 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))] - - fun readRequestFromStdIO (): message = - let - val headers = readAllHeaders () - val lengthO = List.find (fn (k,v) => k = "Content-Length") headers - val request = case lengthO of - NONE => raise Fail "No header with Content-Length found" - | SOME (k, v) => - case Int.fromString v of - NONE => raise Fail ("Couldn't parse content-length from string: " ^ v) - | SOME i => TextIO.inputN (TextIO.stdIn, i) - val parsed = Json.parse request - in - parseMessage parsed - end - - type hoverReq = { textDocument: textDocumentIdentifier , position: position } - type hoverResp = {contents: string} option - fun parseHoverReq (params: Json.json): hoverReq = - { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) - , position = parsePosition (FromJson.get "position" params) - } - fun printHoverResponse (resp: hoverResp): Json.json = - case resp of - NONE => Json.Null - | SOME obj => Json.Obj [("contents", Json.String (#contents obj))] - - type didOpenParams = { textDocument: textDocumentItem } - fun parseDidOpenParams (params: Json.json): didOpenParams = - { textDocument = parseTextDocumentItem (FromJson.get "textDocument" params) } - - 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 = 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 } - fun parseDidSaveParams (params: Json.json): didSaveParams = - { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) - (* , text = ... *) - } - type didCloseParams = { textDocument: textDocumentIdentifier } - fun parseDidCloseParams (params: Json.json): didCloseParams = - { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) - } - type initializeParams = - { rootUri: documentUri option } - fun parseInitializeParams (j: Json.json) = - { rootUri = - Option.map - parseDocumentUri - (FromJson.asOptionalString (FromJson.get "rootUri" j)) - } - type diagnostic = { range: range - (* code?: number | string *) - , severity: int (* 1 = error, 2 = warning, 3 = info, 4 = hint*) - , source: string - , message: string - (* relatedInformation?: DiagnosticRelatedInformation[]; *) - } - fun printDiagnostic (d: diagnostic): Json.json = - Json.Obj [ ("range", printRange (#range d)) - , ("severity", Json.Int (#severity d)) - , ("source", Json.String (#source d)) - , ("message", Json.String (#message d)) - ] - type publishDiagnosticsParams = { uri: documentUri - , diagnostics: diagnostic list - } - 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 - } - }} - fun printInitializeResponse (res: initializeResponse) = - Json.Obj [("capabilities", - let - 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) )])] - end - )] - end - )] - - datatype 'a result = - Success of 'a - | Error of (int * string) - - fun mapResult (f: 'a -> 'b) (a: 'a result): 'b result = - case a of - Success contents => Success (f contents) - | Error e => Error e - type toclient = { showMessage: string -> int -> unit - , publishDiagnostics: publishDiagnosticsParams -> unit } - type messageHandlers = - { initialize: initializeParams -> initializeResponse result - , shutdown: unit -> unit result - , textDocument_hover: toclient -> hoverReq -> hoverResp result - , textDocument_completion: completionReq -> completionResp result - } - - fun showMessage str typ = - let - val jsonToPrint = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") - , ("method", Json.String "window/showMessage") - , ("params", Json.Obj [ ("type", Json.Int typ) - , ("message", Json.String str)]) - ]) - val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint - in - TextIO.print toPrint - end - fun publishDiagnostics diags = - let - val jsonToPrint = Json.print ((Json.Obj [ ("jsonrpc", Json.String "2.0") - , ("method", Json.String "textDocument/publishDiagnostics") - , ("params", printPublishDiagnosticsParams diags) - ])) - val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint - in - TextIO.print toPrint - end - val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} - - fun handleMessage - (requestMessage: {id: Json.json, method: string, params: Json.json}) - (handlers: messageHandlers) - : unit = - let - val result: Json.json result = - case #method requestMessage of - "initialize" => - mapResult - printInitializeResponse - ((#initialize handlers) - (parseInitializeParams (#params requestMessage))) - | "textDocument/hover" => - mapResult - printHoverResponse - ((#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 => (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 - case result of - Success j => - let - val jsonToPrint = - Json.print (Json.Obj [ ("id", #id requestMessage) - , ("jsonrpc", Json.String "2.0") - , ("result", j) - ]) - val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint - in - TextIO.print toPrint - end - | Error (i, err) => - let - val jsonToPrint = - Json.print (Json.Obj [ ("id", #id requestMessage) - , ("jsonrpc", Json.String "2.0") - , ("error", Json.Obj [ ("code", Json.Int i) - , ("message", Json.String err) - ]) - ]) - val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint - in - TextIO.print toPrint - end - end - - type notificationHandlers = - { initialized: unit -> unit - , textDocument_didOpen: toclient -> didOpenParams -> unit - , textDocument_didChange: toclient -> didChangeParams -> unit - , textDocument_didSave: toclient -> didSaveParams -> unit - , textDocument_didClose: toclient -> didCloseParams -> unit - } - fun handleNotification - (notification: {method: string, params: Json.json}) - (handlers: notificationHandlers) - = - case #method notification of - "initialized" => (#initialized handlers) () - | "textDocument/didOpen" => (#textDocument_didOpen handlers) toclient (parseDidOpenParams (#params notification)) - | "textDocument/didChange" => (#textDocument_didChange handlers) toclient (parseDidChangeParams (#params notification)) - | "textDocument/didSave" => (#textDocument_didSave handlers) toclient (parseDidSaveParams (#params notification)) - | "textDocument/didClose" => (#textDocument_didClose handlers) toclient (parseDidCloseParams (#params notification)) - | m => debug ("Notification method not supported: " ^ m) - -end structure Lsp :> LSP = struct - -datatype lspError = InternalError of string -exception LspError of lspError -fun handleLspErrorInNotification (e: lspError) : unit = - let - fun print (message: string) = - let - val jsonStr = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") - , ("method", Json.String "window/showMessage") - , ("params", Json.Obj [ ("type", Json.Int 1 (* Error*)) - , ("message", Json.String message)]) - ]) - in - TextIO.print ("Content-Length:" ^ Int.toString (String.size jsonStr) ^ "\r\n\r\n" ^ jsonStr) - end - in - case e of - InternalError str => print str - end -fun handleLspErrorInRequest (id: Json.json) (e: lspError): unit = - let - fun print (code: int) (message: string) = - let - val jsonStr = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") - , ("id", id) - , ("error", Json.Obj [ ("code", Json.Int code (* Error*)) - , ("message", Json.String message)]) - ]) - in - TextIO.print ("Content-Length:" ^ Int.toString (String.size jsonStr) ^ "\r\n\r\n" ^ jsonStr) - end - in - case e of - InternalError str => print (~32603) str - end +val debug = LspSpec.debug structure SK = struct type ord_key = string @@ -614,7 +103,7 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef val () = Elaborate.incremental := true (* Parsing .urp *) val job = case C.run (C.transform C.parseUrp "parseUrp") (#urpPath state) of - NONE => raise LspError (InternalError ("Couldn't parse .urp file at " ^ (#urpPath state))) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Couldn't parse .urp file at " ^ (#urpPath state))) | SOME a => a val moduleSearchRes = List.foldl @@ -629,7 +118,7 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef val modulesBeforeThisFile = #1 moduleSearchRes val () = if #2 moduleSearchRes then () - else raise LspError (InternalError ("Couldn't find file " ^ fileName ^ " referenced in .urp file at " ^ (#urpPath state))) + else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find file " ^ fileName ^ " referenced in .urp file at " ^ (#urpPath state))) (* Parsing .urs files of previous modules *) val parsedUrss = List.map (fn entry => let @@ -639,9 +128,9 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef , parsed = if OS.FileSys.access (fileName, []) then case C.run (C.transform C.parseUrs "parseUrs") fileName of - NONE => raise LspError (InternalError ("Failed to parse .urs file at " ^ fileName)) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse .urs file at " ^ fileName)) | SOME a => a - else raise LspError (InternalError ("Couldn't find an .urs file for " ^ fileName)) + else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find an .urs file for " ^ fileName)) } end) modulesBeforeThisFile @@ -655,15 +144,15 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef val parsedBasisUrs = case C.run (C.transform C.parseUrs "parseUrs") basisF of - NONE => raise LspError (InternalError ("Failed to parse basis.urs file at " ^ basisF)) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse basis.urs file at " ^ basisF)) | SOME a => a val parsedTopUrs = case C.run (C.transform C.parseUrs "parseUrs") topF of - NONE => raise LspError (InternalError ("Failed to parse top.urs file at " ^ topF)) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse top.urs file at " ^ topF)) | SOME a => a val parsedTopUr = case C.run (C.transform C.parseUr "parseUr") topF' of - NONE => raise LspError (InternalError ("Failed to parse top.ur file at " ^ topF')) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse top.ur file at " ^ topF')) | SOME a => a (* Parsing .ur and .urs of current file *) @@ -1031,10 +520,10 @@ fun handleDocumentDidClose (state: state) (toclient: LspSpec.toclient) (p: LspSp fun serverLoop () = let + val state = !stateRef val requestMessage = LspSpec.readRequestFromStdIO () handle ex => (debug (General.exnMessage ex) ; raise ex) - val state = !stateRef in case state of NONE => @@ -1065,7 +554,7 @@ fun serverLoop () = | SOME state => (case requestMessage of LspSpec.Notification n => - ((LspSpec.handleNotification + (LspSpec.handleNotification n { initialized = fn () => () , textDocument_didOpen = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) (SOME (#text (#textDocument p))) @@ -1073,19 +562,15 @@ fun serverLoop () = , textDocument_didSave = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) NONE , textDocument_didClose = fn toclient => fn p => handleDocumentDidClose state toclient p }) - handle LspError e => handleLspErrorInNotification e - | ex => handleLspErrorInNotification (InternalError (General.exnMessage ex))) | LspSpec.RequestMessage m => (* TODO should error handling here be inside handleMessage? *) - ((LspSpec.handleMessage + (LspSpec.handleMessage m { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") , shutdown = fn () => LspSpec.Success () , 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))) ) end diff --git a/src/lspspec.sml b/src/lspspec.sml new file mode 100644 index 00000000..7993038e --- /dev/null +++ b/src/lspspec.sml @@ -0,0 +1,447 @@ +structure LspSpec = struct + + datatype lspError = InternalError of string + exception LspError of lspError + + fun debug (str: string): unit = + (TextIO.output (TextIO.stdErr, str ^ "\n\n"); TextIO.flushOut TextIO.stdErr) + + fun trim (s: substring): substring = + Substring.dropr + (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") + (Substring.dropl (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") s) + + fun readHeader (): (string * string) option = + let + val line = TextIO.inputLine TextIO.stdIn + in + case line of + NONE => OS.Process.exit OS.Process.success + | SOME str => + if Substring.isEmpty (trim (Substring.full str)) + then NONE + else + let + val (key, value) = Substring.splitl (fn c => c <> #":") (Substring.full str) + in + if Substring.isEmpty (trim value) + then raise Fail ("Failed to parse LSP header: Line is not empty but is also not a valid header: " ^ str) + else SOME ( Substring.string (trim key) + , Substring.string (trim (Substring.dropl (fn c => c = #":") (trim value)))) + end + end + + fun readAllHeaders (): (string * string) list = + let + fun doReadAllHeaders (l: (string * string) list): (string * string) list = + case readHeader () of + NONE => l + | SOME tup => tup :: doReadAllHeaders l + + in + doReadAllHeaders [] + end + datatype message = + RequestMessage of { id: Json.json, method: string, params: Json.json} + | Notification of { method: string, params: Json.json} + fun parseMessage (j: Json.json): message = + let + val id = SOME (FromJson.get "id" j) + handle ex => NONE + val method = FromJson.asString (FromJson.get "method" j) + val params = FromJson.get "params" j + in + case id of + NONE => Notification {method = method, params = params} + | SOME id => RequestMessage {id = id, method = method, params = params} + end + + type documentUri = + { scheme: string + , authority: string + , path: string + , query: string + , fragment: string + } + fun parseDocumentUri (str: string): documentUri = + let + val str = Substring.full str + val (scheme, rest) = Substring.splitl (fn c => c <> #":") str + val (authority, rest) = Substring.splitl (fn c => c <> #"/") (Substring.triml 3 rest (* :// *)) + val (path, rest) = Substring.splitl (fn c => c <> #"?" orelse c <> #"#") rest + val (query, rest) = if Substring.first rest = SOME #"?" + then Substring.splitl (fn c => c <> #"#") (Substring.triml 1 rest (* ? *)) + else (Substring.full "", rest) + val fragment = if Substring.first rest = SOME #"#" + then (Substring.triml 1 rest (* # *)) + else Substring.full "" + + in + { scheme = Substring.string scheme + , authority = Substring.string authority + , path = Substring.string path + , query = Substring.string query + , fragment = Substring.string fragment + } + end + fun printDocumentUri (d: documentUri) = + (#scheme d) ^ "://" ^ + (#authority d) ^ + (#path d) ^ + (if #query d <> "" then "?" ^ #query d else "") ^ + (if #fragment d <> "" then "#" ^ #fragment d else "") + + type textDocumentIdentifier = { uri: documentUri} + fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j))} + + type versionedTextDocumentIdentifier = + { uri: documentUri + , version: int option + } + fun parseVersionedTextDocumentIdentifier (j: Json.json): versionedTextDocumentIdentifier = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) + , version = FromJson.asOptionalInt (FromJson.get "version" j) + } + + type textDocumentItem = { + uri: documentUri, + languageId: string, + version: int, (* The version number of this document (it will increase after each change, including undo/redo). *) + text: string + } + fun parseTextDocumentItem (j: Json.json) = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) + , languageId = FromJson.asString (FromJson.get "languageId" j) + , version = FromJson.asInt (FromJson.get "version" j) + , text = FromJson.asString (FromJson.get "text" j) + } + + type position = { line: int + , character: int + } + fun parsePosition (j: Json.json) = + { line = FromJson.asInt (FromJson.get "line" j) + , character = FromJson.asInt (FromJson.get "character" j) + } + fun printPosition (p: position): Json.json = Json.Obj [ ("line", Json.Int (#line p)) + , ("character", Json.Int (#character p))] + + 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))] + + fun readRequestFromStdIO (): message = + let + val headers = readAllHeaders () + val lengthO = List.find (fn (k,v) => k = "Content-Length") headers + val request = case lengthO of + NONE => raise Fail "No header with Content-Length found" + | SOME (k, v) => + case Int.fromString v of + NONE => raise Fail ("Couldn't parse content-length from string: " ^ v) + | SOME i => TextIO.inputN (TextIO.stdIn, i) + val parsed = Json.parse request + in + parseMessage parsed + end + + type hoverReq = { textDocument: textDocumentIdentifier , position: position } + type hoverResp = {contents: string} option + fun parseHoverReq (params: Json.json): hoverReq = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + , position = parsePosition (FromJson.get "position" params) + } + fun printHoverResponse (resp: hoverResp): Json.json = + case resp of + NONE => Json.Null + | SOME obj => Json.Obj [("contents", Json.String (#contents obj))] + + type didOpenParams = { textDocument: textDocumentItem } + fun parseDidOpenParams (params: Json.json): didOpenParams = + { textDocument = parseTextDocumentItem (FromJson.get "textDocument" params) } + + 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 = 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 } + fun parseDidSaveParams (params: Json.json): didSaveParams = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + (* , text = ... *) + } + type didCloseParams = { textDocument: textDocumentIdentifier } + fun parseDidCloseParams (params: Json.json): didCloseParams = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + } + type initializeParams = + { rootUri: documentUri option } + fun parseInitializeParams (j: Json.json) = + { rootUri = + Option.map + parseDocumentUri + (FromJson.asOptionalString (FromJson.get "rootUri" j)) + } + type diagnostic = { range: range + (* code?: number | string *) + , severity: int (* 1 = error, 2 = warning, 3 = info, 4 = hint*) + , source: string + , message: string + (* relatedInformation?: DiagnosticRelatedInformation[]; *) + } + fun printDiagnostic (d: diagnostic): Json.json = + Json.Obj [ ("range", printRange (#range d)) + , ("severity", Json.Int (#severity d)) + , ("source", Json.String (#source d)) + , ("message", Json.String (#message d)) + ] + type publishDiagnosticsParams = { uri: documentUri + , diagnostics: diagnostic list + } + 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 + } + }} + fun printInitializeResponse (res: initializeResponse) = + Json.Obj [("capabilities", + let + 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) )])] + end + )] + end + )] + + datatype 'a result = + Success of 'a + | Error of (int * string) + + fun mapResult (f: 'a -> 'b) (a: 'a result): 'b result = + case a of + Success contents => Success (f contents) + | Error e => Error e + type toclient = { showMessage: string -> int -> unit + , publishDiagnostics: publishDiagnosticsParams -> unit } + type messageHandlers = + { initialize: initializeParams -> initializeResponse result + , shutdown: unit -> unit result + , textDocument_hover: toclient -> hoverReq -> hoverResp result + , textDocument_completion: completionReq -> completionResp result + } + + fun showMessage str typ = + let + val jsonToPrint = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") + , ("method", Json.String "window/showMessage") + , ("params", Json.Obj [ ("type", Json.Int typ) + , ("message", Json.String str)]) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + fun publishDiagnostics diags = + let + val jsonToPrint = Json.print ((Json.Obj [ ("jsonrpc", Json.String "2.0") + , ("method", Json.String "textDocument/publishDiagnostics") + , ("params", printPublishDiagnosticsParams diags) + ])) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} + + fun handleMessage + (requestMessage: {id: Json.json, method: string, params: Json.json}) + (handlers: messageHandlers) + : unit = + let + val result: Json.json result = + ((case #method requestMessage of + "initialize" => + mapResult + printInitializeResponse + ((#initialize handlers) + (parseInitializeParams (#params requestMessage))) + | "textDocument/hover" => + mapResult + printHoverResponse + ((#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 => (debug ("Method not supported: " ^ method); + Error (~32601, "Method not supported: " ^ method))) + handle LspError (InternalError str) => Error (~32603, str) + | ex => Error (~32603, (General.exnMessage ex)) + ) + (* val () = (TextIO.output (TextIO.stdErr, "Got result: " ^ (case result of Success _ => "success\n" *) + (* | Error _ => "error\n")); TextIO.flushOut TextIO.stdErr) *) + in + case result of + Success j => + let + val jsonToPrint = + Json.print (Json.Obj [ ("id", #id requestMessage) + , ("jsonrpc", Json.String "2.0") + , ("result", j) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + | Error (i, err) => + let + val jsonToPrint = + Json.print (Json.Obj [ ("id", #id requestMessage) + , ("jsonrpc", Json.String "2.0") + , ("error", Json.Obj [ ("code", Json.Int i) + , ("message", Json.String err) + ]) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + end + + type notificationHandlers = + { initialized: unit -> unit + , textDocument_didOpen: toclient -> didOpenParams -> unit + , textDocument_didChange: toclient -> didChangeParams -> unit + , textDocument_didSave: toclient -> didSaveParams -> unit + , textDocument_didClose: toclient -> didCloseParams -> unit + } + fun handleNotification + (notification: {method: string, params: Json.json}) + (handlers: notificationHandlers) + = + (case #method notification of + "initialized" => (#initialized handlers) () + | "textDocument/didOpen" => (#textDocument_didOpen handlers) toclient (parseDidOpenParams (#params notification)) + | "textDocument/didChange" => (#textDocument_didChange handlers) toclient (parseDidChangeParams (#params notification)) + | "textDocument/didSave" => (#textDocument_didSave handlers) toclient (parseDidSaveParams (#params notification)) + | "textDocument/didClose" => (#textDocument_didClose handlers) toclient (parseDidCloseParams (#params notification)) + | m => debug ("Notification method not supported: " ^ m)) + handle LspError (InternalError str) => showMessage str 1 + | ex => showMessage (General.exnMessage ex) 1 + +end diff --git a/src/sources b/src/sources index c407ea2a..74171365 100644 --- a/src/sources +++ b/src/sources @@ -280,6 +280,11 @@ $(SRC)/getinfo.sml $(SRC)/json.sig $(SRC)/json.sml +$(SRC)/fromjson.sig +$(SRC)/fromjson.sml + +$(SRC)/lspspec.sml + $(SRC)/lsp.sig $(SRC)/lsp.sml -- cgit v1.2.3 From 586ebe1d29c591aa735e3ed9b7bfc1b1407b3d69 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sun, 15 Dec 2019 10:20:47 +0100 Subject: Added background threads --- src/bg_thread.sig | 7 ++++ src/bg_thread.sml | 67 ++++++++++++++++++++++++++++++++ src/lsp.sml | 111 ++++++++++++++++++++++++++++++++---------------------- src/sources | 4 ++ 4 files changed, 144 insertions(+), 45 deletions(-) create mode 100644 src/bg_thread.sig create mode 100644 src/bg_thread.sml (limited to 'src/sources') diff --git a/src/bg_thread.sig b/src/bg_thread.sig new file mode 100644 index 00000000..5455bbc8 --- /dev/null +++ b/src/bg_thread.sig @@ -0,0 +1,7 @@ +(* Notice: API is kinda bad. We only allow queuing a single task per file *) +(* This works for us because we only do elaboration in the background, nothing else *) +signature BGTHREAD = sig + val queueBgTask: string (* fileName *) -> (unit -> unit) -> unit + val hasBgTasks: unit -> bool + val runBgTaskForABit: unit -> unit +end diff --git a/src/bg_thread.sml b/src/bg_thread.sml new file mode 100644 index 00000000..c5eb723c --- /dev/null +++ b/src/bg_thread.sml @@ -0,0 +1,67 @@ +(* Notice: API is kinda bad. We only allow queuing a single task per file *) +(* This works for us because we only do elaboration in the background, nothing else *) + +structure BgThread:> BGTHREAD = struct + open Posix.Signal + open MLton + open Itimer Signal Thread + + val debug = LspSpec.debug + + val topLevel: Thread.Runnable.t option ref = ref NONE + val currentRunningThreadIsForFileName: string ref = ref "" + (* FIFO queue: Max one task per fileName *) + val tasks: ((Thread.Runnable.t * string) list) ref = ref [] + fun hasBgTasks () = List.length (!tasks) > 0 + + fun setItimer t = + Itimer.set (Itimer.Real, + {value = t, + interval = t}) + + + fun done () = Thread.atomically + (fn () => + ( tasks := (List.filter (fn q => #2 q <> (!currentRunningThreadIsForFileName)) (!tasks)) + ; case !tasks of + [] => (setItimer Time.zeroTime + ; currentRunningThreadIsForFileName := "" + ; switch (fn _ => valOf (!topLevel))) + | t :: rest => (currentRunningThreadIsForFileName := #2 t + ; switch (fn _ => #1 t)))) + + fun queueBgTask fileName f = + let + fun new (f: unit -> unit): Thread.Runnable.t = + Thread.prepare + (Thread.new (fn () => ((f () handle _ => done ()) + ; done ())), + ()) + in + case List.find (fn t => #2 t = fileName) (!tasks) of + NONE => tasks := (new f, fileName) :: (!tasks) + | SOME t => + (* Move existing task to front of list *) + tasks := t :: List.filter (fn q => #2 q <> fileName) (!tasks) + end + + fun replaceInList (l: 'a list) (f: 'a -> bool) (replacement: 'a) = + List.map (fn a => if f a then replacement else a ) l + fun runBgTaskForABit () = + case !(tasks) of + [] => () + | t :: rest => + (setHandler (alrm, Handler.handler (fn t => (setItimer Time.zeroTime + (* This might some not needed, but other wise you get "Dead thread" error *) + ; tasks := replaceInList + (!tasks) + (fn t => #2 t = (!currentRunningThreadIsForFileName)) + (t, (!currentRunningThreadIsForFileName)) + ; currentRunningThreadIsForFileName := "" + ; valOf (!topLevel)))) + ; setItimer (Time.fromMilliseconds 200) + ; currentRunningThreadIsForFileName := #2 t + ; switch (fn top => (topLevel := SOME (Thread.prepare (top, ())); #1 t)) (* store top level thread and activate BG thread *) + ; setItimer Time.zeroTime + ) + end diff --git a/src/lsp.sml b/src/lsp.sml index 23b54a28..79b96ef9 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -480,7 +480,7 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion , l2_) , _)) , l1_)) :: _ => - (debug "!!"; getCompletionsFromFields env (name ^ ".") (Substring.string str) fields) + getCompletionsFromFields env (name ^ ".") (Substring.string str) fields | _ => []) end | _ => @@ -500,13 +500,10 @@ fun handleCompletion (state: state) (p: LspSpec.completionReq) = 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 @@ -550,54 +547,78 @@ fun handleDocumentDidChange (state: state) (toclient: LspSpec.toclient) (p: LspS State.insertText fileName (List.foldl applyContentChange (#text s) (#contentChanges p)) end +fun runInBackground toclient (fileName: string) (f: unit -> unit): unit = + BgThread.queueBgTask + fileName + ((fn () => (f () + handle LspSpec.LspError (LspSpec.InternalError str) => (#showMessage toclient) str 1 + | LspSpec.LspError LspSpec.ServerNotInitialized => (#showMessage toclient) "Server not initialized" 1 + | ex => (#showMessage toclient) (General.exnMessage ex) 1 + ; (#showMessage toclient) ("Done running BG job for " ^ fileName) 3 + ))) + fun handleRequest (requestMessage: LspSpec.message) = case requestMessage of LspSpec.Notification n => - (LspSpec.matchNotification - n - { initialized = fn () => () - , textDocument_didOpen = - fn (p, toclient) => State.withState (fn state => - (State.insertText (#path (#uri (#textDocument p))) (#text (#textDocument p)) ; - elabFileAndSendDiags state toclient (#uri (#textDocument p)))) - , textDocument_didChange = - fn (p, toclient) => State.withState (fn state => handleDocumentDidChange state toclient p) - , textDocument_didSave = - fn (p, toclient) => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p))) - , textDocument_didClose = - fn (p, toclient) => State.removeFile (#path (#uri (#textDocument p))) - }) + LspSpec.matchNotification + n + { initialized = fn () => () + , textDocument_didOpen = + fn (p, toclient) => + (State.insertText (#path (#uri (#textDocument p))) (#text (#textDocument p)); + runInBackground + toclient + (#path (#uri (#textDocument p))) + (fn () => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p))))) + , textDocument_didChange = + fn (p, toclient) => + State.withState (fn state => handleDocumentDidChange state toclient p) + , textDocument_didSave = + fn (p, toclient) => + runInBackground + toclient + (#path (#uri (#textDocument p))) + (fn () => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p)))) + , textDocument_didClose = + fn (p, toclient) => + State.removeFile (#path (#uri (#textDocument p))) + } | LspSpec.RequestMessage m => (* TODO should error handling here be inside handleMessage? *) - (LspSpec.matchMessage - m - { initialize = fn p => - (let val st = initState p - in - State.init st; - LspSpec.Success - { capabilities = - { hoverProvider = true - , completionProvider = SOME { triggerCharacters = ["."]} - , textDocumentSync = { openClose = true - , change = 2 - , save = SOME { includeText = false } - }} - } - end) - , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn toclient => State.withState handleHover - , textDocument_completion = State.withState handleCompletion - }) + LspSpec.matchMessage + m + { initialize = fn p => + (let val st = initState p + in + State.init st; + LspSpec.Success + { capabilities = + { hoverProvider = true + , completionProvider = SOME { triggerCharacters = ["."]} + , textDocumentSync = { openClose = true + , change = 2 + , save = SOME { includeText = false } + }} + } + end) + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = fn toclient => State.withState handleHover + , textDocument_completion = fn p => State.withState (fn s => handleCompletion s p) + } fun serverLoop () = - let - val requestMessage = - LspSpec.readRequestFromStdIO () - handle ex => (debug (General.exnMessage ex) ; raise ex) - in - handleRequest requestMessage - end + if not (Option.isSome (TextIO.canInput (TextIO.stdIn, 1))) andalso BgThread.hasBgTasks () + then + (* no input waiting -> give control to lower prio thread *) + BgThread.runBgTaskForABit () + else + let + val requestMessage = + LspSpec.readRequestFromStdIO () + handle ex => (debug ("Error in reading from stdIn: " ^ General.exnMessage ex) ; raise ex) + in + handleRequest requestMessage + end fun startServer () = while true do serverLoop () end diff --git a/src/sources b/src/sources index 74171365..686832cc 100644 --- a/src/sources +++ b/src/sources @@ -285,6 +285,10 @@ $(SRC)/fromjson.sml $(SRC)/lspspec.sml +$(SML_LIB)/basis/mlton.mlb +$(SRC)/bg_thread.sig +$(SRC)/bg_thread.sml + $(SRC)/lsp.sig $(SRC)/lsp.sml -- cgit v1.2.3 From 874e3bc001e64ba058d6632ebe22fbcdac16c00d Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 8 Jan 2020 12:09:57 +0100 Subject: Add bg_thread.dummy.sml to mock MLton threads in sml/nj --- derivation.nix | 2 +- src/bg_thread.dummy.sml | 9 +++++++ src/bg_thread.mlton.sml | 65 +++++++++++++++++++++++++++++++++++++++++++++++ src/bg_thread.sml | 67 ------------------------------------------------- src/prefix.cm | 2 ++ src/prefix.mlb | 3 +++ src/sources | 4 --- 7 files changed, 80 insertions(+), 72 deletions(-) create mode 100644 src/bg_thread.dummy.sml create mode 100644 src/bg_thread.mlton.sml delete mode 100644 src/bg_thread.sml (limited to 'src/sources') diff --git a/derivation.nix b/derivation.nix index 19582948..e197372e 100644 --- a/derivation.nix +++ b/derivation.nix @@ -18,7 +18,7 @@ stdenv.mkDerivation rec { # rev = "e52ce9f542f64750941cfd84efdb6d993ee20ff0"; # sha256 = "19ba5n7g1dxy7q9949aakqplchsyzwrrnxv8v604vx5sg7fdfn3b"; # }; - src = nix-gitignore.gitignoreSource [] ./.; + src = ./.; buildInputs = [ openssl mlton mysql.connector-c postgresql sqlite automake autoconf libtool icu.dev openssl.dev]; diff --git a/src/bg_thread.dummy.sml b/src/bg_thread.dummy.sml new file mode 100644 index 00000000..699fa741 --- /dev/null +++ b/src/bg_thread.dummy.sml @@ -0,0 +1,9 @@ +(* + Dummy implementation. Threading is only supported in MLton. + All other implementations just immediately run the background tasks +*) +structure BgThread:> BGTHREAD = struct + fun queueBgTask filename f = f () + fun hasBgTasks () = false + fun runBgTaskForABit () = () +end diff --git a/src/bg_thread.mlton.sml b/src/bg_thread.mlton.sml new file mode 100644 index 00000000..91195940 --- /dev/null +++ b/src/bg_thread.mlton.sml @@ -0,0 +1,65 @@ +(* Notice: API is kinda bad. We only allow queuing a single task per file *) +(* This works for us because we only do elaboration in the background, nothing else *) + +structure BgThread:> BGTHREAD = struct + open Posix.Signal + open MLton + open Itimer Signal Thread + + val topLevel: Thread.Runnable.t option ref = ref NONE + val currentRunningThreadIsForFileName: string ref = ref "" + (* FIFO queue: Max one task per fileName *) + val tasks: ((Thread.Runnable.t * string) list) ref = ref [] + fun hasBgTasks () = List.length (!tasks) > 0 + + fun setItimer t = + Itimer.set (Itimer.Real, + {value = t, + interval = t}) + + + fun done () = Thread.atomically + (fn () => + ( tasks := (List.filter (fn q => #2 q <> (!currentRunningThreadIsForFileName)) (!tasks)) + ; case !tasks of + [] => (setItimer Time.zeroTime + ; currentRunningThreadIsForFileName := "" + ; switch (fn _ => valOf (!topLevel))) + | t :: rest => (currentRunningThreadIsForFileName := #2 t + ; switch (fn _ => #1 t)))) + + fun queueBgTask fileName f = + let + fun new (f: unit -> unit): Thread.Runnable.t = + Thread.prepare + (Thread.new (fn () => ((f () handle _ => done ()) + ; done ())), + ()) + in + case List.find (fn t => #2 t = fileName) (!tasks) of + NONE => tasks := (new f, fileName) :: (!tasks) + | SOME t => + (* Move existing task to front of list *) + tasks := t :: List.filter (fn q => #2 q <> fileName) (!tasks) + end + + fun replaceInList (l: 'a list) (f: 'a -> bool) (replacement: 'a) = + List.map (fn a => if f a then replacement else a ) l + fun runBgTaskForABit () = + case !(tasks) of + [] => () + | t :: rest => + (setHandler (alrm, Handler.handler (fn t => (setItimer Time.zeroTime + (* This might some not needed, but other wise you get "Dead thread" error *) + ; tasks := replaceInList + (!tasks) + (fn t => #2 t = (!currentRunningThreadIsForFileName)) + (t, (!currentRunningThreadIsForFileName)) + ; currentRunningThreadIsForFileName := "" + ; valOf (!topLevel)))) + ; setItimer (Time.fromMilliseconds 200) + ; currentRunningThreadIsForFileName := #2 t + ; switch (fn top => (topLevel := SOME (Thread.prepare (top, ())); #1 t)) (* store top level thread and activate BG thread *) + ; setItimer Time.zeroTime + ) + end diff --git a/src/bg_thread.sml b/src/bg_thread.sml deleted file mode 100644 index c5eb723c..00000000 --- a/src/bg_thread.sml +++ /dev/null @@ -1,67 +0,0 @@ -(* Notice: API is kinda bad. We only allow queuing a single task per file *) -(* This works for us because we only do elaboration in the background, nothing else *) - -structure BgThread:> BGTHREAD = struct - open Posix.Signal - open MLton - open Itimer Signal Thread - - val debug = LspSpec.debug - - val topLevel: Thread.Runnable.t option ref = ref NONE - val currentRunningThreadIsForFileName: string ref = ref "" - (* FIFO queue: Max one task per fileName *) - val tasks: ((Thread.Runnable.t * string) list) ref = ref [] - fun hasBgTasks () = List.length (!tasks) > 0 - - fun setItimer t = - Itimer.set (Itimer.Real, - {value = t, - interval = t}) - - - fun done () = Thread.atomically - (fn () => - ( tasks := (List.filter (fn q => #2 q <> (!currentRunningThreadIsForFileName)) (!tasks)) - ; case !tasks of - [] => (setItimer Time.zeroTime - ; currentRunningThreadIsForFileName := "" - ; switch (fn _ => valOf (!topLevel))) - | t :: rest => (currentRunningThreadIsForFileName := #2 t - ; switch (fn _ => #1 t)))) - - fun queueBgTask fileName f = - let - fun new (f: unit -> unit): Thread.Runnable.t = - Thread.prepare - (Thread.new (fn () => ((f () handle _ => done ()) - ; done ())), - ()) - in - case List.find (fn t => #2 t = fileName) (!tasks) of - NONE => tasks := (new f, fileName) :: (!tasks) - | SOME t => - (* Move existing task to front of list *) - tasks := t :: List.filter (fn q => #2 q <> fileName) (!tasks) - end - - fun replaceInList (l: 'a list) (f: 'a -> bool) (replacement: 'a) = - List.map (fn a => if f a then replacement else a ) l - fun runBgTaskForABit () = - case !(tasks) of - [] => () - | t :: rest => - (setHandler (alrm, Handler.handler (fn t => (setItimer Time.zeroTime - (* This might some not needed, but other wise you get "Dead thread" error *) - ; tasks := replaceInList - (!tasks) - (fn t => #2 t = (!currentRunningThreadIsForFileName)) - (t, (!currentRunningThreadIsForFileName)) - ; currentRunningThreadIsForFileName := "" - ; valOf (!topLevel)))) - ; setItimer (Time.fromMilliseconds 200) - ; currentRunningThreadIsForFileName := #2 t - ; switch (fn top => (topLevel := SOME (Thread.prepare (top, ())); #1 t)) (* store top level thread and activate BG thread *) - ; setItimer Time.zeroTime - ) - end diff --git a/src/prefix.cm b/src/prefix.cm index 2e71d073..eab0bf71 100644 --- a/src/prefix.cm +++ b/src/prefix.cm @@ -4,4 +4,6 @@ $/basis.cm $/smlnj-lib.cm $smlnj/ml-yacc/ml-yacc-lib.cm $/pp-lib.cm +$(SRC)/bg_thread.sig +$(SRC)/bg_thread.dummy.sml diff --git a/src/prefix.mlb b/src/prefix.mlb index 6a510481..13122fcf 100644 --- a/src/prefix.mlb +++ b/src/prefix.mlb @@ -3,5 +3,8 @@ local $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb $(SML_LIB)/smlnj-lib/PP/pp-lib.mlb + $(SML_LIB)/basis/mlton.mlb + $(SRC)/bg_thread.sig + $(SRC)/bg_thread.mlton.sml in diff --git a/src/sources b/src/sources index 686832cc..74171365 100644 --- a/src/sources +++ b/src/sources @@ -285,10 +285,6 @@ $(SRC)/fromjson.sml $(SRC)/lspspec.sml -$(SML_LIB)/basis/mlton.mlb -$(SRC)/bg_thread.sig -$(SRC)/bg_thread.sml - $(SRC)/lsp.sig $(SRC)/lsp.sml -- cgit v1.2.3