lean2/src/emacs/lean-server.el

437 lines
16 KiB
EmacsLisp
Raw Normal View History

;; -*- lexical-binding: t; -*-
2014-08-14 00:02:49 +00:00
;; Copyright (c) 2014 Microsoft Corporation. All rights reserved.
;; Released under Apache 2.0 license as described in the file LICENSE.
;;
;; Author: Soonho Kong
;;
(require 'cl-lib)
(require 'dash)
2014-08-14 00:02:49 +00:00
(require 'lean-variable)
(require 'lean-cmd)
(require 'lean-info)
(require 'lean-util)
(require 'flycheck)
2014-08-14 00:02:49 +00:00
;; Parameters
;; ==========
(defvar-local lean-server-process-name "lean-server")
(defvar-local lean-server-buffer-name "*lean-server*")
(defvar-local lean-server-trace-buffer-name "*lean-server-trace*")
(defvar-local lean-server-debug-buffer-name "*lean-server-debug*")
(defvar-local lean-server-option "--server")
(defvar-local lean-server-trace-mode nil)
(defvar-local lean-server-debug-mode nil)
;; Log, Trace, Debug Function
;; ==========================
(defun lean-server-output-to-buffer (buffer-name format-string args)
(with-current-buffer
(get-buffer-create buffer-name)
(save-selected-window
(ignore-errors
(select-window (get-buffer-window buffer-name t)))
(goto-char (point-max))
(insert (apply 'format format-string args)))))
2014-08-14 00:02:49 +00:00
(defun lean-server-log (format-string &rest args)
"Display a message at the bottom of the *lean-server* buffer."
(lean-server-output-to-buffer (lean-server-get-buffer)
(concat format-string)
args))
(defun lean-server-trace (format-string &rest args)
"Display a message at the bottom of the *lean-server* buffer."
(message "?\n")
(when lean-server-trace-mode
(message "!\n")
(when lean-global-server-last-time-sent
(let ((time-diff (- (float-time) lean-global-server-last-time-sent)))
(lean-server-output-to-buffer lean-server-trace-buffer-name
"SLEEP %i\n"
`(,(truncate (* 1000 time-diff))))))
(setq lean-global-server-last-time-sent (float-time))
(lean-server-output-to-buffer lean-server-trace-buffer-name
format-string args)))
(defun lean-server-debug (format-string &rest args)
"Display a message at the bottom of the *lean-server-debug* buffer."
(when lean-server-debug-mode
(lean-server-output-to-buffer lean-server-debug-buffer-name
(concat "%s -- " format-string "\n")
(cons (format-time-string "%H:%M:%S:%3N" (current-time))
args))))
(defun lean-server-turn-on-debug-mode ()
(interactive)
(setq-local lean-server-debug-mode t))
(defun lean-server-turn-off-debug-mode ()
(interactive)
(setq-local lean-server-debug-mode nil))
(defun lean-server-toggle-debug-mode ()
(interactive)
(if lean-server-debug-mode
(lean-server-turn-off-debug-mode)
(lean-server-turn-on-debug-mode)))
(defun lean-server-turn-on-trace-mode ()
(interactive)
(setq-local lean-server-trace-mode t))
(defun lean-server-turn-off-trace-mode ()
(interactive)
(setq-local lean-server-trace-mode nil))
(defun lean-server-toggle-trace-mode ()
(interactive)
(if lean-server-trace-mode
(lean-server-turn-off-trace-mode)
(lean-server-turn-on-trace-mode)))
2014-08-14 00:02:49 +00:00
;; How to read data from an async process
;; ======================================
(defconst lean-server-syntax-pattern
2014-09-04 22:30:23 +00:00
`((INFO ,(rx line-start "-- BEGININFO" (* not-newline) line-end)
,(rx line-start (group "-- ENDINFO") line-end))
(SET ,(rx line-start "-- BEGINSET" line-end)
,(rx line-start (group "-- ENDSET") line-end))
(EVAL ,(rx line-start "-- BEGINEVAL" line-end)
,(rx line-start (group "-- ENDEVAL") line-end))
(OPTIONS ,(rx line-start "-- BEGINOPTIONS" line-end)
2014-09-04 22:30:23 +00:00
,(rx line-start (group "-- ENDOPTIONS") line-end))
(SHOW ,(rx line-start "-- BEGINSHOW" line-end)
,(rx line-start (group "-- ENDSHOW") line-end))
(FINDP ,(rx line-start "-- BEGINFINDP" (* not-newline) line-end)
,(rx line-start (group "-- ENDFINDP") line-end))
(ERROR ,(rx line-start "-- " (0+ not-newline) line-end)
,(rx line-start (group "-- ERROR" (0+ not-newline)) line-end)))
"Regular expression pattern for lean-server message syntax")
(defun lean-server-split-buffer (buf-str beg-regex end-regex)
""
(let ((beg (string-match beg-regex buf-str))
(end (string-match end-regex buf-str))
pre body post)
(when (and beg end)
(setq end (match-end 1))
(setq pre (substring-no-properties buf-str 0 beg))
(setq body (substring-no-properties buf-str beg end))
(setq post (substring-no-properties buf-str end))
`(,pre ,body ,post))))
(defun lean-server-check-buffer-and-partition (buf-str)
"Return the status of buffer."
(let (result)
(when buf-str
(cl-loop for (type beg-regex end-regex) in lean-server-syntax-pattern
do (setq partition-result (lean-server-split-buffer buf-str beg-regex end-regex))
if partition-result
return `(,type ,partition-result)))))
2014-08-14 00:02:49 +00:00
(defun lean-server-process-received-message (buf str)
"Process received message from lean-server"
(lean-server-log "%s:\n%s\n"
(propertize "Received Message" 'face 'font-lock-variable-name-face)
str)
(setq lean-global-server-buffer (concat lean-global-server-buffer str)))
2014-08-14 00:02:49 +00:00
(defun lean-server-output-filter (process string)
"Filter function attached to lean-server process"
(lean-server-process-received-message (process-buffer process) string))
2014-08-26 23:21:48 +00:00
(defun lean-server-handle-signal (process event)
"Handle signals for lean-server-process"
(cond
((string-prefix-p "hangup" event)
(lean-server-initialize-global-vars))
((string-prefix-p "killed" event)
2014-08-26 23:21:48 +00:00
(lean-server-initialize-global-vars))))
2014-08-14 00:02:49 +00:00
;; How to create an async process
;; ==============================
2014-08-26 23:21:48 +00:00
(defun lean-server-initialize-global-vars ()
"Initialize lean-server related global variables"
(setq lean-global-server-buffer nil)
(setq lean-global-server-current-file-name nil)
(setq lean-global-server-message-to-process nil)
(setq lean-global-server-last-time-sent nil)
(setq lean-global-async-task-queue nil)
(when (timerp lean-global-retry-timer)
(cancel-timer lean-global-retry-timer))
(setq lean-global-retry-timer nil))
2014-08-26 23:21:48 +00:00
2014-08-14 00:02:49 +00:00
(defun lean-server-create-process ()
"Create lean-server process."
2014-08-21 16:09:54 +00:00
;; (when (buffer-modified-p)
;; (error "Please save the buffer before start lean-server."))
2014-08-14 00:02:49 +00:00
(let ((process-connection-type nil)
(lean-server-process
(start-process lean-server-process-name
lean-server-buffer-name
(lean-get-executable lean-executable-name)
lean-server-option)))
(set-process-coding-system lean-server-process 'utf-8 'utf-8)
(set-process-filter lean-server-process 'lean-server-output-filter)
2014-08-26 23:21:48 +00:00
(set-process-sentinel lean-server-process 'lean-server-handle-signal)
(lean-server-initialize-global-vars)
(setq lean-global-server-process lean-server-process)
2014-08-14 00:02:49 +00:00
lean-server-process))
(defun lean-server-kill-process ()
"Kill lean-server process. Return t if killed, nil if nothing to kill"
(interactive)
(lean-server-initialize-global-vars)
(cond
2014-08-26 23:21:48 +00:00
((and lean-global-server-process
(not (= 0 (process-exit-status lean-global-server-process))))
(setq lean-global-server-process nil) t)
(lean-global-server-process
(when (interactive-p)
(message "lean-server-kill-process: %S killed" lean-global-server-process))
(kill-process lean-global-server-process)
(setq lean-global-server-process nil) t)
2014-08-26 23:21:48 +00:00
(t
(when (interactive-p)
(message "lean-server-kill-process: no process to kill")) nil)))
(defun lean-server-restart-process ()
"Restart lean-server process."
(interactive)
(and (lean-server-kill-process)
(lean-server-create-process)))
2014-08-14 00:02:49 +00:00
(defun lean-server-get-process ()
"Get lean-server process. If needed, create a one."
(cond ((not lean-global-server-process)
(lean-server-create-process))
((not (process-live-p lean-global-server-process))
(when (interactive-p)
(message "lean-server-get-process: %S is not live, kill it"
lean-global-server-process))
(lean-server-restart-process))
(t lean-global-server-process)))
2014-08-14 00:02:49 +00:00
(defun lean-server-get-buffer ()
"Get lean-server buffer."
2014-08-14 00:02:49 +00:00
(process-buffer (lean-server-get-process)))
;; How to send data to an async process
;; ====================================
(defun lean-flush-changed-lines ()
"Flush lean-changed-lines.
Send REPLACE commands to lean-server, reset lean-changed-lines to nil."
(cl-loop for n in lean-changed-lines
do (lean-server-send-cmd-async (lean-cmd-replace n (lean-grab-line n)))
2014-08-14 00:02:49 +00:00
finally (setq lean-changed-lines nil)))
(defun lean-server-check-current-file (&optional file-name)
2014-08-14 00:02:49 +00:00
"Check lean-global-server-current-file-name.
If it's not the same with file-name (default: buffer-file-name), send VISIT cmd."
(let ((current-file-name (or file-name (buffer-file-name))))
2014-08-14 00:02:49 +00:00
(unless (string= lean-global-server-current-file-name
current-file-name)
(lean-server-send-cmd-async (lean-cmd-visit current-file-name)))))
2014-08-14 00:02:49 +00:00
(defun lean-server-before-send-cmd (cmd)
"Operations to perform before sending a command."
2014-08-14 00:02:49 +00:00
(cl-case (lean-cmd-type cmd)
('LOAD (setq lean-global-server-current-file-name
(lean-cmd-load-get-file-name cmd)))
('VISIT (setq lean-global-server-current-file-name
(lean-cmd-visit-get-file-name cmd)))
2014-08-14 00:02:49 +00:00
('REPLACE (lean-server-check-current-file))
('INSERT (lean-server-check-current-file))
('REMOVE (lean-server-check-current-file))
('INFO (lean-flush-changed-lines))
('CHECK ())
('SET ())
('EVAL (lean-server-check-current-file))
('OPTIONS ())
2014-09-04 22:30:23 +00:00
('SHOW (lean-server-check-current-file))
('VALID (lean-server-check-current-file))
('FINDP (lean-server-check-current-file))))
2014-08-14 00:02:49 +00:00
(defun lean-server-after-send-cmd (cmd)
"Operations to perform after sending a command."
2014-08-14 00:02:49 +00:00
(cl-case (lean-cmd-type cmd)
('LOAD ())
('VISIT ())
2014-08-14 00:02:49 +00:00
('REPLACE ())
('INSERT ())
('REMOVE ())
('INFO ())
('CHECK ())
('SET ())
('EVAL ())
('OPTIONS ())
('SHOW ())
2014-09-04 22:30:23 +00:00
('VALID ())
('FINDP ())))
2014-08-14 00:02:49 +00:00
(defun lean-server-send-cmd (cmd)
"Send cmd to lean-server"
2014-08-14 00:02:49 +00:00
(let ((proc (lean-server-get-process))
(string-to-send (concat (lean-cmd-to-string cmd) "\n")))
(lean-server-before-send-cmd cmd)
;; Logging
(lean-server-log "%s:\n%s"
(propertize "Sent Message" 'face 'font-lock-variable-name-face)
string-to-send)
;; Trace
(lean-server-trace
(format "%s" string-to-send))
(process-send-string proc string-to-send)
(lean-server-after-send-cmd cmd)))
(defun lean-server-process-message-with-cont (body type cont)
"Process the message from lean-server and call continuation"
(cl-case type
(INFO
(let ((info-record (lean-server-get-info-record-at-pos body)))
(funcall cont info-record)))
(SET
;; Call cont with string
(funcall cont (lean-set-parse-string body)))
(EVAL
;; Call cont with string
(funcall cont (lean-eval-parse-string body)))
(OPTIONS
;; Call cont with alist of lean-option-records
(funcall cont (lean-options-parse-string body)))
(SHOW
;; Call cont with string
(funcall cont (lean-show-parse-string body)))
(FINDP
;; Call cont with (name * type) list
(funcall cont (lean-findp-parse-string body)))
(ERROR
(lean-server-log "Error detected:\n%s" body))))
(defun lean-server-check-and-process-buffer-with-cont (cont)
"Check server-buffer and process the message with a continuation if it's ready."
(let ((partition-result (lean-server-check-buffer-and-partition
lean-global-server-buffer))
result)
(pcase partition-result
(`(,type (,pre ,body ,post))
(lean-server-log "The following pre-message will be thrown away:")
(lean-server-log "%s" pre)
(setq lean-global-server-buffer post)
(setq result (lean-server-process-message-with-cont body type cont))
2014-09-05 04:04:44 +00:00
`(PROCESSED ,result)))))
(defun lean-server-send-cmd-async (cmd &optional cont)
"Send cmd to lean-server and attach continuation to the queue."
(lean-server-debug "send-cmd-async: %S %S" (lean-cmd-type cmd) (cl-second cmd))
(lean-server-debug "send-cmd-async: queue len = %d" (length lean-global-async-task-queue))
(lean-server-send-cmd cmd)
(when cont
(setq lean-global-async-task-queue (-snoc lean-global-async-task-queue cont))
(lean-server-cancel-retry-timer)
(lean-server-debug "send-cmd-async: added to the queue = %S"
(length lean-global-async-task-queue))
(lean-server-debug "send-cmd-async: call handler")
(lean-server-event-handler)))
(defun lean-server-cancel-retry-timer ()
(when (timerp lean-global-retry-timer)
(cancel-timer lean-global-retry-timer)
(setq lean-global-retry-timer nil)))
2014-09-05 04:04:44 +00:00
(defun lean-server-consume-all-async-tasks ()
(while lean-global-async-task-queue
(accept-process-output (lean-server-get-process) 0 50 t)
(let* ((cont (car lean-global-async-task-queue))
(result (lean-server-check-and-process-buffer-with-cont cont)))
(pcase result
(`(PROCESSED ,ret)
2014-09-05 04:04:44 +00:00
(!cdr lean-global-async-task-queue))))))
2014-09-05 04:04:44 +00:00
(defun lean-server-send-cmd-sync (cmd &optional cont)
"Send cmd to lean-server (sync)."
(lean-server-debug "send-cmd-sync: %S" (lean-cmd-type cmd))
(lean-server-cancel-retry-timer)
(lean-server-consume-all-async-tasks)
(lean-server-send-cmd cmd)
(let ((result (lean-server-check-and-process-buffer-with-cont cont)))
(while (not result)
(accept-process-output (lean-server-get-process) 0 50 t)
(setq result (lean-server-check-and-process-buffer-with-cont cont)))
(pcase result
2014-09-05 04:04:44 +00:00
(`(PROCESSED ,ret) ret))))
(defun lean-show-parse-string (str)
"Parse the output of show command."
(let ((str-list (split-string str "\n")))
;; Drop the first line "-- BEGINSHOW" and
;; the last line "-- ENDSHOW"
(setq str-list
(-take (- (length str-list) 2)
(-drop 1 str-list)))
(string-join str-list "\n")))
2014-09-04 22:30:23 +00:00
(defun lean-findp-parse-string (str)
"Parse the output of findp command."
(let ((str-list (split-string str "\n")))
;; Drop the first line "-- BEGINFINDP" and
;; the last line "-- ENDFINDP"
(setq str-list
(-take (- (length str-list) 2)
(-drop 1 str-list)))
(--map
(let ((items (split-string it "|")))
`(,(cl-first items) . ,(cl-second items))) str-list)))
(defun lean-server-show ()
(interactive)
(lean-server-send-cmd-async (lean-cmd-show) 'message))
(defun lean-server-valid ()
(interactive)
(lean-server-send-cmd-async (lean-cmd-valid) 'message))
(defun lean-server-set-timer-for-event-handler ()
(lean-server-debug "set-timer-for-event-handler")
(unless lean-global-retry-timer
(setq lean-global-retry-timer
(run-with-idle-timer
(if (current-idle-time)
(time-add (seconds-to-time lean-server-retry-time) (current-idle-time))
lean-server-retry-time)
nil
'lean-server-event-handler)))
nil)
2014-08-14 00:02:49 +00:00
(defun lean-server-get-info-record-at-pos (body)
(let* ((file-name (buffer-file-name))
(column (current-column))
(cur-char (char-after (point))))
(when (and cur-char
(--any? (char-equal cur-char it) '(?\s ?\t ?\, ?\) ?\} ?\]))
(> column 1))
(setq column (1- column)))
(lean-info-record-parse body file-name column)))
(defun lean-server-event-handler ()
"Process an item from async-task-queue.
If it's successful, take it out from the queue. Otherwise, set an
idle-timer to call the handler again"
(setq lean-global-retry-timer nil)
(let* ((cont (car lean-global-async-task-queue))
2014-09-05 04:04:44 +00:00
(result (lean-server-check-and-process-buffer-with-cont cont)))
(pcase result
(`(PROCESSED ,ret)
(!cdr lean-global-async-task-queue)
ret)))
(when lean-global-async-task-queue
(lean-server-set-timer-for-event-handler)))
(defadvice save-buffers-kill-emacs
(before lean-server-kill-before-kill-emacs activate)
"Call `lean-server-kill-process', to avoid the user being
prompted to kill the lean-server process."
(lean-server-kill-process))
2014-08-14 00:02:49 +00:00
(provide 'lean-server)