From 5bf5f09fbce799a9be4e4ac9b2b5ff3f06b3c2dd Mon Sep 17 00:00:00 2001 From: Milo Davis Date: Fri, 11 Aug 2017 15:32:28 +0200 Subject: [PATCH] Emacs: vertical stack printing and suggestions --- emacs/README.md | 9 + emacs/michelson-mode.el | 446 +++++++++++++++--- .../embedded/alpha/client_proto_programs.ml | 41 +- 3 files changed, 419 insertions(+), 77 deletions(-) diff --git a/emacs/README.md b/emacs/README.md index 37913a483..df817a2bd 100644 --- a/emacs/README.md +++ b/emacs/README.md @@ -3,6 +3,15 @@ This mode is a work in progress. Please contact us with bugs and feature requests. All of the options mentioned below are also accessible via the customize menu. +## Dependencies: +To operate the mode, please install the following dependencies. +All are available from either melpa, elpa, or marmalade +and are available under a free software license. + +| Package | Package Repository | Sources | +| -------- | ------------------ | --------------- | +| deferred | Melpa | https://github.com/kiwanami/emacs-deferred | + ## Required Configuration To use the mode, you must load the `michelson-mode.el` file into Emacs. Add the following to your `.emacs` file. diff --git a/emacs/michelson-mode.el b/emacs/michelson-mode.el index 1299056d9..dbbdddb83 100644 --- a/emacs/michelson-mode.el +++ b/emacs/michelson-mode.el @@ -1,6 +1,7 @@ ;; Major mode for editing Michelson smart contracts. -(require 'cl) +(require 'cl-lib) +(require 'deferred) (defvar michelson-mode-hook nil) @@ -105,6 +106,12 @@ Overrides `michelson-print-errors' and `michelson-highlight-errors'" "Face for Michelson annotations." :group 'michelson-faces) +(defface michelson-stack-highlight-face + '(( ((class color) (background light)) (:background "gray86") ) + ( ((class color) (background dark)) (:background "grey21") )) + "Face for alternating lines of the stack." + :group 'michelson-faces) + (defun michelson-customize-options () "Open the general customization group for Michelson mode." (interactive) @@ -351,18 +358,14 @@ Overrides `michelson-print-errors' and `michelson-highlight-errors'" (defun michelson-async-command-to-string (command callback) "Asynchronously execute `COMMAND' and call the `CALLBACK' on the resulting string." - (lexical-let ((callback-fun callback)) - (michelson-erase-process-buffer) - (set-process-sentinel - (start-process-shell-command - "michelson-shell-process" - michelson-process-output-buffer - command) - (lambda (process signal) - (let ((output - (with-current-buffer michelson-process-output-buffer - (buffer-string)))) - (funcall callback-fun output)))))) + (lexical-let ((command command) + (callback-fun callback)) + (deferred:$ + (deferred:$ + (apply 'deferred:process command) + (deferred:nextc it callback-fun)) + ;; TODO: make this show only the client error + (deferred:error it (lambda (err) (michelson-write-output-buffer (cadr err))))))) (defun michelson-clean-cache () "Clean the buffer's program info cache." @@ -382,36 +385,51 @@ Overrides `michelson-print-errors' and `michelson-highlight-errors'" "Refresh the info about the program in `BUFFER-NAME' from the command." (lexical-let ((tmp-file (make-temp-file buffer-name))) (write-region (point-min) (point-max) tmp-file nil 'no-message) - (let ((command (concat - "ALPHANET_EMACS=true " - "TEZOS_ALPHANET_DO_NOT_PULL=yes " - michelson-client-command - " typecheck program " + (let ((command + (append (split-string (expand-file-name michelson-client-command) " ") + (list + "typecheck" + "program" (let ((file-name (make-temp-file (buffer-name)))) (write-region (point-min) (point-max) file-name nil 'no-message) (if michelson-alphanet (concat "container:" file-name) file-name)) - " -details -emacs"))) - (michelson-async-command-to-string - command - (lambda (output) - (condition-case err - (let* - ((record (car (read-from-string output))) - (errors (cdr (assoc 'errors record))) - (types (cdr (assoc 'types record)))) - (setq michelson-cached-buffer-info (make-cache :types types :errors errors))) - ((error err) - (let ((inhibit-message t)) - (message output))))))))) + "-details" + "-emacs")))) + (michelson-async-command-to-string + command + (lambda (output) + (condition-case err + (let* + ((record (car (read-from-string output))) + (errors (cdr (assoc 'errors record))) + (types (cdr (assoc 'types record)))) + (setq michelson-cached-buffer-info (make-cache :types types :errors errors))) + ((error err) + (let ((inhibit-message t)) + (message output))))))))) (defvar michelson-output-buffer-name "*Michelson*") -(defun michelson-write-output-buffer (data) - "Write the given `DATA' to the output buffer." +(defun michelson-output-width () + (lexical-let* ((buffer (get-buffer-create michelson-output-buffer-name)) + (message-window + (if (get-buffer-window buffer) + (get-buffer-window buffer) + (display-buffer-below-selected buffer nil)))) + (window-body-width message-window))) + + +(defun michelson-write-output-buffer (data &optional do-not-overwrite) + "Write the given `DATA' to the output buffer. +If `DATA' is a string, it is written directly, +overwriting the data in the buffer. +If `DATA' is a list of strings, the strings are written into the buffer, +with alternating lines highlighted. +If `DO-NOT-OVERWRITE' is non-nil, the existing contents of the buffer are maintained." (lexical-let* ((buffer (get-buffer-create michelson-output-buffer-name)) (message-window @@ -424,8 +442,20 @@ Overrides `michelson-print-errors' and `michelson-highlight-errors'" (save-excursion (set-buffer michelson-output-buffer-name) (read-only-mode -1) - (erase-buffer) - (insert data) + (unless do-not-overwrite + (erase-buffer)) + (goto-char (point-min)) + (remove-overlays) + (if (listp data) + (lexical-let ((michelson-highlighting t)) + (dolist (ele (reverse data)) + (lexical-let ((prev-point (point))) + (insert ele) + (when michelson-highlighting + (overlay-put (make-overlay prev-point (point)) + 'face 'michelson-stack-highlight-face)) + (setq michelson-highlighting (not michelson-highlighting))))) + (insert data)) (read-only-mode 1) (goto-char (point-min)) (while (not (eobp)) @@ -438,38 +468,333 @@ Overrides `michelson-print-errors' and `michelson-highlight-errors'" (window-size message-window)) 2)))))) -(defun michelson-show-program-info (types errors) +(defun michelson-format-stack-top (bef-ele aft-ele width) + (lexical-let* + ((pp-no-trailing-newline (lambda (sexp) + (let* ((str (pp-to-string sexp)) + (len (length str))) + (if (equal "\n" (substring str (- len 1) len)) + (substring str 0 (- len 1)) + str)))) + (bef-strs (if bef-ele (split-string (funcall pp-no-trailing-newline bef-ele) "\n") '(""))) + (aft-strs (if aft-ele (split-string (funcall pp-no-trailing-newline aft-ele) "\n") '(""))) + (width width)) + (letrec ((format-strings + (lambda (befs afts) + (if (or befs afts) + (concat (format (format "%%-%ds| %%s\n" (/ width 2)) + (if befs (car befs) "") + (if afts (car afts) "")) + (funcall format-strings (cdr befs) (cdr afts))) + "")))) + (funcall format-strings bef-strs aft-strs)))) + + +(defun michelson-format-stacks (bef-stack aft-stack) + (letrec ((michelson-format-stacks-help + (lambda (bef aft) + (if (or bef aft) + (cons (michelson-format-stack-top (car bef) (car aft) (michelson-output-width)) + (funcall michelson-format-stacks-help (cdr bef) (cdr aft))) + '())))) + (funcall michelson-format-stacks-help (reverse bef-stack) (reverse aft-stack)))) + +(cl-defstruct michelson-stacks + "A pair of stacks, from `BEF' (before) and `AFT' (after) the instruction" + bef + aft) + +(defun michelson-get-previous-stack () + (save-excursion + (michelson-goto-previous-token) + (lexical-let ((stacks nil) + (brace-count 0) + (break nil)) + (while (and (not break) + (not stacks) + (> (point) 0) + (>= brace-count 0)) + (backward-char) + (cond ((and (equal (get-text-property (point) 'face) + 'michelson-face-instruction) + (= brace-count 0)) + (setq break t) + (setq stacks (michelson-stacks-at-loc (point)))) + ((equal (string (char-after (point))) "{") + (setq brace-count (- brace-count 1))) + ((equal (string (char-after (point))) "}") + (setq brace-count (+ brace-count 1))) + (t nil))) + stacks))) + + +(defun michelson-completion-at-point () + (let ((prev-stack (michelson-get-previous-stack))) + (if prev-stack + (let* ((bds (bounds-of-thing-at-point 'word)) + (start (car bds)) + (end (cdr bds)) + (completion-stack (michelson-stacks-aft prev-stack)) + (instrs (michelson-get-suggestion-list completion-stack))) + (list start end instrs . nil)) + nil))) + +(defun michelson-stacks-at-loc (loc) + (let ((types-info nil)) + (dolist (elt (cache-types michelson-cached-buffer-info)) + (when (and (<= (car elt) loc) (<= loc (cadr elt)) + (equal (get-text-property loc 'face) + 'michelson-face-instruction)) + (setq types-info (make-michelson-stacks :bef (caddr elt) + :aft (cadddr elt))))) + types-info)) + +(defun michelson-show-program-info () "Show the program's `TYPES' and `ERRORS'." (interactive) (remove-overlays) - (lexical-let ((types-info nil) - (errors-info nil)) - (dolist (elt types) - (if (and (<= (car elt) (point)) (<= (point) (cadr elt)) - (equal (get-text-property (point) 'face) - 'michelson-face-instruction)) - (setq types-info (cadr (cdr elt))))) + (lexical-let* ((stacks (michelson-stacks-at-loc (point))) + (types-info (and stacks (michelson-format-stacks (michelson-stacks-bef stacks) + (michelson-stacks-aft stacks)))) + (errors-info nil)) (when michelson-highlight-errors - (dolist (elt errors) + (dolist (elt (cache-errors michelson-cached-buffer-info)) (overlay-put (make-overlay (car elt) (cadr elt)) 'face 'michelson-face-error) - (if (and (<= (car elt) (point)) (<= (point) (cadr elt))) - (progn - (when michelson-print-errors - (unless errors-info - (setq errors-info (concat errors-info "\n"))) - (setq errors-info (concat errors-info (cadr (cdr elt))))))))) - (michelson-write-output-buffer - (cond ((not (or types-info types-info)) "\n No instruction at point.\n") - ((and errors-info (not types-info)) errors-info) - (t (concat types-info "\n\n" errors-info)))))) + (when (and (<= (car elt) (point)) (<= (point) (cadr elt))) + (progn + (when michelson-print-errors + (unless errors-info + (setq errors-info (concat errors-info "\n"))) + (setq errors-info (concat errors-info (cadr (cdr elt))))))))) + (cond ((and types-info errors-info) + (michelson-write-output-buffer errors-info nil) + (michelson-write-output-buffer types-info t)) + (types-info + (michelson-write-output-buffer types-info nil)) + (errors-info + (michelson-write-output-buffer errors-info nil)) + (t (michelson-write-output-buffer "\nNo information available at point"))))) (defun michelson-type-at-point () "Display the type of the expression under the cursor." (interactive) (michelson-get-info (buffer-name)) - (let ((types (cache-types michelson-cached-buffer-info)) - (errors (cache-errors michelson-cached-buffer-info))) - (michelson-show-program-info types errors))) + (michelson-show-program-info)) + +(defun michelson-make-suggest (instr pred) + "Suggest `INSTR' if `PRED' is not nil." + (lexical-let ((instr instr) + (pred pred)) + (lambda (stack) + (if (funcall pred stack) + (if (listp instr) + instr + `(,instr)) + nil)))) + + +(defun michelson-constrained-p (var hash) + (not (equal var (gethash var hash var)))) + +(defun michelson-polymorphic-match (tbl match-types stack) + (cond ((not match-types) t) + ((not stack) nil) + ((and (consp match-types) (consp stack)) + (and (michelson-polymorphic-match tbl (car match-types) (car stack)) + (michelson-polymorphic-match tbl (cdr match-types) (cdr stack)))) + ((and (symbolp match-types) (symbolp stack)) + (if (and (michelson-constrained-p match-types tbl) + (gethash match-types tbl)) + (equal (gethash match-types tbl nil) stack) + (progn + (puthash match-types stack tbl) + t))) + (t nil))) + +(defmacro forall (vars matching-stack) + (unless (listp ',vars) + (error "forall must take a list of vars")) + `(lambda (stack) + (let ((tbl (make-hash-table :test 'equal))) + ,@(mapcar (lambda (var) `(puthash ',var ',var tbl)) vars) + (michelson-polymorphic-match tbl ',matching-stack stack)))) + +(defun michelson-literals-match-p (types) + "Generate a predicate that matches `TYPES' against the top of the stack." + (lexical-let ((types types)) + (lambda (stack) + (michelson-polymorphic-match + (make-hash-table :test 'equal) + types + stack)))) + +(defun michelson-suggest-literals (instr &rest types) + "Suggest `INSTR' when `TYPES' are on the top of the stack." + (michelson-make-suggest + instr + (michelson-literals-match-p types))) + + +(defun michelson-suggest-or (instr pred1 pred2) + (lexical-let ((pred1 pred1) + (pred2 pred2)) + (michelson-make-suggest + instr + (lambda (stack) (or (funcall pred1 stack) (funcall pred2 stack)))))) + +(defun michelson-suggest-reorderable (instr type1 type2) + (michelson-suggest-or instr + (michelson-literals-match-p `(,type1 ,type2)) + (michelson-literals-match-p `(,type2 ,type1)))) + +(defvar michelson-suggest-always-available + '("FAIL" "PUSH" "UNIT" "LAMBDA" "NONE" + "EMPTY_SET" "EMPTY_MAP" "NIL" "BALANCE" + "AMOUNT" "STEPS_TO_QUOTA" "NOW")) + +(defun michelson-comparable-p (type) + "Is the `TYPE' comparable?" + (memq type '(int nat string tez bool key timestamp))) + + +(defun michelson-suggest-pairs-help (pair-type accessor-prefix) + "Suggest all possible pair accessors on the given `PAIR-TYPE' and `ACCESSOR-PREFIX'." + (cons (concat accessor-prefix "R") + (if (and (consp pair-type) (equal (car pair-type) 'pair)) + (let ((car-ele (cadr pair-type)) + (cdr-ele (caddr pair-type))) + (append + (michelson-suggest-pairs-help car-ele + (concat accessor-prefix "A")) + (michelson-suggest-pairs-help car-ele + (concat accessor-prefix "D")) + '()))))) + +(defun michelson-suggest-pairs (stack) + "Suggest all possible pair accessors on the given `STACK'." + (if (and (consp (car stack)) (equal (caar stack) 'pair)) + (append (michelson-suggest-pairs-help (cadar stack) "CA") + (michelson-suggest-pairs-help (caddar stack) "CD") + nil))) + +(defconst michelson-comparison-operations + '("EQ" "NEQ" "LT" "LE" "GT" "GE")) + +(defun michelson-suggest-comparable (stack) + (let ((first (car stack)) + (second (cadr stack))) + (if (and first + second + (michelson-comparable-p first) + (equal first second)) + (cons + "COMPARE" + (append + (mapcar (lambda (x) (concat "CMP" x)) + michelson-comparison-operations) + (mapcar (lambda (x) (concat "IFCMP" x)) + michelson-comparison-operations))) + '()))) + +(defun michelson-suggest-depth (instrs depth) + "Suggest `INSTRS' if the stack depth is greater than or equal to `DEPTH'." + (michelson-make-suggest + instrs + (lexical-let ((depth depth)) + (lambda (stack) (>= (length stack) depth))))) + +(defun michelson-suggest-prefix-depth (prefix additional suffix) + (lexical-let ((prefix prefix) + (additional additional) + (suffix suffix)) + (lambda (stack) + (reverse (car (reduce + (lambda (acc ele) + (lexical-let ((existing (car acc)) + (prefix (concat (cdr acc) additional))) + (cons (cons (concat prefix suffix) existing) + prefix))) + stack + :initial-value (cons nil "D"))))))) + +(defvar michelson-type-completion-list + (list + (michelson-make-suggest "EXEC" (forall (arg ret) (arg (lambda arg ret)))) + (michelson-make-suggest "MEM" (forall (val-type) (val-type (set val-type)))) + (michelson-make-suggest "MEM" (forall (key-type val-type) (key-type (map key-type val-type)))) + (michelson-make-suggest "UPDATE" (forall (val-type) (val-type bool (set val-type)))) + (michelson-make-suggest "UPDATE" (forall (key-type val-type) + (key-type (option val-type) (map key-type val-type)))) + (michelson-make-suggest "MAP" (forall (lt rt) ((lambda lt rt) (list lt)))) + (michelson-make-suggest "MAP" (forall (k v b) ((lambda (pair k v) b) (map k v)))) + (michelson-suggest-literals "IF" 'bool) + (michelson-suggest-literals "LOOP" 'bool) + (michelson-suggest-literals michelson-comparison-operations 'int) + 'michelson-suggest-comparable + 'michelson-suggest-pairs + (michelson-suggest-prefix-depth "D" "I" "P") + (michelson-suggest-prefix-depth "D" "U" "P") + (lambda (stack) (and (cdr stack) + (funcall (michelson-suggest-prefix-depth "PA" "A" "IP") (cdr stack)))) + (michelson-suggest-literals "NOT" 'bool) + (michelson-suggest-literals '("OR" "AND" "XOR") 'bool 'bool) + (michelson-suggest-literals "ABS" 'int) + (michelson-make-suggest + '("ADD" "SUB" "MUL" "EDIV") + (lambda (stack) + (let ((first (car stack)) + (second (cadr stack)) + (intnat '(int nat))) + (and first + second + (memq first intnat) + (memq second intnat))))) + (michelson-suggest-reorderable "ADD" 'nat 'timestamp) + (michelson-suggest-literals "NOT" 'int) + (michelson-suggest-literals '("OR" "AND" "XOR" "LSL" "LSR") 'nat 'nat) + (michelson-suggest-literals '("CONCAT") 'string 'string) + (michelson-suggest-depth '("SOME" "LEFT" "RIGHT") 1) + (michelson-suggest-literals '("ADD" "SUB") 'tez 'tez) + (michelson-suggest-reorderable '("ADD" "SUB" "MUL") 'tez 'nat) + (michelson-suggest-literals "EDIV" 'tez 'nat) + (michelson-suggest-literals "EDIV" 'tez 'tez) + (michelson-suggest-literals "DEFAULT_ACCOUNT" 'key) + (michelson-suggest-depth "SWAP" 2) + (michelson-suggest-depth '("DROP" "H") 1) + (michelson-suggest-literals "CHECK_SIGNATURE" 'key '(pair signature string)) + (michelson-suggest-literals "CREATE_ACCOUNT" 'key '(option key) 'bool 'tez) + (michelson-make-suggest "IF_NONE" (forall (x) (option x))) + (michelson-make-suggest "IF_LEFT" (forall (x y) (or x y))) + ;; This is not exactly the type of TRANSFER_TOKENS. + ;; It will be changed once the concurrency model is worked out + (michelson-make-suggest "TRANSFER_TOKENS" (forall (p r g) (p tez (contract p r) g))) + (michelson-make-suggest + "CREATE_CONTRACT" + (forall (p r g) (key (option key) bool bool tez (lambda (pair p g) (pair r g)) g))) + (michelson-make-suggest "MANAGER" (forall (p r) ((contract p r)))) + (michelson-make-suggest "CONS" (forall (a) (a (list a)))) + (michelson-make-suggest "IF_CONS" (forall (a) (list a))) + (michelson-make-suggest "GET" (forall (k v) (k (map k v)))) + (michelson-make-suggest "UPDATE" (forall (v) (v bool (set v)))) + (michelson-make-suggest "UPDATE" (forall (k v) (k (option v) (map k v)))) + (michelson-make-suggest "REDUCE" (forall (elt b) ((lambda (pair elt b) b) (set elt) b))) + (michelson-make-suggest "REDUCE" (forall (key val b) ((lambda (pair (pair key val) b) b) (map key val) b))) + (michelson-make-suggest "REDUCE" (forall (a b) ((lambda (pair a b) b) (list a) b))) + + +)) + +;; Special handling +;; PA+IR + + +(defun michelson-get-suggestion-list (stack) + (lexical-let ((stack stack)) + (reduce (lambda (func acc) (append (funcall func stack) acc)) + michelson-type-completion-list + :from-end t + :initial-value michelson-suggest-always-available))) + (defun michelson-toggle-live-editing () "Toggle `michelson-live-editing'. @@ -482,6 +807,7 @@ Enables or disables stack and error display." (kill-buffer-and-window))) (setq michelson-live-editing (not michelson-live-editing))) + (defun michelson-update-minibuffer-info () (when (nth 2 michelson-state) (cancel-timer (nth 2 michelson-state))) @@ -531,8 +857,12 @@ Enables or disables stack and error display." (setq indent-tabs-mode nil) (setq show-trailing-whitespace t) (setq buffer-file-coding-system 'utf-8-unix) + (add-hook 'completion-at-point-functions 'michelson-completion-at-point nil 'local) + (setq-local company-backends '(company-capf)) + (setq-local process-environment (cons "ALPHANET_EMACS=true" + (cons "TEZOS_ALPHANET_DO_NOT_PULL=yes" + process-environment))) (run-hooks 'michelson-mode-hook)) - (add-to-list 'auto-mode-alist '("\\.tz\\'" . michelson-mode)) (add-to-list 'auto-mode-alist '("\\.tez\\'" . michelson-mode)) diff --git a/src/client/embedded/alpha/client_proto_programs.ml b/src/client/embedded/alpha/client_proto_programs.ml index 6da20d936..f79176064 100644 --- a/src/client/embedded/alpha/client_proto_programs.ml +++ b/src/client/embedded/alpha/client_proto_programs.ml @@ -45,18 +45,18 @@ let print_location_mark ppf = function let no_locations _ = None -let rec print_expr_unwrapped locations ppf = function +let rec print_expr_unwrapped_help emacs locations ppf = function | Script.Prim (loc, name, []) -> begin match locations loc with | None -> Format.fprintf ppf "%s" name | Some _ as l -> Format.fprintf ppf "(%s%a)" name print_location_mark l end | Script.Prim (loc, name, args) -> - Format.fprintf ppf "@[%s%a@ %a@]" + Format.fprintf ppf (if emacs then "%s%a %a" else "@[%s%a@ %a@]") name print_location_mark (locations loc) (Format.pp_print_list ~pp_sep: Format.pp_print_space - (print_expr locations)) + (print_expr_help emacs locations)) args | Script.Seq (loc, []) -> begin match locations loc with @@ -71,30 +71,37 @@ let rec print_expr_unwrapped locations ppf = function Format.fprintf ppf "%a@] }" (Format.pp_print_list ~pp_sep: (fun ppf () -> Format.fprintf ppf " ;@ ") - (print_expr_unwrapped locations)) + (print_expr_unwrapped_help emacs locations)) exprs | Script.Int (loc, n) -> Format.fprintf ppf "%s%a" n print_location_mark (locations loc) | Script.String (loc, s) -> Format.fprintf ppf "%S%a" s print_location_mark (locations loc) -and print_expr locations ppf = function +and print_expr_help emacs locations ppf = function | Script.Prim (_, _, _ :: _) as expr -> - Format.fprintf ppf "(%a)" (print_expr_unwrapped locations) expr - | expr -> print_expr_unwrapped locations ppf expr + Format.fprintf ppf "(%a)" (print_expr_unwrapped_help emacs locations) expr + | expr -> print_expr_unwrapped_help emacs locations ppf expr + +let print_expr_unwrapped = print_expr_unwrapped_help false +let print_expr = print_expr_help false let print_storage ppf ({ storage } : Script.storage) = print_expr no_locations ppf storage -let print_stack ppf = function - | [] -> Format.fprintf ppf "[]" +let print_stack_help emacs ppf = function + | [] -> Format.fprintf ppf (if emacs then "()" else "[]") | more -> - Format.fprintf ppf "@[[ %a ]@]" + Format.fprintf ppf (if emacs then "(%a)" else "@[[ %a ]@]") (Format.pp_print_list - ~pp_sep: (fun ppf () -> Format.fprintf ppf " :@ ") - (print_expr_unwrapped no_locations)) + ~pp_sep: (fun ppf () -> Format.fprintf ppf (if emacs then "@ " else " :@ ")) + ((if emacs then print_expr else print_expr_unwrapped) no_locations)) more +let print_stack = print_stack_help false + +let print_emacs_stack = print_stack_help true + let print_typed_code locations ppf (expr, type_map) = let rec print_typed_code_unwrapped ppf expr = match expr with @@ -736,17 +743,13 @@ let commands () = | _ -> Lwt.return ([], []) end >>= fun (types, errors) -> cctxt.message - "(@[(types . (@[%a@]))@,\ - (errors . (@[%a@])))@]" + "((types . (%a)) (errors . (%a)))" (Format.pp_print_list (fun ppf (({ Script_located_ir.point = s }, { Script_located_ir.point = e }), bef, aft) -> - Format.fprintf ppf "(%d %d \"%s\")" (s + 1) (e + 1) - (String.concat "\\n" - (String.split_on_char '\n' - (Format.asprintf "@[%a@, \\u2B87@,%a@]" - print_stack bef print_stack aft))))) + Format.fprintf ppf "(%d %d %a %a)" (s + 1) (e + 1) + print_emacs_stack bef print_emacs_stack aft)) types (Format.pp_print_list (fun ppf (({ Script_located_ir.point = s },