Added initial version of lsp

6 files changed, 457 insertions, 0 deletions

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 <http://www.gnu.org/licenses/>.
+******************************************************************************)
+
+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 <file> and exit"),
               ("getInfo", ONE ("<file:row:col>", getInfo),
                     SOME "print info of expression at <file:row:col> and exit"),
+              ("startLspServer", ZERO Lsp.startServer, SOME "Start Language Server Protocol server"),
               ("noEmacs", set_true Demo.noEmacs,
                     NONE),
               ("limit", TWO ("<class>", "<num>", 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