haskal
/
utop
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

emacs mode 

Ignore-this: a387797436a4995b0376c76507334795

darcs-hash:20110727090447-c41ad-da8929cec04466dcd94b1cf62cbc58f6b8c0f75b
This commit is contained in:
Jeremie Dimino 2011-07-27 11:04:47 +02:00
parent 02d98fff98
commit a1ebb70cb6
5 changed files with 497 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
_oasis
View File

@ -33,6 +33,14 @@ Executable utop
MainIs: uTop_console_top.ml
BuildDepends: utop, findlib, lambda-term, lwt.syntax
Executable "utop-emacs"
Install: true
Path: src
CompiledObject: byte
MainIs: uTop_emacs_top.ml
BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads
DataFiles: utop.el ($datadir/emacs/site-lisp)
# +-------------------------------------------------------------------+
# | Misc |
# +-------------------------------------------------------------------+

1
_tags
View File

@ -3,6 +3,7 @@
<**/*.ml>: syntax_camlp4o, pkg_lwt.syntax
<src/*>: use_compiler_libs, pkg_lambda-term, pkg_findlib
<**/*.top>: use_utop
<**/uTop_emacs_top.top>: pkg_threads
# OASIS_START
# OASIS_STOP

90
src/uTop_emacs.ml Normal file
View File

@ -0,0 +1,90 @@
(*
* uTop_emacs.ml
* -------------
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
* Licence : BSD3
*
* This file is a part of utop.
*)
(* Main for emacs mode. *)
open Lwt
(* Copy standard output, which will be used to send commands. *)
let command_oc = Unix.out_channel_of_descr (Unix.dup Unix.stdout)
(* +-----------------------------------------------------------------+
| Sending commands to Emacs |
+-----------------------------------------------------------------+ *)
(* Mutex used to send commands to Emacs. *)
let command_mutex = Mutex.create ()
let send command argument =
Mutex.lock command_mutex;
output_string command_oc command;
output_char command_oc ':';
output_string command_oc argument;
output_char command_oc '\n';
flush command_oc;
Mutex.unlock command_mutex
(* +-----------------------------------------------------------------+
| Standard outputs redirection |
+-----------------------------------------------------------------+ *)
(* The output of ocaml (stdout and stderr) is redirected so the emacs
parts of celtop can recognize it. *)
(* Continuously copy the output of ocaml to Emacs. *)
let rec copy_output which ic =
let line = input_line ic in
send which line;
copy_output which ic
(* Create a thread which redirect the given output: *)
let redirect which fd =
let fdr, fdw = Unix.pipe () in
Unix.dup2 fdw fd;
Unix.close fdw;
Thread.create (copy_output which) (Unix.in_channel_of_descr fdr)
(* Redirects stdout and stderr: *)
let _ = redirect "stdout" Unix.stdout
let _ = redirect "stderr" Unix.stderr
(* +-----------------------------------------------------------------+
| Input |
+-----------------------------------------------------------------+ *)
let rec copy_input buffer offset length =
if offset = length then
return (offset, false)
else
Lwt_io.read_char_opt Lwt_io.stdin >>= function
| Some '\n' ->
buffer.[offset] <- '\n';
return (offset + 1, false)
| Some ch ->
buffer.[offset] <- ch;
copy_input buffer (offset + 1) length
| None ->
return (offset, true)
let read_input prompt buffer length =
match prompt with
| "# " ->
(* New phrase. *)
send "prompt" "";
Lwt_main.run (copy_input buffer 0 length)
| "* " | " " ->
(* Continuation of the current phrase. *)
send "continue" "";
Lwt_main.run (copy_input buffer 0 length)
| _ ->
send "stderr" "unrecognized prompt";
exit 1
let () =
Toploop.read_interactive_input := read_input

4
src/uTop_emacs_top.mltop Normal file
View File

@ -0,0 +1,4 @@
UTop_emacs
UTop_lexer
UTop_token
UTop_complete

394
src/utop.el Normal file
View File

