|
| 1 | +(* cSpell:words cmdliner signum Open_wronly Open_creat fprintf kdprintf *) |
| 2 | + |
| 3 | +open Cmdliner |
| 4 | + |
| 5 | +let traceln_mutex = Mutex.create () |
| 6 | + |
| 7 | +let transport_of_args tr_stdio tr_socket = |
| 8 | + let open Tlapm_lsp_lib.Server in |
| 9 | + match (tr_stdio, tr_socket) with |
| 10 | + | true, None -> Ok Stdio |
| 11 | + | false, Some port -> Ok (Socket port) |
| 12 | + | _ -> Error "Exactly one of transports has to be specified." |
| 13 | + |
| 14 | +let run transport log_to log_io = |
| 15 | + Printexc.record_backtrace true; |
| 16 | + let main_fun (env : Eio_unix.Stdenv.base) = |
| 17 | + let main_switch _sw = |
| 18 | + let stop_promise, stop_resolver = Eio.Std.Promise.create () in |
| 19 | + let handle_signal (_signum : int) = |
| 20 | + Eio.Std.Promise.resolve stop_resolver "Stopping on SigINT" |
| 21 | + in |
| 22 | + Sys.set_signal Sys.sigint (Signal_handle handle_signal); |
| 23 | + Tlapm_lsp_lib.Server.run transport log_io env stop_promise |
| 24 | + in |
| 25 | + let with_log_stderr () = Eio.Switch.run main_switch in |
| 26 | + let with_log_file log_file = |
| 27 | + let with_log_chan log_chan = |
| 28 | + (* This is mostly a copy of default_traceln from eio/core/debug.ml, |
| 29 | + just modified to take a specific out channel instead of stderr. *) |
| 30 | + let traceln_impl ?__POS__:pos fmt = |
| 31 | + let k go = |
| 32 | + let b = Buffer.create 512 in |
| 33 | + let f = Format.formatter_of_buffer b in |
| 34 | + go f; |
| 35 | + Option.iter |
| 36 | + (fun (file, line, _, _) -> Format.fprintf f " [%s:%d]" file line) |
| 37 | + pos; |
| 38 | + Format.pp_close_box f (); |
| 39 | + Format.pp_print_flush f (); |
| 40 | + let msg = Buffer.contents b in |
| 41 | + let lines = String.split_on_char '\n' msg in |
| 42 | + Mutex.lock traceln_mutex; |
| 43 | + Fun.protect ~finally:(fun () -> Mutex.unlock traceln_mutex) |
| 44 | + @@ fun () -> |
| 45 | + List.iter (Printf.fprintf log_chan "+%s\n") lines; |
| 46 | + flush log_chan |
| 47 | + in |
| 48 | + Format.kdprintf k ("@[" ^^ fmt) |
| 49 | + in |
| 50 | + let traceln_bnd = { Eio.Debug.traceln = traceln_impl } in |
| 51 | + let debug = Eio.Stdenv.debug env in |
| 52 | + Eio.Fiber.with_binding debug#traceln traceln_bnd (fun _ -> |
| 53 | + Format.pp_set_formatter_out_channel Format.err_formatter log_chan; |
| 54 | + Eio.Switch.run main_switch) |
| 55 | + in |
| 56 | + Out_channel.with_open_gen |
| 57 | + [ Open_append; Open_wronly; Open_creat ] |
| 58 | + 0o644 log_file with_log_chan |
| 59 | + in |
| 60 | + match log_to with |
| 61 | + | None -> with_log_stderr () |
| 62 | + | Some log_file -> with_log_file log_file |
| 63 | + in |
| 64 | + Eio_main.run main_fun |
| 65 | + |
| 66 | +module Cli = struct |
| 67 | + let arg_stdio = |
| 68 | + let doc = "Run LSP over StdIO." in |
| 69 | + let info = Arg.info [ "stdio" ] ~docv:"BOOL" ~doc in |
| 70 | + Arg.value (Arg.flag info) |
| 71 | + |
| 72 | + let arg_socket = |
| 73 | + let doc = "Run LSP over TCP, use the specified port." in |
| 74 | + let info = Arg.info [ "socket"; "port" ] ~docv:"NUM" ~doc in |
| 75 | + Arg.value (Arg.opt (Arg.some Arg.int) None info) |
| 76 | + |
| 77 | + let arg_log_to = |
| 78 | + let doc = "Log all to the specified file instead of StdErr." in |
| 79 | + let info = Arg.info [ "log-to" ] ~docv:"FILE" ~doc in |
| 80 | + Arg.value (Arg.opt (Arg.some Arg.string) None info) |
| 81 | + |
| 82 | + let arg_log_io = |
| 83 | + let doc = "Log protocol's IO." in |
| 84 | + let info = Arg.info [ "log-io" ] ~docv:"BOOL" ~doc in |
| 85 | + Arg.value (Arg.flag info) |
| 86 | + |
| 87 | + let term () = |
| 88 | + let combine tr_stdio tr_socket log_to log_io = |
| 89 | + match transport_of_args tr_stdio tr_socket with |
| 90 | + | Ok transport -> `Ok (run transport log_to log_io) |
| 91 | + | Error err -> `Error (false, err) |
| 92 | + in |
| 93 | + Term.(const combine $ arg_stdio $ arg_socket $ arg_log_to $ arg_log_io) |
| 94 | + |
| 95 | + let name = "tlapm_lsp" |
| 96 | + let doc = "LSP interface for TLAPS." |
| 97 | + |
| 98 | + let man = |
| 99 | + [ |
| 100 | + `S Manpage.s_description; |
| 101 | + `P "tlapm_lsp allows LSP based IDEs to access the prover functions."; |
| 102 | + `S Manpage.s_see_also; |
| 103 | + `P "The TLAPM code repository: https://github.com/tlaplus/tlapm"; |
| 104 | + ] |
| 105 | + |
| 106 | + let main () = |
| 107 | + let info = Cmd.info ~doc ~man name in |
| 108 | + Cmd.v info (Term.ret (term ())) |> Cmd.eval |> Stdlib.exit |
| 109 | +end |
| 110 | + |
| 111 | +let () = Cli.main () |
0 commit comments