Refactored LSP into few modules

1 files 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