Added background threads

4 files changed, 144 insertions, 45 deletions

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