@ -0,0 +1,394 @@
;; utop.el
;; -------
;; Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
;; Licence : BSD3
;;
;; This file is a part of utop.
;; +-----------------------------------------------------------------+
;; | Customizable variables |
;; +-----------------------------------------------------------------+
(defgroup utop nil
"A toplevel for the ocaml programming language which interact
with Emacs to provide an enhanced environment."
:tag "The Caml Emacs-Lisp Toplevel"
:version "1.0"
:group 'applications)
(defcustom utop-command "utop-emacs"
"The command to execute for utop."
:type 'string
:group 'utop)
(defcustom utop-prompt 'utop-default-prompt
"The function which create the prompt for utop."
:type 'function
:group 'utop)
(defcustom utop-mode-hook nil
"A hook that gets run when `utop-mode' is entered."
:type 'hook
:group 'utop)
(defcustom utop-exit-hook nil
"A hook that is run whenever `utop' is exited.
This hook is only run if exiting actually kills the buffer."
:type 'hook
:group 'utop)
(defface utop-prompt
'((t (:foreground "Cyan1")))
"The face used to highlight the prompt."
:group 'utop)
(defface utop-stdout
nil
"The face used to highlight messages comming from stdout."
:group 'utop)
(defface utop-stderr
nil
"The face used to highlight messages commong from stderr."
:group 'utop)
(defface utop-frozen
'((t (:bold t)))
"The face used to highlight text that has been sent to utop.")
;; +-----------------------------------------------------------------+
;; | Constants |
;; +-----------------------------------------------------------------+
(defconst utop-buffer-name "*utop*"
"The name of the buffer utop is running on.")
;; +-----------------------------------------------------------------+
;; | Variables |
;; +-----------------------------------------------------------------+
(defvar utop-process nil
"The Lisp-object for the utop sub-process")
(defvar utop-mode-map nil
"The utop local keymap.")
(defvar utop-prompt-min 0
"The point at the beginning of the current prompt.")
(defvar utop-prompt-max 0
"The point at the end of the current prompt.")
(defvar utop-last-prompt 0
"The contents of the last displayed prompt.")
(defvar utop-output ""
"The output of the utop sub-process not yet processed.")
(defvar utop-command-number 0
"The number of the current command.")
(defvar utop-history nil
"The history of typed command.")
(defvar utop-history-prev nil
"The history before the cursor.")
(defvar utop-history-next nil
"The history after the cursor.")
;; +-----------------------------------------------------------------+
;; | Utils |
;; +-----------------------------------------------------------------+
(defun utop-add-text-properties-rear-nonsticky (start end properties nonsticky-properties &optional object)
"Same as ``add-text-properties'' but put the last character in
non-sticky mode."
(when (< start end)
;; Put everything between start and end-1 in sticky read-only mode
(add-text-properties start (- end 1) properties object)
;; Put the last character in non-sticky mode
(add-text-properties (- end 1) end
(append
properties
(list 'rear-nonsticky nonsticky-properties))
object)))
;; +-----------------------------------------------------------------+
;; | Prompt |
;; +-----------------------------------------------------------------+
(defun utop-default-prompt ()
"The default prompt function."
(let ((prompt (format "utop[%d]> " utop-command-number)))
(add-text-properties 0 (length prompt) '(face utop-prompt) prompt)
prompt))
;; +-----------------------------------------------------------------+
;; | History |
;; +-----------------------------------------------------------------+
(defun utop-history-goto-prev ()
"Go to the previous entry of the history."
(interactive)
(unless (null utop-history-prev)
(with-current-buffer utop-buffer-name
;; Push current input after the history cursor
(push (delete-and-extract-region utop-prompt-max (point-max)) utop-history-next)
;; Go to after the prompt to insert the previous input
(goto-char utop-prompt-max)
;; Pop one element from history before the cursor and insert it
(insert (pop utop-history-prev)))))
(defun utop-history-goto-next ()
"Go to the next entry of the history."
(interactive)
(unless (null utop-history-next)
(with-current-buffer utop-buffer-name
;; Push current input before the history cursor
(push (delete-and-extract-region utop-prompt-max (point-max)) utop-history-prev)
;; Go to after the prompt to insert the next input
(goto-char utop-prompt-max)
;; Pop one element from history after the cursor and insert it
(insert (pop utop-history-next)))))
;; +-----------------------------------------------------------------+
;; | Receiving input from the utop sub-process |
;; +-----------------------------------------------------------------+
(defun utop-insert-output (output &optional face)
"Insert the given output before the prompt."
(with-current-buffer utop-buffer-name
(save-excursion
(let ((line (concat output "\n")))
;; Make the line read-only
(add-text-properties 0 (length line) '(read-only t) line)
;; Apply the given face if provided
(when face (add-text-properties 0 (length line) (list 'face face) line))
;; Goto before the prompt
(goto-char utop-prompt-min)
;; Insert the output
(let ((inhibit-read-only t)) (insert line))
;; Advance the prompt
(setq utop-prompt-min (+ utop-prompt-min (length line)))
(setq utop-prompt-max (+ utop-prompt-max (length line)))))))
(defun utop-insert-prompt (prompt)
"Insert the given prompt."
(with-current-buffer utop-buffer-name
;; Make the old prompt sticky so we cannot edit after it
(let ((inhibit-read-only t))
(remove-text-properties utop-prompt-min utop-prompt-max '(rear-nonsticky nil)))
;; Make the prompt read-only. Make the read-only property
;; non-sticky so the buffer can be edited after the prompt
(utop-add-text-properties-rear-nonsticky 0 (length prompt) '(read-only t) '(face read-only) prompt)
;; Goto the end of the buffer
(goto-char (point-max))
;; Make it the start of the prompt
(setq utop-prompt-min (point))
;; Insert the prompt
(let ((inhibit-read-only t)) (insert prompt))
;; Set the end of prompt
(setq utop-prompt-max (point))))
(defun utop-process-line (line)
"Process one line from the utop sub-process."
;; Extract the command and its argument
(string-match "\\`\\([a-z]*\\):\\(.*\\)\\'" line)
(let ((command (match-string 1 line)) (argument (match-string 2 line)))
(cond
;; Output on stdout
((string= command "stdout")
(utop-insert-output argument 'utop-stdout))
;; Output on stderr
((string= command "stderr")
(utop-insert-output argument 'utop-stderr))
;; A new prompt
((string= command "prompt")
(let ((prompt (apply utop-prompt ())))
;; Save current prompt
(setq utop-last-prompt prompt)
;; Insert the new prompt
(utop-insert-prompt prompt)
;; Increment the command number
(setq utop-command-number (+ utop-command-number 1))))
;; Continuation of previous input
((string= command "continue")
(utop-insert-prompt utop-last-prompt)))))
(defun utop-process-output (process output)
"Process the output of utop"
;; Concatenate the output with the output not yet processed
(setq utop-output (concat utop-output output))
;; Split lines. Each line contains exactly one command
(let ((lines (split-string utop-output "\n")))
(while (>= (length lines) 2)
;; Process the first line
(utop-process-line (car lines))
;; Remove it and continue
(setq lines (cdr lines)))
;; When the list contains only one element, then this is either
;; the end of commands, either an unterminated one, so we save
;; it for later
(setq utop-output (car lines))))
;; +-----------------------------------------------------------------+
;; | Sending data to the utop sub-process |
;; +-----------------------------------------------------------------+
(defun utop-send-input ()
"Send the text typed at current prompt to the utop
sub-process."
(interactive)
(with-current-buffer utop-buffer-name
;; Add current input to the history if it is different from the
;; top of the history
(let ((input (buffer-substring-no-properties utop-prompt-max (point-max))))
(unless (and (consp utop-history) (string= input (car utop-history)))
(push input utop-history)))
;; Reset history
(setq utop-history-prev utop-history)
(setq utop-history-next nil)
;; Goto the end of the buffer
(goto-char (point-max))
;; Terminate input by a newline
(insert "\n")
;; Make the text read-only
(add-text-properties utop-prompt-max (point-max) '(read-only t))
;; Make the old prompt sticky so we cannot edit after it
(let ((inhibit-read-only t))
(remove-text-properties utop-prompt-min utop-prompt-max '(rear-nonsticky nil)))
;; Send everything after the prompt to utop
(process-send-region utop-process utop-prompt-max (point-max))
;; Makes the text sent part of the prompt so it won't be sent
;; again. Also add it the frozen face.
(let ((inhibit-read-only t))
(utop-add-text-properties-rear-nonsticky utop-prompt-max (point-max)
'(read-only t face utop-frozen)
'(face read-only)))
(setq utop-prompt-max (point-max))))
;; +-----------------------------------------------------------------+
;; | Completion |
;; +-----------------------------------------------------------------+
;; +-----------------------------------------------------------------+
;; | Tuareg integration |
;; +-----------------------------------------------------------------+
(defun utop-eval-region (start end)
"Eval the current region in utop."
(interactive "r")
(save-excursion (utop))
(setq tuareg-interactive-last-phrase-pos-in-source start)
(save-excursion
(goto-char start)
(tuareg-skip-blank-and-comments)
(setq start (point))
(goto-char end)
(tuareg-skip-to-end-of-phrase)
(setq end (point))
(let ((text (buffer-substring-no-properties start end)))
(with-current-buffer utop-buffer-name
(goto-char (point-max))
(insert text ";;")
(utop-send-input)))))
(defun utop-eval-phrase ()
"Eval the surrounding Caml phrase (or block) in utop."
(interactive)
(let ((end))
(save-excursion
(let ((pair (tuareg-discover-phrase)))
(setq end (nth 2 pair))
(utop-eval-region (nth 0 pair) (nth 1 pair))))
(if tuareg-skip-after-eval-phrase
(goto-char end))))
(defun utop-eval-buffer ()
"Send the buffer to utop."
(interactive)
(utop-eval-region (point-min) (point-max)))
;; +-----------------------------------------------------------------+
;; | Edition functions |
;; +-----------------------------------------------------------------+
(defun utop-bol ()
"Go to the beginning of line or to the end of the prompt."
(interactive)
(with-current-buffer utop-buffer-name
(if (= (point-at-bol) utop-prompt-min)
(goto-char utop-prompt-max)
(move-beginning-of-line 1))))
;; +-----------------------------------------------------------------+
;; | The mode |
;; +-----------------------------------------------------------------+
(defun utop-mode ()
"Caml Emacs-Lisp Toplevel.
\\{utop-mode-map}"
;; Local variables
(make-local-variable 'utop-mode-map)
(make-local-variable 'utop-process)
(make-local-variable 'utop-prompt-min)
(make-local-variable 'utop-prompt-max)
(make-local-variable 'utop-last-prompt)
(make-local-variable 'utop-output)
(make-local-variable 'utop-command-number)
(make-local-variable 'utop-history)
(make-local-variable 'utop-history-prev)
(make-local-variable 'utop-history-next)
;; Set the major mode
(setq major-mode 'utop-mode)
(setq mode-name "utop")
;; Create and use the local keymap utop-mode-map
(setq utop-mode-map (make-sparse-keymap))
(use-local-map utop-mode-map)
;; Create the sub-process
(setq utop-process (start-process "utop" (current-buffer) utop-command))
;; Filter the output of the sub-process with our filter function
(set-process-filter utop-process 'utop-process-output)
;; Define keys
(define-key utop-mode-map [return] 'utop-send-input)
(define-key utop-mode-map [(control ?m)] 'utop-send-input)
(define-key utop-mode-map [(control ?j)] 'utop-send-input)
(define-key utop-mode-map [home] 'utop-bol)
(define-key utop-mode-map [(control ?a)] 'utop-bol)
(define-key utop-mode-map [(meta ?p)] 'utop-history-goto-prev)
(define-key utop-mode-map [(meta ?n)] 'utop-history-goto-next)
;; Register the exit hook
(add-hook 'kill-buffer-hook (lambda () (run-hooks 'utop-exit-hook)) t t)
;; Call hooks
(run-mode-hooks 'utop-mode-hook))
;; +-----------------------------------------------------------------+
;; | Starting utop |
;; +-----------------------------------------------------------------+
;;;###autoload
(defun utop ()
"Start utop."
(interactive)
;; Create the utop buffer if it does not exists, otherwise just
;; retreive it
(let ((buf (get-buffer-create utop-buffer-name)))
;; Jump to that buffer
(pop-to-buffer buf)
;; Set the utop mode in that buffer if not already done
(unless (eq major-mode 'utop-mode) (utop-mode))
;; Finally return it
buf))
(provide 'utop)