From 562694cbb5beb31906610b7eabf42a56087673b5 Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Sun, 7 Jul 2019 17:55:02 +0200 Subject: First iteration of more detailed elaboration caching --- src/elaborate.sml | 26 +++++++++++++++++++------- src/errormsg.sig | 4 ++++ src/errormsg.sml | 21 ++++++++++++++++++++- src/mod_db.sig | 4 +++- src/mod_db.sml | 47 +++++++++++++++++++++++++++++++++++++++++------ 5 files changed, 87 insertions(+), 15 deletions(-) diff --git a/src/elaborate.sml b/src/elaborate.sml index 97b36a0b..3547d784 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2800,7 +2800,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ([(L'.SgiClass (x, n, k, c'), loc)], (env, denv, [])) end) -and elabSgn (env, denv) (sgn, loc) = +and elabSgn (env, denv) (sgn, loc): (L'.sgn * D.goal list) = case sgn of L.SgnConst sgis => let @@ -4165,6 +4165,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = | NONE => let val () = if !verbose then TextIO.print ("CHECK: " ^ x ^ "\n") else () + val () = ErrorMsg.startElabStructure x val () = if x = "Basis" then raise Fail "Not allowed to redefine structure 'Basis'" @@ -4206,7 +4207,13 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = L'.StrFun _ => () | _ => strError env (FunctorRebind loc)) | _ => (); - Option.map (fn tm => ModDb.insert (dNew, tm)) tmo; + Option.map (fn tm => ModDb.insert (dNew, + tm, + ErrorMsg.stopElabStructureAndGetErrored x, + case sgno of + NONE => true + | SOME sgn => false + )) tmo; ([dNew], (env', denv', gs' @ gs)) end) @@ -4221,6 +4228,8 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = end | NONE => let + val () = ErrorMsg.startElabStructure x + val (sgn', gs') = elabSgn (env, denv) sgn val (env', n) = E.pushStrNamed env x sgn' @@ -4239,7 +4248,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = epreface ("item", p_sgn_item env sgi))) | _ => raise Fail "FFI signature isn't SgnConst"; - Option.map (fn tm => ModDb.insert (dNew, tm)) tmo; + Option.map (fn tm => ModDb.insert (dNew, tm, ErrorMsg.stopElabStructureAndGetErrored x, false)) tmo; ([dNew], (env', denv, enD gs' @ gs)) end) @@ -4735,6 +4744,8 @@ fun resolveClass env = E.resolveClass (hnormCon env) (consEq env dummy) env fun elabFile basis basis_tm topStr topSgn top_tm env file = let val () = ModDb.snapshot () + val () = ErrorMsg.resetStructureTracker () + val () = mayDelay := true val () = delayedUnifs := [] @@ -4756,7 +4767,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (env', basis_n) = E.pushStrNamed env "Basis" sgn in - ModDb.insert ((L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan), basis_tm); + ModDb.insert ((L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan), basis_tm, false, false); (* TODO: also check for errors? *) (basis_n, env', sgn) end | SOME (d' as (L'.DFfiStr (_, basis_n, sgn), _)) => @@ -4815,7 +4826,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (env', top_n) = E.pushStrNamed env' "Top" topSgn in - ModDb.insert ((L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan), top_tm); + ModDb.insert ((L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan), top_tm, false, false); (* TODO: also check for errors? *) (top_n, env', topSgn, topStr) end | SOME (d' as (L'.DStr (_, top_n, topSgn, topStr), _)) => @@ -5099,9 +5110,10 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = (); if ErrorMsg.anyErrors () then - ModDb.revert () + () else - (); + ModDb.flagAllOk (); + (*Print.preface("File", ElabPrint.p_file env file);*) diff --git a/src/errormsg.sig b/src/errormsg.sig index 92425842..b4a508d9 100644 --- a/src/errormsg.sig +++ b/src/errormsg.sig @@ -48,6 +48,10 @@ signature ERROR_MSG = sig val posOf : int -> pos val spanOf : int * int -> span + val startElabStructure : string -> unit + val stopElabStructureAndGetErrored : string -> bool (* Did the module elab encounter errors? *) + + val resetStructureTracker: unit -> unit val resetErrors : unit -> unit val anyErrors : unit -> bool val error : string -> unit diff --git a/src/errormsg.sml b/src/errormsg.sml index 8f3c93b1..eee20768 100644 --- a/src/errormsg.sml +++ b/src/errormsg.sml @@ -88,12 +88,31 @@ fun spanOf (pos1, pos2) = {file = !file, val errors = ref false +val structuresCurrentlyElaborating: ((string * bool) list) ref = ref nil + +fun startElabStructure s = + structuresCurrentlyElaborating := ((s, false) :: !structuresCurrentlyElaborating) +fun stopElabStructureAndGetErrored s = + let + val errored = + case List.find (fn x => #1 x = s) (!structuresCurrentlyElaborating) of + NONE => false + | SOME tup => #2 tup + val () = structuresCurrentlyElaborating := + (List.filter (fn x => #1 x <> s) (!structuresCurrentlyElaborating)) + in + errored + end +fun resetStructureTracker () = + structuresCurrentlyElaborating := [] fun resetErrors () = errors := false fun anyErrors () = !errors fun error s = (TextIO.output (TextIO.stdErr, s); TextIO.output1 (TextIO.stdErr, #"\n"); - errors := true) + errors := true; + structuresCurrentlyElaborating := + List.map (fn (s, e) => (s, true)) (!structuresCurrentlyElaborating)) fun errorAt (span : span) s = (TextIO.output (TextIO.stdErr, #file span); TextIO.output (TextIO.stdErr, ":"); diff --git a/src/mod_db.sig b/src/mod_db.sig index 8f78f2c2..f4bf661a 100644 --- a/src/mod_db.sig +++ b/src/mod_db.sig @@ -30,12 +30,14 @@ signature MOD_DB = sig val reset : unit -> unit - val insert : Elab.decl * Time.time -> unit + val insert : Elab.decl * Time.time * bool (* hasErrors *) * bool (* hasInference *) -> unit (* Here's a declaration, including the modification timestamp of the file it came from. * We might invalidate other declarations that depend on this one, if the timestamp has changed. *) val lookup : Source.decl -> Elab.decl option + val flagAllOk : unit -> unit + (* Allow undoing to snapshots after failed compilations. *) val snapshot : unit -> unit val revert : unit -> unit diff --git a/src/mod_db.sml b/src/mod_db.sml index 2d6b285b..53bcdc7e 100644 --- a/src/mod_db.sml +++ b/src/mod_db.sml @@ -42,7 +42,10 @@ structure IM = IntBinaryMap type oneMod = {Decl : decl, When : Time.time, - Deps : SS.set} + Deps : SS.set, + HasErrors: bool, + HasInference: bool + } val byName = ref (SM.empty : oneMod SM.map) val byId = ref (IM.empty : string IM.map) @@ -50,7 +53,25 @@ val byId = ref (IM.empty : string IM.map) fun reset () = (byName := SM.empty; byId := IM.empty) -fun insert (d, tm) = +fun printByName (bn: oneMod SM.map): unit = + (TextIO.print ("Contents of ModDb.byName: \n"); + List.app (fn tup => + let + val name = #1 tup + val m = #2 tup + val renderedDeps = String.concatWith ", " (SS.listItems (#Deps m)) + val renderedMod = + " " ^ name + ^ ". Stored at : " ^ Time.toString (#When m) + ^", HasErrors: " ^ Bool.toString (#HasErrors m) + ^", HasInference: " ^ Bool.toString (#HasInference m) + ^". Deps: " ^ renderedDeps ^"\n" + in + TextIO.print renderedMod + end) + (SM.listItemsi bn)) + +fun insert (d, tm, hasErrors, hasInference) = let val xn = case #1 d of @@ -73,7 +94,10 @@ fun insert (d, tm) = let fun doMod (n', deps) = case IM.find (!byId, n') of - NONE => deps + NONE => raise Fail ("ModDb: Trying to make dep tree but couldn't find module " ^ Int.toString n') + (* This should probably throw: *) + (* Trying to add a dep for a module but can't find the dep... *) + (* That will always cause a hole in the dependency tree and cause problems down the line *) | SOME x' => SS.union (deps, SS.add (case SM.find (!byName, x') of @@ -118,8 +142,12 @@ fun insert (d, tm) = x, {Decl = d, When = tm, - Deps = deps}); + Deps = deps, + HasErrors = hasErrors, + HasInference = hasInference + }); byId := IM.insert (!byId, n, x) + (* printByName (!byName) *) end end end @@ -130,7 +158,7 @@ fun lookup (d : Source.decl) = (case SM.find (!byName, x) of NONE => NONE | SOME r => - if tm = #When r then + if tm = #When r andalso not (#HasErrors r) andalso not (#HasInference r) then SOME (#Decl r) else NONE) @@ -138,7 +166,7 @@ fun lookup (d : Source.decl) = (case SM.find (!byName, x) of NONE => NONE | SOME r => - if tm = #When r then + if tm = #When r andalso not (#HasErrors r) andalso not (#HasInference r) then SOME (#Decl r) else NONE) @@ -147,6 +175,13 @@ fun lookup (d : Source.decl) = val byNameBackup = ref (!byName) val byIdBackup = ref (!byId) +fun flagAllOk () = byName := SM.map (fn r => { Decl = #Decl r + , When = #When r + , Deps = #Deps r + , HasErrors = #HasErrors r + , HasInference = false + }) (!byName) + fun snapshot () = (byNameBackup := !byName; byIdBackup := !byId) fun revert () = (byName := !byNameBackup; byId := !byIdBackup) -- cgit v1.2.3 From bc67c873a23309d2ef9e8365e0a9b7f8f15577ca Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Mon, 29 Jul 2019 11:09:28 +0200 Subject: Don't use interfaces anymore for ModDb validity, but check for undetermined unif vars --- src/elaborate.sml | 17 ++++----------- src/main.mlton.sml | 6 ++++-- src/mod_db.sig | 4 +--- src/mod_db.sml | 63 ++++++++++++++++++++++++++++++++++++++---------------- 4 files changed, 54 insertions(+), 36 deletions(-) diff --git a/src/elaborate.sml b/src/elaborate.sml index 3547d784..1c76250f 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -4209,10 +4209,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = | _ => (); Option.map (fn tm => ModDb.insert (dNew, tm, - ErrorMsg.stopElabStructureAndGetErrored x, - case sgno of - NONE => true - | SOME sgn => false + ErrorMsg.stopElabStructureAndGetErrored x )) tmo; ([dNew], (env', denv', gs' @ gs)) end) @@ -4248,7 +4245,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = epreface ("item", p_sgn_item env sgi))) | _ => raise Fail "FFI signature isn't SgnConst"; - Option.map (fn tm => ModDb.insert (dNew, tm, ErrorMsg.stopElabStructureAndGetErrored x, false)) tmo; + Option.map (fn tm => ModDb.insert (dNew, tm, ErrorMsg.stopElabStructureAndGetErrored x)) tmo; ([dNew], (env', denv, enD gs' @ gs)) end) @@ -4767,7 +4764,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (env', basis_n) = E.pushStrNamed env "Basis" sgn in - ModDb.insert ((L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan), basis_tm, false, false); (* TODO: also check for errors? *) + ModDb.insert ((L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan), basis_tm, false); (* TODO: also check for errors? *) (basis_n, env', sgn) end | SOME (d' as (L'.DFfiStr (_, basis_n, sgn), _)) => @@ -4826,7 +4823,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (env', top_n) = E.pushStrNamed env' "Top" topSgn in - ModDb.insert ((L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan), top_tm, false, false); (* TODO: also check for errors? *) + ModDb.insert ((L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan), top_tm, false); (* TODO: also check for errors? *) (top_n, env', topSgn, topStr) end | SOME (d' as (L'.DStr (_, top_n, topSgn, topStr), _)) => @@ -5109,12 +5106,6 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = else (); - if ErrorMsg.anyErrors () then - () - else - ModDb.flagAllOk (); - - (*Print.preface("File", ElabPrint.p_file env file);*) (L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan) diff --git a/src/main.mlton.sml b/src/main.mlton.sml index bfa40265..cb7c8a77 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -435,10 +435,12 @@ val () = (Globals.setResetTime (); wrs = [Socket.sockDesc sock], exs = [], timeout = SOME (Time.fromSeconds 1)}))) then - (app (fn arg => send (sock, arg ^ "\n")) args; + (TextIO.print "Using daemon\n"; + app (fn arg => send (sock, arg ^ "\n")) args; send (sock, "\n"); OS.Process.exit (wait ())) else (OS.FileSys.remove socket; raise OS.SysErr ("", NONE)) - end handle OS.SysErr _ => OS.Process.exit (oneRun args)) + end handle OS.SysErr _ => + OS.Process.exit (oneRun args)) diff --git a/src/mod_db.sig b/src/mod_db.sig index f4bf661a..c45fd203 100644 --- a/src/mod_db.sig +++ b/src/mod_db.sig @@ -30,14 +30,12 @@ signature MOD_DB = sig val reset : unit -> unit - val insert : Elab.decl * Time.time * bool (* hasErrors *) * bool (* hasInference *) -> unit + val insert : Elab.decl * Time.time * bool (* hasErrors *) -> unit (* Here's a declaration, including the modification timestamp of the file it came from. * We might invalidate other declarations that depend on this one, if the timestamp has changed. *) val lookup : Source.decl -> Elab.decl option - val flagAllOk : unit -> unit - (* Allow undoing to snapshots after failed compilations. *) val snapshot : unit -> unit val revert : unit -> unit diff --git a/src/mod_db.sml b/src/mod_db.sml index 53bcdc7e..2e2b9c6c 100644 --- a/src/mod_db.sml +++ b/src/mod_db.sml @@ -43,8 +43,7 @@ structure IM = IntBinaryMap type oneMod = {Decl : decl, When : Time.time, Deps : SS.set, - HasErrors: bool, - HasInference: bool + HasErrors: bool } val byName = ref (SM.empty : oneMod SM.map) @@ -59,19 +58,43 @@ fun printByName (bn: oneMod SM.map): unit = let val name = #1 tup val m = #2 tup - val renderedDeps = String.concatWith ", " (SS.listItems (#Deps m)) + val renderedDeps = + String.concatWith ", " (SS.listItems (#Deps m)) val renderedMod = " " ^ name ^ ". Stored at : " ^ Time.toString (#When m) ^", HasErrors: " ^ Bool.toString (#HasErrors m) - ^", HasInference: " ^ Bool.toString (#HasInference m) ^". Deps: " ^ renderedDeps ^"\n" in TextIO.print renderedMod end) (SM.listItemsi bn)) -fun insert (d, tm, hasErrors, hasInference) = +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, + con = fn _ => false, + exp = fn e => case e of + EUnif (ref NONE) => true + | _ => false, + sgn_item = fn _ => false, + sgn = fn _ => false, + str = fn _ => false, + decl = fn _ => false} + d + +fun insert (d, tm, hasErrors) = let val xn = case #1 d of @@ -83,10 +106,13 @@ fun insert (d, tm, hasErrors, hasInference) = NONE => () | SOME (x, n) => let + (* Keep module when it's file didn't change and it was OK before *) val skipIt = case SM.find (!byName, x) of NONE => false | SOME r => #When r = tm + andalso not (#HasErrors r) + andalso not (dContainsUndeterminedUnif (#Decl r)) in if skipIt then () @@ -94,8 +120,16 @@ fun insert (d, tm, hasErrors, hasInference) = let fun doMod (n', deps) = case IM.find (!byId, n') of - NONE => raise Fail ("ModDb: Trying to make dep tree but couldn't find module " ^ Int.toString n') - (* This should probably throw: *) + NONE => + (TextIO.print ("MISSED_DEP: " ^ Int.toString n' ^"\n"); + deps) + (* raise Fail ("ModDb: Trying to make dep tree but couldn't find module " ^ Int.toString n') *) + (* I feel like this should throw, but the dependency searching algorithm *) + (* is not 100% precise. I encountered problems in json.urs: *) + (* datatype r = Rec of M.t r *) + (* M is the structure passed to the Recursive functor, so this is not an external dependency *) + (* I'm just not sure how to filter these out yet *) + (* I still think this should throw: *) (* Trying to add a dep for a module but can't find the dep... *) (* That will always cause a hole in the dependency tree and cause problems down the line *) | SOME x' => @@ -143,11 +177,11 @@ fun insert (d, tm, hasErrors, hasInference) = {Decl = d, When = tm, Deps = deps, - HasErrors = hasErrors, - HasInference = hasInference + HasErrors = hasErrors }); byId := IM.insert (!byId, n, x) (* printByName (!byName) *) + (* printById (!byId) *) end end end @@ -158,7 +192,7 @@ fun lookup (d : Source.decl) = (case SM.find (!byName, x) of NONE => NONE | SOME r => - if tm = #When r andalso not (#HasErrors r) andalso not (#HasInference r) then + if tm = #When r andalso not (#HasErrors r) andalso not (dContainsUndeterminedUnif (#Decl r)) then SOME (#Decl r) else NONE) @@ -166,7 +200,7 @@ fun lookup (d : Source.decl) = (case SM.find (!byName, x) of NONE => NONE | SOME r => - if tm = #When r andalso not (#HasErrors r) andalso not (#HasInference r) then + if tm = #When r andalso not (#HasErrors r) andalso not (dContainsUndeterminedUnif (#Decl r)) then SOME (#Decl r) else NONE) @@ -175,13 +209,6 @@ fun lookup (d : Source.decl) = val byNameBackup = ref (!byName) val byIdBackup = ref (!byId) -fun flagAllOk () = byName := SM.map (fn r => { Decl = #Decl r - , When = #When r - , Deps = #Deps r - , HasErrors = #HasErrors r - , HasInference = false - }) (!byName) - fun snapshot () = (byNameBackup := !byName; byIdBackup := !byId) fun revert () = (byName := !byNameBackup; byId := !byIdBackup) -- cgit v1.2.3 From 83bab4581d9570e151b23db3b4de016600afa76d Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Mon, 29 Jul 2019 11:15:53 +0200 Subject: Removed MISSED_DEP print --- src/mod_db.sml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/mod_db.sml b/src/mod_db.sml index 2e2b9c6c..de428570 100644 --- a/src/mod_db.sml +++ b/src/mod_db.sml @@ -121,7 +121,8 @@ fun insert (d, tm, hasErrors) = fun doMod (n', deps) = case IM.find (!byId, n') of NONE => - (TextIO.print ("MISSED_DEP: " ^ Int.toString n' ^"\n"); + ( + (* TextIO.print ("MISSED_DEP: " ^ Int.toString n' ^"\n"); *) deps) (* raise Fail ("ModDb: Trying to make dep tree but couldn't find module " ^ Int.toString n') *) (* I feel like this should throw, but the dependency searching algorithm *) -- cgit v1.2.3 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/compiler.sig | 1 + src/compiler.sml | 187 +++++++++++ src/elab_util_pos.sig | 63 ++++ src/elab_util_pos.sml | 910 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/main.mlton.sml | 6 + src/mod_db.sig | 2 + src/mod_db.sml | 9 + src/search.sig | 5 + src/search.sml | 8 + src/sources | 3 + 10 files changed, 1194 insertions(+) create mode 100644 src/elab_util_pos.sig create mode 100644 src/elab_util_pos.sml diff --git a/src/compiler.sig b/src/compiler.sig index 6ed2f9a6..7f724b0f 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -215,6 +215,7 @@ 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 0aba3a40..46a035ee 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1781,4 +1781,191 @@ fun moduleOf fname = end end +fun isPosIn row col span = + let + val start = #first span + val end_ = #last span + in + ((#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 (decl, deps) => + let + (* TODO Top is not always found as a dep *) + 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 to environment *) + val env = + case #1 decl of + Elab.DStr (name, _, sgn, str) => + (case #1 str of + Elab.StrConst decls => + List.foldl + (fn (d, e) => ElabEnv.declBinds e d) + env + decls + | _ => env) + | Elab.DFfiStr _ => env + | _ => env + (* Look for item under cursor *) + val (atPosition, env) = + ElabUtilPos.Decl.foldB + { kind = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Kind (k, span), env) + else acc , + con = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Con (k, span), env) + else acc, + exp = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Exp (k, span), env) + else acc, + sgn_item = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Sgn_item (k, span), env) + else acc, + sgn = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Sgn (k, span), env) + else acc, + str = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Str (k, span), env) + else acc, + decl = fn (env, (k, span), acc) => + if isPosIn row col span andalso isSmallerThan span (getSpan acc) + then (Decl (k, span), env) + else 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 + (Decl (#1 decl, { file = file + , first = { line = 0, char = 0} + , last = { line = 99999, char = 0} }) + , env) + decl + in + case atPosition of + Kind k => + Print.box [Print.PD.string "Not implemented yet, KIND: ", ElabPrint.p_kind env k] + | Con c => + Print.box [Print.PD.string "Not implemented yet, CON: ", ElabPrint.p_con env c] + | Exp (Elab.EPrim p, _) => + 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, _) => + ((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, _) => + ((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) => + (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 => Print.box [Print.PD.string "Not implemented yet, EXP: ", ElabPrint.p_exp env e] + | Sgn_item si => Print.box [Print.PD.string "Not implemented yet, SGN_ITEM: ", ElabPrint.p_sgn_item env si] + | Sgn s => Print.box [Print.PD.string "Not implemented yet, SGN: ", ElabPrint.p_sgn env s] + | Str s => Print.box [Print.PD.string "Not implemented yet, STR: ", ElabPrint.p_str env s] + | Decl d => Print.box [Print.PD.string "Not implemented yet, DECL: ", ElabPrint.p_decl env d] + 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) => + Print.box [getTypeAt file row col, Print.PD.string "\n"] + | _ => 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 new file mode 100644 index 00000000..f616f7f3 --- /dev/null +++ b/src/elab_util_pos.sig @@ -0,0 +1,63 @@ +(* Copyright (c) 2008-2010, 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 ELAB_UTIL_POS = sig + + val mliftConInCon : (int -> Elab.con -> Elab.con) ref + + structure Decl : sig + datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | RelE of string * Elab.con + | NamedE of string * Elab.con + | Str of string * int * Elab.sgn + | Sgn of string * int * Elab.sgn + + val fold : {kind : Elab.kind * 'state -> 'state, + con : Elab.con * 'state -> 'state, + exp : Elab.exp * 'state -> 'state, + sgn_item : Elab.sgn_item * 'state -> 'state, + sgn : Elab.sgn * 'state -> 'state, + str : Elab.str * 'state -> 'state, + decl : Elab.decl * 'state -> 'state} + -> 'state -> Elab.decl -> 'state + + val foldB : {kind : 'context * Elab.kind * 'state -> 'state, + con : 'context * Elab.con * 'state -> 'state, + exp : 'context * Elab.exp * 'state -> 'state, + sgn_item : 'context * Elab.sgn_item * 'state -> 'state, + sgn : 'context * Elab.sgn * 'state -> 'state, + str : 'context * Elab.str * 'state -> 'state, + decl : 'context * Elab.decl * 'state -> 'state, + bind: 'context * binder -> 'context + } + -> 'context -> 'state -> Elab.decl -> 'state + end + +end diff --git a/src/elab_util_pos.sml b/src/elab_util_pos.sml new file mode 100644 index 00000000..d8d1bfdd --- /dev/null +++ b/src/elab_util_pos.sml @@ -0,0 +1,910 @@ +(* Copyright (c) 2008-2010, 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 ElabUtilPos :> ELAB_UTIL_POS = struct + +open Elab + +structure S = Search + +structure Kind = struct + +fun mapfoldB {kind, bind} = + let + fun mfk ctx k acc = + S.bindPWithPos (mfk' ctx k acc, kind ctx) + + and mfk' ctx (kAll as (k, loc)) = + case k of + KType => S.return2 kAll + + | KArrow (k1, k2) => + S.bind2 (mfk ctx k1, + fn k1' => + S.map2 (mfk ctx k2, + fn k2' => + (KArrow (k1', k2'), loc))) + + | KName => S.return2 kAll + + | KRecord k => + S.map2 (mfk ctx k, + fn k' => + (KRecord k', loc)) + + | KUnit => S.return2 kAll + + | KTuple ks => + S.map2 (ListUtil.mapfold (mfk ctx) ks, + fn ks' => + (KTuple ks', loc)) + + | KError => S.return2 kAll + + | KUnif (_, _, ref (KKnown k)) => mfk' ctx k + | KUnif _ => S.return2 kAll + + | KTupleUnif (_, _, ref (KKnown k)) => mfk' ctx k + | KTupleUnif (loc, nks, r) => + S.map2 (ListUtil.mapfold (fn (n, k) => + S.map2 (mfk ctx k, + fn k' => + (n, k'))) nks, + fn nks' => + (KTupleUnif (loc, nks', r), loc)) + + + | KRel _ => S.return2 kAll + | KFun (x, k) => + S.map2 (mfk (bind (ctx, x)) k, + fn k' => + (KFun (x, k'), loc)) + in + mfk + end + +end + +val mliftConInCon = ref (fn n : int => fn c : con => (raise Fail "You didn't set ElabUtil.mliftConInCon!") : con) + +structure Con = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + +fun mapfoldB {kind = fk, con = fc, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, s) => bind (ctx, RelK s)} + + fun mfc ctx c acc = + S.bindPWithPos (mfc' ctx c acc, fc ctx) + + and mfc' ctx (cAll as (c, loc)) = + case c of + TFun (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (TFun (c1', c2'), loc))) + | TCFun (e, x, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc (bind (ctx, RelC (x, k))) c, + fn c' => + (TCFun (e, x, k', c'), loc))) + | TDisjoint (c1, c2, c3) => + S.bind2 (mfc ctx c1, + fn c1' => + S.bind2 (mfc ctx c2, + fn c2' => + S.map2 (mfc ctx c3, + fn c3' => + (TDisjoint (c1', c2', c3'), loc)))) + | TRecord c => + S.map2 (mfc ctx c, + fn c' => + (TRecord c', loc)) + + | CRel _ => S.return2 cAll + | CNamed _ => S.return2 cAll + | CModProj _ => S.return2 cAll + | CApp (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (CApp (c1', c2'), loc))) + | CAbs (x, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc (bind (ctx, RelC (x, k))) c, + fn c' => + (CAbs (x, k', c'), loc))) + + | CName _ => S.return2 cAll + + | CRecord (k, xcs) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (ListUtil.mapfold (fn (x, c) => + S.bind2 (mfc ctx x, + fn x' => + S.map2 (mfc ctx c, + fn c' => + (x', c')))) + xcs, + fn xcs' => + (CRecord (k', xcs'), loc))) + | CConcat (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (CConcat (c1', c2'), loc))) + | CMap (k1, k2) => + S.bind2 (mfk ctx k1, + fn k1' => + S.map2 (mfk ctx k2, + fn k2' => + (CMap (k1', k2'), loc))) + + | CUnit => S.return2 cAll + + | CTuple cs => + S.map2 (ListUtil.mapfold (mfc ctx) cs, + fn cs' => + (CTuple cs', loc)) + + | CProj (c, n) => + S.map2 (mfc ctx c, + fn c' => + (CProj (c', n), loc)) + + | CError => S.return2 cAll + | CUnif (nl, _, _, _, ref (Known c)) => mfc' ctx (!mliftConInCon nl c) + | CUnif _ => S.return2 cAll + + | CKAbs (x, c) => + S.map2 (mfc (bind (ctx, RelK x)) c, + fn c' => + (CKAbs (x, c'), loc)) + | CKApp (c, k) => + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfk ctx k, + fn k' => + (CKApp (c', k'), loc))) + | TKFun (x, c) => + S.map2 (mfc (bind (ctx, RelK x)) c, + fn c' => + (TKFun (x, c'), loc)) + in + mfc + end + +end + +structure Exp = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | RelE of string * Elab.con + | NamedE of string * Elab.con + +fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun bind' (ctx, b) = + let + val b' = case b of + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x + in + bind (ctx, b') + end + val mfc = Con.mapfoldB {kind = fk, con = fc, bind = bind'} + + fun doVars ((p, _), ctx) = + case p of + PVar xt => bind (ctx, RelE xt) + | PPrim _ => ctx + | PCon (_, _, _, NONE) => ctx + | PCon (_, _, _, SOME p) => doVars (p, ctx) + | PRecord xpcs => + foldl (fn ((_, p, _), ctx) => doVars (p, ctx)) + ctx xpcs + + fun mfe ctx e acc = + S.bindPWithPos (mfe' ctx e acc, fe ctx) + + and mfe' ctx (eAll as (e, loc)) = + case e of + EPrim _ => S.return2 eAll + | ERel _ => S.return2 eAll + | ENamed _ => S.return2 eAll + | EModProj _ => S.return2 eAll + | EApp (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (EApp (e1', e2'), loc))) + | EAbs (x, dom, ran, e) => + S.bind2 (mfc ctx dom, + fn dom' => + S.bind2 (mfc ctx ran, + fn ran' => + S.map2 (mfe (bind (ctx, RelE (x, dom'))) e, + fn e' => + (EAbs (x, dom', ran', e'), loc)))) + + | ECApp (e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (ECApp (e', c'), loc))) + | ECAbs (expl, x, k, e) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfe (bind (ctx, RelC (x, k))) e, + fn e' => + (ECAbs (expl, x, k', e'), loc))) + + | ERecord xes => + S.map2 (ListUtil.mapfold (fn (x, e, t) => + S.bind2 (mfc ctx x, + fn x' => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx t, + fn t' => + (x', e', t'))))) + xes, + fn xes' => + (ERecord xes', loc)) + | EField (e, c, {field, rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.bind2 (mfc ctx field, + fn field' => + S.map2 (mfc ctx rest, + fn rest' => + (EField (e', c', {field = field', rest = rest'}), loc))))) + | EConcat (e1, c1, e2, c2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.bind2 (mfc ctx c1, + fn c1' => + S.bind2 (mfe ctx e2, + fn e2' => + S.map2 (mfc ctx c2, + fn c2' => + (EConcat (e1', c1', e2', c2'), + loc))))) + | ECut (e, c, {field, rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.bind2 (mfc ctx field, + fn field' => + S.map2 (mfc ctx rest, + fn rest' => + (ECut (e', c', {field = field', rest = rest'}), loc))))) + + | ECutMulti (e, c, {rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfc ctx rest, + fn rest' => + (ECutMulti (e', c', {rest = rest'}), loc)))) + + | ECase (e, pes, {disc, result}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (ListUtil.mapfold (fn (p, e) => + let + fun pb ((p, _), ctx) = + case p of + PVar (x, t) => bind (ctx, RelE (x, t)) + | PPrim _ => ctx + | PCon (_, _, _, NONE) => ctx + | PCon (_, _, _, SOME p) => pb (p, ctx) + | PRecord xps => foldl (fn ((_, p, _), ctx) => + pb (p, ctx)) ctx xps + in + S.bind2 (mfp ctx p, + fn p' => + S.map2 (mfe (pb (p', ctx)) e, + fn e' => (p', e'))) + end) pes, + fn pes' => + S.bind2 (mfc ctx disc, + fn disc' => + S.map2 (mfc ctx result, + fn result' => + (ECase (e', pes', {disc = disc', result = result'}), loc))))) + + | EError => S.return2 eAll + | EUnif (ref (SOME e)) => mfe ctx e + | EUnif _ => S.return2 eAll + + | ELet (des, e, t) => + let + val (des, ctx') = foldl (fn (ed, (des, ctx)) => + let + val ctx' = + case #1 ed of + EDVal (p, _, _) => doVars (p, ctx) + | EDValRec vis => + foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) + ctx vis + in + (S.bind2 (des, + fn des' => + S.map2 (mfed ctx ed, + fn ed' => ed' :: des')), + ctx') + end) + (S.return2 [], ctx) des + in + S.bind2 (des, + fn des' => + S.bind2 (mfe ctx' e, + fn e' => + S.map2 (mfc ctx t, + fn t' => + (ELet (rev des', e', t'), loc)))) + end + + | EKAbs (x, e) => + S.map2 (mfe (bind (ctx, RelK x)) e, + fn e' => + (EKAbs (x, e'), loc)) + | EKApp (e, k) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfk ctx k, + fn k' => + (EKApp (e', k'), loc))) + + and mfp ctx (pAll as (p, loc)) = + case p of + PVar (x, t) => + S.map2 (mfc ctx t, + fn t' => + (PVar (x, t'), loc)) + | PPrim _ => S.return2 pAll + | PCon (dk, pc, args, po) => + S.bind2 (ListUtil.mapfold (mfc ctx) args, + fn args' => + S.map2 ((case po of + NONE => S.return2 NONE + | SOME p => S.map2 (mfp ctx p, SOME)), + fn po' => + (PCon (dk, pc, args', po'), loc))) + | PRecord xps => + S.map2 (ListUtil.mapfold (fn (x, p, c) => + S.bind2 (mfp ctx p, + fn p' => + S.map2 (mfc ctx c, + fn c' => + (x, p', c')))) xps, + fn xps' => + (PRecord xps', loc)) + + and mfed ctx (dAll as (d, loc)) = + case d of + EDVal (p, t, e) => + S.bind2 (mfc ctx t, + fn t' => + S.map2 (mfe ctx e, + fn e' => + (EDVal (p, t', e'), loc))) + | EDValRec vis => + let + val ctx = foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis + in + S.map2 (ListUtil.mapfold (mfvi ctx) vis, + fn vis' => + (EDValRec vis', loc)) + end + + and mfvi ctx (x, c, e) = + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfe ctx e, + fn e' => + (x, c', e'))) + in + mfe + end + +end + +structure Sgn = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | Str of string * int * Elab.sgn + | Sgn of string * int * Elab.sgn + +fun mapfoldB {kind, con, sgn_item, sgn, bind} = + let + fun bind' (ctx, b) = + let + val b' = case b of + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x + in + bind (ctx, b') + end + val con = Con.mapfoldB {kind = kind, con = con, bind = bind'} + + val kind = Kind.mapfoldB {kind = kind, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun sgi ctx si acc = + S.bindPWithPos (sgi' ctx si acc, sgn_item ctx) + + and sgi' ctx (siAll as (si, loc)) = + case si of + SgiConAbs (x, n, k) => + S.map2 (kind ctx k, + fn k' => + (SgiConAbs (x, n, k'), loc)) + | SgiCon (x, n, k, c) => + S.bind2 (kind ctx k, + fn k' => + S.map2 (con ctx c, + fn c' => + (SgiCon (x, n, k', c'), loc))) + | SgiDatatype dts => + S.map2 (ListUtil.mapfold (fn (x, n, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (con ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => (x, n, xs, xncs'))) dts, + fn dts' => + (SgiDatatype dts', loc)) + | SgiDatatypeImp (x, n, m1, ms, s, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (con ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (SgiDatatypeImp (x, n, m1, ms, s, xs, xncs'), loc)) + | SgiVal (x, n, c) => + S.map2 (con ctx c, + fn c' => + (SgiVal (x, n, c'), loc)) + | SgiStr (im, x, n, s) => + S.map2 (sg ctx s, + fn s' => + (SgiStr (im, x, n, s'), loc)) + | SgiSgn (x, n, s) => + S.map2 (sg ctx s, + fn s' => + (SgiSgn (x, n, s'), loc)) + | SgiConstraint (c1, c2) => + S.bind2 (con ctx c1, + fn c1' => + S.map2 (con ctx c2, + fn c2' => + (SgiConstraint (c1', c2'), loc))) + | SgiClassAbs (x, n, k) => + S.map2 (kind ctx k, + fn k' => + (SgiClassAbs (x, n, k'), loc)) + | SgiClass (x, n, k, c) => + S.bind2 (kind ctx k, + fn k' => + S.map2 (con ctx c, + fn c' => + (SgiClass (x, n, k', c'), loc))) + + and sg ctx s acc = + S.bindPWithPos (sg' ctx s acc, sgn ctx) + + and sg' ctx (sAll as (s, loc)) = + case s of + SgnConst sgis => + S.map2 (ListUtil.mapfoldB (fn (ctx, si) => + (case #1 si of + SgiConAbs (x, n, k) => + bind (ctx, NamedC (x, n, k, NONE)) + | SgiCon (x, n, k, c) => + bind (ctx, NamedC (x, n, k, SOME c)) + | SgiDatatype dts => + foldl (fn ((x, n, ks, _), ctx) => + let + val k' = (KType, loc) + val k = foldl (fn (_, k) => (KArrow (k', k), loc)) + k' ks + in + bind (ctx, NamedC (x, n, k, NONE)) + end) ctx dts + | SgiDatatypeImp (x, n, m1, ms, s, _, _) => + bind (ctx, NamedC (x, n, (KType, loc), + SOME (CModProj (m1, ms, s), loc))) + | SgiVal _ => ctx + | SgiStr (_, x, n, sgn) => + bind (ctx, Str (x, n, sgn)) + | SgiSgn (x, n, sgn) => + bind (ctx, Sgn (x, n, sgn)) + | SgiConstraint _ => ctx + | SgiClassAbs (x, n, k) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc), NONE)) + | SgiClass (x, n, k, c) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc), SOME c)), + sgi ctx si)) ctx sgis, + fn sgis' => + (SgnConst sgis', loc)) + + | SgnVar _ => S.return2 sAll + | SgnFun (m, n, s1, s2) => + S.bind2 (sg ctx s1, + fn s1' => + S.map2 (sg (bind (ctx, Str (m, n, s1'))) s2, + fn s2' => + (SgnFun (m, n, s1', s2'), loc))) + | SgnProj _ => S.return2 sAll + | SgnWhere (sgn, ms, x, c) => + S.bind2 (sg ctx sgn, + fn sgn' => + S.map2 (con ctx c, + fn c' => + (SgnWhere (sgn', ms, x, c'), loc))) + | SgnError => S.return2 sAll + in + sg + end + +end + +structure Decl = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | RelE of string * Elab.con + | NamedE of string * Elab.con + | Str of string * int * Elab.sgn + | Sgn of string * int * Elab.sgn + +fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = fst, decl = fd, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun bind' (ctx, b) = + let + val b' = case b of + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x + in + bind (ctx, b') + end + val mfc = Con.mapfoldB {kind = fk, con = fc, bind = bind'} + + fun bind' (ctx, b) = + let + val b' = case b of + Exp.RelK x => RelK x + | Exp.RelC x => RelC x + | Exp.NamedC x => NamedC x + | Exp.RelE x => RelE x + | Exp.NamedE x => NamedE x + in + bind (ctx, b') + end + val mfe = Exp.mapfoldB {kind = fk, con = fc, exp = fe, bind = bind'} + + fun bind' (ctx, b) = + let + val b' = case b of + Sgn.RelK x => RelK x + | Sgn.RelC x => RelC x + | Sgn.NamedC x => NamedC x + | Sgn.Sgn x => Sgn x + | Sgn.Str x => Str x + in + bind (ctx, b') + end + val mfsg = Sgn.mapfoldB {kind = fk, con = fc, sgn_item = fsgi, sgn = fsg, bind = bind'} + + fun mfst ctx str acc = + S.bindPWithPos (mfst' ctx str acc, fst ctx) + + and mfst' ctx (strAll as (str, loc)) = + case str of + StrConst ds => + S.map2 (ListUtil.mapfoldB (fn (ctx, d) => + (case #1 d of + DCon (x, n, k, c) => + bind (ctx, NamedC (x, n, k, SOME c)) + | DDatatype dts => + let + fun doOne ((x, n, xs, xncs), ctx) = + let + val ctx = bind (ctx, NamedC (x, n, (KType, loc), NONE)) + in + foldl (fn ((x, _, co), ctx) => + let + val t = + case co of + NONE => CNamed n + | SOME t => TFun (t, (CNamed n, loc)) + + val k = (KType, loc) + val t = (t, loc) + val t = foldr (fn (x, t) => + (TCFun (Explicit, + x, + k, + t), loc)) + t xs + in + bind (ctx, NamedE (x, t)) + end) + ctx xncs + end + in + foldl doOne ctx dts + end + | DDatatypeImp (x, n, m, ms, x', _, _) => + bind (ctx, NamedC (x, n, (KType, loc), + SOME (CModProj (m, ms, x'), loc))) + | DVal (x, _, c, _) => + bind (ctx, NamedE (x, c)) + | DValRec vis => + foldl (fn ((x, _, c, _), ctx) => bind (ctx, NamedE (x, c))) ctx vis + | DSgn (x, n, sgn) => + bind (ctx, Sgn (x, n, sgn)) + | DStr (x, n, sgn, _) => + bind (ctx, Str (x, n, sgn)) + | DFfiStr (x, n, sgn) => + bind (ctx, Str (x, n, sgn)) + | DConstraint _ => ctx + | DExport _ => ctx + | DTable (tn, x, n, c, _, pc, _, cc) => + let + val ct = (CModProj (n, [], "sql_table"), loc) + val ct = (CApp (ct, c), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) + in + bind (ctx, NamedE (x, ct)) + end + | DSequence (tn, x, n) => + bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc))) + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (n, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + bind (ctx, NamedE (x, ct)) + end + | DDatabase _ => ctx + | DCookie (tn, x, n, c) => + bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), + c), loc))) + | DStyle (tn, x, n) => + bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) + | DTask _ => ctx + | DPolicy _ => ctx + | DOnError _ => ctx + | DFfi (x, _, _, t) => bind (ctx, NamedE (x, t)), + mfd ctx d)) ctx ds, + fn ds' => (StrConst ds', loc)) + | StrVar _ => S.return2 strAll + | StrProj (str, x) => + S.map2 (mfst ctx str, + fn str' => + (StrProj (str', x), loc)) + | StrFun (x, n, sgn1, sgn2, str) => + S.bind2 (mfsg ctx sgn1, + fn sgn1' => + S.bind2 (mfsg ctx sgn2, + fn sgn2' => + S.map2 (mfst ctx str, + fn str' => + (StrFun (x, n, sgn1', sgn2', str'), loc)))) + | StrApp (str1, str2) => + S.bind2 (mfst ctx str1, + fn str1' => + S.map2 (mfst ctx str2, + fn str2' => + (StrApp (str1', str2'), loc))) + | StrError => S.return2 strAll + + and mfd ctx d acc = + S.bindPWithPos (mfd' ctx d acc, fd ctx) + + and mfd' ctx (dAll as (d, loc)) = + case d of + DCon (x, n, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc ctx c, + fn c' => + (DCon (x, n, k', c'), loc))) + | DDatatype dts => + S.map2 (ListUtil.mapfold (fn (x, n, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (mfc ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (x, n, xs, xncs'))) dts, + fn dts' => + (DDatatype dts', loc)) + | DDatatypeImp (x, n, m1, ms, s, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (mfc ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (DDatatypeImp (x, n, m1, ms, s, xs, xncs'), loc)) + | DVal vi => + S.map2 (mfvi ctx vi, + fn vi' => + (DVal vi', loc)) + | DValRec vis => + S.map2 (ListUtil.mapfold (mfvi ctx) vis, + fn vis' => + (DValRec vis', loc)) + | DSgn (x, n, sgn) => + S.map2 (mfsg ctx sgn, + fn sgn' => + (DSgn (x, n, sgn'), loc)) + | DStr (x, n, sgn, str) => + S.bind2 (mfsg ctx sgn, + fn sgn' => + S.map2 (mfst ctx str, + fn str' => + (DStr (x, n, sgn', str'), loc))) + | DFfiStr (x, n, sgn) => + S.map2 (mfsg ctx sgn, + fn sgn' => + (DFfiStr (x, n, sgn'), loc)) + | DConstraint (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (DConstraint (c1', c2'), loc))) + | DExport (en, sgn, str) => + S.bind2 (mfsg ctx sgn, + fn sgn' => + S.map2 (mfst ctx str, + fn str' => + (DExport (en, sgn', str'), loc))) + + | DTable (tn, x, n, c, pe, pc, ce, cc) => + S.bind2 (mfc ctx c, + fn c' => + S.bind2 (mfe ctx pe, + fn pe' => + S.bind2 (mfc ctx pc, + fn pc' => + S.bind2 (mfe ctx ce, + fn ce' => + S.map2 (mfc ctx cc, + fn cc' => + (DTable (tn, x, n, c', pe', pc', ce', cc'), loc)))))) + | DSequence _ => S.return2 dAll + | DView (tn, x, n, e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (DView (tn, x, n, e', c'), loc))) + + | DDatabase _ => S.return2 dAll + + | DCookie (tn, x, n, c) => + S.map2 (mfc ctx c, + fn c' => + (DCookie (tn, x, n, c'), loc)) + | DStyle _ => S.return2 dAll + | DTask (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (DTask (e1', e2'), loc))) + | DPolicy e1 => + S.map2 (mfe ctx e1, + fn e1' => + (DPolicy e1', loc)) + | DOnError _ => S.return2 dAll + | DFfi (x, n, modes, t) => + S.map2 (mfc ctx t, + fn t' => + (DFfi (x, n, modes, t'), loc)) + + and mfvi ctx (x, n, c, e) = + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfe ctx e, + fn e' => + (x, n, c', e'))) + in + mfd + end + + fun fold {kind, con, exp, sgn_item, sgn, str, decl} (st : 'a) d : 'a = + case mapfoldB {kind = fn () => fn k => fn st => S.Continue (#1 k, kind (k, st)), + con = fn () => fn c => fn st => S.Continue (#1 c, con (c, st)), + exp = fn () => fn e => fn st => S.Continue (#1 e, exp (e, st)), + sgn_item = fn () => fn sgi => fn st => S.Continue (#1 sgi, sgn_item (sgi, st)), + sgn = fn () => fn s => fn st => S.Continue (#1 s, sgn (s, st)), + str = fn () => fn str' => fn st => S.Continue (#1 str', str (str', st)), + decl = fn () => fn d => fn st => S.Continue (#1 d, decl (d, st)), + bind = fn ((), _) => () + } () d st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Decl.fold: Impossible" + + fun foldB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx (st : 'a) d : 'a = + case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (#1 k, kind (ctx, k, st)), + con = fn ctx => fn c => fn st => S.Continue (#1 c, con (ctx, c, st)), + exp = fn ctx => fn e => fn st => S.Continue (#1 e, exp (ctx, e, st)), + sgn_item = fn ctx => fn sgi => fn st => S.Continue (#1 sgi, sgn_item (ctx, sgi, st)), + sgn = fn ctx => fn s => fn st => S.Continue (#1 s, sgn (ctx, s, st)), + str = fn ctx => fn str' => fn st => S.Continue (#1 str', str (ctx, str', st)), + decl = fn ctx => fn d => fn st => S.Continue (#1 d, decl (ctx, d, st)), + bind = bind + } ctx d st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Decl.foldB: Impossible" + end +end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index cb7c8a77..8e70e398 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -139,6 +139,10 @@ fun oneRun args = fun printModuleOf fname = print_and_exit (Compiler.moduleOf fname) () + fun typeOf loc = + (Print.print (Compiler.typeOf loc); + raise Code OS.Process.success) + fun add_class (class, num) = case Int.fromString num of NONE => raise Fail ("Invalid limit number '" ^ num ^ "'") @@ -245,6 +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"), ("noEmacs", set_true Demo.noEmacs, NONE), ("limit", TWO ("", "", add_class), diff --git a/src/mod_db.sig b/src/mod_db.sig index c45fd203..40cd52e2 100644 --- a/src/mod_db.sig +++ b/src/mod_db.sig @@ -36,6 +36,8 @@ signature MOD_DB = sig val lookup : Source.decl -> Elab.decl option + val lookupForTooling : string -> (Elab.decl * Elab.decl list) option + (* Allow undoing to snapshots after failed compilations. *) val snapshot : unit -> unit val revert : unit -> unit diff --git a/src/mod_db.sml b/src/mod_db.sml index de428570..fdf6d5ab 100644 --- a/src/mod_db.sml +++ b/src/mod_db.sml @@ -207,6 +207,15 @@ fun lookup (d : Source.decl) = NONE) | _ => NONE +fun lookupForTooling 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)) + (SS.listItems (#Deps m)))) + val byNameBackup = ref (!byName) val byIdBackup = ref (!byId) diff --git a/src/search.sig b/src/search.sig index ac867146..2de85425 100644 --- a/src/search.sig +++ b/src/search.sig @@ -59,4 +59,9 @@ signature SEARCH = sig * ('state11 -> 'state2 -> ('state11 * 'state2, 'abort) result) -> (('state11 * 'state12) * 'state2, 'abort) result + val bindPWithPos : + (('state11 * 'state12) * 'state2, 'abort) result + * (('state11 * 'state12) -> 'state2 -> ('state11 * 'state2, 'abort) result) + -> (('state11 * 'state12) * 'state2, 'abort) result + end diff --git a/src/search.sml b/src/search.sml index 563496fe..5e4e135f 100644 --- a/src/search.sml +++ b/src/search.sml @@ -70,4 +70,12 @@ fun bindP (r, f) = ((x', pos), acc')) | Return x => Return x +fun bindPWithPos (r, f) = + case r of + Continue ((x, pos), acc) => + map (f (x, pos) acc, + fn (x', acc') => + ((x', pos), acc')) + | Return x => Return x + end 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 9e2b026fea11ae89a53d4fc1c674ef8e43b2c2ce Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Thu, 1 Aug 2019 09:57:46 +0200 Subject: Added file check to typeOf and always add Top and Basis to env in typeOf --- src/compiler.sml | 22 ++++++++++++---------- src/mod_db.sml | 7 ++++++- 2 files changed, 18 insertions(+), 11 deletions(-) diff --git a/src/compiler.sml b/src/compiler.sml index 46a035ee..51cf20e1 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1781,11 +1781,13 @@ fun moduleOf fname = end end -fun isPosIn row col span = +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 @@ -1827,10 +1829,10 @@ fun getTypeAt file row col = NONE => Print.PD.string ("ERROR: No module found: " ^ moduleOf file) | SOME (decl, deps) => let - (* TODO Top is not always found as a dep *) val () = ElabUtilPos.mliftConInCon := ElabEnv.mliftConInCon (* Adding dependencies to environment *) - val env = List.foldl (fn (d, e) => ElabEnv.declBinds e d) + val env = List.foldl (fn (d, e) => + ElabEnv.declBinds e d) ElabEnv.empty deps (* Adding previous declarations to environment *) @@ -1850,31 +1852,31 @@ fun getTypeAt file row col = val (atPosition, env) = ElabUtilPos.Decl.foldB { kind = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Kind (k, span), env) else acc , con = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Con (k, span), env) else acc, exp = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Exp (k, span), env) else acc, sgn_item = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Sgn_item (k, span), env) else acc, sgn = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Sgn (k, span), env) else acc, str = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Str (k, span), env) else acc, decl = fn (env, (k, span), acc) => - if isPosIn row col span andalso isSmallerThan span (getSpan acc) + if isPosIn file row col span andalso isSmallerThan span (getSpan acc) then (Decl (k, span), env) else acc, bind = fn (env, binder) => diff --git a/src/mod_db.sml b/src/mod_db.sml index fdf6d5ab..57d85195 100644 --- a/src/mod_db.sml +++ b/src/mod_db.sml @@ -214,7 +214,12 @@ fun lookupForTooling name = SOME (#Decl m, List.map (fn a => #Decl a) (List.mapPartial (fn d => SM.find (!byName, d)) - (SS.listItems (#Deps m)))) + (* 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)))))) val byNameBackup = ref (!byName) val byIdBackup = ref (!byId) -- cgit v1.2.3 From 0e520d3fd675bcebb5751bd1a0c304033f4f7782 Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Thu, 1 Aug 2019 17:38:09 +0200 Subject: Improved typeOf searching and handling of Top and Basis --- src/compiler.sml | 285 ++++++++++++++++++++++++++++++++---------------------- src/elaborate.sig | 6 ++ 2 files changed, 173 insertions(+), 118 deletions(-) diff --git a/src/compiler.sml b/src/compiler.sml index 51cf20e1..7ceb209a 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1786,13 +1786,14 @@ fun isPosIn file row col span = val start = #first span val end_ = #last span in - (String.isSuffix file (#file span)) + String.isSuffix file (#file span) andalso - ((#line start < row) orelse - (#line start = row) andalso (#char start <= col)) + (#line start < row orelse + #line start = row andalso #char start <= col) andalso - ((#line end_ > row) orelse - (#line end_ = row) andalso (#char end_ >= col)) + (#line end_ > row orelse + #line end_ = row andalso #char end_ >= col) + end fun isSmallerThan (s1: ErrorMsg.span) (s2: ErrorMsg.span) = @@ -1827,138 +1828,186 @@ fun getTypeAt file row col = else case ModDb.lookupForTooling (moduleOf file) of NONE => Print.PD.string ("ERROR: No module found: " ^ moduleOf file) - | SOME (decl, deps) => + | SOME (modDecl, deps) => let val () = ElabUtilPos.mliftConInCon := ElabEnv.mliftConInCon + (* Adding dependencies to environment *) - val env = List.foldl (fn (d, e) => - ElabEnv.declBinds e d) + val env = List.foldl (fn (d, e) => ElabEnv.declBinds e d) ElabEnv.empty deps - (* Adding previous declarations to environment *) + + (* 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 decl of + case #1 modDecl of Elab.DStr (name, _, sgn, str) => (case #1 str of Elab.StrConst decls => - List.foldl - (fn (d, e) => ElabEnv.declBinds e d) - env - 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] + , Print.PD.string "\n" + ] + + (* 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 (atPosition, env) = + val result = ElabUtilPos.Decl.foldB - { kind = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Kind (k, span), env) - else acc , - con = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Con (k, span), env) - else acc, - exp = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Exp (k, span), env) - else acc, - sgn_item = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Sgn_item (k, span), env) - else acc, - sgn = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Sgn (k, span), env) - else acc, - str = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Str (k, span), env) - else acc, - decl = fn (env, (k, span), acc) => - if isPosIn file row col span andalso isSmallerThan span (getSpan acc) - then (Decl (k, span), env) - else acc, + { 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) + 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 - (Decl (#1 decl, { file = file - , first = { line = 0, char = 0} - , last = { line = 99999, char = 0} }) - , env) - decl + { 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 atPosition of - Kind k => - Print.box [Print.PD.string "Not implemented yet, KIND: ", ElabPrint.p_kind env k] - | Con c => - Print.box [Print.PD.string "Not implemented yet, CON: ", ElabPrint.p_con env c] - | Exp (Elab.EPrim p, _) => - 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, _) => - ((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, _) => - ((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) => - (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 => Print.box [Print.PD.string "Not implemented yet, EXP: ", ElabPrint.p_exp env e] - | Sgn_item si => Print.box [Print.PD.string "Not implemented yet, SGN_ITEM: ", ElabPrint.p_sgn_item env si] - | Sgn s => Print.box [Print.PD.string "Not implemented yet, SGN: ", ElabPrint.p_sgn env s] - | Str s => Print.box [Print.PD.string "Not implemented yet, STR: ", ElabPrint.p_str env s] - | Decl d => Print.box [Print.PD.string "Not implemented yet, DECL: ", ElabPrint.p_decl env d] + case #smallestgoodpart result of + NONE => printLiterally (#smallest result) + | SOME (desc, span) => + Print.box [(* Print.PD.string (ErrorMsg.spanToString span), Print.PD.string " @ " *) + desc + , Print.PD.string "\n"] end diff --git a/src/elaborate.sig b/src/elaborate.sig index d60cff42..03359814 100644 --- a/src/elaborate.sig +++ b/src/elaborate.sig @@ -47,4 +47,10 @@ signature ELABORATE = sig val incremental : bool ref val verbose : bool ref + val dopen: ElabEnv.env + -> { str: int + , strs: string list + , sgn: Elab.sgn } + -> (Elab.decl list * ElabEnv.env) + end -- cgit v1.2.3 From 120b7d2886e71b6e2000f94f0570d933542b2941 Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Sat, 3 Aug 2019 08:19:26 +0200 Subject: Removed some unnecessary prints --- src/compiler.sml | 9 ++------- src/main.mlton.sml | 3 +-- 2 files changed, 3 insertions(+), 9 deletions(-) diff --git a/src/compiler.sml b/src/compiler.sml index 7ceb209a..2e6cf312 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1880,7 +1880,6 @@ fun getTypeAt file row col = | 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] - , Print.PD.string "\n" ] (* TODO We lose some really useful information, like eg. inferred parameters, *) @@ -2004,10 +2003,7 @@ fun getTypeAt file row col = in case #smallestgoodpart result of NONE => printLiterally (#smallest result) - | SOME (desc, span) => - Print.box [(* Print.PD.string (ErrorMsg.spanToString span), Print.PD.string " @ " *) - desc - , Print.PD.string "\n"] + | SOME (desc, span) => desc end @@ -2015,8 +2011,7 @@ 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) => - Print.box [getTypeAt file row col, Print.PD.string "\n"] + (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/main.mlton.sml b/src/main.mlton.sml index 8e70e398..bb5d2166 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -441,8 +441,7 @@ val () = (Globals.setResetTime (); wrs = [Socket.sockDesc sock], exs = [], timeout = SOME (Time.fromSeconds 1)}))) then - (TextIO.print "Using daemon\n"; - app (fn arg => send (sock, arg ^ "\n")) args; + (app (fn arg => send (sock, arg ^ "\n")) args; send (sock, "\n"); OS.Process.exit (wait ())) else -- 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 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 85287c07fff6682c6d3a935efc30aad623e69179 Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Sat, 3 Aug 2019 10:46:18 +0200 Subject: Added emacs functions for getInfo --- src/elisp/urweb-mode.el | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 69b0e23c..1eb9a1eb 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -925,6 +925,32 @@ Optional argument STYLE is currently ignored." (urweb-skip-siblings)) fullname))) +(defun urweb-get-proj-dir (bfn) + (locate-dominating-file + bfn + (lambda (dir) + (some (lambda (f) (s-suffix? ".urp" f)) + (if (f-dir? dir) + (directory-files dir) + (list '(dir))))))) + +(defun urweb-get-info () + (interactive) + (let* + ((row (line-number-at-pos)) + (col (evil-column)) + (bfn (or (buffer-file-name) + "/Users/Simon/ur-proj/testje/a.ur")) + (proj-dir (urweb-get-proj-dir bfn)) + (filename (file-relative-name bfn proj-dir)) + (loc (concat filename ":" (number-to-string row) ":" (number-to-string col))) + ) + (require 'popup) + (message (let + ((default-directory proj-dir)) + (shell-command-to-string (concat "urweb -getInfo " loc))))) + ) + (provide 'urweb-mode) ;;; urweb-mode.el ends here -- cgit v1.2.3 From 870ce334b835614bab3f114b2aa57617f699c6be Mon Sep 17 00:00:00 2001 From: FrigoEU Date: Sat, 3 Aug 2019 11:01:42 +0200 Subject: Cleaned up elisp and added dependencies --- src/elisp/urweb-mode.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 1eb9a1eb..057761ac 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -939,13 +939,14 @@ Optional argument STYLE is currently ignored." (let* ((row (line-number-at-pos)) (col (evil-column)) - (bfn (or (buffer-file-name) - "/Users/Simon/ur-proj/testje/a.ur")) + (bfn (buffer-file-name)) (proj-dir (urweb-get-proj-dir bfn)) (filename (file-relative-name bfn proj-dir)) (loc (concat filename ":" (number-to-string row) ":" (number-to-string col))) ) - (require 'popup) + (require 's) + (require 'f) + (require 'simple) (message (let ((default-directory proj-dir)) (shell-command-to-string (concat "urweb -getInfo " loc))))) -- cgit v1.2.3 From 6a27ba96989166da2d16397852e7343ac4d10b1e Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Mon, 4 Nov 2019 15:17:47 +0100 Subject: Added nix files --- .envrc | 1 + default.nix | 9 +++++++++ derivation.nix | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 66 insertions(+) create mode 100644 .envrc create mode 100644 default.nix create mode 100644 derivation.nix diff --git a/.envrc b/.envrc new file mode 100644 index 00000000..4a4726a5 --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use_nix diff --git a/default.nix b/default.nix new file mode 100644 index 00000000..ba9eed30 --- /dev/null +++ b/default.nix @@ -0,0 +1,9 @@ +let + pinnedNixpkgs = import (builtins.fetchTarball { + name = "pinned-nixpkgs-for-urweb-school"; + url = https://github.com/NixOS/nixpkgs/archive/5a8bfc98a23669f71596d079df20730ccdfdf04b.tar.gz; + # Hash obtained using `nix-prefetch-url --unpack ` + sha256 = "15qbfjjw5ak1bpiq36s0y9iq3j45azmb8nz06fpx4dgkg32i8fm5"; + }) {}; +in +{pkgs ? pinnedNixpkgs}: pkgs.callPackage ./derivation.nix {} diff --git a/derivation.nix b/derivation.nix new file mode 100644 index 00000000..c07ef0f6 --- /dev/null +++ b/derivation.nix @@ -0,0 +1,56 @@ +{ stdenv, lib, fetchFromGitHub, file, openssl, mlton +, mysql, postgresql, sqlite, gcc +, automake, autoconf, libtool, icu +}: + +stdenv.mkDerivation rec { + name = "urweb-${version}"; + version = "2018-06-22"; + + # src = fetchurl { + # url = "http://www.impredicative.com/ur/${name}.tgz"; + # sha256 = "17qh9mcmlhbv6r52yij8l9ik7j7x6x7c09lf6pznnbdh4sf8p5wb"; + # }; + + # src = fetchFromGitHub { + # owner = "FrigoEU"; + # repo = "urweb"; + # rev = "e52ce9f542f64750941cfd84efdb6d993ee20ff0"; + # sha256 = "19ba5n7g1dxy7q9949aakqplchsyzwrrnxv8v604vx5sg7fdfn3b"; + # }; + src = ./.; + + buildInputs = [ openssl mlton mysql.connector-c postgresql sqlite automake autoconf libtool icu.dev]; + + # prePatch = '' + # sed -e 's@/usr/bin/file@${file}/bin/file@g' -i configure + # ''; + + configureFlags = "--with-openssl=${openssl.dev}"; + + preConfigure = '' + ./autogen.sh + export PGHEADER="${postgresql}/include/libpq-fe.h"; + export MSHEADER="${mysql.connector-c}/include/mysql/mysql.h"; + export SQHEADER="${sqlite.dev}/include/sqlite3.h"; + export CC="${gcc}/bin/gcc"; + export CCARGS="-I$out/include \ + -I${icu.dev}/include \ + -L${openssl.out}/lib \ + -L${mysql.connector-c}/lib \ + -L${postgresql.lib}/lib \ + -L${sqlite.out}/lib \ + -L${icu.out}/lib"; + ''; + + # Be sure to keep the statically linked libraries + dontDisableStatic = true; + + meta = { + description = "Advanced purely-functional web programming language"; + homepage = "http://www.impredicative.com/ur/"; + license = stdenv.lib.licenses.bsd3; + platforms = stdenv.lib.platforms.linux ++ stdenv.lib.platforms.darwin; + maintainers = [ stdenv.lib.maintainers.thoughtpolice stdenv.lib.maintainers.sheganinans ]; + }; +} -- cgit v1.2.3 From e6b943962dd1bf522a67178220cb1753d34240fa Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sun, 8 Dec 2019 00:04:51 +0100 Subject: Added openSSL dev files to nix --- derivation.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/derivation.nix b/derivation.nix index c07ef0f6..f956a619 100644 --- a/derivation.nix +++ b/derivation.nix @@ -20,7 +20,7 @@ stdenv.mkDerivation rec { # }; src = ./.; - buildInputs = [ openssl mlton mysql.connector-c postgresql sqlite automake autoconf libtool icu.dev]; + buildInputs = [ openssl mlton mysql.connector-c postgresql sqlite automake autoconf libtool icu.dev openssl.dev]; # prePatch = '' # sed -e 's@/usr/bin/file@${file}/bin/file@g' -i configure -- 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 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 26e16f90067ee294d1ccd6341547dbae585cdb3e Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Mon, 9 Dec 2019 11:47:57 +0100 Subject: Refactored LSP into few modules --- src/lsp.sml | 311 ++++++++++++++++++++++++++++++++++++------------------------ 1 file changed, 189 insertions(+), 122 deletions(-) diff --git a/src/lsp.sml b/src/lsp.sml index 1fd50109..2ddce0e3 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,141 +1,194 @@ -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) + (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 = +structure FromJson = struct +fun get (s: string) (l: Json.json): Json.json = let - val line = TextIO.inputLine TextIO.stdIn + 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) 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 + 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) 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 = +fun asInt (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 = +fun asString (j: Json.json): string = case j of Json.String s => s | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) +end -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 () = +(* signature LSPSPEC = sig *) +(* type textDocumentIdentifier = *) +(* { scheme: string *) +(* , authority: string *) +(* , path: string *) +(* , query: string *) +(* , fragment: string *) +(* } *) +(* type position = { line: int *) +(* , character: int *) +(* } *) +(* val readRequestFromStdIO: () -> {id: Json.json, method: string, params: Json.json} *) +(* val parseRequest: {id: Json.json, method: string, params: Json.json} -> request *) +(* datatype request = *) +(* 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 => + 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 (): (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 + + fun parseBasicRequest (j: Json.json): {id: Json.json, method: string, params: Json.json} = + let + val id = FromJson.get "id" j + val method = FromJson.asString (FromJson.get "method" j) + val params = FromJson.get "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 (FromJson.asString (FromJson.get "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 = FromJson.asInt (FromJson.get "line" j) + , character = FromJson.asInt (FromJson.get "character" j) + } + + + fun readRequestFromStdIO (): {id: Json.json, method: string, params: Json.json} = + 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 + parseBasicRequest parsed + end + + fun parseHoverReq (params: Json.json): { textDocument: textDocumentIdentifier , position: position } = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + , position = parsePosition (FromJson.get "position" params) + } + + fun printHoverResponse (resp: {contents: string}): Json.json = + Json.Obj (("contents", Json.String (#contents resp)) :: []) + + 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 handlers = + { initialize: unit -> { capabilities: {hoverProvider: bool}} result + , shutdown: unit -> unit result + , textDocument_hover: { textDocument: textDocumentIdentifier + , position: position } + -> {contents: string} result + } + + fun handleRequest + (requestMessage: {id: Json.json, method: string, params: Json.json}) + (handlers: handlers) + : unit = 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 = + val result: Json.json 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 + "initialize" => + mapResult + (fn res => Json.Obj (("capabilities", Json.Obj (("hoverProvider", Json.Bool (#hoverProvider (#capabilities res))) + :: [])) + :: [])) + ((#initialize handlers) ()) + | "textDocument/hover" => + mapResult + printHoverResponse + ((#textDocument_hover handlers) + (parseHoverReq (#params requestMessage))) + | "shutdown" => + mapResult + (fn () => Json.Null) + ((#shutdown handlers) ()) + | "exit" => + OS.Process.exit OS.Process.success | method => Error (~32601, "Method not supported: " ^ method) in case result of @@ -152,8 +205,22 @@ fun serverLoop () = :: [] ))) end + +end + +structure Lsp :> LSP = struct + +fun serverLoop () = + let + val requestMessage = LspSpec.readRequestFromStdIO () + in + LspSpec.handleRequest + requestMessage + { initialize = fn () => LspSpec.Success {capabilities = {hoverProvider = true}} + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = fn _ => LspSpec.Success {contents = ""} + } + end -fun startServer () = - while (1 < 2) do - serverLoop () +fun startServer () = while true do serverLoop () end -- cgit v1.2.3 From 1953cd47c6abdec2437c833cb8e26cf1e8ac1834 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Mon, 9 Dec 2019 14:45:37 +0100 Subject: First actually working version of LSP --- src/json.sml | 11 ++-- src/lsp.sml | 187 +++++++++++++++++++++++++++++++++++------------------------ 2 files changed, 115 insertions(+), 83 deletions(-) diff --git a/src/json.sml b/src/json.sml index fab15a6c..f189cc4d 100644 --- a/src/json.sml +++ b/src/json.sml @@ -79,7 +79,7 @@ struct and parsePair () = Callbacks.json_pair (parseString (), - (ws(); consume ":"; parseValue ())) + (ws(); consume ":"; ws(); parseValue ())) and parseArray () = if not (matches "[") then @@ -142,10 +142,9 @@ struct and parseInt () = let val f = - if peek () = #"0" then - raise JSONParseError ("Invalid number", !inputPosition) - else if peek () = #"-" then (take (); "~") - else String.str (take ()) + if peek () = #"-" + then (take (); "~") + else String.str (take ()) in f ^ parseDigits () end @@ -270,6 +269,6 @@ fun print (ast: json): string = | 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 + ^ List.foldl (fn ((k, v), acc) => acc ^ (if acc = "" then "" else ", ") ^ "\"" ^ k ^ "\": " ^ print v ) "" l ^ "}" end diff --git a/src/lsp.sml b/src/lsp.sml index 2ddce0e3..f3fed67c 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,4 +1,3 @@ - fun trim (s: substring): substring = Substring.dropr (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") @@ -6,19 +5,12 @@ fun trim (s: substring): substring = structure FromJson = struct fun get (s: string) (l: Json.json): Json.json = - let - 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) - in - 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) - end + case l of + Json.Obj pairs => + (case List.find (fn tup => #1 tup = s) pairs of + NONE => raise Fail ("Failed to find JSON object key " ^ s ^ " in " ^ Json.print l) + | SOME tup => #2 tup) + | _ => raise Fail ("Expected JSON object, got: " ^ Json.print l) fun asInt (j: Json.json): int = case j of @@ -32,24 +24,6 @@ fun asString (j: Json.json): string = end -(* signature LSPSPEC = sig *) -(* type textDocumentIdentifier = *) -(* { scheme: string *) -(* , authority: string *) -(* , path: string *) -(* , query: string *) -(* , fragment: string *) -(* } *) -(* type position = { line: int *) -(* , character: int *) -(* } *) -(* val readRequestFromStdIO: () -> {id: Json.json, method: string, params: Json.json} *) -(* val parseRequest: {id: Json.json, method: string, params: Json.json} -> request *) -(* datatype request = *) -(* end *) - - - structure LspSpec (* :> LSPSPEC *) = struct fun readHeader (): (string * string) option = let @@ -57,15 +31,18 @@ structure LspSpec (* :> LSPSPEC *) = struct 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 + | 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 = @@ -78,14 +55,19 @@ structure LspSpec (* :> LSPSPEC *) = struct in doReadAllHeaders [] end - - fun parseBasicRequest (j: Json.json): {id: Json.json, method: string, params: Json.json} = + 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 = FromJson.get "id" j + 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 - {id = id, method = method, params = params} + case id of + NONE => Notification {method = method, params = params} + | SOME id => RequestMessage {id = id, method = method, params = params} end type textDocumentIdentifier = @@ -125,8 +107,7 @@ structure LspSpec (* :> LSPSPEC *) = struct , character = FromJson.asInt (FromJson.get "character" j) } - - fun readRequestFromStdIO (): {id: Json.json, method: string, params: Json.json} = + fun readRequestFromStdIO (): message = let val headers = readAllHeaders () val lengthO = List.find (fn (k,v) => k = "Content-Length") headers @@ -138,7 +119,7 @@ structure LspSpec (* :> LSPSPEC *) = struct | SOME i => TextIO.inputN (TextIO.stdIn, i) val parsed = Json.parse request in - parseBasicRequest parsed + parseMessage parsed end fun parseHoverReq (params: Json.json): { textDocument: textDocumentIdentifier , position: position } = @@ -146,8 +127,10 @@ structure LspSpec (* :> LSPSPEC *) = struct , position = parsePosition (FromJson.get "position" params) } - fun printHoverResponse (resp: {contents: string}): Json.json = - Json.Obj (("contents", Json.String (#contents resp)) :: []) + fun printHoverResponse (resp: {contents: string} option): Json.json = + case resp of + NONE => Json.Null + | SOME obj => Json.Obj [("contents", Json.String (#contents obj))] datatype 'a result = Success of 'a @@ -157,31 +140,38 @@ structure LspSpec (* :> LSPSPEC *) = struct case a of Success contents => Success (f contents) | Error e => Error e - type handlers = + type messageHandlers = { initialize: unit -> { capabilities: {hoverProvider: bool}} result , shutdown: unit -> unit result - , textDocument_hover: { textDocument: textDocumentIdentifier - , position: position } - -> {contents: string} result + , textDocument_hover: + { showMessage: string -> int -> unit} + -> { textDocument: textDocumentIdentifier + , position: position } + -> ({contents: string} option) result } - fun handleRequest + fun handleMessage (requestMessage: {id: Json.json, method: string, params: Json.json}) - (handlers: handlers) + (handlers: messageHandlers) : unit = let + fun showMessage str typ = + TextIO.print (Json.print (Json.Obj [ ("method", Json.String "window/showMessage") + , ("params", Json.Obj [ ("type", Json.Int typ) + , ("message", Json.String str)]) + ])); + val result: Json.json result = case #method requestMessage of "initialize" => mapResult - (fn res => Json.Obj (("capabilities", Json.Obj (("hoverProvider", Json.Bool (#hoverProvider (#capabilities res))) - :: [])) - :: [])) + (fn res => Json.Obj [("capabilities", Json.Obj [("hoverProvider", Json.Bool (#hoverProvider (#capabilities res)))])]) ((#initialize handlers) ()) | "textDocument/hover" => mapResult printHoverResponse ((#textDocument_hover handlers) + {showMessage = showMessage} (parseHoverReq (#params requestMessage))) | "shutdown" => mapResult @@ -190,21 +180,47 @@ structure LspSpec (* :> LSPSPEC *) = struct | "exit" => OS.Process.exit OS.Process.success | 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 => TextIO.output (TextIO.stdOut, - Json.print (Json.Obj (("id", #id requestMessage) - :: ("result", j) - :: []))) + 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) => - TextIO.output (TextIO.stdOut, - Json.print (Json.Obj (("id", #id requestMessage) - :: ("error", Json.Obj (("code", Json.Int i) - :: ("message", Json.String 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 + } + fun handleNotification + (notification: {method: string, params: Json.json}) + (handlers: notificationHandlers) + = case #method notification of + "initialized" => (#initialized handlers) () + | m => (TextIO.output ( TextIO.stdErr, "Notification method not supported: " ^ m); + TextIO.flushOut TextIO.stdErr) + end @@ -212,14 +228,31 @@ structure Lsp :> LSP = struct fun serverLoop () = let - val requestMessage = LspSpec.readRequestFromStdIO () + val requestMessage = + LspSpec.readRequestFromStdIO () + handle ex => (TextIO.output (TextIO.stdErr, General.exnMessage ex ^ "\n"); TextIO.flushOut TextIO.stdErr ; raise ex) in - LspSpec.handleRequest - requestMessage - { initialize = fn () => LspSpec.Success {capabilities = {hoverProvider = true}} - , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn _ => LspSpec.Success {contents = ""} - } + (case requestMessage of + LspSpec.Notification n => + ((* TextIO.output (TextIO.stdErr, "Handling notification: " ^ #method n ^ "\n"); *) + (* TextIO.flushOut TextIO.stdErr; *) + LspSpec.handleNotification + n + { initialized = fn () => () + }) + | LspSpec.RequestMessage m => + ((* TextIO.output (TextIO.stdErr, "Handling message: " ^ #method m ^ "\n"); *) + (* TextIO.flushOut TextIO.stdErr; *) + LspSpec.handleMessage + m + { initialize = fn () => LspSpec.Success {capabilities = {hoverProvider = true}} + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = + fn ctx => + fn _ => LspSpec.Success NONE + } + ) + ) handle ex => (TextIO.output (TextIO.stdErr, General.exnMessage ex ^ "\n"); TextIO.flushOut TextIO.stdErr ; raise ex) end fun startServer () = while true do serverLoop () -- cgit v1.2.3 From d53867eae4608bce7ecd39c488705339f4fabd0a Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Mon, 9 Dec 2019 21:03:05 +0100 Subject: Added some LSP notifications support --- .envrc | 2 +- src/lsp.sml | 139 ++++++++++++++++++++++++++++++++++++++++++++++-------------- 2 files changed, 109 insertions(+), 32 deletions(-) diff --git a/.envrc b/.envrc index 4a4726a5..051d09d2 100644 --- a/.envrc +++ b/.envrc @@ -1 +1 @@ -use_nix +eval "$(lorri direnv)" diff --git a/src/lsp.sml b/src/lsp.sml index f3fed67c..d2c380c6 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -22,6 +22,11 @@ fun asString (j: Json.json): string = 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) end structure LspSpec (* :> LSPSPEC *) = struct @@ -70,16 +75,16 @@ structure LspSpec (* :> LSPSPEC *) = struct | SOME id => RequestMessage {id = id, method = method, params = params} end - type textDocumentIdentifier = + type documentUri = { scheme: string , authority: string , path: string , query: string , fragment: string } - fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = + fun parseDocumentUri (str: string): documentUri = let - val str = Substring.full (FromJson.asString (FromJson.get "uri" j)) + 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 <> #"#") (Substring.triml 1 rest (* / *)) @@ -99,6 +104,32 @@ structure LspSpec (* :> LSPSPEC *) = struct } end + 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 } @@ -122,16 +153,58 @@ structure LspSpec (* :> LSPSPEC *) = struct parseMessage parsed end - fun parseHoverReq (params: Json.json): { textDocument: textDocumentIdentifier , position: position } = + 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: {contents: string} option): Json.json = + 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 didChangeParams = { textDocument: versionedTextDocumentIdentifier } + fun parseDidChangeParams (params: Json.json): didChangeParams = + { textDocument = parseVersionedTextDocumentIdentifier (FromJson.get "textDocument" params) + (* , contentChanges = ... *) + } + + type didSaveParams = { textDocument: textDocumentIdentifier } + fun parseDidSaveParams (params: Json.json): didSaveParams = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + (* , text = ... *) + } + + type initializeResponse = { capabilities: + { hoverProvider: bool + , textDocumentSync: { openClose: bool + , save: { includeText: bool} option + } + }} + fun printInitializeResponse (res: initializeResponse) = + Json.Obj [("capabilities", + let + val capabilities = #capabilities res + in + Json.Obj [ ("hoverProvider", Json.Bool (#hoverProvider capabilities)) + , ("textDocumentSync", + let + val textDocumentSync = #textDocumentSync capabilities + in + Json.Obj [ ("openClose", Json.Bool (#openClose 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) @@ -140,14 +213,11 @@ structure LspSpec (* :> LSPSPEC *) = struct case a of Success contents => Success (f contents) | Error e => Error e + type context = { showMessage: string -> int -> unit} type messageHandlers = - { initialize: unit -> { capabilities: {hoverProvider: bool}} result + { initialize: unit -> initializeResponse result , shutdown: unit -> unit result - , textDocument_hover: - { showMessage: string -> int -> unit} - -> { textDocument: textDocumentIdentifier - , position: position } - -> ({contents: string} option) result + , textDocument_hover: context -> hoverReq -> hoverResp result } fun handleMessage @@ -165,7 +235,7 @@ structure LspSpec (* :> LSPSPEC *) = struct case #method requestMessage of "initialize" => mapResult - (fn res => Json.Obj [("capabilities", Json.Obj [("hoverProvider", Json.Bool (#hoverProvider (#capabilities res)))])]) + printInitializeResponse ((#initialize handlers) ()) | "textDocument/hover" => mapResult @@ -212,15 +282,20 @@ structure LspSpec (* :> LSPSPEC *) = struct type notificationHandlers = { initialized: unit -> unit + , textDocument_didOpen: didOpenParams -> unit + , textDocument_didChange: didChangeParams -> unit + , textDocument_didSave: didSaveParams -> unit } fun handleNotification (notification: {method: string, params: Json.json}) (handlers: notificationHandlers) = case #method notification of "initialized" => (#initialized handlers) () + | "textDocument/didOpen" => (#textDocument_didOpen handlers) (parseDidOpenParams (#params notification)) + | "textDocument/didChange" => (#textDocument_didChange handlers) (parseDidChangeParams (#params notification)) + | "textDocument/didSave" => (#textDocument_didSave handlers) (parseDidSaveParams (#params notification)) | m => (TextIO.output ( TextIO.stdErr, "Notification method not supported: " ^ m); TextIO.flushOut TextIO.stdErr) - end @@ -234,24 +309,26 @@ fun serverLoop () = in (case requestMessage of LspSpec.Notification n => - ((* TextIO.output (TextIO.stdErr, "Handling notification: " ^ #method n ^ "\n"); *) - (* TextIO.flushOut TextIO.stdErr; *) - LspSpec.handleNotification - n - { initialized = fn () => () - }) + LspSpec.handleNotification + n + { initialized = fn () => () + , textDocument_didOpen = fn didOpenParams => () + , textDocument_didChange = fn didChangeParams => () + , textDocument_didSave = fn didChangeParams => () + } | LspSpec.RequestMessage m => - ((* TextIO.output (TextIO.stdErr, "Handling message: " ^ #method m ^ "\n"); *) - (* TextIO.flushOut TextIO.stdErr; *) - LspSpec.handleMessage - m - { initialize = fn () => LspSpec.Success {capabilities = {hoverProvider = true}} - , shutdown = fn () => LspSpec.Success () - , textDocument_hover = - fn ctx => - fn _ => LspSpec.Success NONE - } - ) + LspSpec.handleMessage + m + { initialize = fn () => LspSpec.Success + { capabilities = + { hoverProvider = true + , textDocumentSync = { openClose = true + , save = SOME { includeText = false } + }} + } + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = fn ctx => fn _ => LspSpec.Success NONE + } ) handle ex => (TextIO.output (TextIO.stdErr, General.exnMessage ex ^ "\n"); TextIO.flushOut TextIO.stdErr ; raise ex) end -- cgit v1.2.3 From 53050c6917f46ba7e803b0d51a5c3e615e6be00b Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Mon, 9 Dec 2019 21:04:14 +0100 Subject: Add shell.nix --- shell.nix | 1 + 1 file changed, 1 insertion(+) create mode 100644 shell.nix diff --git a/shell.nix b/shell.nix new file mode 100644 index 00000000..95da550b --- /dev/null +++ b/shell.nix @@ -0,0 +1 @@ +import ./default.nix -- cgit v1.2.3 From 98ebd4d0b10165693a205d30399149e32954b833 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Tue, 10 Dec 2019 11:11:11 +0100 Subject: Started work on keeping some state in LSP server --- src/lsp.sml | 140 +++++++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 111 insertions(+), 29 deletions(-) diff --git a/src/lsp.sml b/src/lsp.sml index d2c380c6..cff30d5e 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -27,6 +27,12 @@ fun asOptionalInt (j: Json.json): int option = 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 @@ -179,12 +185,20 @@ structure LspSpec (* :> LSPSPEC *) = struct { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) (* , text = ... *) } - + type initializeParams = + { rootUri: documentUri option } + fun parseInitializeParams (j: Json.json) = + { rootUri = + Option.map + parseDocumentUri + (FromJson.asOptionalString (FromJson.get "rootUri" j)) + } type initializeResponse = { capabilities: { hoverProvider: bool - , textDocumentSync: { openClose: bool - , save: { includeText: bool} option - } + , textDocumentSync: + { openClose: bool + , save: { includeText: bool } option + } }} fun printInitializeResponse (res: initializeResponse) = Json.Obj [("capabilities", @@ -215,7 +229,7 @@ structure LspSpec (* :> LSPSPEC *) = struct | Error e => Error e type context = { showMessage: string -> int -> unit} type messageHandlers = - { initialize: unit -> initializeResponse result + { initialize: initializeParams -> initializeResponse result , shutdown: unit -> unit result , textDocument_hover: context -> hoverReq -> hoverResp result } @@ -236,7 +250,8 @@ structure LspSpec (* :> LSPSPEC *) = struct "initialize" => mapResult printInitializeResponse - ((#initialize handlers) ()) + ((#initialize handlers) + (parseInitializeParams (#params requestMessage))) | "textDocument/hover" => mapResult printHoverResponse @@ -301,35 +316,102 @@ end structure Lsp :> LSP = struct +structure SK = struct + type ord_key = string + val compare = String.compare +end +structure SM = BinaryMapFn(SK) + +type fileState = + { envOfPreviousModules : ElabEnv.env + , decls : Elab.decl list + } +type state = + { rootUri : LspSpec.documentUri + , fileStates : fileState SM.map + } +val stateRef = ref (NONE: state option) + +(* Throws Fail if can't init *) +fun initState (initParams: LspSpec.initializeParams): state = + { rootUri = case #rootUri initParams of + NONE => raise Fail "Failed to initialize: no rootUri" + | SOME a => a + , fileStates = SM.empty + } +fun calculateFileState (state: state) (fileName: string): fileState = + { envOfPreviousModules = ElabEnv.empty + , decls = [] + } + fun serverLoop () = let val requestMessage = LspSpec.readRequestFromStdIO () handle ex => (TextIO.output (TextIO.stdErr, General.exnMessage ex ^ "\n"); TextIO.flushOut TextIO.stdErr ; raise ex) + val state = !stateRef in - (case requestMessage of - LspSpec.Notification n => - LspSpec.handleNotification - n - { initialized = fn () => () - , textDocument_didOpen = fn didOpenParams => () - , textDocument_didChange = fn didChangeParams => () - , textDocument_didSave = fn didChangeParams => () - } - | LspSpec.RequestMessage m => - LspSpec.handleMessage - m - { initialize = fn () => LspSpec.Success - { capabilities = - { hoverProvider = true - , textDocumentSync = { openClose = true - , save = SOME { includeText = false } - }} - } - , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn ctx => fn _ => LspSpec.Success NONE - } - ) handle ex => (TextIO.output (TextIO.stdErr, General.exnMessage ex ^ "\n"); TextIO.flushOut TextIO.stdErr ; raise ex) + case state of + NONE => + (case requestMessage of + LspSpec.RequestMessage m => + LspSpec.handleMessage + m + { initialize = fn _ => + let val st = initState (LspSpec.parseInitializeParams (#params m)) + in + stateRef := SOME st; + LspSpec.Success + { capabilities = + { hoverProvider = true + , textDocumentSync = { openClose = true + , save = SOME { includeText = false } + }} + } + end + handle (Fail str) => LspSpec.Error (~32602, str) + , shutdown = fn () => LspSpec.Error (~32002, "Server not initialized") + , textDocument_hover = fn ctx => fn _ => LspSpec.Error (~32002, "Server not initialized") + } + | LspSpec.Notification n => ()) + | SOME state => + (case requestMessage of + LspSpec.Notification n => + LspSpec.handleNotification + n + { initialized = fn () => () + , textDocument_didOpen = fn didOpenParams => + let + val path = #path (#uri (#textDocument didOpenParams)) + val fileState = calculateFileState state (path) + in + stateRef := SOME { rootUri = #rootUri state + , fileStates = SM.insert ( #fileStates state + , path + , fileState) + } + end + , textDocument_didChange = fn didChangeParams => () + , textDocument_didSave = fn didSaveParams => + let + val path = #path (#uri (#textDocument didSaveParams)) + val fileState = calculateFileState state (path) + in + stateRef := SOME { rootUri = #rootUri state + , fileStates = SM.insert ( #fileStates state + , path + , fileState) + } + end + } + | LspSpec.RequestMessage m => + LspSpec.handleMessage + m + { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = fn ctx => fn _ => LspSpec.Success NONE + } + ) handle ex => (TextIO.output (TextIO.stdErr, General.exnMessage ex ^ "\n"); TextIO.flushOut TextIO.stdErr ; raise ex) end fun startServer () = while true do serverLoop () -- cgit v1.2.3 From 053783525d8365b8a498ac38942d44f4669d6a54 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Tue, 10 Dec 2019 20:21:35 +0100 Subject: First version of calculateFileState --- src/elaborate.sig | 14 +++++ src/lsp.sml | 149 +++++++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 150 insertions(+), 13 deletions(-) diff --git a/src/elaborate.sig b/src/elaborate.sig index 03359814..88ea068f 100644 --- a/src/elaborate.sig +++ b/src/elaborate.sig @@ -53,4 +53,18 @@ signature ELABORATE = sig , sgn: Elab.sgn } -> (Elab.decl list * ElabEnv.env) + val elabSgn: (ElabEnv.env * Disjoint.env) + -> Source.sgn + -> (Elab.sgn * Disjoint.goal list) + + datatype constraint = + Disjoint of Disjoint.goal + | TypeClass of ElabEnv.env * Elab.con * Elab.exp option ref * ErrorMsg.span + + val elabStr: (ElabEnv.env * Disjoint.env) + -> Source.str + -> (Elab.str * Elab.sgn * constraint list) + + val subSgn: ElabEnv.env -> ErrorMsg.span -> Elab.sgn -> Elab.sgn -> unit + end diff --git a/src/lsp.sml b/src/lsp.sml index cff30d5e..89a0e4b2 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,3 +1,5 @@ +structure C = Compiler + fun trim (s: substring): substring = Substring.dropr (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") @@ -327,22 +329,143 @@ type fileState = , decls : Elab.decl list } type state = - { rootUri : LspSpec.documentUri + { urpPath : string , fileStates : fileState SM.map } val stateRef = ref (NONE: state option) +fun scanDir (f: string -> bool) (path: string) = + let + val dir = OS.FileSys.openDir path + fun doScanDir acc = + case OS.FileSys.readDir dir of + NONE => (OS.FileSys.closeDir dir; acc) + | SOME fname => + (if f fname + then doScanDir (fname :: acc) + else doScanDir acc) + in + doScanDir [] + end + (* Throws Fail if can't init *) fun initState (initParams: LspSpec.initializeParams): state = - { rootUri = case #rootUri initParams of - NONE => raise Fail "Failed to initialize: no rootUri" - | SOME a => a - , fileStates = SM.empty - } + let + val rootPath = case #rootUri initParams of + NONE => raise Fail "No rootdir found" + | SOME a => #path a + val foundUrps = scanDir (fn fname => OS.Path.ext fname = SOME "urp") rootPath + in + { urpPath = case foundUrps of + [] => raise Fail ("No .urp files found in path " ^ rootPath) + | one :: [] => one + | many => raise Fail ("Found multiple .urp files in path " ^ rootPath) + , fileStates = SM.empty + } + end + +fun addSgnToEnv (env: ElabEnv.env) (sgn: Source.sgn_item list) (fileName: string) (addUnprefixed: bool): ElabEnv.env = + let + val moduleName = C.moduleOf fileName + val (sgn, gs) = Elaborate.elabSgn (env, Disjoint.empty) (Source.SgnConst sgn, { file = fileName + , first = ErrorMsg.dummyPos + , last = ErrorMsg.dummyPos }) + val () = case gs of + [] => () + | _ => (app (fn (_, env, _, c1, c2) => + Print.prefaces "Unresolved" + [("c1", ElabPrint.p_con env c1), + ("c2", ElabPrint.p_con env c2)]) gs; + raise Fail ("Unresolved disjointness constraints in " ^ moduleName ^ " at " ^ fileName)) (* TODO Not sure if this is needed for all signatures or only for Basis *) + val (env', n) = ElabEnv.pushStrNamed env moduleName sgn + val (_, env') = if addUnprefixed + then Elaborate.dopen env' {str = n, strs = [], sgn = sgn} + else ([], env) + in + env' + end + fun calculateFileState (state: state) (fileName: string): fileState = - { envOfPreviousModules = ElabEnv.empty - , decls = [] - } + let + (* TODO Optim: cache parsed urp file? *) + val () = if (OS.Path.ext fileName = SOME "ur") + then () + else raise Fail ("Can only handle .ur files for now") + val () = Elaborate.unifyMore := true + val job = valOf (C.run (C.transform C.parseUrp "parseUrp") (#urpPath state)) + fun entryInUrpToFileName (entry: string) (ext: string) = (#urpPath state) ^ "/" ^ entry ^ ext + val modulesBeforeAndAfterThisFile = + List.partition (fn entry => entryInUrpToFileName entry ".ur" = fileName) (#sources job) + val () = case #2 modulesBeforeAndAfterThisFile of + [] => + (* Module we're handling should always be in here *) + raise Fail ("Couldn't find file " ^ fileName ^ " referenced in .urp file at " ^ (#urpPath state)) + | _ => () + val parsedUrss = List.map (fn entry => + let + val fileName = entryInUrpToFileName entry ".urs" + in + { fileName = fileName + , parsed = + if OS.FileSys.access (fileName, []) + then raise (Fail ("Couldn't find an .urs file for " ^ fileName)) + else valOf (C.run (C.transform C.parseUrs "parseUrs") fileName)} + end) + (#1 modulesBeforeAndAfterThisFile) + val parsedBasisUrs = valOf (C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "basis.urs")) + val parsedTopUrs = valOf (C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "top.urs")) + val envWithStdLib = + addSgnToEnv + (addSgnToEnv ElabEnv.empty parsedBasisUrs (Settings.libFile "basis.urs") true) + parsedTopUrs (Settings.libFile "top.urs") true + val envBeforeThisFile = List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envWithStdLib parsedUrss + val (parsedUr: Source.decl list) = + valOf (C.run (C.transform C.parseUr "parseUr") fileName) + val (parsedUrs: (Source.sgn_item list) option) = + if OS.FileSys.access (fileName ^ "s", []) then + SOME (valOf (C.run (C.transform C.parseUrs "parseUrs") (fileName ^ "s"))) + else + NONE + val (str, sgn', gs) = + Elaborate.elabStr + (envBeforeThisFile, Disjoint.empty) + (Source.StrConst parsedUr, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) + + (* TODO definitily not sure about this one, just copied from "top" processing *) + val () = case gs of + [] => () + | _ => app (fn Elaborate.Disjoint (loc, env, denv, c1, c2) => + (case Disjoint.prove env denv (c1, c2, loc) of + [] => () + | _ => + (Print.prefaces "Unresolved constraint in top.ur" + [("loc", Print.PD.string (ErrorMsg.spanToString loc)), + ("c1", ElabPrint.p_con env c1), + ("c2", ElabPrint.p_con env c2)]; + raise Fail "Unresolved constraint in top.ur")) + | Elaborate.TypeClass (env, c, r, loc) => + () + (* let *) + (* val c = normClassKey env c *) + (* in *) + (* case resolveClass env c of *) + (* SOME e => r := SOME e *) + (* | NONE => expError env (Unresolvable (loc, c)) *) + (* end *) + ) gs + val (sgn, gs) = Elaborate.elabSgn + (envBeforeThisFile, Disjoint.empty) + ( Source.SgnConst (case parsedUrs of NONE => [] | SOME a => a) + , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) + val () = case gs of [] => () | _ => raise Fail ("Unresolved disjointness constraints in " ^ fileName) (* TODO not sure? *) + val () = Elaborate.subSgn envBeforeThisFile ErrorMsg.dummySpan sgn' sgn + in + { envOfPreviousModules = envBeforeThisFile + , decls = case str of + (Elab.StrConst decls, _) => decls + | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") + } + end fun serverLoop () = let @@ -383,9 +506,9 @@ fun serverLoop () = , textDocument_didOpen = fn didOpenParams => let val path = #path (#uri (#textDocument didOpenParams)) - val fileState = calculateFileState state (path) + val fileState = calculateFileState state path in - stateRef := SOME { rootUri = #rootUri state + stateRef := SOME { urpPath = #urpPath state , fileStates = SM.insert ( #fileStates state , path , fileState) @@ -395,9 +518,9 @@ fun serverLoop () = , textDocument_didSave = fn didSaveParams => let val path = #path (#uri (#textDocument didSaveParams)) - val fileState = calculateFileState state (path) + val fileState = calculateFileState state path in - stateRef := SOME { rootUri = #rootUri state + stateRef := SOME { urpPath = #urpPath state , fileStates = SM.insert ( #fileStates state , path , fileState) -- cgit v1.2.3 From 3515286a783fb1eb38acc001d23389dd67fdc910 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Tue, 10 Dec 2019 21:12:59 +0100 Subject: First publishDiagnostics implementation --- src/errormsg.sig | 3 ++ src/errormsg.sml | 8 ++- src/lsp.sml | 145 +++++++++++++++++++++++++++++++++++++------------------ 3 files changed, 109 insertions(+), 47 deletions(-) diff --git a/src/errormsg.sig b/src/errormsg.sig index 4cf8b50a..1fa4013c 100644 --- a/src/errormsg.sig +++ b/src/errormsg.sig @@ -58,4 +58,7 @@ signature ERROR_MSG = sig val error : string -> unit val errorAt : span -> string -> unit val errorAt' : int * int -> string -> unit + val readErrorLog: unit -> + { span: span + , message: string } list end diff --git a/src/errormsg.sml b/src/errormsg.sml index eee20768..d40789ed 100644 --- a/src/errormsg.sml +++ b/src/errormsg.sml @@ -88,6 +88,9 @@ fun spanOf (pos1, pos2) = {file = !file, val errors = ref false +val errorLog = ref ([]: { span: span + , message: string } list) +fun readErrorLog () = !errorLog val structuresCurrentlyElaborating: ((string * bool) list) ref = ref nil fun startElabStructure s = @@ -106,7 +109,7 @@ fun stopElabStructureAndGetErrored s = fun resetStructureTracker () = structuresCurrentlyElaborating := [] -fun resetErrors () = errors := false +fun resetErrors () = (errors := false; errorLog := []) fun anyErrors () = !errors fun error s = (TextIO.output (TextIO.stdErr, s); TextIO.output1 (TextIO.stdErr, #"\n"); @@ -120,6 +123,9 @@ fun errorAt (span : span) s = (TextIO.output (TextIO.stdErr, #file span); TextIO.output (TextIO.stdErr, ": (to "); TextIO.output (TextIO.stdErr, posToString (#last span)); TextIO.output (TextIO.stdErr, ") "); + errorLog := ({ span = span + , message = s + } :: !errorLog); error s) fun errorAt' span s = errorAt (spanOf span) s diff --git a/src/lsp.sml b/src/lsp.sml index 89a0e4b2..976faa25 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -5,6 +5,9 @@ fun trim (s: substring): substring = (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 get (s: string) (l: Json.json): Json.json = case l of @@ -111,6 +114,12 @@ structure LspSpec (* :> LSPSPEC *) = struct , 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 = @@ -145,6 +154,13 @@ structure LspSpec (* :> LSPSPEC *) = struct { 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 printRange (r: range): Json.json = Json.Obj [ ("start", printPosition (#start r)) + , ("end", printPosition (#end_ r))] fun readRequestFromStdIO (): message = let @@ -195,6 +211,26 @@ structure LspSpec (* :> LSPSPEC *) = struct 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 initializeResponse = { capabilities: { hoverProvider: bool , textDocumentSync: @@ -229,24 +265,27 @@ structure LspSpec (* :> LSPSPEC *) = struct case a of Success contents => Success (f contents) | Error e => Error e - type context = { showMessage: string -> int -> unit} + type toclient = { showMessage: string -> int -> unit + , publishDiagnostics: publishDiagnosticsParams -> unit } type messageHandlers = { initialize: initializeParams -> initializeResponse result , shutdown: unit -> unit result - , textDocument_hover: context -> hoverReq -> hoverResp result + , textDocument_hover: toclient -> hoverReq -> hoverResp result } + fun showMessage str typ = + TextIO.print (Json.print (Json.Obj [ ("method", Json.String "window/showMessage") + , ("params", Json.Obj [ ("type", Json.Int typ) + , ("message", Json.String str)]) + ])); + fun publishDiagnostics diags = TextIO.print (Json.print (printPublishDiagnosticsParams diags)) + val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} + fun handleMessage (requestMessage: {id: Json.json, method: string, params: Json.json}) (handlers: messageHandlers) : unit = let - fun showMessage str typ = - TextIO.print (Json.print (Json.Obj [ ("method", Json.String "window/showMessage") - , ("params", Json.Obj [ ("type", Json.Int typ) - , ("message", Json.String str)]) - ])); - val result: Json.json result = case #method requestMessage of "initialize" => @@ -258,7 +297,7 @@ structure LspSpec (* :> LSPSPEC *) = struct mapResult printHoverResponse ((#textDocument_hover handlers) - {showMessage = showMessage} + toclient (parseHoverReq (#params requestMessage))) | "shutdown" => mapResult @@ -299,18 +338,19 @@ structure LspSpec (* :> LSPSPEC *) = struct type notificationHandlers = { initialized: unit -> unit - , textDocument_didOpen: didOpenParams -> unit - , textDocument_didChange: didChangeParams -> unit - , textDocument_didSave: didSaveParams -> unit + , textDocument_didOpen: toclient -> didOpenParams -> unit + , textDocument_didChange: toclient -> didChangeParams -> unit + , textDocument_didSave: toclient -> didSaveParams -> unit } fun handleNotification (notification: {method: string, params: Json.json}) (handlers: notificationHandlers) - = case #method notification of + = + case #method notification of "initialized" => (#initialized handlers) () - | "textDocument/didOpen" => (#textDocument_didOpen handlers) (parseDidOpenParams (#params notification)) - | "textDocument/didChange" => (#textDocument_didChange handlers) (parseDidChangeParams (#params notification)) - | "textDocument/didSave" => (#textDocument_didSave handlers) (parseDidSaveParams (#params notification)) + | "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)) | m => (TextIO.output ( TextIO.stdErr, "Notification method not supported: " ^ m); TextIO.flushOut TextIO.stdErr) @@ -385,7 +425,8 @@ fun addSgnToEnv (env: ElabEnv.env) (sgn: Source.sgn_item list) (fileName: string env' end -fun calculateFileState (state: state) (fileName: string): fileState = +(* TODO: get errors from elaboration and subsgn and make Diagnostics from these *) +fun calculateFileState (state: state) (fileName: string): (fileState * LspSpec.diagnostic list) = let (* TODO Optim: cache parsed urp file? *) val () = if (OS.Path.ext fileName = SOME "ur") @@ -426,12 +467,13 @@ fun calculateFileState (state: state) (fileName: string): fileState = SOME (valOf (C.run (C.transform C.parseUrs "parseUrs") (fileName ^ "s"))) else NONE + val () = ErrorMsg.resetErrors () val (str, sgn', gs) = Elaborate.elabStr (envBeforeThisFile, Disjoint.empty) (Source.StrConst parsedUr, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) - (* TODO definitily not sure about this one, just copied from "top" processing *) + (* TODO definitely not sure about this one, just copied from "top" processing *) val () = case gs of [] => () | _ => app (fn Elaborate.Disjoint (loc, env, denv, c1, c2) => @@ -459,12 +501,43 @@ fun calculateFileState (state: state) (fileName: string): fileState = , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) val () = case gs of [] => () | _ => raise Fail ("Unresolved disjointness constraints in " ^ fileName) (* TODO not sure? *) val () = Elaborate.subSgn envBeforeThisFile ErrorMsg.dummySpan sgn' sgn + val errors = ErrorMsg.readErrorLog () in - { envOfPreviousModules = envBeforeThisFile - , decls = case str of - (Elab.StrConst decls, _) => decls - | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") - } + ({ envOfPreviousModules = envBeforeThisFile + , decls = case str of + (Elab.StrConst decls, _) => decls + | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") + }, + List.map + (fn err => { range = { start = { line = #line (#first (#span err)) + , character = #char (#first (#span err)) + } + , end_ = { line = #line (#last (#span err)) + , character = #char (#last (#span err)) + } + } + , severity = 1 + , source = "UrWeb" + , message = #message err + } + ) + errors + ) + end + +fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) = + let + val path = #path documentUri + val res = calculateFileState state path + in + stateRef := SOME { urpPath = #urpPath state + , fileStates = SM.insert ( #fileStates state + , path + , #1 res) + }; + case #2 res of + [] => () + | diags => #publishDiagnostics toclient { uri = documentUri , diagnostics = diags} end fun serverLoop () = @@ -503,29 +576,9 @@ fun serverLoop () = LspSpec.handleNotification n { initialized = fn () => () - , textDocument_didOpen = fn didOpenParams => - let - val path = #path (#uri (#textDocument didOpenParams)) - val fileState = calculateFileState state path - in - stateRef := SOME { urpPath = #urpPath state - , fileStates = SM.insert ( #fileStates state - , path - , fileState) - } - end - , textDocument_didChange = fn didChangeParams => () - , textDocument_didSave = fn didSaveParams => - let - val path = #path (#uri (#textDocument didSaveParams)) - val fileState = calculateFileState state path - in - stateRef := SOME { urpPath = #urpPath state - , fileStates = SM.insert ( #fileStates state - , path - , fileState) - } - end + , textDocument_didOpen = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) + , textDocument_didChange = fn ctx => fn didChangeParams => () + , textDocument_didSave = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) } | LspSpec.RequestMessage m => LspSpec.handleMessage -- cgit v1.2.3 From e4f98c318fcadff9247c83d1659a39b15e8c9d58 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Tue, 10 Dec 2019 22:44:51 +0100 Subject: First working version of publishDiagnostics --- src/json.sml | 12 ++++-- src/lsp.sml | 120 +++++++++++++++++++++++++++++++++-------------------------- 2 files changed, 76 insertions(+), 56 deletions(-) diff --git a/src/json.sml b/src/json.sml index f189cc4d..cc9ea6ae 100644 --- a/src/json.sml +++ b/src/json.sml @@ -114,8 +114,12 @@ struct and parseChars () = let fun pickChars s = - if peek () = #"\"" (* " *) then s else - pickChars (s ^ String.str (take ())) + if peek () = #"\"" (* " *) + then s + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"\"" + then (consume "\\\""; pickChars (s ^ "\"")) + else pickChars (s ^ String.str (take ())) in pickChars "" end @@ -256,8 +260,8 @@ fun parse (str: string): json = fun print (ast: json): string = case ast of Array l => "[" - ^ List.foldl (fn (a, acc) => acc ^ "," ^ print a) "" l - ^ "]" + ^ List.foldl (fn (a, acc) => acc ^ (if acc = "" then "" else ", ") ^ print a) "" l + ^ "]" | Null => "null" | Float r => Real.toString r | String s => diff --git a/src/lsp.sml b/src/lsp.sml index 976faa25..175a71ee 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,4 +1,6 @@ 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 @@ -98,7 +100,7 @@ structure LspSpec (* :> LSPSPEC *) = struct 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 <> #"#") (Substring.triml 1 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) @@ -116,7 +118,7 @@ structure LspSpec (* :> LSPSPEC *) = struct end fun printDocumentUri (d: documentUri) = (#scheme d) ^ "://" ^ - (#authority d) ^ "/" ^ + (#authority d) ^ (#path d) ^ (if #query d <> "" then "?" ^ #query d else "") ^ (if #fragment d <> "" then "#" ^ #fragment d else "") @@ -274,11 +276,27 @@ structure LspSpec (* :> LSPSPEC *) = struct } fun showMessage str typ = - TextIO.print (Json.print (Json.Obj [ ("method", Json.String "window/showMessage") - , ("params", Json.Obj [ ("type", Json.Int typ) - , ("message", Json.String str)]) - ])); - fun publishDiagnostics diags = TextIO.print (Json.print (printPublishDiagnosticsParams diags)) + 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 + (debug ("Sending diagnostics: " ^ toPrint); + TextIO.print toPrint) + end val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} fun handleMessage @@ -351,8 +369,7 @@ structure LspSpec (* :> LSPSPEC *) = struct | "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)) - | m => (TextIO.output ( TextIO.stdErr, "Notification method not supported: " ^ m); - TextIO.flushOut TextIO.stdErr) + | m => debug ("Notification method not supported: " ^ m) end @@ -394,11 +411,12 @@ fun initState (initParams: LspSpec.initializeParams): state = val rootPath = case #rootUri initParams of NONE => raise Fail "No rootdir found" | SOME a => #path a + (* val () = debug ("Scanning dir: " ^ rootPath) *) val foundUrps = scanDir (fn fname => OS.Path.ext fname = SOME "urp") rootPath in { urpPath = case foundUrps of [] => raise Fail ("No .urp files found in path " ^ rootPath) - | one :: [] => one + | one :: [] => OS.Path.base (OS.Path.file one) | many => raise Fail ("Found multiple .urp files in path " ^ rootPath) , fileStates = SM.empty } @@ -425,7 +443,6 @@ fun addSgnToEnv (env: ElabEnv.env) (sgn: Source.sgn_item list) (fileName: string env' end -(* TODO: get errors from elaboration and subsgn and make Diagnostics from these *) fun calculateFileState (state: state) (fileName: string): (fileState * LspSpec.diagnostic list) = let (* TODO Optim: cache parsed urp file? *) @@ -474,27 +491,26 @@ fun calculateFileState (state: state) (fileName: string): (fileState * LspSpec.d (Source.StrConst parsedUr, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) (* TODO definitely not sure about this one, just copied from "top" processing *) - val () = case gs of - [] => () - | _ => app (fn Elaborate.Disjoint (loc, env, denv, c1, c2) => - (case Disjoint.prove env denv (c1, c2, loc) of - [] => () - | _ => - (Print.prefaces "Unresolved constraint in top.ur" - [("loc", Print.PD.string (ErrorMsg.spanToString loc)), - ("c1", ElabPrint.p_con env c1), - ("c2", ElabPrint.p_con env c2)]; - raise Fail "Unresolved constraint in top.ur")) - | Elaborate.TypeClass (env, c, r, loc) => - () - (* let *) - (* val c = normClassKey env c *) - (* in *) - (* case resolveClass env c of *) - (* SOME e => r := SOME e *) - (* | NONE => expError env (Unresolvable (loc, c)) *) - (* end *) - ) gs + (* val () = case gs of *) + (* [] => () *) + (* | _ => app (fn Elaborate.Disjoint (loc, env, denv, c1, c2) => *) + (* (case Disjoint.prove env denv (c1, c2, loc) of *) + (* [] => () *) + (* | _ => *) + (* (Print.prefaces "Unresolved constraint in top.ur" *) + (* [("loc", Print.PD.string (ErrorMsg.spanToString loc)), *) + (* ("c1", ElabPrint.p_con env c1), *) + (* ("c2", ElabPrint.p_con env c2)]; *) + (* raise Fail "Unresolved constraint in top.ur")) *) + (* | Elaborate.TypeClass (env, c, r, loc) => *) + (* let *) + (* val c = normClassKey env c *) + (* in *) + (* case resolveClass env c of *) + (* SOME e => r := SOME e *) + (* | NONE => expError env (Unresolvable (loc, c)) *) + (* end *) + (* ) gs *) val (sgn, gs) = Elaborate.elabSgn (envBeforeThisFile, Disjoint.empty) ( Source.SgnConst (case parsedUrs of NONE => [] | SOME a => a) @@ -502,17 +518,19 @@ fun calculateFileState (state: state) (fileName: string): (fileState * LspSpec.d val () = case gs of [] => () | _ => raise Fail ("Unresolved disjointness constraints in " ^ fileName) (* TODO not sure? *) val () = Elaborate.subSgn envBeforeThisFile ErrorMsg.dummySpan sgn' sgn val errors = ErrorMsg.readErrorLog () + val decls = case str of + (Elab.StrConst decls, _) => decls + | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") + val () = debug ("Finished calculateFileState for " ^ fileName ^ " with " ^ Int.toString (List.length errors) ^ " errors. " ^ Int.toString (List.length decls) ^ " decls found") in ({ envOfPreviousModules = envBeforeThisFile - , decls = case str of - (Elab.StrConst decls, _) => decls - | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") + , decls = decls }, List.map - (fn err => { range = { start = { line = #line (#first (#span err)) + (fn err => { range = { start = { line = #line (#first (#span err)) - 1 , character = #char (#first (#span err)) } - , end_ = { line = #line (#last (#span err)) + , end_ = { line = #line (#last (#span err)) - 1 , character = #char (#last (#span err)) } } @@ -535,16 +553,14 @@ fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: , path , #1 res) }; - case #2 res of - [] => () - | diags => #publishDiagnostics toclient { uri = documentUri , diagnostics = diags} + #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res} end fun serverLoop () = let val requestMessage = LspSpec.readRequestFromStdIO () - handle ex => (TextIO.output (TextIO.stdErr, General.exnMessage ex ^ "\n"); TextIO.flushOut TextIO.stdErr ; raise ex) + handle ex => (debug (General.exnMessage ex) ; raise ex) val state = !stateRef in case state of @@ -554,17 +570,17 @@ fun serverLoop () = LspSpec.handleMessage m { initialize = fn _ => - let val st = initState (LspSpec.parseInitializeParams (#params m)) - in - stateRef := SOME st; - LspSpec.Success - { capabilities = - { hoverProvider = true - , textDocumentSync = { openClose = true + (let val st = initState (LspSpec.parseInitializeParams (#params m)) + in + stateRef := SOME st; + LspSpec.Success + { capabilities = + { hoverProvider = true + , textDocumentSync = { openClose = true , save = SOME { includeText = false } - }} - } - end + }} + } + end) handle (Fail str) => LspSpec.Error (~32602, str) , shutdown = fn () => LspSpec.Error (~32002, "Server not initialized") , textDocument_hover = fn ctx => fn _ => LspSpec.Error (~32002, "Server not initialized") @@ -587,7 +603,7 @@ fun serverLoop () = , shutdown = fn () => LspSpec.Success () , textDocument_hover = fn ctx => fn _ => LspSpec.Success NONE } - ) handle ex => (TextIO.output (TextIO.stdErr, General.exnMessage ex ^ "\n"); TextIO.flushOut TextIO.stdErr ; raise ex) + ) handle ex => (debug (General.exnMessage ex); raise ex) end fun startServer () = while true do serverLoop () -- cgit v1.2.3 From 96c72b6bd8bbb2e31da5664172c05a1bcfb41b64 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Tue, 10 Dec 2019 22:48:36 +0100 Subject: Add parse error comment --- src/lsp.sml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/lsp.sml b/src/lsp.sml index 175a71ee..658ca7a6 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -443,6 +443,7 @@ fun addSgnToEnv (env: ElabEnv.env) (sgn: Source.sgn_item list) (fileName: string env' end +(* TODO: Any parse error -> valOf fails, throws and server crashes *) fun calculateFileState (state: state) (fileName: string): (fileState * LspSpec.diagnostic list) = let (* TODO Optim: cache parsed urp file? *) -- cgit v1.2.3 From a0efdaf11337df1fb1a5478f9a193a2737b2665b Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 11 Dec 2019 12:31:50 +0100 Subject: Fixed parsing errors and loading of interfaces --- src/json.sml | 4 +- src/lsp.sml | 262 ++++++++++++++++++++++++++++++++++++----------------------- 2 files changed, 163 insertions(+), 103 deletions(-) diff --git a/src/json.sml b/src/json.sml index cc9ea6ae..656d28ff 100644 --- a/src/json.sml +++ b/src/json.sml @@ -271,7 +271,9 @@ fun print (ast: json): string = s ^ "\"" | Bool b => if b then "true" else "false" - | Int i => Int.toString i + | Int i => if i >= 0 + then (Int.toString i) + else "-" ^ (Int.toString (Int.abs i)) (* default printing uses ~ instead of - *) | Obj l => "{" ^ List.foldl (fn ((k, v), acc) => acc ^ (if acc = "" then "" else ", ") ^ "\"" ^ k ^ "\": " ^ print v ) "" l ^ "}" diff --git a/src/lsp.sml b/src/lsp.sml index 658ca7a6..34209231 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -294,8 +294,7 @@ structure LspSpec (* :> LSPSPEC *) = struct ])) val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint in - (debug ("Sending diagnostics: " ^ toPrint); - TextIO.print toPrint) + TextIO.print toPrint end val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} @@ -375,6 +374,42 @@ 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 + structure SK = struct type ord_key = string val compare = String.compare @@ -411,7 +446,6 @@ fun initState (initParams: LspSpec.initializeParams): state = val rootPath = case #rootUri initParams of NONE => raise Fail "No rootdir found" | SOME a => #path a - (* val () = debug ("Scanning dir: " ^ rootPath) *) val foundUrps = scanDir (fn fname => OS.Path.ext fname = SOME "urp") rootPath in { urpPath = case foundUrps of @@ -438,110 +472,126 @@ fun addSgnToEnv (env: ElabEnv.env) (sgn: Source.sgn_item list) (fileName: string val (env', n) = ElabEnv.pushStrNamed env moduleName sgn val (_, env') = if addUnprefixed then Elaborate.dopen env' {str = n, strs = [], sgn = sgn} - else ([], env) + else ([], env') in env' end -(* TODO: Any parse error -> valOf fails, throws and server crashes *) -fun calculateFileState (state: state) (fileName: string): (fileState * LspSpec.diagnostic list) = +fun errorToDiagnostic (err: { span: ErrorMsg.span , message: string }): LspSpec.diagnostic = + { range = { start = { line = #line (#first (#span err)) - 1 + , character = #char (#first (#span err)) + } + , end_ = { line = #line (#last (#span err)) - 1 + , character = #char (#last (#span err)) + } + } + , severity = 1 + , source = "UrWeb" + , message = #message err + } + +(* TODO FFI modules ? Check compiler.sml -> parse -> parseFfi *) +(* TODO Optim: cache parsed urp file? *) +fun calculateFileState (state: state) (fileName: string): (fileState option * LspSpec.diagnostic list) = let - (* TODO Optim: cache parsed urp file? *) val () = if (OS.Path.ext fileName = SOME "ur") then () else raise Fail ("Can only handle .ur files for now") val () = Elaborate.unifyMore := true - val job = valOf (C.run (C.transform C.parseUrp "parseUrp") (#urpPath state)) - fun entryInUrpToFileName (entry: string) (ext: string) = (#urpPath state) ^ "/" ^ entry ^ ext - val modulesBeforeAndAfterThisFile = - List.partition (fn entry => entryInUrpToFileName entry ".ur" = fileName) (#sources job) - val () = case #2 modulesBeforeAndAfterThisFile of - [] => - (* Module we're handling should always be in here *) - raise Fail ("Couldn't find file " ^ fileName ^ " referenced in .urp file at " ^ (#urpPath state)) - | _ => () + (* 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))) + | SOME a => a + val moduleSearchRes = + List.foldl + (fn (entry, acc) => if #2 acc + then acc + else + if entry ^ ".ur" = fileName + then (List.rev (#1 acc), true) + else (entry :: #1 acc, false)) + ([] (* modules before *), false (* module found *)) + (#sources job) + 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))) + (* Parsing .urs files of previous modules *) val parsedUrss = List.map (fn entry => let - val fileName = entryInUrpToFileName entry ".urs" + val fileName = entry ^ ".urs" in { fileName = fileName , parsed = if OS.FileSys.access (fileName, []) - then raise (Fail ("Couldn't find an .urs file for " ^ fileName)) - else valOf (C.run (C.transform C.parseUrs "parseUrs") fileName)} + then case C.run (C.transform C.parseUrs "parseUrs") fileName of + NONE => raise LspError (InternalError ("Failed to parse .urs file at " ^ fileName)) + | SOME a => a + else raise LspError (InternalError ("Couldn't find an .urs file for " ^ fileName)) + } end) - (#1 modulesBeforeAndAfterThisFile) - val parsedBasisUrs = valOf (C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "basis.urs")) - val parsedTopUrs = valOf (C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "top.urs")) + modulesBeforeThisFile + (* Parsing Basis and Top .urs *) + val parsedBasisUrs = + case C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "basis.urs") of + NONE => raise LspError (InternalError ("Failed to parse basis.urs file at " ^ (Settings.libFile "basis.urs"))) + | SOME a => a + val parsedTopUrs = + case C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "top.urs") of + NONE => raise LspError (InternalError ("Failed to parse top.urs file at " ^ (Settings.libFile "top.urs"))) + | SOME a => a + (* Building env with previous .urs files *) val envWithStdLib = addSgnToEnv (addSgnToEnv ElabEnv.empty parsedBasisUrs (Settings.libFile "basis.urs") true) parsedTopUrs (Settings.libFile "top.urs") true val envBeforeThisFile = List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envWithStdLib parsedUrss - val (parsedUr: Source.decl list) = - valOf (C.run (C.transform C.parseUr "parseUr") fileName) + (* Parsing .ur and .urs of current file *) val (parsedUrs: (Source.sgn_item list) option) = - if OS.FileSys.access (fileName ^ "s", []) then - SOME (valOf (C.run (C.transform C.parseUrs "parseUrs") (fileName ^ "s"))) - else - NONE + (if OS.FileSys.access (fileName ^ "s", []) + then + case C.run (C.transform C.parseUrs "parseUrs") (fileName ^ "s") of + NONE => NONE + | SOME a => SOME a + else + NONE) handle ex => NONE val () = ErrorMsg.resetErrors () - val (str, sgn', gs) = - Elaborate.elabStr - (envBeforeThisFile, Disjoint.empty) - (Source.StrConst parsedUr, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) - - (* TODO definitely not sure about this one, just copied from "top" processing *) - (* val () = case gs of *) - (* [] => () *) - (* | _ => app (fn Elaborate.Disjoint (loc, env, denv, c1, c2) => *) - (* (case Disjoint.prove env denv (c1, c2, loc) of *) - (* [] => () *) - (* | _ => *) - (* (Print.prefaces "Unresolved constraint in top.ur" *) - (* [("loc", Print.PD.string (ErrorMsg.spanToString loc)), *) - (* ("c1", ElabPrint.p_con env c1), *) - (* ("c2", ElabPrint.p_con env c2)]; *) - (* raise Fail "Unresolved constraint in top.ur")) *) - (* | Elaborate.TypeClass (env, c, r, loc) => *) - (* let *) - (* val c = normClassKey env c *) - (* in *) - (* case resolveClass env c of *) - (* SOME e => r := SOME e *) - (* | NONE => expError env (Unresolvable (loc, c)) *) - (* end *) - (* ) gs *) - val (sgn, gs) = Elaborate.elabSgn - (envBeforeThisFile, Disjoint.empty) - ( Source.SgnConst (case parsedUrs of NONE => [] | SOME a => a) - , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) - val () = case gs of [] => () | _ => raise Fail ("Unresolved disjointness constraints in " ^ fileName) (* TODO not sure? *) - val () = Elaborate.subSgn envBeforeThisFile ErrorMsg.dummySpan sgn' sgn - val errors = ErrorMsg.readErrorLog () - val decls = case str of - (Elab.StrConst decls, _) => decls - | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") - val () = debug ("Finished calculateFileState for " ^ fileName ^ " with " ^ Int.toString (List.length errors) ^ " errors. " ^ Int.toString (List.length decls) ^ " decls found") + val (parsedUrO: (Source.decl list) option) = + C.run (C.transform C.parseUr "parseUr") fileName in - ({ envOfPreviousModules = envBeforeThisFile - , decls = decls - }, - List.map - (fn err => { range = { start = { line = #line (#first (#span err)) - 1 - , character = #char (#first (#span err)) - } - , end_ = { line = #line (#last (#span err)) - 1 - , character = #char (#last (#span err)) - } - } - , severity = 1 - , source = "UrWeb" - , message = #message err - } - ) - errors - ) + case parsedUrO of + NONE => (* Parse error *) (NONE, List.map errorToDiagnostic (ErrorMsg.readErrorLog ())) + | SOME parsedUr => + (* .ur file found -> typecheck *) + let + val (str, sgn', gs) = + Elaborate.elabStr + (envBeforeThisFile, Disjoint.empty) + (Source.StrConst parsedUr, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) + val () = + (* .urs file found -> check and compare with .ur file *) + (case parsedUrs of + NONE => () + | SOME parsedUrs => + let + val (sgn, gs) = Elaborate.elabSgn + (envBeforeThisFile, Disjoint.empty) + ( Source.SgnConst parsedUrs + , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}); + in + Elaborate.subSgn envBeforeThisFile ErrorMsg.dummySpan sgn' sgn + end) + (* report back errors (as Diagnostics) *) + val errors = ErrorMsg.readErrorLog () + val decls = case str of + (Elab.StrConst decls, _) => decls + | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") + in + (SOME { envOfPreviousModules = envBeforeThisFile + , decls = decls + }, + List.map errorToDiagnostic errors) + end end fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) = @@ -549,11 +599,14 @@ fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: val path = #path documentUri val res = calculateFileState state path in - stateRef := SOME { urpPath = #urpPath state - , fileStates = SM.insert ( #fileStates state - , path - , #1 res) - }; + (case #1 res of + NONE => () + | SOME fs => + stateRef := SOME { urpPath = #urpPath state + , fileStates = SM.insert ( #fileStates state + , path + , fs) + }) ; #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res} end @@ -590,21 +643,26 @@ fun serverLoop () = | SOME state => (case requestMessage of LspSpec.Notification n => - LspSpec.handleNotification - n - { initialized = fn () => () - , textDocument_didOpen = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) - , textDocument_didChange = fn ctx => fn didChangeParams => () - , textDocument_didSave = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) - } + ((LspSpec.handleNotification + n + { initialized = fn () => () + , textDocument_didOpen = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) + , textDocument_didChange = fn ctx => fn didChangeParams => () + , textDocument_didSave = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) + }) + handle LspError e => handleLspErrorInNotification e + | ex => handleLspErrorInNotification (InternalError (General.exnMessage ex))) | LspSpec.RequestMessage m => - LspSpec.handleMessage - m - { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") - , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn ctx => fn _ => LspSpec.Success NONE - } - ) handle ex => (debug (General.exnMessage ex); raise ex) + (* TODO should error handling here be inside handleMessage? *) + ((LspSpec.handleMessage + m + { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = fn ctx => fn _ => LspSpec.Success NONE + }) + handle LspError e => handleLspErrorInRequest (#id m) e + | ex => handleLspErrorInRequest (#id m) (InternalError (General.exnMessage ex))) + ) end fun startServer () = while true do serverLoop () -- cgit v1.2.3 From 25b0685cefe772c73562665a4cc8d2d40e5ff600 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 11 Dec 2019 13:58:01 +0100 Subject: Use elabFile completely instead of rebuilding it partially --- src/compiler.sml | 2 +- src/elaborate.sig | 5 +++- src/elaborate.sml | 4 ++- src/lsp.sml | 73 ++++++++++++++++++++++++++----------------------------- 4 files changed, 42 insertions(+), 42 deletions(-) diff --git a/src/compiler.sml b/src/compiler.sml index fab939f9..ab7b86b4 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1283,7 +1283,7 @@ val elaborate = { in Elaborate.elabFile basis (OS.FileSys.modTime basisF) topStr topSgn (if Time.< (tm1, tm2) then tm2 else tm1) - ElabEnv.empty file + ElabEnv.empty (fn env => env) file end, print = ElabPrint.p_file ElabEnv.empty } diff --git a/src/elaborate.sig b/src/elaborate.sig index 88ea068f..d6747241 100644 --- a/src/elaborate.sig +++ b/src/elaborate.sig @@ -29,7 +29,10 @@ signature ELABORATE = sig val elabFile : Source.sgn_item list -> Time.time -> Source.decl list -> Source.sgn_item list -> Time.time - -> ElabEnv.env -> Source.file -> Elab.file + -> ElabEnv.env + -> (ElabEnv.env -> ElabEnv.env) (* Adapt env after stdlib but before elaborate *) + -> Source.file + -> Elab.file val resolveClass : ElabEnv.env -> Elab.con -> Elab.exp option diff --git a/src/elaborate.sml b/src/elaborate.sml index d5e190fa..85234775 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -4760,7 +4760,7 @@ and elabStr (env, denv) (str, loc) = fun resolveClass env = E.resolveClass (hnormCon env) (consEq env dummy) env -fun elabFile basis basis_tm topStr topSgn top_tm env file = +fun elabFile basis basis_tm topStr topSgn top_tm env changeEnv file = let val () = ModDb.snapshot () val () = ErrorMsg.resetStructureTracker () @@ -4857,6 +4857,8 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (ds', env') = dopen env' {str = top_n, strs = [], sgn = topSgn} + val env' = changeEnv env' + fun elabDecl' x = (resetKunif (); resetCunif (); diff --git a/src/lsp.sml b/src/lsp.sml index 34209231..b5a92683 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -417,9 +417,7 @@ end structure SM = BinaryMapFn(SK) type fileState = - { envOfPreviousModules : ElabEnv.env - , decls : Elab.decl list - } + { decls : Elab.decl list } type state = { urpPath : string , fileStates : fileState SM.map @@ -498,6 +496,8 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls then () else raise Fail ("Can only handle .ur files for now") val () = Elaborate.unifyMore := true + (* To reuse Basis and Top *) + 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))) @@ -531,28 +531,35 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls } end) modulesBeforeThisFile - (* Parsing Basis and Top .urs *) + (* Parsing Basis and Top *) + val basisF = Settings.libFile "basis.urs" + val topF = Settings.libFile "top.urs" + val topF' = Settings.libFile "top.ur" + + val tm1 = OS.FileSys.modTime topF + val tm2 = OS.FileSys.modTime topF' + val parsedBasisUrs = - case C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "basis.urs") of - NONE => raise LspError (InternalError ("Failed to parse basis.urs file at " ^ (Settings.libFile "basis.urs"))) + case C.run (C.transform C.parseUrs "parseUrs") basisF of + NONE => raise LspError (InternalError ("Failed to parse basis.urs file at " ^ basisF)) | SOME a => a val parsedTopUrs = - case C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "top.urs") of - NONE => raise LspError (InternalError ("Failed to parse top.urs file at " ^ (Settings.libFile "top.urs"))) + case C.run (C.transform C.parseUrs "parseUrs") topF of + NONE => raise LspError (InternalError ("Failed to parse top.urs file at " ^ topF)) | SOME a => a - (* Building env with previous .urs files *) - val envWithStdLib = - addSgnToEnv - (addSgnToEnv ElabEnv.empty parsedBasisUrs (Settings.libFile "basis.urs") true) - parsedTopUrs (Settings.libFile "top.urs") true - val envBeforeThisFile = List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envWithStdLib parsedUrss + val parsedTopUr = + case C.run (C.transform C.parseUr "parseUr") topF' of + NONE => raise LspError (InternalError ("Failed to parse top.ur file at " ^ topF')) + | SOME a => a + (* Parsing .ur and .urs of current file *) - val (parsedUrs: (Source.sgn_item list) option) = + val (parsedUrs: Source.sgn option) = (if OS.FileSys.access (fileName ^ "s", []) then case C.run (C.transform C.parseUrs "parseUrs") (fileName ^ "s") of NONE => NONE - | SOME a => SOME a + | SOME a => SOME ( Source.SgnConst a + , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) else NONE) handle ex => NONE val () = ErrorMsg.resetErrors () @@ -562,34 +569,22 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls case parsedUrO of NONE => (* Parse error *) (NONE, List.map errorToDiagnostic (ErrorMsg.readErrorLog ())) | SOME parsedUr => - (* .ur file found -> typecheck *) + (* Parsing of .ur succeeded *) let - val (str, sgn', gs) = - Elaborate.elabStr - (envBeforeThisFile, Disjoint.empty) - (Source.StrConst parsedUr, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) - val () = - (* .urs file found -> check and compare with .ur file *) - (case parsedUrs of - NONE => () - | SOME parsedUrs => - let - val (sgn, gs) = Elaborate.elabSgn - (envBeforeThisFile, Disjoint.empty) - ( Source.SgnConst parsedUrs - , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}); - in - Elaborate.subSgn envBeforeThisFile ErrorMsg.dummySpan sgn' sgn - end) + val loc = {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos} + val res = Elaborate.elabFile + parsedBasisUrs tm1 parsedTopUr parsedTopUrs tm2 ElabEnv.empty + (* Adding urs's of previous modules to env *) + (fn envB => List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envB parsedUrss) + [( Source.DStr (C.moduleOf fileName, parsedUrs, NONE, (Source.StrConst parsedUr, loc), false) + , loc )] (* report back errors (as Diagnostics) *) val errors = ErrorMsg.readErrorLog () - val decls = case str of - (Elab.StrConst decls, _) => decls + val decls = case List.last res of + (Elab.DStr (_, _, _, (Elab.StrConst decls, _)), _) => decls | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") in - (SOME { envOfPreviousModules = envBeforeThisFile - , decls = decls - }, + (SOME { decls = decls }, List.map errorToDiagnostic errors) end end -- cgit v1.2.3 From 9b00dc724363ac7b0a31687f14cc3bb2f2460f9b Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 11 Dec 2019 22:56:29 +0100 Subject: Integrated getInfo into LSP --- src/getinfo.sig | 7 +- src/getinfo.sml | 353 ++++++++++++++++++++++++----------------------------- src/lsp.sml | 69 ++++++++++- src/main.mlton.sml | 6 - 4 files changed, 230 insertions(+), 205 deletions(-) diff --git a/src/getinfo.sig b/src/getinfo.sig index 317b7e79..334e19f1 100644 --- a/src/getinfo.sig +++ b/src/getinfo.sig @@ -26,6 +26,11 @@ *) signature GET_INFO = sig - val getInfo: string (* file:row:col *) -> Print.PD.pp_desc + val getInfo: + ElabEnv.env -> + Elab.str' -> + string (* fileName *) -> + { line: int , character: int} -> + Print.PD.pp_desc end diff --git a/src/getinfo.sml b/src/getinfo.sml index 37c50928..7925aba3 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -73,198 +73,163 @@ fun getSpan (f: item * E.env) = | Str s => #2 s | Decl d => #2 d -fun getInfo' file row col = - if not (!Elaborate.incremental) - then P.PD.string "ERROR: urweb daemon is needed to use typeOf command" - else - case ModDb.lookupModAndDepsIncludingErrored (Compiler.moduleOf file) of - NONE => P.PD.string ("ERROR: No module found: " ^ Compiler.moduleOf file) - | SOME (modDecl, deps) => - let - val () = U.mliftConInCon := E.mliftConInCon - - (* Adding signature of dependencies to environment *) - val env = List.foldl (fn (d, e) => E.declBinds e d) E.empty deps - - (* Adding previous declarations in file to environment *) - (* "open " statements are already translated during elaboration *) - (* They get added to the env here "unprefixed" *) - val env = - case #1 modDecl of - L.DStr (name, _, sgn, str) => - (case #1 str of - L.StrConst decls => - List.foldl (fn (d, env) => - if #line (#first (#2 d)) <= row - andalso #char (#first (#2 d)) <= col - then E.declBinds env d - else env) env decls - | _ => env) - | L.DFfiStr _ => env - | _ => env - - (* Basis and Top need to be added to the env explicitly *) - val env = - case ModDb.lookupModAndDepsIncludingErrored "Top" of - NONE => raise Fail "ERROR: Top module not found in ModDb" - | SOME ((L.DStr (_, top_n, topSgn, topStr), _), _) => - #2 (Elaborate.dopen env {str = top_n, strs = [], sgn = topSgn}) - | _ => raise Fail "ERROR: Impossible" - val env = - case ModDb.lookupModAndDepsIncludingErrored "Basis" of - NONE => raise Fail "ERROR: Top module not found in ModDb" - | SOME ((L.DFfiStr (_, basis_n, sgn), _), _) => - #2 (Elaborate.dopen env {str = basis_n, strs = [], sgn = sgn}) - | _ => raise Fail "ERROR: Impossible" - - (* Just use ElabPrint functions. *) - (* These are better for compiler error message, but it's better than nothing *) - fun printLiterally {span = span, item = item, env = env} = - P.box [ case item of - Kind k => P.box [P.PD.string "KIND: ", ElabPrint.p_kind env k] - | Con c => P.box [P.PD.string "CON: ", ElabPrint.p_con env c] - | Exp e => P.box [P.PD.string "EXP: ", ElabPrint.p_exp env e] - | Sgn_item si => P.box [P.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] - | Sgn s => P.box [P.PD.string "SGN: ", ElabPrint.p_sgn env s] - | Str s => P.box [P.PD.string "STR: ", ElabPrint.p_str env s] - | Decl d => P.box [P.PD.string "DECL: ", ElabPrint.p_decl env d] - ] - - (* TODO We lose some really useful information, like eg. inferred parameters, *) - (* which we do have in the actual items (L.Decl, L.Exp, etc) *) - (* but not when we do a lookup into the Env *) - (* TODO Rename? *) - fun printGoodPart env f span = - (case f of - Exp (L.EPrim p, _) => - SOME (P.box [Prim.p_t p, - P.PD.string ": ", - P.PD.string (case p of - Prim.Int _ => "int" - | Prim.Float _ => "float" - | Prim.String _ => "string" - | Prim.Char _ => "char")]) - | Exp (L.ERel n, _) => - SOME ((let val found = E.lookupERel env n - in - P.box [ P.PD.string (#1 found) - , P.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) - | Exp (L.ENamed n, _) => - SOME ((let val found = E.lookupENamed env n - in - P.box [ P.PD.string (#1 found) - , P.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle E.UnboundNamed _ => P.PD.string ("UNBOUND_NAMED" ^ Int.toString n)) - | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) - , ms (* names of submodules - possibly none *) - , x (* identifier *)), loc) => - SOME (let - val (m1name, m1sgn) = E.lookupStrNamed env m1 - val (str, sgn) = foldl (fn (m, (str, sgn)) => - case E.projectStr env {sgn = sgn, str = str, field = m} of - NONE => raise Fail ("Couldn't find Structure: " ^ m) - | SOME sgn => ((L.StrProj (str, m), loc), sgn)) - ((L.StrVar m1, loc), m1sgn) - ms - val t = case E.projectVal env {sgn = sgn, str = str, field = x} of - NONE => raise Fail ("Couldn't find identifier: " ^ x) - | SOME t => t - in - P.box [ P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) - , P.PD.string ": " - , ElabPrint.p_con env t - ] - end - handle E.UnboundNamed _ => P.PD.string ("Module not found: " ^ Int.toString m1)) - | Exp e => NONE - | Kind k => NONE - | Con c => NONE - | Sgn_item si => NONE - | Sgn s => NONE - | Str s => NONE - | Decl d => NONE) - - fun add env item span acc = - if not (isPosIn file row col span) - then - acc - else - let - val smallest = - if isSmallerThan span (#span (#smallest acc)) - then {span = span, item = item, env = env} - else #smallest acc - val smallestgoodpart = - case #smallestgoodpart acc of - NONE => - (case printGoodPart env item span of - NONE => NONE - | SOME desc => SOME (desc, span)) - | SOME (desc', span') => - if isSmallerThan span span' - then - (case printGoodPart env item span of - NONE => SOME (desc', span') - | SOME desc => SOME (desc, span)) - else SOME (desc', span') - in - {smallest = smallest, smallestgoodpart = smallestgoodpart} - end - - (* Look for item at input position *) - (* We're looking for two things simultaneously: *) - (* 1. The "smallest" part, ie. the one of which the source span is the smallest *) - (* 2. The "smallestgoodpart" part, ie. the one of which the source span is the smallest AND has a special case in printGoodPart *) - (* If we end up with a smallestgoodpart, we'll show that one since that one is probably more useful *) - (* TODO source spans of XML and SQL sources are weird and you end *) - (* up with eg: a span from eg 1-5 and another from 2-6, makes no sense? *) - (* That's one of the reasons why we're searching for the two things mentioned above *) - val result = - U.Decl.foldB - { kind = fn (env, (k, span), acc) => add env (Kind (k, span)) span acc, - con = fn (env, (k, span), acc) => add env (Con (k, span)) span acc, - exp = fn (env, (k, span), acc) => add env (Exp (k, span)) span acc, - sgn_item = fn (env, (k, span), acc) => add env (Sgn_item (k, span)) span acc, - sgn = fn (env, (k, span), acc) => add env (Sgn (k, span)) span acc, - str = fn (env, (k, span), acc) => add env (Str (k, span)) span acc, - decl = fn (env, (k, span), acc) => add env (Decl (k, span)) span acc, - bind = fn (env, binder) => - case binder of - U.Decl.RelK x => E.pushKRel env x - | U.Decl.RelC (x, k) => E.pushCRel env x k - | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co - | U.Decl.RelE (x, c) => E.pushERel env x c - | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) - | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) - | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) - } - env - { smallestgoodpart = NONE - , smallest = { item = Decl (#1 modDecl, { file = file - , first = { line = 0, char = 0} - , last = { line = 99999, char = 0} }) - , span = { file = file - , first = { line = 0, char = 0} - , last = { line = 99999, char = 0} } - , env = env } - } - modDecl - in - case #smallestgoodpart result of - NONE => printLiterally (#smallest result) - | SOME (desc, span) => desc - end - -fun getInfo loc = - case String.tokens (fn ch => ch = #":") loc of - file :: rowStr :: colStr :: nil => - (case (Int.fromString rowStr, Int.fromString colStr) of - (SOME row, SOME col) => getInfo' file row col - | _ => P.PD.string "ERROR: Wrong typeOf input format, should be ") - | _ => P.PD.string "ERROR: Wrong typeOf input format, should be " +fun getInfo env str fileName {line = row, character = col} = + let + val () = U.mliftConInCon := E.mliftConInCon + + (* Adding previous declarations in file to environment *) + (* "open " statements are already translated during elaboration *) + (* They get added to the env here "unprefixed" *) + val env = (case str of + L.StrConst decls => + List.foldl (fn (d, env) => + if #line (#first (#2 d)) <= row + andalso #char (#first (#2 d)) <= col + then E.declBinds env d + else env) env decls + | _ => env) + + (* Just use ElabPrint functions. *) + (* These are better for compiler error messages, but it's better than nothing *) + fun printLiterally {span = span, item = item, env = env} = + P.box [ case item of + Kind k => P.box [P.PD.string "KIND: ", ElabPrint.p_kind env k] + | Con c => P.box [P.PD.string "CON: ", ElabPrint.p_con env c] + | Exp e => P.box [P.PD.string "EXP: ", ElabPrint.p_exp env e] + | Sgn_item si => P.box [P.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] + | Sgn s => P.box [P.PD.string "SGN: ", ElabPrint.p_sgn env s] + | Str s => P.box [P.PD.string "STR: ", ElabPrint.p_str env s] + | Decl d => P.box [P.PD.string "DECL: ", ElabPrint.p_decl env d] + ] + + (* TODO We lose some really useful information, like eg. inferred parameters, *) + (* which we do have in the actual items (L.Decl, L.Exp, etc) *) + (* but not when we do a lookup into the Env *) + (* TODO Rename? *) + fun printGoodPart env f span = + (case f of + Exp (L.EPrim p, _) => + SOME (P.box [Prim.p_t p, + P.PD.string ": ", + P.PD.string (case p of + Prim.Int _ => "int" + | Prim.Float _ => "float" + | Prim.String _ => "string" + | Prim.Char _ => "char")]) + | Exp (L.ERel n, _) => + SOME ((let val found = E.lookupERel env n + in + P.box [ P.PD.string (#1 found) + , P.PD.string ": " + , ElabPrint.p_con env (#2 found)] + end) + handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) + | Exp (L.ENamed n, _) => + SOME ((let val found = E.lookupENamed env n + in + P.box [ P.PD.string (#1 found) + , P.PD.string ": " + , ElabPrint.p_con env (#2 found)] + end) + handle E.UnboundNamed _ => P.PD.string ("UNBOUND_NAMED" ^ Int.toString n)) + | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) + , ms (* names of submodules - possibly none *) + , x (* identifier *)), loc) => + SOME (let + val (m1name, m1sgn) = E.lookupStrNamed env m1 + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail ("Couldn't find Structure: " ^ m) + | SOME sgn => ((L.StrProj (str, m), loc), sgn)) + ((L.StrVar m1, loc), m1sgn) + ms + val t = case E.projectVal env {sgn = sgn, str = str, field = x} of + NONE => raise Fail ("Couldn't find identifier: " ^ x) + | SOME t => t + in + P.box [ P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) + , P.PD.string ": " + , ElabPrint.p_con env t + ] + end + handle E.UnboundNamed _ => P.PD.string ("Module not found: " ^ Int.toString m1)) + | Exp e => NONE + | Kind k => NONE + | Con c => NONE + | Sgn_item si => NONE + | Sgn s => NONE + | Str s => NONE + | Decl d => NONE) + + fun add env item span acc = + if not (isPosIn fileName row col span) + then + acc + else + let + val smallest = + if isSmallerThan span (#span (#smallest acc)) + then {span = span, item = item, env = env} + else #smallest acc + val smallestgoodpart = + case #smallestgoodpart acc of + NONE => + (case printGoodPart env item span of + NONE => NONE + | SOME desc => SOME (desc, span)) + | SOME (desc', span') => + if isSmallerThan span span' + then + (case printGoodPart env item span of + NONE => SOME (desc', span') + | SOME desc => SOME (desc, span)) + else SOME (desc', span') + in + {smallest = smallest, smallestgoodpart = smallestgoodpart} + end + + (* Look for item at input position *) + (* We're looking for two things simultaneously: *) + (* 1. The "smallest" part, ie. the one of which the source span is the smallest *) + (* 2. The "smallestgoodpart" part, ie. the one of which the source span is the smallest AND has a special case in printGoodPart *) + (* If we end up with a smallestgoodpart, we'll show that one since that one is probably more useful *) + (* TODO source spans of XML and SQL sources are weird and you end *) + (* up with eg: a span from eg 1-5 and another from 2-6, makes no sense? *) + (* That's one of the reasons why we're searching for the two things mentioned above *) + val result = + U.Decl.foldB + { kind = fn (env, (k, span), acc) => add env (Kind (k, span)) span acc, + con = fn (env, (k, span), acc) => add env (Con (k, span)) span acc, + exp = fn (env, (k, span), acc) => add env (Exp (k, span)) span acc, + sgn_item = fn (env, (k, span), acc) => add env (Sgn_item (k, span)) span acc, + sgn = fn (env, (k, span), acc) => add env (Sgn (k, span)) span acc, + str = fn (env, (k, span), acc) => add env (Str (k, span)) span acc, + decl = fn (env, (k, span), acc) => add env (Decl (k, span)) span acc, + bind = fn (env, binder) => + case binder of + U.Decl.RelK x => E.pushKRel env x + | U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co + | U.Decl.RelE (x, c) => E.pushERel env x c + | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) + | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) + | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) + } + env + { smallestgoodpart = NONE + , smallest = { item = Str (str, { file = fileName + , first = { line = 0, char = 0} + , last = { line = 99999, char = 0} }) + , span = { file = fileName + , first = { line = 0, char = 0} + , last = { line = 99999, char = 0} } + , env = env } + } + ( L.DStr (Compiler.moduleOf "fileName", 0, (L.SgnError, ErrorMsg.dummySpan), (str, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos})) + , {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) + in + case #smallestgoodpart result of + NONE => printLiterally (#smallest result) + | SOME (desc, span) => desc + end end diff --git a/src/lsp.sml b/src/lsp.sml index b5a92683..cfdec863 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -417,7 +417,8 @@ end structure SM = BinaryMapFn(SK) type fileState = - { decls : Elab.decl list } + { envBeforeThisModule: ElabEnv.env + , decls : Elab.decl list } type state = { urpPath : string , fileStates : fileState SM.map @@ -572,10 +573,17 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls (* Parsing of .ur succeeded *) let val loc = {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos} + val envBeforeThisModule = ref ElabEnv.empty val res = Elaborate.elabFile parsedBasisUrs tm1 parsedTopUr parsedTopUrs tm2 ElabEnv.empty (* Adding urs's of previous modules to env *) - (fn envB => List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envB parsedUrss) + (fn envB => + let + val newEnv = List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envB parsedUrss + in + (envBeforeThisModule := newEnv; newEnv) + end + ) [( Source.DStr (C.moduleOf fileName, parsedUrs, NONE, (Source.StrConst parsedUr, loc), false) , loc )] (* report back errors (as Diagnostics) *) @@ -584,7 +592,7 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls (Elab.DStr (_, _, _, (Elab.StrConst decls, _)), _) => decls | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") in - (SOME { decls = decls }, + (SOME { envBeforeThisModule = !envBeforeThisModule, decls = decls }, List.map errorToDiagnostic errors) end end @@ -605,6 +613,59 @@ fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res} end +fun scanDir (f: string -> bool) (path: string) = + let + val dir = OS.FileSys.openDir path + fun doScanDir acc = + case OS.FileSys.readDir dir of + NONE => (OS.FileSys.closeDir dir; acc) + | SOME fname => + (if f fname + then doScanDir (fname :: acc) + else doScanDir acc) + in + doScanDir [] + end + +fun readFile (fileName: string): string = + let + val str = TextIO.openIn fileName + fun doReadFile acc = + case TextIO.inputLine str of + NONE => acc + | SOME str => (str ^ "\n" ^ acc) + val res = doReadFile "" + in + (TextIO.closeIn str; res) + end + + +fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec.result = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => LspSpec.Success NONE + | SOME s => + let + val env = #envBeforeThisModule s + val decls = #decls s + val loc = #position p + val pp = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line loc + 1 + , character = #character loc + 1} + (* TODO I couldn't figure out how to print just to a string, so writing to a temp file, then reading it, then deleting it, ... *) + val tempfile = OS.FileSys.tmpName () + val outStr = TextIO.openOut tempfile + val outDev = TextIOPP.openOut {dst = outStr, wid = 70} + val () = Print.fprint outDev pp + val res = readFile tempfile + val () = TextIO.closeOut outStr + in + LspSpec.Success (SOME {contents = res}) + end + end + fun serverLoop () = let val requestMessage = @@ -653,7 +714,7 @@ fun serverLoop () = m { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn ctx => fn _ => LspSpec.Success NONE + , textDocument_hover = fn ctx => fn p => handleHover state p }) handle LspError e => handleLspErrorInRequest (#id m) e | ex => handleLspErrorInRequest (#id m) (InternalError (General.exnMessage ex))) diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 1747d702..9042307a 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -141,10 +141,6 @@ fun oneRun args = fun printModuleOf fname = print_and_exit (Compiler.moduleOf fname) () - fun getInfo loc = - (Print.print (GetInfo.getInfo loc); - raise Code OS.Process.success) - fun add_class (class, num) = case Int.fromString num of NONE => raise Fail ("Invalid limit number '" ^ num ^ "'") @@ -251,8 +247,6 @@ fun oneRun args = NONE), ("moduleOf", ONE ("", printModuleOf), SOME "print module name of and exit"), - ("getInfo", ONE ("", getInfo), - SOME "print info of expression at and exit"), ("startLspServer", ZERO Lsp.startServer, SOME "Start Language Server Protocol server"), ("noEmacs", set_true Demo.noEmacs, NONE), -- cgit v1.2.3 From faff2d8ac927fd49f13fbaf9b84ffc99bbb6f9b8 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Thu, 12 Dec 2019 22:44:50 +0100 Subject: Added tracking of text of source files and autocomplete --- derivation.nix | 4 +- shell.nix | 8 +- src/elab_env.sig | 4 + src/elab_env.sml | 9 +- src/elab_print.sig | 1 + src/getinfo.sig | 20 ++- src/getinfo.sml | 51 ++++--- src/json.sml | 11 +- src/lsp.sml | 399 +++++++++++++++++++++++++++++++++++++++++++++++------ 9 files changed, 438 insertions(+), 69 deletions(-) diff --git a/derivation.nix b/derivation.nix index f956a619..19582948 100644 --- a/derivation.nix +++ b/derivation.nix @@ -1,6 +1,6 @@ { stdenv, lib, fetchFromGitHub, file, openssl, mlton , mysql, postgresql, sqlite, gcc -, automake, autoconf, libtool, icu +, automake, autoconf, libtool, icu, nix-gitignore }: stdenv.mkDerivation rec { @@ -18,7 +18,7 @@ stdenv.mkDerivation rec { # rev = "e52ce9f542f64750941cfd84efdb6d993ee20ff0"; # sha256 = "19ba5n7g1dxy7q9949aakqplchsyzwrrnxv8v604vx5sg7fdfn3b"; # }; - src = ./.; + src = nix-gitignore.gitignoreSource [] ./.; buildInputs = [ openssl mlton mysql.connector-c postgresql sqlite automake autoconf libtool icu.dev openssl.dev]; diff --git a/shell.nix b/shell.nix index 95da550b..e9b047ee 100644 --- a/shell.nix +++ b/shell.nix @@ -1 +1,7 @@ -import ./default.nix +let + pkgs = import {}; + def = import ./default.nix; +in +pkgs.mkShell { + buildInputs = def.buildInputs; +} diff --git a/src/elab_env.sig b/src/elab_env.sig index 47b31c08..55909b53 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -85,6 +85,8 @@ signature ELAB_ENV = sig val pushENamedAs : env -> string -> int -> Elab.con -> env val lookupENamed : env -> int -> string * Elab.con val checkENamed : env -> int -> bool + val matchNamedEByPrefix: env -> string -> (string * Elab.con) list + val matchRelEByPrefix: env -> string -> (string * Elab.con) list val lookupE : env -> string -> Elab.con var @@ -100,6 +102,8 @@ signature ELAB_ENV = sig val lookupStrNamed : env -> int -> string * Elab.sgn val lookupStr : env -> string -> (int * Elab.sgn) option + val matchStrByPrefix: env -> string -> (string * (int * Elab.sgn)) list + val edeclBinds : env -> Elab.edecl -> env val declBinds : env -> Elab.decl -> env diff --git a/src/elab_env.sml b/src/elab_env.sml index a2097aa9..e79b665d 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -932,6 +932,12 @@ fun lookupENamed (env : env) n = NONE => raise UnboundNamed n | SOME x => x +fun matchNamedEByPrefix (env: env) (str: string) = + List.filter (fn (name,con) => String.isPrefix str name) (IM.listItems (#namedE env)) + +fun matchRelEByPrefix (env: env) (str: string) = + List.filter (fn (name,con) => String.isPrefix str name) (#relE env) + fun checkENamed (env : env) n = Option.isSome (IM.find (#namedE env, n)) @@ -985,7 +991,8 @@ fun lookupStrNamed (env : env) n = | SOME x => x fun lookupStr (env : env) x = SM.find (#renameStr env, x) - +fun matchStrByPrefix (env: env) prefix = + List.filter (fn (name,_) => String.isPrefix prefix name) (SM.listItemsi (#renameStr env)) fun sgiSeek (sgi, (sgns, strs, cons)) = case sgi of diff --git a/src/elab_print.sig b/src/elab_print.sig index 1eb832b3..84715b9d 100644 --- a/src/elab_print.sig +++ b/src/elab_print.sig @@ -38,6 +38,7 @@ signature ELAB_PRINT = sig val p_sgn : ElabEnv.env -> Elab.sgn Print.printer val p_str : ElabEnv.env -> Elab.str Print.printer val p_file : ElabEnv.env -> Elab.file Print.printer + val debug : bool ref end diff --git a/src/getinfo.sig b/src/getinfo.sig index 334e19f1..50eee70a 100644 --- a/src/getinfo.sig +++ b/src/getinfo.sig @@ -26,11 +26,29 @@ *) signature GET_INFO = sig + + datatype item = + Kind of Elab.kind + | Con of Elab.con + | Exp of Elab.exp + | Sgn_item of Elab.sgn_item + | Sgn of Elab.sgn + | Str of Elab.str + | Decl of Elab.decl + val getInfo: ElabEnv.env -> Elab.str' -> string (* fileName *) -> { line: int , character: int} -> - Print.PD.pp_desc + { smallest : { span : ErrorMsg.span + , item : item + , env : ElabEnv.env } + , smallestgoodpart : { span : ErrorMsg.span + , desc : Print.PD.pp_desc + , env : ElabEnv.env + , item : item + } option +} end diff --git a/src/getinfo.sml b/src/getinfo.sml index 7925aba3..1d657637 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -73,6 +73,19 @@ fun getSpan (f: item * E.env) = | Str s => #2 s | Decl d => #2 d +(* Just use ElabPrint functions. *) +(* These are better for compiler error messages, but it's better than nothing *) +fun printLiterally {span = span, item = item, env = env} = + P.box [ case item of + Kind k => P.box [P.PD.string "KIND: ", ElabPrint.p_kind env k] + | Con c => P.box [P.PD.string "CON: ", ElabPrint.p_con env c] + | Exp e => P.box [P.PD.string "EXP: ", ElabPrint.p_exp env e] + | Sgn_item si => P.box [P.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] + | Sgn s => P.box [P.PD.string "SGN: ", ElabPrint.p_sgn env s] + | Str s => P.box [P.PD.string "STR: ", ElabPrint.p_str env s] + | Decl d => P.box [P.PD.string "DECL: ", ElabPrint.p_decl env d] + ] + fun getInfo env str fileName {line = row, character = col} = let val () = U.mliftConInCon := E.mliftConInCon @@ -89,19 +102,6 @@ fun getInfo env str fileName {line = row, character = col} = else env) env decls | _ => env) - (* Just use ElabPrint functions. *) - (* These are better for compiler error messages, but it's better than nothing *) - fun printLiterally {span = span, item = item, env = env} = - P.box [ case item of - Kind k => P.box [P.PD.string "KIND: ", ElabPrint.p_kind env k] - | Con c => P.box [P.PD.string "CON: ", ElabPrint.p_con env c] - | Exp e => P.box [P.PD.string "EXP: ", ElabPrint.p_exp env e] - | Sgn_item si => P.box [P.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] - | Sgn s => P.box [P.PD.string "SGN: ", ElabPrint.p_sgn env s] - | Str s => P.box [P.PD.string "STR: ", ElabPrint.p_str env s] - | Decl d => P.box [P.PD.string "DECL: ", ElabPrint.p_decl env d] - ] - (* TODO We lose some really useful information, like eg. inferred parameters, *) (* which we do have in the actual items (L.Decl, L.Exp, etc) *) (* but not when we do a lookup into the Env *) @@ -161,7 +161,16 @@ fun getInfo env str fileName {line = row, character = col} = | Str s => NONE | Decl d => NONE) - fun add env item span acc = + fun add (env: ElabEnv.env) (item: item) (span: ErrorMsg.span) (acc: { smallest : { span : ErrorMsg.span + , item : item + , env : ElabEnv.env } + , smallestgoodpart : { span : ErrorMsg.span + , desc : P.PD.pp_desc + , env : ElabEnv.env + , item : item + } option + } + ) = if not (isPosIn fileName row col span) then acc @@ -176,14 +185,14 @@ fun getInfo env str fileName {line = row, character = col} = NONE => (case printGoodPart env item span of NONE => NONE - | SOME desc => SOME (desc, span)) - | SOME (desc', span') => + | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) + | SOME (prev as {desc = desc', span = span', env = env', item = item'}) => if isSmallerThan span span' then (case printGoodPart env item span of - NONE => SOME (desc', span') - | SOME desc => SOME (desc, span)) - else SOME (desc', span') + NONE => SOME prev + | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) + else SOME prev in {smallest = smallest, smallestgoodpart = smallestgoodpart} end @@ -228,8 +237,6 @@ fun getInfo env str fileName {line = row, character = col} = ( L.DStr (Compiler.moduleOf "fileName", 0, (L.SgnError, ErrorMsg.dummySpan), (str, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos})) , {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) in - case #smallestgoodpart result of - NONE => printLiterally (#smallest result) - | SOME (desc, span) => desc + result end end diff --git a/src/json.sml b/src/json.sml index 656d28ff..4f604cc4 100644 --- a/src/json.sml +++ b/src/json.sml @@ -113,13 +113,20 @@ struct and parseChars () = let + val escapedchars = ["n", "r", "b", "f", "t"] fun pickChars s = - if peek () = #"\"" (* " *) + if peek () = #"\"" (* " = end of string *) then s else if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"\"" then (consume "\\\""; pickChars (s ^ "\"")) - else pickChars (s ^ String.str (take ())) + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"n" + then (consume "\\n"; pickChars (s ^ "\n")) + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"r" + then (consume "\\r"; pickChars (s ^ "\r")) + else pickChars (s ^ String.str (take ())) in pickChars "" end diff --git a/src/lsp.sml b/src/lsp.sml index cfdec863..aaef422c 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -11,13 +11,17 @@ fun joinStr (sep: string) (strs: string list): string = List.foldl (fn (str, acc) => if acc = "" then str else acc ^ sep ^ str) "" strs structure FromJson = struct +fun getO (s: string) (l: Json.json): Json.json option = + case l of + Json.Obj pairs => + (case List.find (fn tup => #1 tup = s) pairs of + NONE => NONE + | SOME tup => SOME (#2 tup)) + | _ => raise Fail ("Expected JSON object, got: " ^ Json.print l) fun get (s: string) (l: Json.json): Json.json = - case l of - Json.Obj pairs => - (case List.find (fn tup => #1 tup = s) pairs of - NONE => raise Fail ("Failed to find JSON object key " ^ s ^ " in " ^ Json.print l) - | SOME tup => #2 tup) - | _ => raise Fail ("Expected JSON object, got: " ^ Json.print l) + (case getO s l of + NONE => raise Fail ("Failed to find JSON object key " ^ s ^ " in " ^ Json.print l) + | SOME a => a) fun asInt (j: Json.json): int = case j of @@ -161,6 +165,10 @@ structure LspSpec (* :> LSPSPEC *) = struct type range = { start: position , end_: position } + fun parseRange (j: Json.json): range = + { start = parsePosition (FromJson.get "start" j) + , end_ = parsePosition (FromJson.get "end" j) + } fun printRange (r: range): Json.json = Json.Obj [ ("start", printPosition (#start r)) , ("end", printPosition (#end_ r))] @@ -194,10 +202,23 @@ structure LspSpec (* :> LSPSPEC *) = struct fun parseDidOpenParams (params: Json.json): didOpenParams = { textDocument = parseTextDocumentItem (FromJson.get "textDocument" params) } - type didChangeParams = { textDocument: versionedTextDocumentIdentifier } + type contentChange = { range: range option + , rangeLength: int option + , text: string } + type didChangeParams = + { textDocument: versionedTextDocumentIdentifier + , contentChanges: contentChange list + } fun parseDidChangeParams (params: Json.json): didChangeParams = { textDocument = parseVersionedTextDocumentIdentifier (FromJson.get "textDocument" params) - (* , contentChanges = ... *) + , contentChanges = case FromJson.get "contentChanges" params of + Json.Array js => + List.map (fn j => { range = Option.map parseRange (FromJson.getO "range" j) + , rangeLength = Option.map FromJson.asInt (FromJson.getO "rangeLength" j) + , text = FromJson.asString (FromJson.get "text" j) + } + ) js + | j => raise Fail ("Expected JSON array, got: " ^ Json.print j) } type didSaveParams = { textDocument: textDocumentIdentifier } @@ -232,11 +253,77 @@ structure LspSpec (* :> LSPSPEC *) = struct fun printPublishDiagnosticsParams (p: publishDiagnosticsParams): Json.json = Json.Obj [ ("uri", Json.String (printDocumentUri (#uri p))) , ("diagnostics", Json.Array (List.map printDiagnostic (#diagnostics p)))] - + + type completionReq = + { textDocument: textDocumentIdentifier + , position: position + , context: { triggerCharacter: string option + , triggerKind: int (* 1 = Invoked = typing an identifier or manual invocation or API + 2 = TriggerCharacter + 3 = TriggerForIncompleteCompletions*)} option + } + fun parseCompletionReq (j: Json.json): completionReq = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" j) + , position = parsePosition (FromJson.get "position" j) + , context = case FromJson.getO "context" j of + NONE => NONE + | SOME ctx => SOME { triggerCharacter = Option.map FromJson.asString (FromJson.getO "triggerCharacter" ctx) + , triggerKind = FromJson.asInt (FromJson.get "triggerKind" ctx) + } + } + + datatype completionItemKind = Text | Method | Function | Constructor | Field | Variable | Class | Interface | Module | Property | Unit | Value | Enum | Keyword | Snippet | Color | File | Reference | Folder | EnumMember | Constant | Struct | Event | Operator | TypeParameter + fun completionItemKindToInt (a: completionItemKind) = + case a of + Text => 1 + | Method => 2 + | Function => 3 + | Constructor => 4 + | Field => 5 + | Variable => 6 + | Class => 7 + | Interface => 8 + | Module => 9 + | Property => 10 + | Unit => 11 + | Value => 12 + | Enum => 13 + | Keyword => 14 + | Snippet => 15 + | Color => 16 + | File => 17 + | Reference => 18 + | Folder => 19 + | EnumMember => 20 + | Constant => 21 + | Struct => 22 + | Event => 23 + | Operator => 24 + | TypeParameter => 25 + + type completionItem = { label: string + , kind: completionItemKind + , detail: string + } + type completionResp = { isIncomplete: bool + , items: completionItem list + } + + fun printCompletionItem (a: completionItem): Json.json = + Json.Obj [ ("label", Json.String (#label a)) + , ("kind", Json.Int (completionItemKindToInt (#kind a))) + , ("detail", Json.String (#detail a)) + ] + fun printCompletionResp (a: completionResp): Json.json = + Json.Obj [ ("isIncomplete", Json.Bool (#isIncomplete a)) + , (("items", Json.Array (List.map printCompletionItem (#items a))))] + type initializeResponse = { capabilities: { hoverProvider: bool + , completionProvider: {triggerCharacters: string list} option , textDocumentSync: { openClose: bool + , change: int (* 0 = None, 1 = Full, 2 = Incremental *) , save: { includeText: bool } option } }} @@ -246,11 +333,16 @@ structure LspSpec (* :> LSPSPEC *) = struct val capabilities = #capabilities res in Json.Obj [ ("hoverProvider", Json.Bool (#hoverProvider capabilities)) + , ("completionProvider", case #completionProvider capabilities of + NONE => Json.Null + | SOME cp => Json.Obj [("triggerCharacters", Json.Array (List.map Json.String (#triggerCharacters cp)))] + ) , ("textDocumentSync", let val textDocumentSync = #textDocumentSync capabilities in Json.Obj [ ("openClose", Json.Bool (#openClose textDocumentSync )) + , ("change", Json.Int (#change textDocumentSync)) , ("save", case #save textDocumentSync of NONE => Json.Null | SOME save => Json.Obj [("includeText", Json.Bool (#includeText save) )])] @@ -273,6 +365,7 @@ structure LspSpec (* :> LSPSPEC *) = struct { initialize: initializeParams -> initializeResponse result , shutdown: unit -> unit result , textDocument_hover: toclient -> hoverReq -> hoverResp result + , textDocument_completion: completionReq -> completionResp result } fun showMessage str typ = @@ -316,13 +409,19 @@ structure LspSpec (* :> LSPSPEC *) = struct ((#textDocument_hover handlers) toclient (parseHoverReq (#params requestMessage))) + | "textDocument/completion" => + mapResult + printCompletionResp + ((#textDocument_completion handlers) + (parseCompletionReq (#params requestMessage))) | "shutdown" => mapResult (fn () => Json.Null) ((#shutdown handlers) ()) | "exit" => OS.Process.exit OS.Process.success - | method => Error (~32601, "Method not supported: " ^ method) + | method => (debug ("Method not supported: " ^ method); + Error (~32601, "Method not supported: " ^ method)) (* val () = (TextIO.output (TextIO.stdErr, "Got result: " ^ (case result of Success _ => "success\n" *) (* | Error _ => "error\n")); TextIO.flushOut TextIO.stdErr) *) in @@ -418,13 +517,21 @@ structure SM = BinaryMapFn(SK) type fileState = { envBeforeThisModule: ElabEnv.env - , decls : Elab.decl list } + , decls: Elab.decl list + , text: string} type state = { urpPath : string , fileStates : fileState SM.map } val stateRef = ref (NONE: state option) +fun insertFileState (state: state) (fileName: string) (fs: fileState) = + stateRef := SOME { urpPath = #urpPath state + , fileStates = SM.insert ( #fileStates state + , fileName + , fs) + } + fun scanDir (f: string -> bool) (path: string) = let val dir = OS.FileSys.openDir path @@ -491,12 +598,12 @@ fun errorToDiagnostic (err: { span: ErrorMsg.span , message: string }): LspSpec. (* TODO FFI modules ? Check compiler.sml -> parse -> parseFfi *) (* TODO Optim: cache parsed urp file? *) -fun calculateFileState (state: state) (fileName: string): (fileState option * LspSpec.diagnostic list) = +fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBeforeThisModule: ElabEnv.env} option * LspSpec.diagnostic list) = let val () = if (OS.Path.ext fileName = SOME "ur") then () else raise Fail ("Can only handle .ur files for now") - val () = Elaborate.unifyMore := true + (* val () = Elaborate.unifyMore := true *) (* To reuse Basis and Top *) val () = Elaborate.incremental := true (* Parsing .urp *) @@ -597,20 +704,29 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls end end -fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) = +fun handleDocumentSavedOrOpened (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) (textO: string option) = let - val path = #path documentUri - val res = calculateFileState state path + val fileName = #path documentUri + val res = elabFile state fileName + val text = case textO of + NONE => (case SM.find (#fileStates state, fileName) of + NONE => ((#showMessage toclient) ("No previous state for file " ^ fileName) 2; NONE) + | SOME previousState => SOME (#text previousState)) + | SOME text => SOME text in - (case #1 res of - NONE => () - | SOME fs => - stateRef := SOME { urpPath = #urpPath state - , fileStates = SM.insert ( #fileStates state - , path - , fs) - }) ; - #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res} + case text of + NONE => () + | SOME text => + (case #1 res of + NONE => + insertFileState state fileName { text = text + , envBeforeThisModule = ElabEnv.empty + , decls = [] } + | SOME fs => + (insertFileState state fileName { text = text + , envBeforeThisModule = #envBeforeThisModule fs + , decls = #decls fs }); + #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res}) end fun scanDir (f: string -> bool) (path: string) = @@ -640,6 +756,19 @@ fun readFile (fileName: string): string = end +(* TODO I couldn't figure out how to print just to a string, so writing to a temp file, then reading it, then deleting it, ... *) +fun ppToString (pp: Print.PD.pp_desc) (width: int): string = + let + val tempfile = OS.FileSys.tmpName () + val outStr = TextIO.openOut tempfile + val outDev = TextIOPP.openOut {dst = outStr, wid = width} + val () = Print.fprint outDev pp + val res = readFile tempfile + val () = TextIO.closeOut outStr + in + res + end + fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec.result = let val fileName = #path (#uri (#textDocument p)) @@ -652,17 +781,203 @@ fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec. val env = #envBeforeThisModule s val decls = #decls s val loc = #position p - val pp = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line loc + 1 - , character = #character loc + 1} - (* TODO I couldn't figure out how to print just to a string, so writing to a temp file, then reading it, then deleting it, ... *) - val tempfile = OS.FileSys.tmpName () - val outStr = TextIO.openOut tempfile - val outDev = TextIOPP.openOut {dst = outStr, wid = 70} - val () = Print.fprint outDev pp - val res = readFile tempfile - val () = TextIO.closeOut outStr + val result = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line loc + 1 + , character = #character loc + 1} + in + case #smallestgoodpart result of + NONE => LspSpec.Success NONE + | SOME {desc = desc, ...} => + LspSpec.Success (SOME {contents = ppToString desc 70}) + end + end + +fun getCompletionsFromFields (env: ElabEnv.env) (prefix: string) (searchStr: string) (fields: (Elab.con * Elab.con) list): LspSpec.completionItem list = + let + fun mapF (c1, c2) = + case c1 of + (Elab.CName fieldName, _) => + if String.isPrefix searchStr fieldName + then SOME { label = prefix ^ fieldName + , kind = LspSpec.Field + , detail = ppToString (ElabPrint.p_con env c2) 150 + } + else NONE + | _ => NONE + in + List.mapPartial mapF fields + end + +fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (searchStr: string) (items: Elab.sgn_item list): LspSpec.completionItem list = + let + fun mapF item = + case item of + (Elab.SgiVal (name, _, con), _) => + if String.isPrefix searchStr name + then [{ label = prefix ^ name + , kind = LspSpec.Value + , detail = ppToString (ElabPrint.p_con env con) 150 + }] + else [] + | (Elab.SgiCon (name, _, _, con), _) => + if String.isPrefix searchStr name + then [{ label = prefix ^ name + , kind = LspSpec.Variable + , detail = ppToString (ElabPrint.p_con env con) 150 + }] + else [] + | (Elab.SgiDatatype cs, _) => + (List.concat + (List.map (fn (constr as (dtName, n, xs, constrs)) => + (* Copied from elab_print *) + let + val k = (Elab.KType, ErrorMsg.dummySpan) + val env = ElabEnv.pushCNamedAs env dtName n k NONE + val env = List.foldl (fn (x, env) => ElabEnv.pushCRel env dtName k) env xs + in + List.mapPartial (fn (constrName, _, conO) => + if String.isPrefix searchStr constrName + then SOME { label = prefix ^ constrName + , kind = LspSpec.Function + , detail = case conO of + NONE => "Datatype " ^ dtName + | SOME con => "Datatype " ^ dtName ^ " - " ^ ppToString (ElabPrint.p_con env con) 150 + } + else NONE) constrs + end) + cs)) + | (Elab.SgiDatatypeImp _, _) => + (* TODO ??? no idea what this is *) + [] + | (Elab.SgiStr (_, name, _, _), _) => + if String.isPrefix searchStr name + then [{ label = prefix ^ name + , kind = LspSpec.Module + , detail = "" + }] + else [] + | (Elab.SgiClass (name, _, _, con), _) => + if String.isPrefix searchStr name + then [{ label = prefix ^ name + , kind = LspSpec.Class + , detail = ppToString (ElabPrint.p_con env con) 150 + }] + else [] + | _ => [] + in + List.concat (List.map mapF items) + end + +fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completionItem list = + let + val splitted = Substring.fields (fn c => c = #".") (Substring.full str) + in + case splitted of + (_ :: []) => + if str = "" + then [] + else (List.map (fn (name,con) => + { label = name + , kind = LspSpec.Variable + , detail = ppToString (ElabPrint.p_con env con) 150 + }) + (ElabEnv.matchRelEByPrefix env str + @ ElabEnv.matchNamedEByPrefix env str)) + | (r :: str :: []) => + if Char.isUpper (Substring.sub (r, 0)) + then (* r should be a structure *) + let + (* TODO Perf: first match and then equal is not perfect *) + val foundStrs = ElabEnv.matchStrByPrefix env (Substring.string r) + val filteredStrs = List.filter (fn (name,_) => name = Substring.string r) foundStrs + in + (case List.map (fn (name, (i, sgn)) => (name, ElabEnv.hnormSgn env sgn)) filteredStrs of + [] => [] + | (name, (Elab.SgnConst sgis, _)) :: _ => + getCompletionsFromSignatureItems env (name ^ ".") (Substring.string str) sgis + | _ => []) + end + else (* r should be a record *) + (* TODO is it correct to first try RelE and then NamedE? *) + let + (* TODO Perf: first match and then equal is not perfect *) + val foundRelEs = ElabEnv.matchRelEByPrefix env (Substring.string r) + val foundNamedEs = ElabEnv.matchNamedEByPrefix env (Substring.string r) + val filteredEs = List.filter (fn (name,_) => name = Substring.string r) (foundRelEs @ foundNamedEs) + in + (case List.map (fn (name, c) => (name, ElabOps.reduceCon env c)) filteredEs of + [] => [] + | (name, (Elab.TRecord (Elab.CRecord (_, fields), _), _)) :: _ => + getCompletionsFromFields env (name ^ ".") (Substring.string str) fields + | _ => []) + end + | _ => [] + end + +(* TODO can we use the real parser to figure out what we're typing (exp, con, field, etc) to predict better? *) +fun handleCompletion (state: state) (p: LspSpec.completionReq) = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => LspSpec.Success { isIncomplete = false, items = []} + | SOME s => + let + val pos = #position p + val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full (#text s)), #line pos) + val () = debug ("line" ^ Substring.string line) + val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":" + , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] + val lineUntilPos = Substring.slice (line, 0, SOME (#character pos)) + val () = debug ("lineUntilPos: \"" ^ Substring.string lineUntilPos ^ "\"") + val searchStr = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilPos) + val () = debug ("Looking for completions for: \"" ^ searchStr ^ "\"") + val env = #envBeforeThisModule s + val decls = #decls s + val getInfoRes = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line pos + 1 + , character = #character pos + 1} + val envOfSmallest = #env (#smallest getInfoRes) + in + LspSpec.Success { isIncomplete = false + , items = findMatchingStringInEnv envOfSmallest searchStr} + end + end + +fun applyContentChange ((c, s): LspSpec.contentChange * string): string = + case (#range c, #rangeLength c) of + (SOME range, SOME _) => + let + val lines = Substring.fields (fn c => c = #"\n") (Substring.full s) + val linesBefore = List.take (lines, #line (#start range)) + val linesAfter = List.drop (lines, #line (#end_ range) + 1) + val startLine = List.nth (lines, #line (#start range)) + val startText = Substring.slice (startLine, 0, SOME (#character (#start range))) + val endLine = List.nth (lines, #line (#end_ range)) + val endText = Substring.triml (#character (#end_ range)) endLine + in + Substring.concatWith "\n" (linesBefore + @ [Substring.full (Substring.concat [startText, Substring.full (#text c), endText])] + @ linesAfter) + end + | _ => + #text c + +fun handleDocumentDidChange (state: state) (toclient: LspSpec.toclient) (p: LspSpec.didChangeParams): unit = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => + (debug ("Got change event for file that isn't open: " ^ fileName); + (#showMessage toclient) ("Got change event for file that isn't open: " ^ fileName) 1) + | SOME s => + let + val newtext = List.foldl applyContentChange (#text s) (#contentChanges p) in - LspSpec.Success (SOME {contents = res}) + insertFileState state fileName { text = newtext + , decls = #decls s + , envBeforeThisModule = #envBeforeThisModule s} end end @@ -686,14 +1001,17 @@ fun serverLoop () = LspSpec.Success { capabilities = { hoverProvider = true + , completionProvider = SOME { triggerCharacters = ["."]} , textDocumentSync = { openClose = true + , change = 2 , save = SOME { includeText = false } }} } end) handle (Fail str) => LspSpec.Error (~32602, str) , shutdown = fn () => LspSpec.Error (~32002, "Server not initialized") - , textDocument_hover = fn ctx => fn _ => LspSpec.Error (~32002, "Server not initialized") + , textDocument_hover = fn toclient => fn _ => LspSpec.Error (~32002, "Server not initialized") + , textDocument_completion = fn _ => LspSpec.Error (~32002, "Server not initialized") } | LspSpec.Notification n => ()) | SOME state => @@ -702,9 +1020,9 @@ fun serverLoop () = ((LspSpec.handleNotification n { initialized = fn () => () - , textDocument_didOpen = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) - , textDocument_didChange = fn ctx => fn didChangeParams => () - , textDocument_didSave = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) + , textDocument_didOpen = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) (SOME (#text (#textDocument p))) + , textDocument_didChange = handleDocumentDidChange state + , textDocument_didSave = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) NONE }) handle LspError e => handleLspErrorInNotification e | ex => handleLspErrorInNotification (InternalError (General.exnMessage ex))) @@ -714,7 +1032,8 @@ fun serverLoop () = m { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn ctx => fn p => handleHover state p + , textDocument_hover = fn toclient => handleHover state + , textDocument_completion = handleCompletion state }) handle LspError e => handleLspErrorInRequest (#id m) e | ex => handleLspErrorInRequest (#id m) (InternalError (General.exnMessage ex))) -- cgit v1.2.3 From 679977b188fc9bbfd1b311e895ca48454876b7f4 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Thu, 12 Dec 2019 22:50:35 +0100 Subject: Tweaks to autocompletion of datatype constructors --- src/lsp.sml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lsp.sml b/src/lsp.sml index aaef422c..7aa7a98b 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -832,15 +832,15 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search let val k = (Elab.KType, ErrorMsg.dummySpan) val env = ElabEnv.pushCNamedAs env dtName n k NONE - val env = List.foldl (fn (x, env) => ElabEnv.pushCRel env dtName k) env xs + val env = List.foldl (fn (x, env) => ElabEnv.pushCRel env x k) env xs in List.mapPartial (fn (constrName, _, conO) => if String.isPrefix searchStr constrName then SOME { label = prefix ^ constrName , kind = LspSpec.Function , detail = case conO of - NONE => "Datatype " ^ dtName - | SOME con => "Datatype " ^ dtName ^ " - " ^ ppToString (ElabPrint.p_con env con) 150 + NONE => dtName + | SOME con => ppToString (ElabPrint.p_con env con) 150 ^ " -> " ^ dtName } else NONE) constrs end) -- cgit v1.2.3 From a16c342d75f96a530da30e85465328306f5412ef Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Thu, 12 Dec 2019 22:55:24 +0100 Subject: Last tweak to datatype constructors autocomplete --- src/lsp.sml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/lsp.sml b/src/lsp.sml index 7aa7a98b..50eea923 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -833,14 +833,15 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search val k = (Elab.KType, ErrorMsg.dummySpan) val env = ElabEnv.pushCNamedAs env dtName n k NONE val env = List.foldl (fn (x, env) => ElabEnv.pushCRel env x k) env xs + val typeVarsString = List.foldl (fn (x, acc) => acc ^ " " ^ x) "" xs in List.mapPartial (fn (constrName, _, conO) => if String.isPrefix searchStr constrName then SOME { label = prefix ^ constrName , kind = LspSpec.Function , detail = case conO of - NONE => dtName - | SOME con => ppToString (ElabPrint.p_con env con) 150 ^ " -> " ^ dtName + NONE => dtName ^ typeVarsString + | SOME con => ppToString (ElabPrint.p_con env con) 150 ^ " -> " ^ dtName ^ typeVarsString } else NONE) constrs end) -- cgit v1.2.3 From 171ba38b23b6acfdb28a0b591d26d3e4bb87458b Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 08:56:39 +0100 Subject: Added textDocument_didClose --- src/lsp.sml | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/lsp.sml b/src/lsp.sml index 50eea923..2c9aab56 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -226,6 +226,10 @@ structure LspSpec (* :> LSPSPEC *) = struct { 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) = @@ -457,6 +461,7 @@ structure LspSpec (* :> LSPSPEC *) = struct , 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}) @@ -467,6 +472,7 @@ structure LspSpec (* :> LSPSPEC *) = struct | "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 @@ -982,6 +988,16 @@ fun handleDocumentDidChange (state: state) (toclient: LspSpec.toclient) (p: LspS end end +fun handleDocumentDidClose (state: state) (toclient: LspSpec.toclient) (p: LspSpec.didCloseParams): unit = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + stateRef := SOME { urpPath = #urpPath state + , fileStates = (#1 (SM.remove (#fileStates state, fileName))) handle ex => #fileStates state + } + end + fun serverLoop () = let val requestMessage = @@ -1024,6 +1040,7 @@ fun serverLoop () = , textDocument_didOpen = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) (SOME (#text (#textDocument p))) , textDocument_didChange = handleDocumentDidChange state , textDocument_didSave = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) NONE + , textDocument_didClose = fn toclient => fn p => handleDocumentDidClose state toclient p }) handle LspError e => handleLspErrorInNotification e | ex => handleLspErrorInNotification (InternalError (General.exnMessage ex))) -- cgit v1.2.3 From 8ef0d043574638a48c71b7c4c9844fc05973f13d Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 09:58:15 +0100 Subject: Added completion suggestions for types --- src/elab_env.sig | 4 ++-- src/elab_env.sml | 20 ++++++++++++++----- src/lsp.sml | 58 +++++++++++++++++++++++++++++++++++++------------------- 3 files changed, 56 insertions(+), 26 deletions(-) diff --git a/src/elab_env.sig b/src/elab_env.sig index 55909b53..fb95d68e 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -61,6 +61,7 @@ signature ELAB_ENV = sig val lookupCNamed : env -> int -> string * Elab.kind * Elab.con option val lookupC : env -> string -> Elab.kind var + val matchCByPrefix: env -> string -> (string * Elab.kind) list val pushDatatype : env -> int -> string list -> (string * int * Elab.con option) list -> env type datatyp @@ -85,8 +86,7 @@ signature ELAB_ENV = sig val pushENamedAs : env -> string -> int -> Elab.con -> env val lookupENamed : env -> int -> string * Elab.con val checkENamed : env -> int -> bool - val matchNamedEByPrefix: env -> string -> (string * Elab.con) list - val matchRelEByPrefix: env -> string -> (string * Elab.con) list + val matchEByPrefix: env -> string -> (string * Elab.con) list val lookupE : env -> string -> Elab.con var diff --git a/src/elab_env.sml b/src/elab_env.sml index e79b665d..34071664 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -404,6 +404,14 @@ fun lookupC (env : env) x = | SOME (Rel' x) => Rel x | SOME (Named' x) => Named x +fun matchCByPrefix (env: env) (prefix: string): (string * kind) list = + List.mapPartial (fn (name, value) => if String.isPrefix prefix name + then case value of + Rel' (_, x) => SOME (name, x) + | Named' (_, x) => SOME (name, x) + else NONE) + (SM.listItemsi (#renameC env)) + fun pushDatatype (env : env) n xs xncs = let val dk = U.classifyDatatype xncs @@ -932,11 +940,13 @@ fun lookupENamed (env : env) n = NONE => raise UnboundNamed n | SOME x => x -fun matchNamedEByPrefix (env: env) (str: string) = - List.filter (fn (name,con) => String.isPrefix str name) (IM.listItems (#namedE env)) - -fun matchRelEByPrefix (env: env) (str: string) = - List.filter (fn (name,con) => String.isPrefix str name) (#relE env) +fun matchEByPrefix (env: env) (prefix: string): (string * con) list = + List.mapPartial (fn (name, value) => if String.isPrefix prefix name + then case value of + Rel' (_, x) => SOME (name, x) + | Named' (_, x) => SOME (name, x) + else NONE) + (SM.listItemsi (#renameE env)) fun checkENamed (env : env) n = Option.isSome (IM.find (#namedE env, n)) diff --git a/src/lsp.sml b/src/lsp.sml index 2c9aab56..2d80479b 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -762,7 +762,7 @@ fun readFile (fileName: string): string = end -(* TODO I couldn't figure out how to print just to a string, so writing to a temp file, then reading it, then deleting it, ... *) +(* TODO PERF BIG I couldn't figure out how to print just to a string, so writing to a temp file, then reading it, then deleting it, ... *) fun ppToString (pp: Print.PD.pp_desc) (width: int): string = let val tempfile = OS.FileSys.tmpName () @@ -827,7 +827,7 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search | (Elab.SgiCon (name, _, _, con), _) => if String.isPrefix searchStr name then [{ label = prefix ^ name - , kind = LspSpec.Variable + , kind = LspSpec.Value , detail = ppToString (ElabPrint.p_con env con) 150 }] else [] @@ -874,6 +874,7 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search List.concat (List.map mapF items) end +(* TODO TOCHECK look at con's to specify "kind" more accurately *) fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completionItem list = let val splitted = Substring.fields (fn c => c = #".") (Substring.full str) @@ -882,18 +883,35 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion (_ :: []) => if str = "" then [] - else (List.map (fn (name,con) => - { label = name - , kind = LspSpec.Variable - , detail = ppToString (ElabPrint.p_con env con) 150 - }) - (ElabEnv.matchRelEByPrefix env str - @ ElabEnv.matchNamedEByPrefix env str)) + else + let + val matchingEs = ElabEnv.matchEByPrefix env str (* function params, let bindings and top-level bindings. Should we discern between Rel and Named? *) + val expressionCompletions = List.map (fn (name,con) => + { label = name + , kind = LspSpec.Value + , detail = ppToString (ElabPrint.p_con env con) 150 + }) matchingEs + val matchingStrs = ElabEnv.matchStrByPrefix env str + val structureCompletions = List.map (fn (name,(_,sgn)) => + { label = name + , kind = LspSpec.Module + , detail = "" + }) matchingStrs + val matchingCons = ElabEnv.matchCByPrefix env str + val conCompletions = List.map (fn (name,kind) => + { label = name + , kind = LspSpec.Constructor (* TODO probably wrong... *) + , detail = ppToString (ElabPrint.p_kind env kind) 150 + }) matchingCons + in + expressionCompletions @ structureCompletions @ conCompletions + end | (r :: str :: []) => if Char.isUpper (Substring.sub (r, 0)) - then (* r should be a structure *) + then + (* Completing STRUCTURE *) let - (* TODO Perf: first match and then equal is not perfect *) + (* TODO PERF SMALL: first match and then equal is not perfect *) val foundStrs = ElabEnv.matchStrByPrefix env (Substring.string r) val filteredStrs = List.filter (fn (name,_) => name = Substring.string r) foundStrs in @@ -903,13 +921,13 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion getCompletionsFromSignatureItems env (name ^ ".") (Substring.string str) sgis | _ => []) end - else (* r should be a record *) - (* TODO is it correct to first try RelE and then NamedE? *) + else + (* Completing RECORD *) + (* TODO TOCHECK is it correct to first try RelE and then NamedE? *) let - (* TODO Perf: first match and then equal is not perfect *) - val foundRelEs = ElabEnv.matchRelEByPrefix env (Substring.string r) - val foundNamedEs = ElabEnv.matchNamedEByPrefix env (Substring.string r) - val filteredEs = List.filter (fn (name,_) => name = Substring.string r) (foundRelEs @ foundNamedEs) + (* TODO PERF SMALL: first match and then equal is not perfect *) + val foundEs = ElabEnv.matchEByPrefix env (Substring.string r) + val filteredEs = List.filter (fn (name,_) => name = Substring.string r) foundEs in (case List.map (fn (name, c) => (name, ElabOps.reduceCon env c)) filteredEs of [] => [] @@ -917,10 +935,12 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion getCompletionsFromFields env (name ^ ".") (Substring.string str) fields | _ => []) end - | _ => [] + | _ => + (* TODO NOTIMPLEMENTED submodules / nested records *) + [] end -(* TODO can we use the real parser to figure out what we're typing (exp, con, field, etc) to predict better? *) +(* TODO IDEA can we use the real parser to figure out what we're typing (exp, con, field, etc) to predict better? *) fun handleCompletion (state: state) (p: LspSpec.completionReq) = let val fileName = #path (#uri (#textDocument p)) -- cgit v1.2.3 From f2ada9d9761c3aa7575571fd93629b79350a1425 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 10:58:11 +0100 Subject: Trial version of completing table fields --- src/elab_env.sml | 7 +++---- src/lsp.sml | 13 ++++++++++++- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/src/elab_env.sml b/src/elab_env.sml index 34071664..f492bc94 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -940,13 +940,12 @@ fun lookupENamed (env : env) n = NONE => raise UnboundNamed n | SOME x => x +(* TODO Why does this work better than using #renameE? *) fun matchEByPrefix (env: env) (prefix: string): (string * con) list = List.mapPartial (fn (name, value) => if String.isPrefix prefix name - then case value of - Rel' (_, x) => SOME (name, x) - | Named' (_, x) => SOME (name, x) + then SOME (name, value) else NONE) - (SM.listItemsi (#renameE env)) + (#relE env @ IM.listItems (#namedE env)) fun checkENamed (env : env) n = Option.isSome (IM.find (#namedE env, n)) diff --git a/src/lsp.sml b/src/lsp.sml index 2d80479b..920f9f35 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -931,8 +931,19 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion in (case List.map (fn (name, c) => (name, ElabOps.reduceCon env c)) filteredEs of [] => [] - | (name, (Elab.TRecord (Elab.CRecord (_, fields), _), _)) :: _ => + | (name, (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_)) :: _ => getCompletionsFromFields env (name ^ ".") (Substring.string str) fields + | (name, (* TODO this doesn't always work. I've only managed to get it working for tables in a different module *) + ( ( Elab.CApp + ( ( (Elab.CApp + ( ( Elab.CModProj (_, _, "sql_table") + , l4_) + , ( Elab.CRecord (_, fields) + , l3_))) + , l2_) + , _)) + , l1_)) :: _ => + (debug "!!"; getCompletionsFromFields env (name ^ ".") (Substring.string str) fields) | _ => []) end | _ => -- 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 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 e74d203806efea612ef2ab33da1e561c077d6c16 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 14:44:20 +0100 Subject: Added initializationOption to specify project if multiple urp files --- src/lsp.sml | 11 ++++++++--- src/lspspec.sml | 4 +++- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/src/lsp.sml b/src/lsp.sml index d902fed4..34137a4f 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -47,12 +47,17 @@ fun initState (initParams: LspSpec.initializeParams): state = val rootPath = case #rootUri initParams of NONE => raise Fail "No rootdir found" | SOME a => #path a + val optsUrpFile = + (SOME (FromJson.asString (FromJson.get "urpfile" (FromJson.get "project" (FromJson.get "urweb" (#initializationOptions initParams)))))) + handle ex => NONE val foundUrps = scanDir (fn fname => OS.Path.ext fname = SOME "urp") rootPath in { urpPath = case foundUrps of [] => raise Fail ("No .urp files found in path " ^ rootPath) | one :: [] => OS.Path.base (OS.Path.file one) - | many => raise Fail ("Found multiple .urp files in path " ^ rootPath) + | many => case List.find (fn m => SOME (OS.Path.base (OS.Path.file m)) = optsUrpFile) many of + NONE => raise Fail ("Found multiple .urp files in path " ^ rootPath) + | SOME f => OS.Path.base (OS.Path.file f) , fileStates = SM.empty } end @@ -531,8 +536,8 @@ fun serverLoop () = LspSpec.RequestMessage m => LspSpec.handleMessage m - { initialize = fn _ => - (let val st = initState (LspSpec.parseInitializeParams (#params m)) + { initialize = fn p => + (let val st = initState p in stateRef := SOME st; LspSpec.Success diff --git a/src/lspspec.sml b/src/lspspec.sml index 7993038e..fe1711f0 100644 --- a/src/lspspec.sml +++ b/src/lspspec.sml @@ -195,12 +195,14 @@ structure LspSpec = struct { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) } type initializeParams = - { rootUri: documentUri option } + { rootUri: documentUri option + , initializationOptions: Json.json } fun parseInitializeParams (j: Json.json) = { rootUri = Option.map parseDocumentUri (FromJson.asOptionalString (FromJson.get "rootUri" j)) + , initializationOptions = FromJson.get "initializationOptions" j } type diagnostic = { range: range (* code?: number | string *) -- cgit v1.2.3 From 1b07e7b1e1b8a81197e98a71baf9c51579f48a3f Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 19:35:58 +0100 Subject: Fixed JSON parsing: newline escaping --- src/json.sml | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/json.sml b/src/json.sml index 4f604cc4..81d7b8b4 100644 --- a/src/json.sml +++ b/src/json.sml @@ -121,12 +121,18 @@ struct if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"\"" then (consume "\\\""; pickChars (s ^ "\"")) else - if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"n" - then (consume "\\n"; pickChars (s ^ "\n")) + if peek () = #"\\" andalso String.sub (!inputData, 1) = #"\\" andalso String.sub (!inputData, 2) = #"n" + then (consume "\\\\n"; pickChars (s ^ "\\n")) else - if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"r" - then (consume "\\r"; pickChars (s ^ "\r")) - else pickChars (s ^ String.str (take ())) + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"n" + then (consume "\\n"; pickChars (s ^ "\n")) + else + if peek () = #"\\" andalso String.sub (!inputData, 1) = #"\\" andalso String.sub (!inputData, 2) = #"r" + then (consume "\\\\r"; pickChars (s ^ "\\r")) + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"r" + then (consume "\\r"; pickChars (s ^ "\r")) + else pickChars (s ^ String.str (take ())) in pickChars "" end -- cgit v1.2.3 From 1fb21cbcb469891265a8be66d992b38ba5a6e05e Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 20:03:01 +0100 Subject: Always add text to fileState even if elabState throws --- src/lsp.sml | 36 ++++++++++++++++++++++++------------ 1 file changed, 24 insertions(+), 12 deletions(-) diff --git a/src/lsp.sml b/src/lsp.sml index 34137a4f..4e5e0637 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -204,12 +204,14 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef end end +(* TODO Bad API: text0 = NONE is Save, text0 = SOME is open *) +(* TODO whole function isn't great, could use a refactor *) fun handleDocumentSavedOrOpened (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) (textO: string option) = let val fileName = #path documentUri - val res = elabFile state fileName + val previousState = SM.find (#fileStates state, fileName) val text = case textO of - NONE => (case SM.find (#fileStates state, fileName) of + NONE => (case previousState of NONE => ((#showMessage toclient) ("No previous state for file " ^ fileName) 2; NONE) | SOME previousState => SOME (#text previousState)) | SOME text => SOME text @@ -217,16 +219,26 @@ fun handleDocumentSavedOrOpened (state: state) (toclient: LspSpec.toclient) (doc case text of NONE => () | SOME text => - (case #1 res of - NONE => - insertFileState state fileName { text = text - , envBeforeThisModule = ElabEnv.empty - , decls = [] } - | SOME fs => - (insertFileState state fileName { text = text - , envBeforeThisModule = #envBeforeThisModule fs - , decls = #decls fs }); - #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res}) + let + (* Insert text before elabFile since that can fail *) + val () = insertFileState state fileName { text = text + , envBeforeThisModule = case previousState of + NONE => ElabEnv.empty + | SOME p => #envBeforeThisModule p + , decls = case previousState of + NONE => [] + | SOME p => #decls p + } + val res = elabFile state fileName + in + (case #1 res of + NONE => () + | SOME fs => + (insertFileState state fileName { text = text + , envBeforeThisModule = #envBeforeThisModule fs + , decls = #decls fs }); + #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res}) + end end fun scanDir (f: string -> bool) (path: string) = -- cgit v1.2.3 From e21042fe736d9bffe7b0b83420530a5b2c0930e7 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 21:17:03 +0100 Subject: Fixed ppToString --- src/lsp.sml | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/src/lsp.sml b/src/lsp.sml index 4e5e0637..a39c8237 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -257,14 +257,16 @@ fun scanDir (f: string -> bool) (path: string) = fun readFile (fileName: string): string = let - val str = TextIO.openIn fileName + val stream = TextIO.openIn fileName fun doReadFile acc = - case TextIO.inputLine str of + case TextIO.inputLine stream of NONE => acc - | SOME str => (str ^ "\n" ^ acc) + | SOME str => (if acc = "" + then doReadFile str + else doReadFile (acc ^ str)) val res = doReadFile "" in - (TextIO.closeIn str; res) + (TextIO.closeIn stream; res) end @@ -299,7 +301,7 @@ fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec. case #smallestgoodpart result of NONE => LspSpec.Success NONE | SOME {desc = desc, ...} => - LspSpec.Success (SOME {contents = ppToString desc 70}) + LspSpec.Success (SOME {contents = ppToString desc 50}) end end @@ -311,7 +313,7 @@ fun getCompletionsFromFields (env: ElabEnv.env) (prefix: string) (searchStr: str if String.isPrefix searchStr fieldName then SOME { label = prefix ^ fieldName , kind = LspSpec.Field - , detail = ppToString (ElabPrint.p_con env c2) 150 + , detail = ppToString (ElabPrint.p_con env c2) 200 } else NONE | _ => NONE @@ -327,14 +329,14 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search if String.isPrefix searchStr name then [{ label = prefix ^ name , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 150 + , detail = ppToString (ElabPrint.p_con env con) 200 }] else [] | (Elab.SgiCon (name, _, _, con), _) => if String.isPrefix searchStr name then [{ label = prefix ^ name , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 150 + , detail = ppToString (ElabPrint.p_con env con) 200 }] else [] | (Elab.SgiDatatype cs, _) => @@ -353,7 +355,7 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search , kind = LspSpec.Function , detail = case conO of NONE => dtName ^ typeVarsString - | SOME con => ppToString (ElabPrint.p_con env con) 150 ^ " -> " ^ dtName ^ typeVarsString + | SOME con => ppToString (ElabPrint.p_con env con) 200 ^ " -> " ^ dtName ^ typeVarsString } else NONE) constrs end) @@ -372,7 +374,7 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search if String.isPrefix searchStr name then [{ label = prefix ^ name , kind = LspSpec.Class - , detail = ppToString (ElabPrint.p_con env con) 150 + , detail = ppToString (ElabPrint.p_con env con) 200 }] else [] | _ => [] @@ -395,7 +397,7 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion val expressionCompletions = List.map (fn (name,con) => { label = name , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 150 + , detail = ppToString (ElabPrint.p_con env con) 200 }) matchingEs val matchingStrs = ElabEnv.matchStrByPrefix env str val structureCompletions = List.map (fn (name,(_,sgn)) => @@ -407,7 +409,7 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion val conCompletions = List.map (fn (name,kind) => { label = name , kind = LspSpec.Constructor (* TODO probably wrong... *) - , detail = ppToString (ElabPrint.p_kind env kind) 150 + , detail = ppToString (ElabPrint.p_kind env kind) 200 }) matchingCons in expressionCompletions @ structureCompletions @ conCompletions -- cgit v1.2.3 From aee7b6df39b763518dead8f160725c06fb8c7d66 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 21:17:11 +0100 Subject: Parse also FFi .urs files --- src/lsp.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lsp.sml b/src/lsp.sml index a39c8237..4259c9ec 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -119,7 +119,7 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef then (List.rev (#1 acc), true) else (entry :: #1 acc, false)) ([] (* modules before *), false (* module found *)) - (#sources job) + (#ffi job @ #sources job) val modulesBeforeThisFile = #1 moduleSearchRes val () = if #2 moduleSearchRes then () -- cgit v1.2.3 From 91d154f3fa8634698faea010c9d965009a76fbcb Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sat, 14 Dec 2019 12:47:27 +0100 Subject: Refactored state into its own module --- src/lsp.sml | 210 +++++++++++++++++++++++++++++--------------------------- src/lspspec.sml | 23 ++++--- 2 files changed, 121 insertions(+), 112 deletions(-) diff --git a/src/lsp.sml b/src/lsp.sml index 4259c9ec..23b54a28 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -18,14 +18,68 @@ type state = { urpPath : string , fileStates : fileState SM.map } + +(* Wrapping this in structure as an attempt to not get concurrency bugs *) +structure State : + sig + val init: state -> unit + val insertText: string -> string -> unit + val insertElabRes: string -> ElabEnv.env -> Elab.decl list -> unit + val removeFile: string -> unit + val withState: (state -> 'a) -> 'a + end = struct val stateRef = ref (NONE: state option) +fun init (s: state) = + stateRef := SOME s +fun withState (f: state -> 'a): 'a = + case !stateRef of + NONE => raise LspSpec.LspError LspSpec.ServerNotInitialized + | SOME s => f s + +fun insertText (fileName: string) (text: string) = + withState (fn oldS => + stateRef := SOME { urpPath = #urpPath oldS + , fileStates = + case SM.find (#fileStates oldS, fileName) of + NONE => SM.insert ( #fileStates oldS + , fileName + , { text = text + , decls = [] + , envBeforeThisModule = ElabEnv.empty }) + | SOME oldfs => + SM.insert ( #fileStates oldS + , fileName + , { text = text + , decls = #decls oldfs + , envBeforeThisModule = #envBeforeThisModule oldfs }) + } + ) + +fun insertElabRes (fileName: string) (env: ElabEnv.env) decls = + withState (fn oldS => + stateRef := SOME { urpPath = #urpPath oldS + , fileStates = + case SM.find (#fileStates oldS, fileName) of + NONE => raise Fail ("No text found for file " ^ fileName) + | SOME oldfs => + SM.insert ( #fileStates oldS + , fileName + , { text = #text oldfs + , decls = decls + , envBeforeThisModule = env }) + } + ) + +fun removeFile (fileName: string) = + withState (fn oldS => + stateRef := SOME { urpPath = #urpPath oldS + , fileStates = #1 (SM.remove (#fileStates oldS, fileName)) + } + ) + +end + -fun insertFileState (state: state) (fileName: string) (fs: fileState) = - stateRef := SOME { urpPath = #urpPath state - , fileStates = SM.insert ( #fileStates state - , fileName - , fs) - } fun scanDir (f: string -> bool) (path: string) = let @@ -204,41 +258,16 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef end end -(* TODO Bad API: text0 = NONE is Save, text0 = SOME is open *) -(* TODO whole function isn't great, could use a refactor *) -fun handleDocumentSavedOrOpened (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) (textO: string option) = +fun elabFileAndSendDiags (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri): unit = let val fileName = #path documentUri - val previousState = SM.find (#fileStates state, fileName) - val text = case textO of - NONE => (case previousState of - NONE => ((#showMessage toclient) ("No previous state for file " ^ fileName) 2; NONE) - | SOME previousState => SOME (#text previousState)) - | SOME text => SOME text + val res = elabFile state fileName in - case text of - NONE => () - | SOME text => - let - (* Insert text before elabFile since that can fail *) - val () = insertFileState state fileName { text = text - , envBeforeThisModule = case previousState of - NONE => ElabEnv.empty - | SOME p => #envBeforeThisModule p - , decls = case previousState of - NONE => [] - | SOME p => #decls p - } - val res = elabFile state fileName - in - (case #1 res of - NONE => () - | SOME fs => - (insertFileState state fileName { text = text - , envBeforeThisModule = #envBeforeThisModule fs - , decls = #decls fs }); - #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res}) - end + (case #1 res of + NONE => () + | SOME fs => + (State.insertElabRes fileName (#envBeforeThisModule fs) (#decls fs)); + #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res}) end fun scanDir (f: string -> bool) (path: string) = @@ -518,79 +547,56 @@ fun handleDocumentDidChange (state: state) (toclient: LspSpec.toclient) (p: LspS (debug ("Got change event for file that isn't open: " ^ fileName); (#showMessage toclient) ("Got change event for file that isn't open: " ^ fileName) 1) | SOME s => - let - val newtext = List.foldl applyContentChange (#text s) (#contentChanges p) - in - insertFileState state fileName { text = newtext - , decls = #decls s - , envBeforeThisModule = #envBeforeThisModule s} - end + State.insertText fileName (List.foldl applyContentChange (#text s) (#contentChanges p)) end -fun handleDocumentDidClose (state: state) (toclient: LspSpec.toclient) (p: LspSpec.didCloseParams): unit = - let - val fileName = #path (#uri (#textDocument p)) - val s = SM.find (#fileStates state, fileName) - in - stateRef := SOME { urpPath = #urpPath state - , fileStates = (#1 (SM.remove (#fileStates state, fileName))) handle ex => #fileStates state - } - end +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.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 + }) fun serverLoop () = let - val state = !stateRef val requestMessage = LspSpec.readRequestFromStdIO () handle ex => (debug (General.exnMessage ex) ; raise ex) in - case state of - NONE => - (case requestMessage of - LspSpec.RequestMessage m => - LspSpec.handleMessage - m - { initialize = fn p => - (let val st = initState p - in - stateRef := SOME st; - LspSpec.Success - { capabilities = - { hoverProvider = true - , completionProvider = SOME { triggerCharacters = ["."]} - , textDocumentSync = { openClose = true - , change = 2 - , save = SOME { includeText = false } - }} - } - end) - handle (Fail str) => LspSpec.Error (~32602, str) - , shutdown = fn () => LspSpec.Error (~32002, "Server not initialized") - , textDocument_hover = fn toclient => fn _ => LspSpec.Error (~32002, "Server not initialized") - , textDocument_completion = fn _ => LspSpec.Error (~32002, "Server not initialized") - } - | LspSpec.Notification n => ()) - | SOME state => - (case requestMessage of - LspSpec.Notification n => - (LspSpec.handleNotification - n - { initialized = fn () => () - , textDocument_didOpen = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) (SOME (#text (#textDocument p))) - , textDocument_didChange = handleDocumentDidChange state - , textDocument_didSave = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) NONE - , textDocument_didClose = fn toclient => fn p => handleDocumentDidClose state toclient p - }) - | LspSpec.RequestMessage m => - (* TODO should error handling here be inside 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 - }) - ) + handleRequest requestMessage end fun startServer () = while true do serverLoop () diff --git a/src/lspspec.sml b/src/lspspec.sml index fe1711f0..bbc78606 100644 --- a/src/lspspec.sml +++ b/src/lspspec.sml @@ -1,6 +1,7 @@ structure LspSpec = struct datatype lspError = InternalError of string + | ServerNotInitialized exception LspError of lspError fun debug (str: string): unit = @@ -361,7 +362,7 @@ structure LspSpec = struct end val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} - fun handleMessage + fun matchMessage (requestMessage: {id: Json.json, method: string, params: Json.json}) (handlers: messageHandlers) : unit = @@ -393,6 +394,7 @@ structure LspSpec = struct | method => (debug ("Method not supported: " ^ method); Error (~32601, "Method not supported: " ^ method))) handle LspError (InternalError str) => Error (~32603, str) + | LspError ServerNotInitialized => Error (~32002, "Server not initialized") | ex => Error (~32603, (General.exnMessage ex)) ) (* val () = (TextIO.output (TextIO.stdErr, "Got result: " ^ (case result of Success _ => "success\n" *) @@ -427,23 +429,24 @@ structure LspSpec = struct 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 + , textDocument_didOpen: (didOpenParams * toclient) -> unit + , textDocument_didChange: (didChangeParams * toclient) -> unit + , textDocument_didSave: (didSaveParams * toclient) -> unit + , textDocument_didClose: (didCloseParams * toclient) -> unit } - fun handleNotification + fun matchNotification (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)) + | "textDocument/didOpen" => (#textDocument_didOpen handlers) (parseDidOpenParams (#params notification), toclient) + | "textDocument/didChange" => (#textDocument_didChange handlers) (parseDidChangeParams (#params notification), toclient) + | "textDocument/didSave" => (#textDocument_didSave handlers) (parseDidSaveParams (#params notification), toclient) + | "textDocument/didClose" => (#textDocument_didClose handlers) (parseDidCloseParams (#params notification), toclient) | m => debug ("Notification method not supported: " ^ m)) handle LspError (InternalError str) => showMessage str 1 + | LspError ServerNotInitialized => showMessage "Server not initialized" 1 | ex => showMessage (General.exnMessage ex) 1 end -- 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 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 472f3cf5206a06f0a7eae721f08f0a43276863cf Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sat, 4 Jan 2020 13:58:50 +0100 Subject: Added some more stuff to lsp getInfo and completions --- src/getinfo.sml | 221 ++++++++++++++++++++++++++++++++++++++++++++++---------- src/lsp.sml | 36 +++++---- 2 files changed, 203 insertions(+), 54 deletions(-) diff --git a/src/getinfo.sml b/src/getinfo.sml index 1d657637..abe3bc61 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -102,6 +102,43 @@ fun getInfo env str fileName {line = row, character = col} = else env) env decls | _ => env) + (* This isn't very precise since we use the span of the parent exp/decl/etc *) + (* to find the "smallest part" *) + fun printPat env (pat: L.pat) = + if isPosIn fileName row col (#2 pat) + then + case #1 pat of + L.PVar (str, c) => SOME (P.box [ P.PD.string str + , P.PD.string " : " + , ElabPrint.p_con env c]) + | L.PCon (_, _, _, SOME p) => printPat env p + | L.PRecord fields => (case List.mapPartial (fn field => printPat env (#2 field)) fields of + [] => NONE + | first :: _ => SOME first) + | _ => NONE + else NONE + + fun isXmlTag env c = + case c of + L.CApp + ((L.CApp + ((L.CApp + (( L.CApp + (( L.CApp + ((L.CNamed n, _) , _) + , _) + , _) + , _) + , _) + , _) + , _) + , _) + , _) => + (case E.lookupCNamed env n of + ("tag", _, _) => true + | _ => false) + | _ => false + (* 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 *) @@ -109,57 +146,164 @@ fun getInfo env str fileName {line = row, character = col} = 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")]) + let + val rendered = 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")] + in + case p of + Prim.String (_, str) => + if Substring.foldl (fn (c, acc) => acc andalso c = #" ") true (Substring.full str) + then NONE + else SOME rendered + | _ => SOME (rendered) + end | Exp (L.ERel n, _) => SOME ((let val found = E.lookupERel env n in P.box [ P.PD.string (#1 found) - , P.PD.string ": " + , 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.ENamed n, span) => + ((let + val found = E.lookupENamed env n + val rendered = P.box [ P.PD.string (#1 found) + , P.PD.string " : " + , ElabPrint.p_con env (#2 found) + ] + (* val () = if #1 found = "body" *) + (* then Print.eprint (ElabPrint.p_con env (#2 found)) *) + (* else () *) + in + (* case #2 found of *) + (* (L.TFun ((L.CUnit, _), (c, _)), _) => *) + (* (if isXmlTag env c *) + (* then SOME (P.box [ P.PD.string "<" *) + (* , P.PD.string ( #1 found) *) + (* , P.PD.string ">" *) + (* ]) *) + (* else SOME rendered) *) + (* | _ => *) SOME rendered + end) + handle E.UnboundNamed _ => SOME (P.PD.string ("UNBOUND_NAMED" ^ Int.toString n))) + | Exp (L.EAbs (varName, domain, _, _), _) => + if isPosIn fileName row col (#2 domain) + then + SOME (P.box [ P.PD.string (varName ^ " : ") + , ElabPrint.p_con env domain + ]) + else NONE + | Exp (L.EField (e, c, {field, ...}), loc) => + SOME (P.box [ElabPrint.p_exp env e, + P.PD.string ".", + ElabPrint.p_con env c, + P.PD.string ": ", + ElabPrint.p_con env field]) | 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)) + , ms (* names of submodules - possibly none *) + , x (* identifier *)), loc) => + (let + val (m1name, m1sgn) = E.lookupStrNamed env m1 + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail ("Couldn't find Structure: " ^ m) + | SOME sgn => ((L.StrProj (str, m), loc), sgn)) + ((L.StrVar m1, loc), m1sgn) + ms + val t = case E.projectVal env {sgn = sgn, str = str, field = x} of + NONE => raise Fail ("Couldn't find identifier: " ^ x) + | SOME t => t + in + case (m1name, x) of + (* Stripping these because XML desugaring adds these with small spans and crowd out the stuff you want to see *) + ("Basis", "cdata") => NONE + | ("Top", "txt") => NONE + | ("Basis", "join") => NONE + | ("Basis", "bind") => NONE + | ("Basis", "sql_subset") => NONE + | ("Basis", "sql_subset_all") => NONE + | ("Basis", "sql_query") => NONE + | ("Basis", "sql_query1") => NONE + | ("Basis", "sql_eq") => NONE + | ("Basis", "sql_inner_join") => NONE + (* | ("Basis", "sql_field") => NONE *) + | ("Basis", "sql_binary") => NONE + | _ => + SOME (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 _ => SOME (P.PD.string ("Module not found: " ^ Int.toString m1))) + | Exp (L.ELet (edecls, _, _), _) => + let + val found = List.mapPartial + (fn (edecl, loc) => + if isPosIn fileName row col loc + then + case edecl of + L.EDVal (pat, _, _) => printPat env pat + | L.EDValRec ((x, c, _) :: _) => + SOME (P.box [ P.PD.string x + , P.PD.string " : " + , ElabPrint.p_con env c]) + | _ => NONE + else NONE) + edecls + in + if List.length found > 0 + then SOME (List.hd found) + else NONE + end + | Exp (L.ECase (_, pats, _), _) => + (case List.find (fn ((pat', loc), exp) => isPosIn fileName row col loc) pats of + NONE => NONE + | SOME (pat, _) => printPat env pat) | Exp e => NONE | Kind k => NONE | Con c => NONE | Sgn_item si => NONE | Sgn s => NONE | Str s => NONE - | Decl d => NONE) + | Decl (L.DVal (x, _, con, _), _) => + SOME (P.box [ P.PD.string x + , P.PD.string " : " + , ElabPrint.p_con env con ]) + | Decl (L.DValRec decls, _) => + (* valrecs don't have nice spans per declaration so we find the *) + (* declaration for which the con starts closest *) + let + val res = + List.foldl (fn (decl, accO) => + let + val distanceFromRow = Int.abs (#line (#first (#2 (#3 decl))) - row) + val accDistanceFromRow = case accO of + NONE => 999 + | SOME acc => Int.abs (#line (#first (#2 (#3 acc))) - row) + in + if distanceFromRow < accDistanceFromRow andalso distanceFromRow <= 1 + then SOME decl + else accO + end) + NONE + decls + in + case res of + NONE => NONE + | SOME (x, _, con, _) => + SOME (P.box [ P.PD.string x + , P.PD.string " : " + , ElabPrint.p_con env con + ]) + end + | Decl d => NONE + ) fun add (env: ElabEnv.env) (item: item) (span: ErrorMsg.span) (acc: { smallest : { span : ErrorMsg.span , item : item @@ -187,7 +331,8 @@ fun getInfo env str fileName {line = row, character = col} = NONE => NONE | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) | SOME (prev as {desc = desc', span = span', env = env', item = item'}) => - if isSmallerThan span span' + if + isSmallerThan span span' then (case printGoodPart env item span of NONE => SOME prev diff --git a/src/lsp.sml b/src/lsp.sml index 79b96ef9..e00bd850 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -465,23 +465,27 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion (* TODO PERF SMALL: first match and then equal is not perfect *) val foundEs = ElabEnv.matchEByPrefix env (Substring.string r) val filteredEs = List.filter (fn (name,_) => name = Substring.string r) foundEs + val reduced = List.map (fn (name, c) => + (name, ElabOps.reduceCon env c) + handle ex => (name, (Elab.CUnit, ErrorMsg.dummySpan))) + filteredEs in - (case List.map (fn (name, c) => (name, ElabOps.reduceCon env c)) filteredEs of - [] => [] - | (name, (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_)) :: _ => - getCompletionsFromFields env (name ^ ".") (Substring.string str) fields - | (name, (* TODO this doesn't always work. I've only managed to get it working for tables in a different module *) - ( ( Elab.CApp - ( ( (Elab.CApp - ( ( Elab.CModProj (_, _, "sql_table") - , l4_) - , ( Elab.CRecord (_, fields) - , l3_))) - , l2_) - , _)) - , l1_)) :: _ => - getCompletionsFromFields env (name ^ ".") (Substring.string str) fields - | _ => []) + case reduced of + [] => [] + | (name, (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_)) :: _ => + getCompletionsFromFields env (name ^ ".") (Substring.string str) fields + | (name, + ( ( Elab.CApp + ( ( (Elab.CApp + ( ( Elab.CModProj (_, _, "sql_table") + , l4_) + , ( Elab.CRecord (_, fields) + , l3_))) + , l2_) + , _)) + , l1_)) :: _ => + getCompletionsFromFields env (name ^ ".") (Substring.string str) fields + | _ => [] end | _ => (* TODO NOTIMPLEMENTED submodules / nested records *) -- cgit v1.2.3 From cffbd03336348508dfb8d647a593c24b9bc89878 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 8 Jan 2020 10:13:39 +0100 Subject: Return only unique diags + better formatting --- src/getinfo.sml | 67 ++++++++++++++++++++++++++------------------------------- src/lsp.sml | 9 +++++++- 2 files changed, 39 insertions(+), 37 deletions(-) diff --git a/src/getinfo.sml b/src/getinfo.sml index abe3bc61..d980afd3 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -138,6 +138,12 @@ fun getInfo env str fileName {line = row, character = col} = ("tag", _, _) => true | _ => false) | _ => false + + fun formatTypeBox (a: P.PD.pp_desc, b: P.PD.pp_desc) = + P.PD.hvBox (P.PD.PPS.Rel 0, [a, + P.PD.string ": ", + P.PD.break {nsp = 0, offset = 2}, + b]) (* TODO We lose some really useful information, like eg. inferred parameters, *) (* which we do have in the actual items (L.Decl, L.Exp, etc) *) @@ -147,13 +153,12 @@ fun getInfo env str fileName {line = row, character = col} = (case f of Exp (L.EPrim p, _) => let - val rendered = 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")] + val rendered = formatTypeBox ( Prim.p_t p + , P.PD.string (case p of + Prim.Int _ => "int" + | Prim.Float _ => "float" + | Prim.String _ => "string" + | Prim.Char _ => "char")) in case p of Prim.String (_, str) => @@ -165,18 +170,15 @@ fun getInfo env str fileName {line = row, character = col} = | 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)] + formatTypeBox ( P.PD.string (#1 found) + , ElabPrint.p_con env (#2 found)) end) handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) | Exp (L.ENamed n, span) => ((let val found = E.lookupENamed env n - val rendered = P.box [ P.PD.string (#1 found) - , P.PD.string " : " - , ElabPrint.p_con env (#2 found) - ] + val rendered = formatTypeBox ( P.PD.string (#1 found) + , ElabPrint.p_con env (#2 found)) (* val () = if #1 found = "body" *) (* then Print.eprint (ElabPrint.p_con env (#2 found)) *) (* else () *) @@ -195,16 +197,15 @@ fun getInfo env str fileName {line = row, character = col} = | Exp (L.EAbs (varName, domain, _, _), _) => if isPosIn fileName row col (#2 domain) then - SOME (P.box [ P.PD.string (varName ^ " : ") - , ElabPrint.p_con env domain - ]) + SOME (formatTypeBox ( P.PD.string varName + , ElabPrint.p_con env domain) + ) else NONE | Exp (L.EField (e, c, {field, ...}), loc) => - SOME (P.box [ElabPrint.p_exp env e, - P.PD.string ".", - ElabPrint.p_con env c, - P.PD.string ": ", - ElabPrint.p_con env field]) + SOME (formatTypeBox ( P.box [ElabPrint.p_exp env e, + P.PD.string ".", + ElabPrint.p_con env c] + , ElabPrint.p_con env field)) | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) , ms (* names of submodules - possibly none *) , x (* identifier *)), loc) => @@ -235,10 +236,8 @@ fun getInfo env str fileName {line = row, character = col} = (* | ("Basis", "sql_field") => NONE *) | ("Basis", "sql_binary") => NONE | _ => - SOME (P.box [ P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) - , P.PD.string " : " - , ElabPrint.p_con env t - ]) + SOME (formatTypeBox ( P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) + , ElabPrint.p_con env t)) end handle E.UnboundNamed _ => SOME (P.PD.string ("Module not found: " ^ Int.toString m1))) | Exp (L.ELet (edecls, _, _), _) => @@ -250,9 +249,8 @@ fun getInfo env str fileName {line = row, character = col} = case edecl of L.EDVal (pat, _, _) => printPat env pat | L.EDValRec ((x, c, _) :: _) => - SOME (P.box [ P.PD.string x - , P.PD.string " : " - , ElabPrint.p_con env c]) + SOME (formatTypeBox ( P.PD.string x + , ElabPrint.p_con env c)) | _ => NONE else NONE) edecls @@ -272,9 +270,8 @@ fun getInfo env str fileName {line = row, character = col} = | Sgn s => NONE | Str s => NONE | Decl (L.DVal (x, _, con, _), _) => - SOME (P.box [ P.PD.string x - , P.PD.string " : " - , ElabPrint.p_con env con ]) + SOME (formatTypeBox ( P.PD.string x + , ElabPrint.p_con env con )) | Decl (L.DValRec decls, _) => (* valrecs don't have nice spans per declaration so we find the *) (* declaration for which the con starts closest *) @@ -297,10 +294,8 @@ fun getInfo env str fileName {line = row, character = col} = case res of NONE => NONE | SOME (x, _, con, _) => - SOME (P.box [ P.PD.string x - , P.PD.string " : " - , ElabPrint.p_con env con - ]) + SOME (formatTypeBox ( P.PD.string x + , ElabPrint.p_con env con)) end | Decl d => NONE ) diff --git a/src/lsp.sml b/src/lsp.sml index e00bd850..ef12bbac 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -258,16 +258,23 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef end end +fun uniq (comp: 'b -> 'b -> bool) (bs: 'b list) = + case bs of + [] => [] + | (l as b :: bs') => b :: uniq comp (List.filter (comp b) bs') + fun elabFileAndSendDiags (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri): unit = let val fileName = #path documentUri val res = elabFile state fileName + fun eq_diag d1 d2 = #range d1 = #range d2 andalso #message d1 = #message d2 + val diags = uniq eq_diag (#2 res) in (case #1 res of NONE => () | SOME fs => (State.insertElabRes fileName (#envBeforeThisModule fs) (#decls fs)); - #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res}) + #publishDiagnostics toclient { uri = documentUri , diagnostics = diags}) end fun scanDir (f: string -> bool) (path: string) = -- 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 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 From 7ebc4f3ff8081424f0e227142ac76bb3f7fc4a20 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 8 Jan 2020 12:11:18 +0100 Subject: Added some type sigs required by SMLNJ --- src/getinfo.sml | 2 +- src/lsp.sml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/getinfo.sml b/src/getinfo.sml index d980afd3..d84f792b 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -32,7 +32,7 @@ structure E = ElabEnv structure L = Elab structure P = Print -fun isPosIn file row col span = +fun isPosIn (file: string) (row: int) (col: int) (span: ErrorMsg.span) = let val start = #first span val end_ = #last span diff --git a/src/lsp.sml b/src/lsp.sml index ef12bbac..d11aab3f 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -267,7 +267,7 @@ fun elabFileAndSendDiags (state: state) (toclient: LspSpec.toclient) (documentUr let val fileName = #path documentUri val res = elabFile state fileName - fun eq_diag d1 d2 = #range d1 = #range d2 andalso #message d1 = #message d2 + fun eq_diag (d1: LspSpec.diagnostic) (d2: LspSpec.diagnostic) = #range d1 = #range d2 andalso #message d1 = #message d2 val diags = uniq eq_diag (#2 res) in (case #1 res of @@ -558,7 +558,7 @@ 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 = +fun runInBackground (toclient: LspSpec.toclient) (fileName: string) (f: unit -> unit): unit = BgThread.queueBgTask fileName ((fn () => (f () -- cgit v1.2.3 From d7ca451f01595ced7cfe70f43714ac2a1150915d Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 8 Jan 2020 12:11:45 +0100 Subject: Allow simple .ur files to double as .urs files for LSP --- src/lsp.sml | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/src/lsp.sml b/src/lsp.sml index d11aab3f..856b7ab8 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -180,18 +180,16 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef 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 - val fileName = entry ^ ".urs" - in - { fileName = fileName - , parsed = - if OS.FileSys.access (fileName, []) - then case C.run (C.transform C.parseUrs "parseUrs") fileName of - NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse .urs file at " ^ fileName)) - | SOME a => a - else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find an .urs file for " ^ fileName)) - } - end) + if OS.FileSys.access (entry ^ ".urs", []) + then case C.run (C.transform C.parseUrs "parseUrs") (entry ^ ".urs") of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse .urs file at " ^ entry)) + | SOME a => { fileName = entry ^ ".urs", parsed = a} + else + if OS.FileSys.access (entry ^ ".ur", []) + then case C.run (C.transform C.parseUrs "parseUrs") (entry ^ ".ur") of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("No .urs file found for " ^ entry ^ " and couldn't parse .ur as .urs file")) + | SOME a => { fileName = entry ^ ".ur" , parsed = a} + else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find an .ur or .urs file for " ^ entry))) modulesBeforeThisFile (* Parsing Basis and Top *) val basisF = Settings.libFile "basis.urs" -- cgit v1.2.3 From 028f15cce127360f29afa41754aab3816718492f Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 8 Jan 2020 12:12:24 +0100 Subject: Fixed smaller review remarks --- src/getinfo.sml | 8 ++++---- src/lspspec.sml | 4 +--- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/src/getinfo.sml b/src/getinfo.sml index d84f792b..5a0fe752 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -37,7 +37,7 @@ fun isPosIn (file: string) (row: int) (col: int) (span: ErrorMsg.span) = val start = #first span val end_ = #last span in - String.isSuffix file (#file span) + OS.Path.base file = OS.Path.base (#file span) andalso (#line start < row orelse #line start = row andalso #char start <= col) @@ -281,7 +281,7 @@ fun getInfo env str fileName {line = row, character = col} = let val distanceFromRow = Int.abs (#line (#first (#2 (#3 decl))) - row) val accDistanceFromRow = case accO of - NONE => 999 + NONE => Option.getOpt (Int.maxInt, 99999) | SOME acc => Int.abs (#line (#first (#2 (#3 acc))) - row) in if distanceFromRow < accDistanceFromRow andalso distanceFromRow <= 1 @@ -368,10 +368,10 @@ fun getInfo env str fileName {line = row, character = col} = { smallestgoodpart = NONE , smallest = { item = Str (str, { file = fileName , first = { line = 0, char = 0} - , last = { line = 99999, char = 0} }) + , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} }) , span = { file = fileName , first = { line = 0, char = 0} - , last = { line = 99999, char = 0} } + , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} } , env = env } } ( L.DStr (Compiler.moduleOf "fileName", 0, (L.SgnError, ErrorMsg.dummySpan), (str, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos})) diff --git a/src/lspspec.sml b/src/lspspec.sml index bbc78606..0d766056 100644 --- a/src/lspspec.sml +++ b/src/lspspec.sml @@ -8,9 +8,7 @@ structure LspSpec = struct (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) + Substring.dropr Char.isSpace (Substring.dropl Char.isSpace s) fun readHeader (): (string * string) option = let -- cgit v1.2.3 From ce6bae891c6d1e22e61a1fb54ce3ecd08ca31891 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 10 Jan 2020 02:25:45 +0100 Subject: Refactor to do all matching on strings, more precise and faster --- src/elab_env.sig | 6 +- src/elab_env.sml | 28 ++- src/getinfo.sig | 34 ++-- src/getinfo.sml | 511 ++++++++++++++++++++++--------------------------------- src/lsp.sml | 229 ++++++------------------- 5 files changed, 291 insertions(+), 517 deletions(-) diff --git a/src/elab_env.sig b/src/elab_env.sig index fb95d68e..4f994221 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -61,7 +61,6 @@ signature ELAB_ENV = sig val lookupCNamed : env -> int -> string * Elab.kind * Elab.con option val lookupC : env -> string -> Elab.kind var - val matchCByPrefix: env -> string -> (string * Elab.kind) list val pushDatatype : env -> int -> string list -> (string * int * Elab.con option) list -> env type datatyp @@ -86,7 +85,6 @@ signature ELAB_ENV = sig val pushENamedAs : env -> string -> int -> Elab.con -> env val lookupENamed : env -> int -> string * Elab.con val checkENamed : env -> int -> bool - val matchEByPrefix: env -> string -> (string * Elab.con) list val lookupE : env -> string -> Elab.con var @@ -102,8 +100,10 @@ signature ELAB_ENV = sig val lookupStrNamed : env -> int -> string * Elab.sgn val lookupStr : env -> string -> (int * Elab.sgn) option - val matchStrByPrefix: env -> string -> (string * (int * Elab.sgn)) list + val dumpCs: env -> (string * Elab.kind) list + val dumpEs: env -> (string * Elab.con) list + val dumpStrs: env -> (string * (int * Elab.sgn)) list val edeclBinds : env -> Elab.edecl -> env val declBinds : env -> Elab.decl -> env diff --git a/src/elab_env.sml b/src/elab_env.sml index f492bc94..5fa32cd2 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -404,14 +404,6 @@ fun lookupC (env : env) x = | SOME (Rel' x) => Rel x | SOME (Named' x) => Named x -fun matchCByPrefix (env: env) (prefix: string): (string * kind) list = - List.mapPartial (fn (name, value) => if String.isPrefix prefix name - then case value of - Rel' (_, x) => SOME (name, x) - | Named' (_, x) => SOME (name, x) - else NONE) - (SM.listItemsi (#renameC env)) - fun pushDatatype (env : env) n xs xncs = let val dk = U.classifyDatatype xncs @@ -940,13 +932,6 @@ fun lookupENamed (env : env) n = NONE => raise UnboundNamed n | SOME x => x -(* TODO Why does this work better than using #renameE? *) -fun matchEByPrefix (env: env) (prefix: string): (string * con) list = - List.mapPartial (fn (name, value) => if String.isPrefix prefix name - then SOME (name, value) - else NONE) - (#relE env @ IM.listItems (#namedE env)) - fun checkENamed (env : env) n = Option.isSome (IM.find (#namedE env, n)) @@ -1000,8 +985,17 @@ fun lookupStrNamed (env : env) n = | SOME x => x fun lookupStr (env : env) x = SM.find (#renameStr env, x) -fun matchStrByPrefix (env: env) prefix = - List.filter (fn (name,_) => String.isPrefix prefix name) (SM.listItemsi (#renameStr env)) + +fun dumpCs (env: env): (string * kind) list = + List.map (fn (name, value) => case value of + Rel' (_, x) => (name, x) + | Named' (_, x) => (name, x)) + (SM.listItemsi (#renameC env)) +(* TODO try again with #renameE *) +fun dumpEs (env: env): (string * con) list = + #relE env @ IM.listItems (#namedE env) +fun dumpStrs (env: env) = + SM.listItemsi (#renameStr env) fun sgiSeek (sgi, (sgns, strs, cons)) = case sgi of diff --git a/src/getinfo.sig b/src/getinfo.sig index 50eee70a..663a9a81 100644 --- a/src/getinfo.sig +++ b/src/getinfo.sig @@ -27,28 +27,24 @@ signature GET_INFO = sig - datatype item = - Kind of Elab.kind - | Con of Elab.con - | Exp of Elab.exp - | Sgn_item of Elab.sgn_item - | Sgn of Elab.sgn - | Str of Elab.str - | Decl of Elab.decl + datatype foundInEnv = FoundStr of (string * Elab.sgn) + | FoundCon of (string * Elab.kind) + | FoundExp of (string * Elab.con) - val getInfo: + val findStringInEnv: ElabEnv.env -> Elab.str' -> string (* fileName *) -> - { line: int , character: int} -> - { smallest : { span : ErrorMsg.span - , item : item - , env : ElabEnv.env } - , smallestgoodpart : { span : ErrorMsg.span - , desc : Print.PD.pp_desc - , env : ElabEnv.env - , item : item - } option -} + {line: int, char: int} -> + string (* query *) -> + (ElabEnv.env * string (* prefix *) * foundInEnv option) + + val matchStringInEnv: + ElabEnv.env -> + Elab.str' -> + string (* fileName *) -> + {line: int, char: int} -> + string (* query *) -> + (ElabEnv.env * string (* prefix *) * foundInEnv list) end diff --git a/src/getinfo.sml b/src/getinfo.sml index 5a0fe752..f18d0638 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -30,21 +30,19 @@ structure GetInfo :> GET_INFO = struct structure U = ElabUtilPos structure E = ElabEnv structure L = Elab -structure P = Print -fun isPosIn (file: string) (row: int) (col: int) (span: ErrorMsg.span) = +fun isPosIn (file: string) (line: int) (char: int) (span: ErrorMsg.span) = let val start = #first span val end_ = #last span in OS.Path.base file = OS.Path.base (#file span) andalso - (#line start < row orelse - #line start = row andalso #char start <= col) + (#line start < line orelse + #line start = line andalso #char start <= char) andalso - (#line end_ > row orelse - #line end_ = row andalso #char end_ >= col) - + (#line end_ > line orelse + #line end_ = line andalso #char end_ >= char) end fun isSmallerThan (s1: ErrorMsg.span) (s2: ErrorMsg.span) = @@ -63,8 +61,8 @@ datatype item = | Str of L.str | Decl of L.decl -fun getSpan (f: item * E.env) = - case #1 f of +fun getSpan (f: item) = + case f of Kind k => #2 k | Con c => #2 c | Exp e => #2 e @@ -73,310 +71,215 @@ fun getSpan (f: item * E.env) = | Str s => #2 s | Decl d => #2 d -(* Just use ElabPrint functions. *) -(* These are better for compiler error messages, but it's better than nothing *) -fun printLiterally {span = span, item = item, env = env} = - P.box [ case item of - Kind k => P.box [P.PD.string "KIND: ", ElabPrint.p_kind env k] - | Con c => P.box [P.PD.string "CON: ", ElabPrint.p_con env c] - | Exp e => P.box [P.PD.string "EXP: ", ElabPrint.p_exp env e] - | Sgn_item si => P.box [P.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] - | Sgn s => P.box [P.PD.string "SGN: ", ElabPrint.p_sgn env s] - | Str s => P.box [P.PD.string "STR: ", ElabPrint.p_str env s] - | Decl d => P.box [P.PD.string "DECL: ", ElabPrint.p_decl env d] - ] -fun getInfo env str fileName {line = row, character = col} = +fun findInStr (f: ElabEnv.env -> item (* curr *) -> item (* prev *) -> bool) + (init: item) + env str fileName {line = line, char = char}: {item: item, env: ElabEnv.env} = let val () = U.mliftConInCon := E.mliftConInCon + val {env: ElabEnv.env, found: Elab.decl option} = + (case str of + L.StrConst decls => + List.foldl (fn (d, acc as {env, found}) => + if #line (#last (#2 d)) < line + then {env = E.declBinds env d, found = found} + else + if #line (#first (#2 d)) <= line andalso line <= #line (#last (#2 d)) + then {env = env, found = SOME d} + else {env = env, found = found}) + {env = env, found = NONE} decls + | _ => { env = env, found = NONE }) + val dummyResult = (init, env) + val result = + case found of + NONE => dummyResult + | SOME d => + U.Decl.foldB + { kind = fn (env, i, acc as (prev, env')) => if f env (Kind i) prev then (Kind i, env) else acc, + con = fn (env, i, acc as (prev, env')) => if f env (Con i) prev then (Con i, env) else acc, + exp = fn (env, i, acc as (prev, env')) => if f env (Exp i) prev then (Exp i, env) else acc, + sgn_item = fn (env, i, acc as (prev, env')) => if f env (Sgn_item i) prev then (Sgn_item i, env) else acc, + sgn = fn (env, i, acc as (prev, env')) => if f env (Sgn i) prev then (Sgn i, env) else acc, + str = fn (env, i, acc as (prev, env')) => if f env (Str i) prev then (Str i, env) else acc, + decl = fn (env, i, acc as (prev, env')) => if f env (Decl i) prev then (Decl i, env) else acc, + bind = fn (env, binder) => + case binder of + U.Decl.RelK x => E.pushKRel env x + | U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co + | U.Decl.RelE (x, c) => E.pushERel env x c + | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) + | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) + | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) + } + env dummyResult d + in + {item = #1 result, env = #2 result} + end - (* Adding previous declarations in file to environment *) - (* "open " statements are already translated during elaboration *) - (* They get added to the env here "unprefixed" *) - val env = (case str of - L.StrConst decls => - List.foldl (fn (d, env) => - if #line (#first (#2 d)) <= row - andalso #char (#first (#2 d)) <= col - then E.declBinds env d - else env) env decls - | _ => env) +fun findSmallestSpan env str fileName {line = line, char = char} = + let + fun fitsAndIsSmaller (env: ElabEnv.env) (curr: item) (prev: item) = + isPosIn fileName line char (getSpan curr) andalso isSmallerThan (getSpan curr) (getSpan prev) + val init = Str (str, { file = fileName + , first = { line = 0, char = 0} + , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} }) + in + findInStr fitsAndIsSmaller init env str fileName {line = line, char = char} + end - (* This isn't very precise since we use the span of the parent exp/decl/etc *) - (* to find the "smallest part" *) - fun printPat env (pat: L.pat) = - if isPosIn fileName row col (#2 pat) - then - case #1 pat of - L.PVar (str, c) => SOME (P.box [ P.PD.string str - , P.PD.string " : " - , ElabPrint.p_con env c]) - | L.PCon (_, _, _, SOME p) => printPat env p - | L.PRecord fields => (case List.mapPartial (fn field => printPat env (#2 field)) fields of - [] => NONE - | first :: _ => SOME first) - | _ => NONE - else NONE +fun findFirstExpAfter env str fileName {line = line, char = char} = + let + fun currIsAfterPosAndBeforePrev (env: ElabEnv.env) (curr: item) (prev: item) = + (* curr is an exp *) + (case curr of Exp _ => true | _ => false) + andalso + (* curr is after input pos *) + ( line < #line (#first (getSpan curr)) + orelse ( line = #line (#first (getSpan curr)) + andalso char < #char (#first (getSpan curr)))) + andalso + (* curr is before prev *) + (#line (#first (getSpan curr)) < #line (#first (getSpan prev)) + orelse + (#line (#first (getSpan curr)) = #line (#first (getSpan prev)) + andalso #char (#first (getSpan curr)) < #char (#first (getSpan prev)))) + val init = Exp (Elab.EPrim (Prim.Int 0), + { file = fileName + , first = { line = Option.getOpt (Int.maxInt, 99999), char = Option.getOpt (Int.maxInt, 99999)} + , last = { line = Option.getOpt (Int.maxInt, 99999), char = Option.getOpt (Int.maxInt, 99999)} }) + in + findInStr currIsAfterPosAndBeforePrev init env str fileName {line = line, char = char} + end - fun isXmlTag env c = - case c of - L.CApp - ((L.CApp - ((L.CApp - (( L.CApp - (( L.CApp - ((L.CNamed n, _) , _) - , _) - , _) - , _) - , _) - , _) - , _) - , _) - , _) => - (case E.lookupCNamed env n of - ("tag", _, _) => true - | _ => false) - | _ => false - fun formatTypeBox (a: P.PD.pp_desc, b: P.PD.pp_desc) = - P.PD.hvBox (P.PD.PPS.Rel 0, [a, - P.PD.string ": ", - P.PD.break {nsp = 0, offset = 2}, - b]) - - (* TODO We lose some really useful information, like eg. inferred parameters, *) - (* which we do have in the actual items (L.Decl, L.Exp, etc) *) - (* but not when we do a lookup into the Env *) - (* TODO Rename? *) - fun printGoodPart env f span = - (case f of - Exp (L.EPrim p, _) => - let - val rendered = formatTypeBox ( Prim.p_t p - , P.PD.string (case p of - Prim.Int _ => "int" - | Prim.Float _ => "float" - | Prim.String _ => "string" - | Prim.Char _ => "char")) - in - case p of - Prim.String (_, str) => - if Substring.foldl (fn (c, acc) => acc andalso c = #" ") true (Substring.full str) - then NONE - else SOME rendered - | _ => SOME (rendered) - end - | Exp (L.ERel n, _) => - SOME ((let val found = E.lookupERel env n - in - formatTypeBox ( P.PD.string (#1 found) - , ElabPrint.p_con env (#2 found)) - end) - handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) - | Exp (L.ENamed n, span) => - ((let - val found = E.lookupENamed env n - val rendered = formatTypeBox ( P.PD.string (#1 found) - , ElabPrint.p_con env (#2 found)) - (* val () = if #1 found = "body" *) - (* then Print.eprint (ElabPrint.p_con env (#2 found)) *) - (* else () *) - in - (* case #2 found of *) - (* (L.TFun ((L.CUnit, _), (c, _)), _) => *) - (* (if isXmlTag env c *) - (* then SOME (P.box [ P.PD.string "<" *) - (* , P.PD.string ( #1 found) *) - (* , P.PD.string ">" *) - (* ]) *) - (* else SOME rendered) *) - (* | _ => *) SOME rendered - end) - handle E.UnboundNamed _ => SOME (P.PD.string ("UNBOUND_NAMED" ^ Int.toString n))) - | Exp (L.EAbs (varName, domain, _, _), _) => - if isPosIn fileName row col (#2 domain) - then - SOME (formatTypeBox ( P.PD.string varName - , ElabPrint.p_con env domain) - ) - else NONE - | Exp (L.EField (e, c, {field, ...}), loc) => - SOME (formatTypeBox ( P.box [ElabPrint.p_exp env e, - P.PD.string ".", - ElabPrint.p_con env c] - , ElabPrint.p_con env field)) - | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) - , ms (* names of submodules - possibly none *) - , x (* identifier *)), loc) => - (let - val (m1name, m1sgn) = E.lookupStrNamed env m1 - val (str, sgn) = foldl (fn (m, (str, sgn)) => - case E.projectStr env {sgn = sgn, str = str, field = m} of - NONE => raise Fail ("Couldn't find Structure: " ^ m) - | SOME sgn => ((L.StrProj (str, m), loc), sgn)) - ((L.StrVar m1, loc), m1sgn) - ms - val t = case E.projectVal env {sgn = sgn, str = str, field = x} of - NONE => raise Fail ("Couldn't find identifier: " ^ x) - | SOME t => t - in - case (m1name, x) of - (* Stripping these because XML desugaring adds these with small spans and crowd out the stuff you want to see *) - ("Basis", "cdata") => NONE - | ("Top", "txt") => NONE - | ("Basis", "join") => NONE - | ("Basis", "bind") => NONE - | ("Basis", "sql_subset") => NONE - | ("Basis", "sql_subset_all") => NONE - | ("Basis", "sql_query") => NONE - | ("Basis", "sql_query1") => NONE - | ("Basis", "sql_eq") => NONE - | ("Basis", "sql_inner_join") => NONE - (* | ("Basis", "sql_field") => NONE *) - | ("Basis", "sql_binary") => NONE - | _ => - SOME (formatTypeBox ( P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) - , ElabPrint.p_con env t)) - end - handle E.UnboundNamed _ => SOME (P.PD.string ("Module not found: " ^ Int.toString m1))) - | Exp (L.ELet (edecls, _, _), _) => - let - val found = List.mapPartial - (fn (edecl, loc) => - if isPosIn fileName row col loc - then - case edecl of - L.EDVal (pat, _, _) => printPat env pat - | L.EDValRec ((x, c, _) :: _) => - SOME (formatTypeBox ( P.PD.string x - , ElabPrint.p_con env c)) - | _ => NONE - else NONE) - edecls - in - if List.length found > 0 - then SOME (List.hd found) - else NONE - end - | Exp (L.ECase (_, pats, _), _) => - (case List.find (fn ((pat', loc), exp) => isPosIn fileName row col loc) pats of - NONE => NONE - | SOME (pat, _) => printPat env pat) - | Exp e => NONE - | Kind k => NONE - | Con c => NONE - | Sgn_item si => NONE - | Sgn s => NONE - | Str s => NONE - | Decl (L.DVal (x, _, con, _), _) => - SOME (formatTypeBox ( P.PD.string x - , ElabPrint.p_con env con )) - | Decl (L.DValRec decls, _) => - (* valrecs don't have nice spans per declaration so we find the *) - (* declaration for which the con starts closest *) - let - val res = - List.foldl (fn (decl, accO) => - let - val distanceFromRow = Int.abs (#line (#first (#2 (#3 decl))) - row) - val accDistanceFromRow = case accO of - NONE => Option.getOpt (Int.maxInt, 99999) - | SOME acc => Int.abs (#line (#first (#2 (#3 acc))) - row) - in - if distanceFromRow < accDistanceFromRow andalso distanceFromRow <= 1 - then SOME decl - else accO - end) - NONE - decls - in - case res of - NONE => NONE - | SOME (x, _, con, _) => - SOME (formatTypeBox ( P.PD.string x - , ElabPrint.p_con env con)) - end - | Decl d => NONE - ) +datatype foundInEnv = FoundStr of (string * Elab.sgn) + | FoundCon of (string * Elab.kind) + | FoundExp of (string * Elab.con) - fun add (env: ElabEnv.env) (item: item) (span: ErrorMsg.span) (acc: { smallest : { span : ErrorMsg.span - , item : item - , env : ElabEnv.env } - , smallestgoodpart : { span : ErrorMsg.span - , desc : P.PD.pp_desc - , env : ElabEnv.env - , item : item - } option - } - ) = - if not (isPosIn fileName row col span) - then - acc - else - let - val smallest = - if isSmallerThan span (#span (#smallest acc)) - then {span = span, item = item, env = env} - else #smallest acc - val smallestgoodpart = - case #smallestgoodpart acc of - NONE => - (case printGoodPart env item span of - NONE => NONE - | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) - | SOME (prev as {desc = desc', span = span', env = env', item = item'}) => - if - isSmallerThan span span' - then - (case printGoodPart env item span of - NONE => SOME prev - | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) - else SOME prev - in - {smallest = smallest, smallestgoodpart = smallestgoodpart} - end +fun getNameOfFoundInEnv (f: foundInEnv) = + case f of + FoundStr (x, _) => x + | FoundCon (x, _) => x + | FoundExp (x, _) => x - (* Look for item at input position *) - (* We're looking for two things simultaneously: *) - (* 1. The "smallest" part, ie. the one of which the source span is the smallest *) - (* 2. The "smallestgoodpart" part, ie. the one of which the source span is the smallest AND has a special case in printGoodPart *) - (* If we end up with a smallestgoodpart, we'll show that one since that one is probably more useful *) - (* TODO source spans of XML and SQL sources are weird and you end *) - (* up with eg: a span from eg 1-5 and another from 2-6, makes no sense? *) - (* That's one of the reasons why we're searching for the two things mentioned above *) - val result = - U.Decl.foldB - { kind = fn (env, (k, span), acc) => add env (Kind (k, span)) span acc, - con = fn (env, (k, span), acc) => add env (Con (k, span)) span acc, - exp = fn (env, (k, span), acc) => add env (Exp (k, span)) span acc, - sgn_item = fn (env, (k, span), acc) => add env (Sgn_item (k, span)) span acc, - sgn = fn (env, (k, span), acc) => add env (Sgn (k, span)) span acc, - str = fn (env, (k, span), acc) => add env (Str (k, span)) span acc, - decl = fn (env, (k, span), acc) => add env (Decl (k, span)) span acc, - bind = fn (env, binder) => - case binder of - U.Decl.RelK x => E.pushKRel env x - | U.Decl.RelC (x, k) => E.pushCRel env x k - | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co - | U.Decl.RelE (x, c) => E.pushERel env x c - | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) - | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) - | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) - } - env - { smallestgoodpart = NONE - , smallest = { item = Str (str, { file = fileName - , first = { line = 0, char = 0} - , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} }) - , span = { file = fileName - , first = { line = 0, char = 0} - , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} } - , env = env } - } - ( L.DStr (Compiler.moduleOf "fileName", 0, (L.SgnError, ErrorMsg.dummySpan), (str, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos})) - , {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) +fun filterSgiItems (items: Elab.sgn_item list) : foundInEnv list = + let + fun mapF item = + case item of + (Elab.SgiVal (name, _, c), _) => [FoundExp (name, c)] + | (Elab.SgiCon (name, _, k, _), _) => [FoundCon (name, k)] + | (Elab.SgiDatatype ds, loc) => + List.concat (List.map (fn (dtx, i, _, cs) => + FoundExp (dtx, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs) ds) + | (Elab.SgiDatatypeImp (x, i, _, _, _, _, cs), loc) => + FoundExp (x, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs + | (Elab.SgiStr (_, name, _, sgn), _) => + [FoundStr (name, sgn)] + | (Elab.SgiSgn (name, _, sgn), _) => + [FoundStr (name, sgn)] + | _ => [] + in + List.concat (List.map mapF items) + end + +fun resolvePrefixes + (env: ElabEnv.env) + (prefixes: string list) + (items : foundInEnv list) + : foundInEnv list + = + case prefixes of + [] => items + | first :: rest => + (case List.find (fn item => getNameOfFoundInEnv item = first) items of + NONE => [] + | SOME (FoundStr (name, sgn)) => (case ElabEnv.hnormSgn env sgn of + (Elab.SgnConst sgis, _) => resolvePrefixes env rest (filterSgiItems sgis) + | _ => []) + | SOME (FoundExp (name, c)) => + let + val fields = case ElabOps.reduceCon env c of + (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_) => + fields + | ( ( Elab.CApp + ( ( (Elab.CApp + ( ( Elab.CModProj (_, _, "sql_table") , l4_) + , ( Elab.CRecord (_, fields) , l3_))) + , l2_) + , _)) + , l1_) => fields + | _ => [] + val items = + List.mapPartial (fn (c1, c2) => case c1 of + (Elab.CName fieldName, _) => SOME (FoundExp (fieldName, c2)) + | _ => NONE) fields + in + resolvePrefixes env rest items + end + | SOME (FoundCon (_, _)) => []) + + +fun findStringInEnv' (env: ElabEnv.env) (preferCon: bool) (str: string): (string (* prefix *) * foundInEnv option) = + let + val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) + val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) + ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) + @ List.map FoundCon (ElabEnv.dumpCs env) + @ List.map FoundExp (ElabEnv.dumpEs env)) + val query = List.last splitted + val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) + in + (prefix, List.find (fn i => getNameOfFoundInEnv i = query) afterResolve) + end + +fun matchStringInEnv' (env: ElabEnv.env) (str: string): (string (* prefix *) * foundInEnv list) = + let + val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) + val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) + ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) + @ List.map FoundCon (ElabEnv.dumpCs env) + @ List.map FoundExp (ElabEnv.dumpEs env)) + val query = List.last splitted + val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) + in + (prefix, List.filter (fn i => String.isPrefix query (getNameOfFoundInEnv i)) afterResolve) + end + +fun getDesc item = + case item of + Kind (_, s) => "Kind " ^ ErrorMsg.spanToString s + | Con (_, s) => "Con " ^ ErrorMsg.spanToString s + | Exp (_, s) => "Exp " ^ ErrorMsg.spanToString s + | Sgn_item (_, s) => "Sgn_item " ^ ErrorMsg.spanToString s + | Sgn (_, s) => "Sgn " ^ ErrorMsg.spanToString s + | Str (_, s) => "Str " ^ ErrorMsg.spanToString s + | Decl (_, s) => "Decl " ^ ErrorMsg.spanToString s + +fun matchStringInEnv env str fileName pos query: (ElabEnv.env * string (* prefix *) * foundInEnv list) = + let + val {item = _, env} = findSmallestSpan env str fileName pos + val (prefix, matches) = matchStringInEnv' env query + in + (env, prefix, matches) + end + +fun findStringInEnv env str fileName pos (query: string): (ElabEnv.env * string (* prefix *) * foundInEnv option) = + let + val {item, env} = findSmallestSpan env str fileName pos + val env = case item of + Exp (L.ECase _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp (L.ELet _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp (L.EAbs _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp e => env + | Con _ => #env (findFirstExpAfter env str fileName pos) + | _ => #env (findFirstExpAfter env str fileName pos) + val preferCon = case item of Con _ => true + | _ => false + val (prefix, found) = findStringInEnv' env preferCon query in - result + (env, prefix, found) end end diff --git a/src/lsp.sml b/src/lsp.sml index 856b7ab8..e29589c2 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,7 +1,8 @@ -structure C = Compiler - structure Lsp :> LSP = struct +structure C = Compiler +structure P = Print + val debug = LspSpec.debug structure SK = struct @@ -317,6 +318,35 @@ fun ppToString (pp: Print.PD.pp_desc) (width: int): string = res end +fun getStringAtCursor + (stopAtCursor: bool) + (text: string) + (pos: LspSpec.position) + : string + = + let + val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full text), #line pos) + val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":" + , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] + val lineUntilCursor = Substring.slice (line, 0, SOME (#character pos)) + val beforeCursor = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilCursor) + val afterCursor = if stopAtCursor + then "" + else let + val lineAfterCursor = Substring.slice (line, #character pos, NONE) + in + Substring.string (Substring.takel (fn c => not (List.exists (fn c' => c = c') (#"." :: chars))) lineAfterCursor) + end + in + beforeCursor ^ afterCursor + end + +fun formatTypeBox (a: P.PD.pp_desc, b: P.PD.pp_desc) = + P.PD.hvBox (P.PD.PPS.Rel 0, [a, + P.PD.string ": ", + P.PD.break {nsp = 0, offset = 2}, + b]) + fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec.result = let val fileName = #path (#uri (#textDocument p)) @@ -326,177 +356,27 @@ fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec. NONE => LspSpec.Success NONE | SOME s => let + val searchString = getStringAtCursor false (#text s) (#position p) val env = #envBeforeThisModule s val decls = #decls s val loc = #position p - val result = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line loc + 1 - , character = #character loc + 1} + val (env, prefix, found) = GetInfo.findStringInEnv env (Elab.StrConst decls) fileName { line = #line loc + 1 + , char = #character loc + 1} searchString in - case #smallestgoodpart result of + case found of NONE => LspSpec.Success NONE - | SOME {desc = desc, ...} => - LspSpec.Success (SOME {contents = ppToString desc 50}) + | SOME f => + let + val desc = case f of + GetInfo.FoundStr (x, (_, sgn)) => formatTypeBox (P.PD.string (prefix ^ x), P.PD.string "module") + | GetInfo.FoundCon (x, kind) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_kind env kind) + | GetInfo.FoundExp (x, con) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_con env con) + in + LspSpec.Success (SOME {contents = ppToString desc 50}) + end end end -fun getCompletionsFromFields (env: ElabEnv.env) (prefix: string) (searchStr: string) (fields: (Elab.con * Elab.con) list): LspSpec.completionItem list = - let - fun mapF (c1, c2) = - case c1 of - (Elab.CName fieldName, _) => - if String.isPrefix searchStr fieldName - then SOME { label = prefix ^ fieldName - , kind = LspSpec.Field - , detail = ppToString (ElabPrint.p_con env c2) 200 - } - else NONE - | _ => NONE - in - List.mapPartial mapF fields - end - -fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (searchStr: string) (items: Elab.sgn_item list): LspSpec.completionItem list = - let - fun mapF item = - case item of - (Elab.SgiVal (name, _, con), _) => - if String.isPrefix searchStr name - then [{ label = prefix ^ name - , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 200 - }] - else [] - | (Elab.SgiCon (name, _, _, con), _) => - if String.isPrefix searchStr name - then [{ label = prefix ^ name - , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 200 - }] - else [] - | (Elab.SgiDatatype cs, _) => - (List.concat - (List.map (fn (constr as (dtName, n, xs, constrs)) => - (* Copied from elab_print *) - let - val k = (Elab.KType, ErrorMsg.dummySpan) - val env = ElabEnv.pushCNamedAs env dtName n k NONE - val env = List.foldl (fn (x, env) => ElabEnv.pushCRel env x k) env xs - val typeVarsString = List.foldl (fn (x, acc) => acc ^ " " ^ x) "" xs - in - List.mapPartial (fn (constrName, _, conO) => - if String.isPrefix searchStr constrName - then SOME { label = prefix ^ constrName - , kind = LspSpec.Function - , detail = case conO of - NONE => dtName ^ typeVarsString - | SOME con => ppToString (ElabPrint.p_con env con) 200 ^ " -> " ^ dtName ^ typeVarsString - } - else NONE) constrs - end) - cs)) - | (Elab.SgiDatatypeImp _, _) => - (* TODO ??? no idea what this is *) - [] - | (Elab.SgiStr (_, name, _, _), _) => - if String.isPrefix searchStr name - then [{ label = prefix ^ name - , kind = LspSpec.Module - , detail = "" - }] - else [] - | (Elab.SgiClass (name, _, _, con), _) => - if String.isPrefix searchStr name - then [{ label = prefix ^ name - , kind = LspSpec.Class - , detail = ppToString (ElabPrint.p_con env con) 200 - }] - else [] - | _ => [] - in - List.concat (List.map mapF items) - end - -(* TODO TOCHECK look at con's to specify "kind" more accurately *) -fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completionItem list = - let - val splitted = Substring.fields (fn c => c = #".") (Substring.full str) - in - case splitted of - (_ :: []) => - if str = "" - then [] - else - let - val matchingEs = ElabEnv.matchEByPrefix env str (* function params, let bindings and top-level bindings. Should we discern between Rel and Named? *) - val expressionCompletions = List.map (fn (name,con) => - { label = name - , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 200 - }) matchingEs - val matchingStrs = ElabEnv.matchStrByPrefix env str - val structureCompletions = List.map (fn (name,(_,sgn)) => - { label = name - , kind = LspSpec.Module - , detail = "" - }) matchingStrs - val matchingCons = ElabEnv.matchCByPrefix env str - val conCompletions = List.map (fn (name,kind) => - { label = name - , kind = LspSpec.Constructor (* TODO probably wrong... *) - , detail = ppToString (ElabPrint.p_kind env kind) 200 - }) matchingCons - in - expressionCompletions @ structureCompletions @ conCompletions - end - | (r :: str :: []) => - if Char.isUpper (Substring.sub (r, 0)) - then - (* Completing STRUCTURE *) - let - (* TODO PERF SMALL: first match and then equal is not perfect *) - val foundStrs = ElabEnv.matchStrByPrefix env (Substring.string r) - val filteredStrs = List.filter (fn (name,_) => name = Substring.string r) foundStrs - in - (case List.map (fn (name, (i, sgn)) => (name, ElabEnv.hnormSgn env sgn)) filteredStrs of - [] => [] - | (name, (Elab.SgnConst sgis, _)) :: _ => - getCompletionsFromSignatureItems env (name ^ ".") (Substring.string str) sgis - | _ => []) - end - else - (* Completing RECORD *) - (* TODO TOCHECK is it correct to first try RelE and then NamedE? *) - let - (* TODO PERF SMALL: first match and then equal is not perfect *) - val foundEs = ElabEnv.matchEByPrefix env (Substring.string r) - val filteredEs = List.filter (fn (name,_) => name = Substring.string r) foundEs - val reduced = List.map (fn (name, c) => - (name, ElabOps.reduceCon env c) - handle ex => (name, (Elab.CUnit, ErrorMsg.dummySpan))) - filteredEs - in - case reduced of - [] => [] - | (name, (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_)) :: _ => - getCompletionsFromFields env (name ^ ".") (Substring.string str) fields - | (name, - ( ( Elab.CApp - ( ( (Elab.CApp - ( ( Elab.CModProj (_, _, "sql_table") - , l4_) - , ( Elab.CRecord (_, fields) - , l3_))) - , l2_) - , _)) - , l1_)) :: _ => - getCompletionsFromFields env (name ^ ".") (Substring.string str) fields - | _ => [] - end - | _ => - (* TODO NOTIMPLEMENTED submodules / nested records *) - [] - end - (* TODO IDEA can we use the real parser to figure out what we're typing (exp, con, field, etc) to predict better? *) fun handleCompletion (state: state) (p: LspSpec.completionReq) = let @@ -508,19 +388,20 @@ fun handleCompletion (state: state) (p: LspSpec.completionReq) = | SOME s => let val pos = #position p - val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full (#text s)), #line pos) - val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":" - , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] - val lineUntilPos = Substring.slice (line, 0, SOME (#character pos)) - val searchStr = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilPos) + val searchStr = getStringAtCursor true (#text s) pos val env = #envBeforeThisModule s val decls = #decls s - val getInfoRes = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line pos + 1 - , character = #character pos + 1} - val envOfSmallest = #env (#smallest getInfoRes) + val (env, prefix, foundItems) = GetInfo.matchStringInEnv env (Elab.StrConst decls) fileName { line = #line pos + 1, char = #character pos + 1} searchStr + val completions = List.map + (fn f => case f of + GetInfo.FoundStr (x, _) => {label = prefix ^ x, kind = LspSpec.Module, detail = ""} + | GetInfo.FoundCon (x, k) => {label = prefix ^ x, kind = LspSpec.Constructor, detail = ppToString (ElabPrint.p_kind env k) 200} + | GetInfo.FoundExp (x, c) => {label = prefix ^ x, kind = LspSpec.Value, detail = ppToString (ElabPrint.p_con env c) 200} + ) + foundItems in LspSpec.Success { isIncomplete = false - , items = findMatchingStringInEnv envOfSmallest searchStr} + , items = completions } end end -- cgit v1.2.3 From 9f002a8199a6cba79c3c965731bc9be72506b388 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 10 Jan 2020 21:05:30 +0100 Subject: Change findSmallestSpan to findClosestSpan: faster at 99% of times better --- src/getinfo.sml | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/src/getinfo.sml b/src/getinfo.sml index f18d0638..760a4d90 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -117,15 +117,24 @@ fun findInStr (f: ElabEnv.env -> item (* curr *) -> item (* prev *) -> bool) {item = #1 result, env = #2 result} end -fun findSmallestSpan env str fileName {line = line, char = char} = +fun findClosestSpan env str fileName {line = line, char = char} = let - fun fitsAndIsSmaller (env: ElabEnv.env) (curr: item) (prev: item) = - isPosIn fileName line char (getSpan curr) andalso isSmallerThan (getSpan curr) (getSpan prev) + fun getDistance (i: item): int = + let + val {first, last, file} = getSpan i + in + Int.abs (#char first - char) + + Int.abs (#char last - char) + + Int.abs (#line first - line) * 25 + + Int.abs (#line last - line) * 25 + end + fun isCloser (env: ElabEnv.env) (curr: item) (prev: item) = + getDistance curr < getDistance prev val init = Str (str, { file = fileName , first = { line = 0, char = 0} - , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} }) + , last = { line = 0, char = 0} }) in - findInStr fitsAndIsSmaller init env str fileName {line = line, char = char} + findInStr isCloser init env str fileName {line = line, char = char} end fun findFirstExpAfter env str fileName {line = line, char = char} = @@ -260,7 +269,7 @@ fun getDesc item = fun matchStringInEnv env str fileName pos query: (ElabEnv.env * string (* prefix *) * foundInEnv list) = let - val {item = _, env} = findSmallestSpan env str fileName pos + val {item = _, env} = findClosestSpan env str fileName pos val (prefix, matches) = matchStringInEnv' env query in (env, prefix, matches) @@ -268,7 +277,7 @@ fun matchStringInEnv env str fileName pos query: (ElabEnv.env * string (* prefix fun findStringInEnv env str fileName pos (query: string): (ElabEnv.env * string (* prefix *) * foundInEnv option) = let - val {item, env} = findSmallestSpan env str fileName pos + val {item, env} = findClosestSpan env str fileName pos val env = case item of Exp (L.ECase _, _) => #env (findFirstExpAfter env str fileName pos) | Exp (L.ELet _, _) => #env (findFirstExpAfter env str fileName pos) -- cgit v1.2.3 From 0e6ae5392121aa2163199292963f0f98776b6790 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sat, 11 Jan 2020 21:51:21 +0100 Subject: Fixed review changes: Better foundInEnv naming, correct interpretation of SgiSgn, fix uniq --- src/getinfo.sig | 4 ++-- src/getinfo.sml | 35 +++++++++++++++++------------------ src/lsp.sml | 14 +++++++------- 3 files changed, 26 insertions(+), 27 deletions(-) diff --git a/src/getinfo.sig b/src/getinfo.sig index 663a9a81..63850ef2 100644 --- a/src/getinfo.sig +++ b/src/getinfo.sig @@ -28,8 +28,8 @@ signature GET_INFO = sig datatype foundInEnv = FoundStr of (string * Elab.sgn) - | FoundCon of (string * Elab.kind) - | FoundExp of (string * Elab.con) + | FoundKind of (string * Elab.kind) + | FoundCon of (string * Elab.con) val findStringInEnv: ElabEnv.env -> diff --git a/src/getinfo.sml b/src/getinfo.sml index 760a4d90..6adfbdcf 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -163,32 +163,31 @@ fun findFirstExpAfter env str fileName {line = line, char = char} = datatype foundInEnv = FoundStr of (string * Elab.sgn) - | FoundCon of (string * Elab.kind) - | FoundExp of (string * Elab.con) + | FoundKind of (string * Elab.kind) + | FoundCon of (string * Elab.con) fun getNameOfFoundInEnv (f: foundInEnv) = case f of FoundStr (x, _) => x + | FoundKind (x, _) => x | FoundCon (x, _) => x - | FoundExp (x, _) => x fun filterSgiItems (items: Elab.sgn_item list) : foundInEnv list = let fun mapF item = case item of - (Elab.SgiVal (name, _, c), _) => [FoundExp (name, c)] - | (Elab.SgiCon (name, _, k, _), _) => [FoundCon (name, k)] + (Elab.SgiVal (name, _, c), _) => [FoundCon (name, c)] + | (Elab.SgiCon (name, _, k, _), _) => [FoundKind (name, k)] | (Elab.SgiDatatype ds, loc) => List.concat (List.map (fn (dtx, i, _, cs) => - FoundExp (dtx, (Elab.CNamed i, loc)) - :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs) ds) + FoundCon (dtx, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundCon (x, (Elab.CRel i, loc))) cs) ds) | (Elab.SgiDatatypeImp (x, i, _, _, _, _, cs), loc) => - FoundExp (x, (Elab.CNamed i, loc)) - :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs + FoundCon (x, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundCon (x, (Elab.CRel i, loc))) cs | (Elab.SgiStr (_, name, _, sgn), _) => [FoundStr (name, sgn)] - | (Elab.SgiSgn (name, _, sgn), _) => - [FoundStr (name, sgn)] + | (Elab.SgiSgn (name, _, sgn), _) => [] | _ => [] in List.concat (List.map mapF items) @@ -208,7 +207,7 @@ fun resolvePrefixes | SOME (FoundStr (name, sgn)) => (case ElabEnv.hnormSgn env sgn of (Elab.SgnConst sgis, _) => resolvePrefixes env rest (filterSgiItems sgis) | _ => []) - | SOME (FoundExp (name, c)) => + | SOME (FoundCon (name, c)) => let val fields = case ElabOps.reduceCon env c of (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_) => @@ -223,12 +222,12 @@ fun resolvePrefixes | _ => [] val items = List.mapPartial (fn (c1, c2) => case c1 of - (Elab.CName fieldName, _) => SOME (FoundExp (fieldName, c2)) + (Elab.CName fieldName, _) => SOME (FoundCon (fieldName, c2)) | _ => NONE) fields in resolvePrefixes env rest items end - | SOME (FoundCon (_, _)) => []) + | SOME (FoundKind (_, _)) => []) fun findStringInEnv' (env: ElabEnv.env) (preferCon: bool) (str: string): (string (* prefix *) * foundInEnv option) = @@ -236,8 +235,8 @@ fun findStringInEnv' (env: ElabEnv.env) (preferCon: bool) (str: string): (string val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) - @ List.map FoundCon (ElabEnv.dumpCs env) - @ List.map FoundExp (ElabEnv.dumpEs env)) + @ List.map FoundKind (ElabEnv.dumpCs env) + @ List.map FoundCon (ElabEnv.dumpEs env)) val query = List.last splitted val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) in @@ -249,8 +248,8 @@ fun matchStringInEnv' (env: ElabEnv.env) (str: string): (string (* prefix *) * f val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) - @ List.map FoundCon (ElabEnv.dumpCs env) - @ List.map FoundExp (ElabEnv.dumpEs env)) + @ List.map FoundKind (ElabEnv.dumpCs env) + @ List.map FoundCon (ElabEnv.dumpEs env)) val query = List.last splitted val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) in diff --git a/src/lsp.sml b/src/lsp.sml index e29589c2..c99a6f2e 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -257,10 +257,10 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef end end -fun uniq (comp: 'b -> 'b -> bool) (bs: 'b list) = +fun uniq (eq: 'b -> 'b -> bool) (bs: 'b list) = case bs of [] => [] - | (l as b :: bs') => b :: uniq comp (List.filter (comp b) bs') + | (l as b :: bs') => b :: uniq eq (List.filter (fn a => not (eq a b)) bs') fun elabFileAndSendDiags (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri): unit = let @@ -326,7 +326,7 @@ fun getStringAtCursor = let val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full text), #line pos) - val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":" + val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":", #"@" , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] val lineUntilCursor = Substring.slice (line, 0, SOME (#character pos)) val beforeCursor = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilCursor) @@ -369,8 +369,8 @@ fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec. let val desc = case f of GetInfo.FoundStr (x, (_, sgn)) => formatTypeBox (P.PD.string (prefix ^ x), P.PD.string "module") - | GetInfo.FoundCon (x, kind) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_kind env kind) - | GetInfo.FoundExp (x, con) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_con env con) + | GetInfo.FoundKind (x, kind) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_kind env kind) + | GetInfo.FoundCon (x, con) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_con env con) in LspSpec.Success (SOME {contents = ppToString desc 50}) end @@ -395,8 +395,8 @@ fun handleCompletion (state: state) (p: LspSpec.completionReq) = val completions = List.map (fn f => case f of GetInfo.FoundStr (x, _) => {label = prefix ^ x, kind = LspSpec.Module, detail = ""} - | GetInfo.FoundCon (x, k) => {label = prefix ^ x, kind = LspSpec.Constructor, detail = ppToString (ElabPrint.p_kind env k) 200} - | GetInfo.FoundExp (x, c) => {label = prefix ^ x, kind = LspSpec.Value, detail = ppToString (ElabPrint.p_con env c) 200} + | GetInfo.FoundKind (x, k) => {label = prefix ^ x, kind = LspSpec.Constructor, detail = ppToString (ElabPrint.p_kind env k) 200} + | GetInfo.FoundCon (x, c) => {label = prefix ^ x, kind = LspSpec.Value, detail = ppToString (ElabPrint.p_con env c) 200} ) foundItems in -- cgit v1.2.3 From aee578b0e409738d3e5e745466f631fe04f8fdb2 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sun, 12 Jan 2020 18:52:13 +0100 Subject: LSP: Improved handling of datatypes from signatures --- src/getinfo.sml | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/src/getinfo.sml b/src/getinfo.sml index 6adfbdcf..2b27b8df 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -174,17 +174,28 @@ fun getNameOfFoundInEnv (f: foundInEnv) = fun filterSgiItems (items: Elab.sgn_item list) : foundInEnv list = let + fun processDatatype loc (dtx, i, ks, cs) = + let + val k' = (Elab.KType, loc) + val k = FoundKind (dtx, foldl (fn (_, k) => (Elab.KArrow (k', k), loc)) k' ks) + val foundCs = List.map (fn (x, j, co) => + let + val c = case co of + NONE => (Elab.CNamed i, loc) + | SOME c => (Elab.TFun (c, (Elab.CNamed i, loc)), loc) + in + FoundCon (x, c) + end) cs + in + k :: foundCs + end fun mapF item = case item of (Elab.SgiVal (name, _, c), _) => [FoundCon (name, c)] | (Elab.SgiCon (name, _, k, _), _) => [FoundKind (name, k)] | (Elab.SgiDatatype ds, loc) => - List.concat (List.map (fn (dtx, i, _, cs) => - FoundCon (dtx, (Elab.CNamed i, loc)) - :: List.map (fn (x, i, _) => FoundCon (x, (Elab.CRel i, loc))) cs) ds) - | (Elab.SgiDatatypeImp (x, i, _, _, _, _, cs), loc) => - FoundCon (x, (Elab.CNamed i, loc)) - :: List.map (fn (x, i, _) => FoundCon (x, (Elab.CRel i, loc))) cs + List.concat (List.map (processDatatype loc) ds) + | (Elab.SgiDatatypeImp (dtx, i, _, ks, _, _, cs), loc) => processDatatype loc (dtx, i, ks, cs) | (Elab.SgiStr (_, name, _, sgn), _) => [FoundStr (name, sgn)] | (Elab.SgiSgn (name, _, sgn), _) => [] -- cgit v1.2.3 From 483115ee395c26ba7b52ac84757c8a1de4fe2d33 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 15 Jan 2020 00:18:07 +0100 Subject: Added some documentation for the LSP server to the manual --- doc/manual.tex | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index 64fe0f24..779db408 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -244,6 +244,21 @@ urweb daemon restart \end{verbatim} Communication happens via a UNIX domain socket in file \cd{.urweb\_daemon} in the working directory. +Bundled with the compiler is an LSP or Language Server Protocol server. This is a program that allows various editors to request information about Ur/Web code via a standardized messaging protocol. The Ur/Web LSP server currently provides basic implementations for autocompletion, hover and compiler errors. The server is started by running +\begin{verbatim} +urweb -startLspServer +\end{verbatim} +Currently there are no prebuilt editor plugins to register this server with your editor of choice but it should be fairly simple to do so. For example in Emacs using the lsp-mode, all you need to make this work is the following configuration (assuming you use the urweb-mode bundled with the compiler): +\begin{verbatim} +(require 'lsp) +(setq lsp-language-id-configuration '((urweb-mode . "urweb"))) +(lsp-register-client + (make-lsp-client :new-connection (lsp-stdio-connection '("urweb" "-startLspServer")) + :major-modes '(urweb-mode) + :server-id 'urweb-lsp)) +\end{verbatim} +Note that to keep the server responsive we don't compile Ur/Web code in the traditional way. Rather, we use only the .urs files (or if applicable .ur files that only contain valid .urs statements) for modules that are not currently being edited. That's why the LSP server requires .urs files for all of your modules. + \medskip Some other command-line parameters are accepted: -- cgit v1.2.3