Basic language server implementation

.github/workflows/Test.yml

@@ -12,7 +12,7 @@ jobs:
       - uses: ocaml/setup-ocaml@v2
         with:
           ocaml-compiler: 5.1.1
-      - run: opam install dune
+      - run: opam install dune yojson uri
       - run: opam exec -- dune build
       - run: opam exec -- dune install
       - run: eval $(opam env) && ./test.sh dbl ./test/test_suite

src/InterpLib/Error.ml

@@ -24,7 +24,7 @@ let color_printer_generator color s =
   then s
   else TextRangePrinting.color_string color s
 
-let report ?pos ~cls msg =
+let report_to_stderr ?pos ~cls msg =
   let module Color = TextRangePrinting in
   let name, color =
     match cls with
@@ -56,6 +56,12 @@ let report ?pos ~cls msg =
   | None, _ ->
     Printf.eprintf "%s: %s\n" name msg
 
+let report_impl = ref report_to_stderr
+
+let set_report_function f = report_impl := f
+
+let report ?pos ~cls msg = !report_impl ?pos ~cls msg
+
 let assert_no_error () =
   if !err_counter <> 0 then
     raise Fatal_error

src/InterpLib/Error.mli

@@ -24,6 +24,11 @@ type error_class =
 (** Report the error *)
 val report : ?pos:Position.t -> cls:error_class -> string -> unit
 
+(** Set a custom function to intercept reports.
+  All reports will be made to this function. Used by the language server. *)
+val set_report_function :
+  (?pos:Position.t -> cls:error_class -> string -> unit) -> unit
+
 (** Abort compilation if any error was reported. Should be called at the end
   of each phase. *)
 val assert_no_error : unit -> unit

src/Lsp/Connection.ml

@@ -0,0 +1,69 @@
+(* This file is part of DBL, released under MIT license.
+ * See LICENSE for details.
+ *)
+
+(** Base HTTP-like protocol *)
+
+(** The JSON-RPC messages are sent over this simple protocol.
+  It consists of a header and a content part, separated by "\r\n":
+    header1: value1\r\n
+    header2: value2\r\n
+    \r\n
+    [JSON-RPC message]
+  The only recognized headers are Content-Length and Content-Type
+  and there is really one possible value for Content-Type,
+  so we don't care about that. *)
+
+open In_channel
+open Out_channel
+
+exception Connection_error of string
+
+type headers =
+  { content_length: int option
+  ; content_type: string option
+  }
+
+let parse_header headers line =
+  match String.split_on_char ':' line |> List.map String.trim with
+  | ["Content-Length"; value] -> begin
+    match int_of_string_opt value with
+    | None -> raise (Connection_error ("Invalid Content-Length value: " ^ line))
+    | Some len -> { headers with content_length = Some len }
+    end
+  | ["Content-Type"; value] -> { headers with content_type = Some value }
+  | _ -> headers
+
+let rec collect_header_lines (ic: in_channel) =
+  match input_line ic with
+  | None -> raise (Connection_error "Unexpected end of input")
+  | Some "\r" -> []
+  | Some line -> line :: collect_header_lines ic
+
+let receive_headers (ic: in_channel) =
+  let headers = collect_header_lines ic in
+  List.fold_left parse_header
+    { content_length = None; content_type = None }
+    headers
+
+let receive_body (ic: in_channel) len =
+  match really_input_string ic len with
+  | None -> raise (Connection_error "Unexpected end of input")
+  | Some body -> body
+
+let receive_string (ic: in_channel) =
+  let headers = receive_headers ic in
+  match headers.content_length with
+  | None -> raise (Connection_error "Missing Content-Length header")
+  | Some len -> receive_body ic len
+
+let output_line (oc: out_channel) message =
+  let line = message ^ "\r\n" in
+  output_string oc line
+
+let send_string (oc: out_channel) message_string =
+  let length = String.length message_string in
+  output_line oc ("Content-Length: " ^ string_of_int length);
+  output_line oc "";
+  output_string oc message_string; flush oc
+

src/Lsp/Connection.mli

@@ -0,0 +1,15 @@
+(* This file is part of DBL, released under MIT license.
+ * See LICENSE for details.
+ *)
+
+(** Base HTTP-like protocol *)
+
+(** An exception indicating a problem with the connection,
+  e.g. unexpected EOF or invalid headers *)
+exception Connection_error of string
+
+(** Receive a message from the client *)
+val receive_string : in_channel -> string
+
+(** Send a message with the specified content to the client *)
+val send_string : out_channel -> string -> unit

src/Lsp/JsonRpc.ml

@@ -0,0 +1,73 @@
+(* This file is part of DBL, released under MIT license.
+ * See LICENSE for details.
+ *)
+
+(** Main loop. Get a message, handle it, send response. *)
+
+open Connection
+open Message
+
+(* ------------------------------------------------------------------------- *)
+(* Auxiliary functions doing type -> json -> string conversion
+  and sending it to the output *)
+
+let send_json state json =
+  let string = Yojson.Safe.to_string json in
+  send_string (State.out_channel state) string
+
+let send_response state response =
+  send_json state (json_of_response response)
+
+let send_message state message =
+  send_json state (json_of_message message)
+
+let send_notification state notification =
+  let message = message_of_notification notification in
+  send_message state message
+
+let send_error state ?id code message =
+  let error = make_response_error ~code ~message () |> Result.error in
+  let response = make_response ?id ~result_or_error:error () in
+  send_response state response
+
+(* ------------------------------------------------------------------------- *)
+(* Main function *)
+
+let rec run state handle_request handle_notification =
+
+  (* Handle messages in a loop *)
+  let rec loop state =
+    let string = receive_string (State.in_channel state) in
+    match message_of_string string with
+    (* There was an error parsing the message *)
+    | Error (code, msg) ->
+      send_error state code msg;
+      loop state
+    (* The message is a notification *)
+    | Ok ({ id = None; _ } as message) -> begin
+      match notification_of_message message with
+      | Ok notification ->
+        let state = handle_notification state notification in
+        loop state
+      (* There was an error interpreting the message as a notification.
+        Because notifications don't get a response, we ignore it
+        (according to the specification). *)
+      | Error _ ->
+        loop state
+      end
+    (* The message is a request *)
+    | Ok ({ id = Some id; _ } as message) -> begin
+      match request_of_message message with
+      | Ok request ->
+        let state, result = handle_request state request in
+        let response = make_response ~id ~result_or_error:result () in
+        send_response state response;
+        loop state
+      (* There was an error interpreting the message as a request *)
+      | Error (code, msg) ->
+        send_error state ~id code msg;
+        loop state
+      end
+
+  in loop state
+

src/Lsp/JsonRpc.mli

@@ -0,0 +1,21 @@
+(* This file is part of DBL, released under MIT license.
+ * See LICENSE for details.
+ *)
+
+(** Main loop. Get a message, handle it, send response. *)
+
+open Message
+
+(** Send a notification to the client *)
+val send_notification : State.t -> server_notification -> unit
+
+(** Main loop of the server. The fuction expects:
+     - the initial state
+     - a handler for requests
+     - a handler for notifications *)
+val run :
+  State.t ->
+  (State.t -> request -> State.t * (server_result, response_error) result) ->
+  (State.t -> client_notification -> State.t) ->
+  'bottom
+