First actually working version of LSP

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