From: Eshel Yaron Date: Fri, 12 Aug 2022 08:44:10 +0000 (+0300) Subject: Checkpoint X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=ad005476114dda7b10c0883750d43b3078c94197;p=dotfiles.git Checkpoint --- diff --git a/.emacs.d/esy.org b/.emacs.d/esy.org index 37858cc..3829307 100644 --- a/.emacs.d/esy.org +++ b/.emacs.d/esy.org @@ -1506,14 +1506,6 @@ include =emacs-lisp-mode= and =lisp-interaction-mode=. #+begin_src emacs-lisp (add-to-list 'auto-mode-alist '("\\.pl\\'" . iprolog-mode)) (add-to-list 'auto-mode-alist '("\\.plt\\'" . iprolog-mode)) - - (defun esy/setup-prolog () - "Setup `prolog-mode' and more Prolog-related settings." - (add-hook 'flymake-diagnostic-functions #'prolog-project--checker nil t) - (setq-local eldoc-documentation-strategy #'eldoc-documentation-default) - (add-hook 'eldoc-documentation-functions #'prolog-project-predicate-modes-doc nil t)) - - (add-hook 'prolog-mode-hook #'esy/setup-prolog) #+end_src *** Make =rg= regard =.pl= files as Prolog rather than Perl @@ -1530,285 +1522,7 @@ include =emacs-lisp-mode= and =lisp-interaction-mode=. #+begin_src emacs-lisp (with-eval-after-load 'project - (add-hook 'project-find-functions #'project-try-prolog -10)) -#+end_src - -*** COMMENT Per project Prolog top-level history :hook: -:PROPERTIES: -:CUSTOM_ID: per-project-prolog-history -:CreatedAt: <2022-08-04 Thu> -:CapturedAt: -:CapturedAs: Emacs configuration fragment -:END: - -#+begin_src emacs-lisp - (defconst esy/prolog-input-ring-file-name ".prolog_history") - - (defun esy/on-prolog-exec () - "Setup the Prolog top-level process." - (when-let ((proc (get-buffer-process (current-buffer)))) - (comint-read-input-ring t) - (set-process-sentinel proc #'esy/prolog-sentinel))) - - (defun esy/prolog-sentinel (_proc _) - (comint-write-input-ring)) - - (defun esy/setup-project-prolog-history () - "Setup per-project Prolog top-level history." - (when-let ((project (project-current))) - (setq comint-input-ring-file-name (expand-file-name esy/prolog-input-ring-file-name (project-root project)) - comint-input-ignoredups t) - (esy/on-prolog-exec) - (add-hook 'kill-buffer-hook #'comint-write-input-ring nil t) - (add-hook 'comint-exec-hook #'esy/on-prolog-exec nil t))) - - (add-hook 'prolog-inferior-mode-hook #'esy/setup-project-prolog-history) -#+end_src - -*** COMMENT Treat SWI-Prolog packages as =project.el= projects :prolog: -:PROPERTIES: -:CUSTOM_ID: swi-prolog-pack -:CreatedAt: <2022-08-05 Fri> -:CapturedAt: -:CapturedAs: Emacs configuration fragment -:END: - -#+begin_src emacs-lisp - (require 'comint) - (require 'project) - - (defcustom swi-prolog-program "swipl" - "The SWI-Prolog executable." - :type 'string - :group 'prolog) - - (defvar swi-prolog-project-buffer-alist nil) - - (defun swi-prolog-execute-to-string (goal) - (shell-command-to-string (concat - swi-prolog-program - " -g " - (prin1-to-string (substring-no-properties goal)) - " -t halt"))) - - (defvar-local swi-prolog-top-level-captured-output nil) - - (defvar-local swi-prolog-top-level-capture-flag nil) - - (defun swi-prolog-top-level-capture-output (s) - (if swi-prolog-top-level-capture-flag - (progn - (setq swi-prolog-top-level-captured-output (concat swi-prolog-top-level-captured-output s)) - (when (string-search "\f" s) - (setq swi-prolog-top-level-captured-output (car (split-string swi-prolog-top-level-captured-output page-delimiter))) - (setq swi-prolog-top-level-capture-flag nil)) - "") - s)) - - - (defun swi-prolog-top-level-capture (goal) - "Execute GOAL and return its entire output as a string." - (interactive "M?- ") - (when-let ((default-directory (swi-prolog-pack-root))) - (swi-prolog-ensure-project-top-level) - (with-current-buffer (swi-prolog-project-top-level-buffer) - (let ((proc (get-buffer-process (current-buffer)))) - (setq swi-prolog-top-level-capture-flag t) - (comint-send-string proc (concat "catch(ignore(notrace((" goal "))), _, _), put_code(12), flush_output.\n")) - (accept-process-output proc) - (while swi-prolog-top-level-capture-flag - (accept-process-output proc)) - (let ((output swi-prolog-top-level-captured-output)) - (setq swi-prolog-top-level-captured-output nil) - output))))) - - (defun swi-prolog-atom-boundaries-at-point () - (let ((case-fold-search nil)) - (save-excursion - (backward-char) - (while (looking-at "[[:alnum:]_]" t) - (backward-char)) - (forward-char) - (when (looking-at "[[:lower:]]" t) - (let ((start (point))) - (while (looking-at "[[:alnum:]_]" t) - (forward-char)) - (cons start (point))))))) - - (defun swi-prolog-predicate-definition (p) - (let ((goal (concat - "pi_head((" - p - "), P), predicate_property(P, file(F)), predicate_property(P, line_count(L)), writeln(F:L)"))) - (let* ((loc (car (string-lines (swi-prolog-top-level-capture goal)))) - (spl (split-string loc ":")) - (file (car spl)) - (line (cadr spl))) - (when line - (cons file (string-to-number line)))))) - - ; (let* ((c (swi-prolog-predicate-definition "member/2")) (f (car c)) (l (cdr c))) (find-file f) (goto-line l)) - - (defun swi-prolog-current-atoms (s) - (let ((goal (concat - "forall((current_atom(A),atom_string(A, S),once(sub_string(S,_,_,_," - (prin1-to-string s) - ")), re_match(\"^[[:lower:]][[:alnum:]_]+$\",S)),writeln(A))"))) - (string-lines (swi-prolog-top-level-capture goal)))) - - (defun swi-prolog-atom-completion-at-point-function () - (when-let ((default-directory (swi-prolog-pack-root))) - (swi-prolog-ensure-project-top-level) - (when-let ((bounds (swi-prolog-atom-boundaries-at-point))) - (let ((start (car bounds)) - (end (cdr bounds))) - (list start end (completion-table-with-cache #'swi-prolog-current-atoms) :exclusive 'no))))) - - (defun swi-prolog-read-current-atom () - (when-let ((default-directory (swi-prolog-pack-root))) - (swi-prolog-ensure-project-top-level) - (completing-read "current_atom(A), A = " (completion-table-with-cache #'swi-prolog-current-atoms)))) - - (defun swi-prolog-atom-at-point () - (when-let ((bounds (swi-prolog-atom-boundaries-at-point))) - (let ((start (car bounds)) - (end (cdr bounds))) - (buffer-substring-no-properties start end)))) - - (defun swi-prolog-project-top-level-buffer () - "." - (alist-get default-directory swi-prolog-project-buffer-alist nil nil #'string=)) - - (defun swi-prolog-pack-root () - "." - (when-let ((proj (project-current))) - (when (eq 'swi-prolog-pack (car proj)) - (project-root proj)))) - - (defconst swi-prolog-top-level-input-ring-file-name ".swipl_history") - - (defun swi-prolog-project-top-level () - "Run a SWI-Prolog top-level." - (interactive) - (when-let ((default-directory (swi-prolog-pack-root))) - (swi-prolog-ensure-project-top-level) - (switch-to-buffer-other-window (swi-prolog-project-top-level-buffer)))) - - (defun swi-prolog-ensure-project-top-level () - (if-let ((buffer (swi-prolog-project-top-level-buffer))) - (swi-prolog-ensure-buffer-top-level buffer) - (setq swi-prolog-project-buffer-alist - (cons - (cons - default-directory - (swi-prolog-create-project-top-level)) - swi-prolog-project-buffer-alist)))) - - (defun swi-prolog-ensure-buffer-top-level (buffer) - (if (buffer-live-p buffer) - (unless (process-live-p (get-buffer-process buffer)) - (make-comint-in-buffer "swi-prolog" buffer swi-prolog-program)) - (setf - (alist-get default-directory swi-prolog-project-buffer-alist nil 'remove #'string=) - (swi-prolog-create-project-top-level)))) - - (defun swi-prolog-create-project-top-level () - (with-current-buffer (generate-new-buffer "swipl") - (swi-prolog-project-top-level-mode) - (make-comint-in-buffer "swi-prolog" (current-buffer) swi-prolog-program))) - - - (defun swi-prolog-project-top-level-on-exec () - "Setup the Prolog top-level process." - (when-let ((proc (get-buffer-process (current-buffer)))) - (set-process-sentinel proc (lambda (p _) (comint-write-input-ring))))) - - (defvar swi-prolog-project-top-level-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [remap self-insert-command] - #'swi-prolog-project-top-level-self-insert-command) - map)) - - (defun swi-prolog-project-top-level-self-insert-command () - "Insert the char in the buffer or pass it directly to the process." - (interactive) - (when-let ((pend (cdr comint-last-prompt))) - (let* ((pstart (car comint-last-prompt)) - (prompt (buffer-substring-no-properties pstart pend))) - (if (and (= (point) pend) - (not (string= "?- " (substring prompt (- pend pstart 3) (- pend pstart)))) - (not (string= "| " prompt))) - (progn - (call-interactively #'self-insert-command) - (comint-send-input)) - (call-interactively #'self-insert-command))))) - - (define-derived-mode swi-prolog-project-top-level-mode comint-mode "SWI-Prolog Project Top-level" - "Major mode for interacting with an inferior SWI-Prolog process." - :group 'swi-prolog-project-top-level - (setq mode-line-process (list ":" - (swi-prolog-pack-name) - ":%s") - comint-prompt-regexp (rx (seq line-start "?- ")) - comint-input-ring-file-name (expand-file-name - swi-prolog-top-level-input-ring-file-name - default-directory) - comint-input-ignoredups t - comint-prompt-read-only t - comint-delimiter-argument-list '(?,) - comint-input-filter (lambda (s) (< 3 (length s)))) - (comint-read-input-ring t) - (add-hook 'completion-at-point-functions #'swi-prolog-atom-completion-at-point-function -10 t) - (add-hook 'kill-buffer-hook #'comint-write-input-ring nil t) - (add-hook 'comint-preoutput-filter-functions #'swi-prolog-top-level-capture-output nil t) - (add-hook 'comint-exec-hook #'swi-prolog-project-top-level-on-exec nil t)) - - (defun swi-prolog-pack-project-try-prolog-pack (dir) - (when dir - (unless (file-remote-p dir) - (if (file-exists-p (expand-file-name "pack.pl" dir)) - (let ((root (string-replace (expand-file-name "~") "~" (file-name-as-directory dir)))) - (cons 'swi-prolog-pack root)) - (let ((parent (file-name-directory (directory-file-name dir)))) - (unless (string= parent dir) - (swi-prolog-pack-project-try-prolog-pack parent))))))) - - (cl-defmethod project-root ((project (head swi-prolog-pack))) - "Return the root of the SWI-Prolog pack corresponding to PROJECT." - (cdr project)) - - (add-hook 'project-find-functions #'swi-prolog-pack-project-try - - (defun swi-prolog-pack-name () - "Return the name of the current SWI-Prolog pack." - (let ((default-directory (project-root (project-current)))) - (swi-prolog-execute-to-string "consult(pack), name(N), write(N)"))) - - (defun swi-prolog-pack-version () - "Return the version of the current SWI-Prolog pack, as a string." - (let ((default-directory (project-root (project-current)))) - (swi-prolog-execute-to-string "consult(pack), vesrion(N), write(N)"))) - - (defun swi-prolog-pack-make-tags () - "Create or update the TAGS file for the current SWI-Prolog pack." - (interactive) - (let* ((default-directory (project-root (project-current))) - (tags-file (expand-file-name "TAGS" default-directory)) - (proc (start-process "swi-prolog-etags" nil xargs-program "etags" "--language=prolog"))) - (dolist (file - (append - (directory-files-recursively - (swi-prolog-execute-to-string - "absolute_file_name(library(.), V), write(V)") - "\\.pl$") - (directory-files-recursively - (expand-file-name "prolog" default-directory) - "\\.pl$"))) - (process-send-string proc file) - (process-send-string proc "\n")) - (process-send-eof proc) - (while (process-live-p proc)) - (visit-tags-table tags-file t))) + (add-hook 'project-find-functions #'project-try-iprolog -10)) #+end_src * LaTeX and PDF settings @@ -2171,6 +1885,38 @@ Add the timezones of places of interest to the list of clocks shown by (repeat-mode) #+end_src +** Predefined SQL connections +:PROPERTIES: +:CUSTOM_ID: predefined-sql-connections +:CreatedAt: <2022-08-11 Thu> +:CapturedAt: [[file:~/tmp/foo.el]] +:CapturedAs: Emacs configuration fragment +:END: + +#+begin_src emacs-lisp + (with-eval-after-load 'sql + (setq sql-connection-alist + (let* ((a (auth-source-search :port 5432 + :max 2 + :require '(:user :port :secret :host))) + (d (car a)) + (p (cadr a))) + `((dev + (sql-product 'postgres) + (sql-user ,(plist-get d :user)) + (sql-port 5432) + (sql-password ,(funcall (plist-get d :secret))) + (sql-server ,(plist-get d :host)) + (sql-database "alerts")) + (prod + (sql-product 'postgres) + (sql-user ,(plist-get p :user)) + (sql-port 5432) + (sql-password ,(funcall (plist-get p :secret))) + (sql-server ,(plist-get p :host)) + (sql-database "alerts")))))) +#+end_src + * Elisp Footer :PROPERTIES: :CUSTOM_ID: footer diff --git a/.emacs.d/lisp/iprolog.el b/.emacs.d/lisp/iprolog.el index ee4e37b..f34da5f 100644 --- a/.emacs.d/lisp/iprolog.el +++ b/.emacs.d/lisp/iprolog.el @@ -25,41 +25,84 @@ (defcustom iprolog-program "swipl" "The Prolog executable." + :package-version '((iprolog . "0.1.0")) + ;; :link '(custom-manual "(iprolog)Top") :type 'string - :group 'iprolog) - -(defcustom iprolog-beginning-of-term-regexp - (rx (seq line-start - (not (or "%" "/" " " "\t")) - (not (or "%" "/" " " "\t")))) - "Regular expression matching the beginning of top Prolog terms." - :type 'regexp + :risky t :group 'iprolog) (defcustom iprolog-project-definition-file-name "pack.pl" "File name for Prolog project definitions." + :package-version '((iprolog . "0.1.0")) :type 'string :group 'iprolog) -(defun iprolog-beginning-of-term (&optional n) - "Move to the beginning of the current term. -If already at the beginning of a term, move to previous term. - -With numeric prefix argument N, move this many terms backward." - (interactive "p" nil iprolog-mode) - (let ((times (or n 1))) - (while (< 0 times) - (search-backward-regexp iprolog-beginning-of-term-regexp nil t) - (beginning-of-line) - (setq times (1- times))))) - -(defun iprolog-beginning-of-next-term () - "Move to the beginning of the next term." - (interactive nil iprolog-mode) - (goto-char (1+ (line-beginning-position))) - (or (search-forward-regexp iprolog-beginning-of-term-regexp nil t) - (goto-char (point-max))) - (beginning-of-line)) +(defun iprolog-beginning-of-defun-function (&optional arg) + "Backend for `beginning-of-defun', which see for the meaning of ARG." + (let ((times (or arg 1))) + (if (< times 0) + (iprolog-beginning-of-next-defun (- times)) + (while (< 0 times) + (goto-char (or (previous-single-property-change (point) 'iprolog-beginning-of-term) (point-min))) + (unless (bobp) (backward-char)) + (setq times (1- times)))))) + +(defun iprolog-end-of-defun-function () + "Backend for `end-of-defun'." + (iprolog-text-property--find-end-forward 'font-lock-face 'iprolog-fullstop-face)) + +(defun iprolog-beginning-of-next-defun (times) + (while (< 0 times) + (when (get-text-property (point) 'iprolog-beginning-of-term) + (forward-char)) + (goto-char (or (next-single-property-change (point) 'iprolog-beginning-of-term) (point-max))) + (setq times (1- times)))) + +(defun iprolog-text-property--find-beg-backward (property value) + (iprolog-text-property--find-end-backward property value) + (goto-char (or (previous-single-property-change (point) property) + (point-min)))) + +(defun iprolog-text-property--find-end-backward (property value) + (let ((go t)) + (while (and go (not (bobp))) + (backward-char) + (setq go (not (equal value + (get-text-property (point) property))))))) + + +(defun iprolog-text-property--find-beg-forward (property value) + (let ((go t)) + (while (and go (not (eobp))) + (forward-char) + (setq go (not (equal value + (get-text-property (point) property))))))) + +(defun iprolog-text-property--find-end-forward (property value) + (iprolog-text-property--find-beg-forward property value) + (goto-char (or (next-single-property-change (point) property) + (point-max)))) + + +;; (defun iprolog-beginning-of-term (&optional n) +;; "Move to the beginning of the current term. +;; If already at the beginning of a term, move to previous term. + +;; With numeric prefix argument N, move this many terms backward." +;; (interactive "p" nil iprolog-mode) +;; (let ((times (or n 1))) +;; (while (< 0 times) +;; (search-backward-regexp iprolog-beginning-of-term-regexp nil t) +;; (beginning-of-line) +;; (setq times (1- times))))) + +;; (defun iprolog-beginning-of-next-term () +;; "Move to the beginning of the next term." +;; (interactive nil iprolog-mode) +;; (goto-char (1+ (line-beginning-position))) +;; (or (search-forward-regexp iprolog-beginning-of-term-regexp nil t) +;; (goto-char (point-max))) +;; (beginning-of-line)) (defun iprolog--atom-at-point () (when-let ((bounds (iprolog--atom-boundaries-at-point))) @@ -82,47 +125,64 @@ With numeric prefix argument N, move this many terms backward." (cons start (point)))))))) (defun iprolog-save-and-load-buffer () + "Save this buffer and load it into the current Prolog session." (interactive nil iprolog-mode) (save-buffer) - (iprolog--request-goal-output (concat "[\"" + (iprolog--request-goal-output (concat "ensure_loaded(\"" (buffer-file-name) - "\"]") + "\")") (lambda (_) (message "iprolog: buffer loaded.")))) -(defun iprolog-eval-dwim (&optional insert) - (interactive "P" iprolog-mode) - (if (region-active-p) - (iprolog-eval-region (region-beginning) (region-end)) - (save-mark-and-excursion - (save-match-data - (iprolog-beginning-of-next-term) - (let ((end (point))) - (iprolog-beginning-of-term) - (iprolog-eval-region (point) end insert)))))) - -(defun iprolog-eval-region (beg end &optional insert) - (interactive "r\nP" iprolog-mode) - (let ((goal (buffer-substring-no-properties beg end)) - (default-directory (or (iprolog-project--root) - default-directory))) - (iprolog--ensure-top-level) - (iprolog--request-goal-output goal - (if insert - (lambda (o) - (message "iprolog: inserting output.") - (newline) - (insert o)) - (lambda (o) - (message "iprolog: received output %s" o)))))) +;; (defun iprolog-eval-dwim (&optional insert) +;; (interactive "P" iprolog-mode) +;; (if (region-active-p) +;; (iprolog-eval-region (region-beginning) (region-end)) +;; (save-mark-and-excursion +;; (save-match-data +;; (iprolog-beginning-of-next-term) +;; (let ((end (point))) +;; (iprolog-beginning-of-term) +;; (iprolog-eval-region (point) end insert)))))) + +;; (defun iprolog-eval-region (beg end &optional insert) +;; (interactive "r\nP" iprolog-mode) +;; (let ((goal (buffer-substring-no-properties beg end)) +;; (default-directory (or (iprolog-project--root) +;; default-directory))) +;; (iprolog--ensure-top-level) +;; (iprolog--request-goal-output goal +;; (if insert +;; (lambda (o) +;; (message "iprolog: inserting output.") +;; (newline) +;; (insert o)) +;; (lambda (o) +;; (message "iprolog: received output %s" o)))))) (defvar-keymap iprolog-mode-map :doc "Keymap for `iprolog-mode'." - "M-a" #'iprolog-beginning-of-term - "C-M-x" #'iprolog-eval-dwim + ;; "M-a" #'iprolog-beginning-of-term + ;; "C-M-x" #'iprolog-eval-dwim "C-c C-t" #'iprolog-top-level "C-c C-l" #'iprolog-save-and-load-buffer) +(defvar iprolog-mode-syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?_ "_" table) + (modify-syntax-entry ?+ "." table) + (modify-syntax-entry ?- "." table) + (modify-syntax-entry ?= "." table) + (modify-syntax-entry ?< "." table) + (modify-syntax-entry ?> "." table) + (modify-syntax-entry ?| "." table) + (modify-syntax-entry ?\' "\"" table) + (modify-syntax-entry ?% "<" table) + (modify-syntax-entry ?\n ">" table) + (modify-syntax-entry ?* ". 23b" table) + (modify-syntax-entry ?/ ". 14" table) + table)) + ;;;###autoload (define-derived-mode iprolog-mode prog-mode "iprolog" "Major mode for editing Prolog code." @@ -138,26 +198,23 @@ With numeric prefix argument N, move this many terms backward." ;; (setq-local electric-indent-chars ...) ;; (setq-local align-rules-alist ...) ;; (setq-local imenu-create-index-function ...) - (setq jit-lock-chunk-size 8192) + ;; (setq-local indent-line-function ...) + ;; (setq-local indent-region-function ...) + ;; (setq jit-lock-chunk-size 8192) + (setq-local beginning-of-defun-function #'iprolog-beginning-of-defun-function) + (setq-local end-of-defun-function #'iprolog-end-of-defun-function) (setq-local font-lock-defaults '(nil t nil nil - (font-lock-fontify-region-function . iprolog-fontify-region)))) + (font-lock-fontify-region-function . iprolog-fontify-region) + (font-lock-extra-managed-props (iprolog-beginning-of-term))))) ;;;; project.el integration -(defun iprolog--execute-to-string (goal) - "Run Prolog with initial goal GOAL and return its output as a string." - (shell-command-to-string (concat - iprolog-program - " -g " - (prin1-to-string (substring-no-properties goal)) - " -t halt"))) - ;;;###autoload -(defun project-try-prolog (dir) +(defun project-try-iprolog (dir) "Find a Prolog project definition file in DIR or a parent thereof. Prolog project definition files are identified according to the value of `iprolog-project-definition-file-name'." @@ -170,7 +227,15 @@ value of `iprolog-project-definition-file-name'." (cons 'iprolog-project root)) (let ((parent (file-name-directory (directory-file-name dir)))) (unless (string= parent dir) - (project-try-prolog parent))))))) + (project-try-iprolog parent))))))) + +(defun iprolog--execute-to-string (goal) + "Call the Prolog goal GOAL and return its output as a string." + (shell-command-to-string (concat + iprolog-program + " -g " + (prin1-to-string (substring-no-properties goal)) + " -t halt"))) (cl-defmethod project-root ((project (head iprolog-project))) "Return the root of the Prolog project PROJECT." @@ -179,8 +244,7 @@ value of `iprolog-project-definition-file-name'." (defun iprolog-project--root () "Return the root directory of the current Prolog project." (when-let ((proj (project-current))) - (when (eq 'iprolog-project (car proj)) - (project-root proj)))) + (project-root proj))) (defun iprolog-project--name () "Return the name of the current Prolog project." @@ -198,9 +262,6 @@ value of `iprolog-project-definition-file-name'." (defvar iprolog--top-level-buffers-alist nil "Global mapping between directories and Prolog top-level buffers.") -(defvar-local iprolog-top-level--capture-flag nil - "Non-nil means we are currently capturing process output.") - (defvar-local iprolog-top-level--captured-output nil "Accumulated captured process output.") @@ -276,7 +337,7 @@ Also start a Prolog server listening on UDP port PORT." "-g" "[library(pldoc/doc_man)]" "-g" "[library(lynx/html_text)]" "-g" "[library(diagnostics)]" - "-g" (concat "thread_create((udp_socket(Socket), tcp_bind(Socket," (number-to-string port) "), tcp_setopt(Socket, sndbuf(65535)), repeat, (catch(udp_receive(Socket, Data, Peer, [as(term),encoding(utf8)]), Ball, (debug(iprolog, \"Caught ~q.\", [Ball]), fail)), debug(iprolog, \"Got ~p from ~q.\", [Data, Peer]), Data = (Id :- Goal) -> debug(iprolog, \"Executing goal ~w.\", [Goal]), catch(with_output_to(string(Output), ignore(Goal)), GBall, (debug(iprolog, \"Ball ~q thrown during goal execution.\", [GBall]), fail)), string_concat(Id, \" :- \", Prefix), string_length(Output, Length), phrase(helper(Output, Length, 49152), Replies), forall(member(Reply0, Replies), (string_concat(Prefix, Reply0, Reply), udp_send(Socket, Reply, Peer, [encoding(utf8)]), debug(iprolog, \"Sending reply ~w.\", [Reply]))) ; debug(iprolog, \"udp_receive failed.\", [])), fail), _, [])") + "-g" (concat "thread_create((udp_socket(Socket), tcp_bind(Socket," (number-to-string port) "), tcp_setopt(Socket, sndbuf(65535)), repeat, (catch(udp_receive(Socket, Data, Peer, [as(term),encoding(utf8)]), Ball, (debug(iprolog, \"Caught ~q.\", [Ball]), fail)), debug(iprolog, \"Got ~p from ~q.\", [Data, Peer]), Data = (Id :- Goal) -> debug(iprolog, \"Executing goal ~w.\", [Goal]), catch(with_output_to(string(Output), ignore(Goal)), GBall, (debug(iprolog, \"Ball ~q thrown during goal execution.\", [GBall]), fail)), string_concat(Id, \" :- \", Prefix), string_length(Output, Length), phrase(helper(Output, Length, 49152), Replies), forall(member(Reply0, Replies), (string_concat(Prefix, Reply0, Reply), udp_send(Socket, Reply, Peer, [encoding(utf8)]))) ; debug(iprolog, \"udp_receive failed.\", [])), fail), _, [])") "-t" "prolog") (setq iprolog--helper-connection (make-network-process @@ -386,48 +447,6 @@ Also start a Prolog server listening on UDP port PORT." (set-window-dedicated-p (selected-window) t) (goto-char (point-max)))) -(defun iprolog-top-level--capture-output (output) - "When `iprolog-top-level--capture-flag' in non-nil, capture OUTPUT." - (pcase iprolog-top-level--capture-flag - ('t - (setq iprolog-top-level--captured-output - (concat iprolog-top-level--captured-output output)) - (when-let ((endpos (string-search "\f" output))) - (setq iprolog-top-level--captured-output - (car (split-string iprolog-top-level--captured-output - "\f"))) - (setq iprolog-top-level--capture-flag - (let ((promptpos (string-search "?- " output)) - (temppos nil)) - (while promptpos - (setq temppos (1+ promptpos)) - (setq promptpos (string-search "?- " output temppos))) - (unless (and temppos (< endpos temppos)) - 'prompt)))) - "") - ('prompt - (when (string-search "?- " output) - (setq iprolog-top-level--capture-flag nil)) - "") - (`(callback ,cb ,f) - (if-let ((endpos (string-search "\f" output))) - (let ((data (car (split-string - output - "\f")))) - (funcall cb data) - (funcall f) - (setq iprolog-top-level--capture-flag - (let ((promptpos (string-search "?- " output)) - (temppos nil)) - (while promptpos - (setq temppos (1+ promptpos)) - (setq promptpos (string-search "?- " output temppos))) - (unless (and temppos (< endpos temppos)) - 'prompt)))) - (funcall cb output)) - "") - (_ output))) - ;;;###autoload (define-derived-mode iprolog-top-level-mode comint-mode "iprolog Top-level" "Major mode for interacting with an inferior Prolog interpreter." @@ -446,7 +465,7 @@ Also start a Prolog server listening on UDP port PORT." comint-delimiter-argument-list '(?,) comint-input-filter (lambda (s) (< 3 (length s)))) (comint-read-input-ring t) - (add-hook 'comint-preoutput-filter-functions #'iprolog-top-level--capture-output nil t) + ;; (add-hook 'comint-preoutput-filter-functions ...) (add-hook 'comint-exec-hook #'iprolog-top-level--on-exec nil t) (setq read-process-output-max 49152) (add-hook 'kill-buffer-hook #'comint-write-input-ring nil t) @@ -455,17 +474,6 @@ Also start a Prolog server listening on UDP port PORT." (add-hook 'eldoc-documentation-functions #'iprolog-predicate-modes-doc -10 t)) -;; (defun iprolog-execute-goal-with-callback (goal cb f) -;; "Execute GOAL, setting up CB to handle its output and F its exit." -;; (when-let ((default-directory (iprolog-project--root))) -;; (iprolog--ensure-top-level) -;; (with-current-buffer (iprolog--top-level-buffer) -;; (let ((proc (get-buffer-process (current-buffer)))) -;; (while iprolog-top-level--capture-flag -;; (accept-process-output proc 10)) -;; (setq iprolog-top-level--capture-flag (list 'callback cb f)) -;; (comint-send-string proc (concat "catch(ignore(notrace((" goal "))), _, _), put_code(12), flush_output.\n")))))) - ;;;; flymake integration (defun iprolog--parse-diagnostic (line start) @@ -500,13 +508,13 @@ as documented in `flymake-diagnostic-functions', ARGS" (save-mark-and-excursion (save-match-data (goto-char pos) - (iprolog-beginning-of-next-term) + (end-of-defun) (point))))) (start (if-let ((pos (plist-get args :changes-start))) (save-mark-and-excursion (save-match-data (goto-char pos) - (iprolog-beginning-of-term) + (beginning-of-defun-comments) (point))) (point-min))) (buffer (current-buffer)) @@ -514,7 +522,7 @@ as documented in `flymake-diagnostic-functions', ARGS" (with-temp-file tempfile (insert-buffer-substring buffer start end)) (iprolog--request-goal-output - (concat "'" (buffer-file-name buffer) "' = Path, [Path], diagnose(Path,'" tempfile "')") + (concat "'" (buffer-file-name buffer) "' = Path, catch([Path], _, true), diagnose(Path,'" tempfile "')") (if end (lambda (o) (with-current-buffer buffer @@ -587,99 +595,80 @@ explanation about the argument CALLBACK." "Faces used to highlight Prolog code." :group 'iprolog) -(defvar iprolog-functor-face 'iprolog-functor-face - "Name of face used to highlight the functor in predicate indicators.") +(eval-when-compile + (defmacro iprolog-defface (name def doc) + "Define iprolog face FACE with doc DOC." + (declare + (indent defun) + (doc-string 3)) + (let ((face (intern (concat "iprolog-" (symbol-name name) "-face")))) + `(progn + (defface ,face + '((default :inherit ,def)) + ,(concat "Face used to highlight " (downcase doc)) + :group 'iprolog-faces) + (defvar ,face ',face + ,(concat "Name of the face used to highlight " (downcase doc))))))) + +(iprolog-defface functor font-lock-function-name-face + "Functors.") -(defface iprolog-functor-face - '((default :inherit font-lock-function-name-face)) - "Face used to highlight the functor in predicate indicators." - :group 'iprolog-faces) +(iprolog-defface arity font-lock-function-name-face + "Arities.") -(defvar iprolog-arity-face 'iprolog-arity-face - "Name of face used to highlight the arity in predicate indicators.") +(iprolog-defface predicate-indicator font-lock-function-name-face + "Predicate indicators.") -(defface iprolog-arity-face - '((default :inherit font-lock-function-name-face)) - "Face used to highlight the arity in predicate indicators." - :group 'iprolog-faces) +(iprolog-defface built-in font-lock-keyword-face + "Built in predicate calls.") -(defvar iprolog-predicate-indicator-face 'iprolog-predicate-indicator-face - "Name of face used to highlight the '/' in predicate indicators.") +(iprolog-defface neck font-lock-preprocessor-face + "Necks.") -(defface iprolog-predicate-indicator-face - '((default :inherit font-lock-function-name-face)) - "Face used to highlight the '/' in predicate indicators." - :group 'iprolog-faces) +(iprolog-defface goal font-lock-function-name-face + "Unspecified predicate goals.") -(defvar iprolog-built-in-face 'iprolog-built-in-face - "Name of face used to highlight calls to built-ins in Prolog code.") +(iprolog-defface string font-lock-string-face + "Strings.") -(defface iprolog-built-in-face - '((default :inherit font-lock-keyword-face)) - "Face used to highlight calls to built-ins in Prolog code." - :group 'iprolog-faces) +(iprolog-defface comment font-lock-comment-face + "Comments.") -(defvar iprolog-neck-face 'iprolog-neck-face - "Name of face used to highlight necks in Prolog code.") +(iprolog-defface head font-lock-builtin-face + "Heads.") -(defface iprolog-neck-face - '((default :inherit font-lock-preprocessor-face)) - "Face used to highlight necks in Prolog code." - :group 'iprolog-faces) +(iprolog-defface recursion font-lock-builtin-face + "Recursive calls.") -(defvar iprolog-goal-face 'iprolog-goal-face - "Name of face used to highlight body goals in Prolog code.") +(iprolog-defface foreign font-lock-keyword-face + "Foreign predicate calls.") -(defface iprolog-goal-face - '((default :inherit font-lock-function-name-face)) - "Face used to highlight body goals in Prolog code." - :group 'iprolog-faces) +(iprolog-defface meta font-lock-type-face + "Meta predicate calls.") -(defvar iprolog-string-face 'iprolog-string-face - "Name of face used to highlight strings in Prolog code.") +(iprolog-defface option-name font-lock-constant-face + "Option names.") -(defface iprolog-string-face - '((default :inherit font-lock-string-face)) - "Face used to highlight strings in Prolog code." - :group 'iprolog-faces) +(iprolog-defface flag-name font-lock-constant-face + "Flag names.") -(defvar iprolog-comment-face 'iprolog-comment-face - "Name of face used to highlight comments in Prolog code.") +(iprolog-defface qq-type font-lock-type-face + "Quasi-quotation types.") -(defface iprolog-comment-face - '((default :inherit font-lock-comment-face)) - "Face used to highlight comments in Prolog code." - :group 'iprolog-faces) +(iprolog-defface op-type font-lock-type-face + "Operator types.") -(defvar iprolog-head-face 'iprolog-head-face - "Name of face used to highlight head functors in Prolog code.") +(iprolog-defface dict-tag font-lock-constant-face + "Dict tags.") -(defface iprolog-head-face - '((default :inherit font-lock-builtin-face)) - "Face used to highlight head functors in Prolog code." - :group 'iprolog-faces) -(defvar iprolog-recursion-face 'iprolog-recursion-face - "Name of face used to highlight recursive calls in Prolog code.") +(iprolog-defface dict-key font-lock-keyword-face + "Dict keys.") -(defface iprolog-recursion-face - '((default :inherit font-lock-builtin-face)) - "Face used to highlight recursive calls in Prolog code." - :group 'iprolog-faces) +(iprolog-defface type-error font-lock-warning-face + "Type errors.") -(eval-when-compile - (defmacro iprolog-defface (name def doc) - "Define iprolog face FACE with doc DOC." - (declare - (indent defun) - (doc-string 3)) - (let ((face (intern (concat "iprolog-" (symbol-name name) "-face")))) - `(progn - (defface ,face - '((default :inherit ,def)) - ,(concat "Face used to highlight " (downcase doc)) - :group 'iprolog-faces) - (defvar ,face ',face - ,(concat "Name of the face used to highlight " (downcase doc))))))) +(iprolog-defface instantiation-error font-lock-warning-face + "Instantiation errors.") (iprolog-defface file button "File specifiers.") @@ -717,6 +706,9 @@ explanation about the argument CALLBACK." (iprolog-defface syntax-error error "Syntax errors.") +(iprolog-defface structured-comment font-lock-doc-face + "Structured comments.") + (defun iprolog--parse-fontification-line (line start) (when (string-match (rx (seq line-start @@ -735,12 +727,17 @@ explanation about the argument CALLBACK." end (cond ((string= type "clause") + (put-text-property beg (1+ beg) 'iprolog-beginning-of-term t) '(nil t)) ((string= type "directive") + (put-text-property beg (1+ beg) 'iprolog-beginning-of-term t) '(nil t)) ((string= type "grammar_rule") + (put-text-property beg (1+ beg) 'iprolog-beginning-of-term t) '(nil t)) ((string= type "comment(structured)") + (list iprolog-structured-comment-face t)) + ((string= type "comment(string)") (list iprolog-comment-face t)) ((string= type "comment(block)") (list iprolog-comment-face t)) @@ -750,12 +747,6 @@ explanation about the argument CALLBACK." (list iprolog-predicate-indicator-face nil)) ((string= type "arity") (list iprolog-arity-face nil)) - ;; ((string-match (rx (seq line-start - ;; "predicate_indicator(" - ;; (+ anychar) - ;; ")")) - ;; type nil t) - ;; (list font-lock-function-name-face nil)) ((string= type "functor") (list iprolog-functor-face nil)) ((string-match (rx (seq line-start @@ -779,6 +770,24 @@ explanation about the argument CALLBACK." ")")) type nil t) (list iprolog-recursion-face nil)) + ((string-match (rx (seq line-start + "goal(meta" + (+ anychar) + ")")) + type nil t) + (list iprolog-meta-face nil)) + ((string-match (rx (seq line-start + "goal(meta" + (+ anychar) + ")")) + type nil t) + (list iprolog-meta-face nil)) + ((string-match (rx (seq line-start + "goal(foreign" + (+ anychar) + ")")) + type nil t) + (list iprolog-foreign-face nil)) ((string-match (rx (seq line-start "goal(built_in" (+ anychar) @@ -791,6 +800,34 @@ explanation about the argument CALLBACK." ")")) type nil t) (list iprolog-goal-face nil)) + ((string= type "dict_tag") + (list iprolog-dict-tag-face nil)) + ((string= type "dict_key") + (list iprolog-dict-key-face nil)) + ((string= type "qq_type") + (list iprolog-qq-type-face nil)) + ((string= type "instantiation_error") + (list iprolog-instantiation-error-face nil)) + ((string-match (rx (seq line-start + "type_error(" + (+ anychar) + ")")) + type nil t) + (list iprolog-type-error-face nil)) + ((string-match (rx (seq line-start + "op_type(" + (+ anychar) + ")")) + type nil t) + (list iprolog-op-type-face nil)) + ((string-match (rx (seq line-start + "flag_name(" + (+ anychar) + ")")) + type nil t) + (list iprolog-goal-face nil)) + ((string= type "option_name") + (list iprolog-option-name-face nil)) ((string= type "comment(line)") (list iprolog-comment-face nil)) ((string-match (rx (seq line-start @@ -830,98 +867,50 @@ explanation about the argument CALLBACK." ((string= type "identifier") (list iprolog-identifier-face nil)))))))) -(defvar-local iprolog-fontified nil) (defun iprolog-fontify-region (beg0 end0 loudly) - (let ((beg1 beg0) - (end1 end0)) - (while - (let ((changed nil)) - (when (and (> beg1 (point-min)) - (get-text-property (1- beg1) 'font-lock-multiline)) - (setq changed t) - (setq beg1 (or (previous-single-property-change - beg1 'font-lock-multiline) - (point-min)))) - (let ((before-end (max (point-min) (1- end1))) - (new-end nil)) - (when (get-text-property before-end 'font-lock-multiline) - (setq new-end (or (text-property-any before-end (point-max) - 'font-lock-multiline nil) - (point-max))) - (when (/= new-end end1) - (setq changed t) - (setq end1 new-end)))) - changed)) - (let ((beg (if iprolog-fontified beg1 (point-min))) - (end (if iprolog-fontified end1 (point-max))) - (buffer (current-buffer)) - (default-directory (or (iprolog-project--root) - default-directory))) - (font-lock-unfontify-region beg end) - (iprolog--ensure-top-level) - (let* ((tempfile (make-temp-file - "iprolog--fontify" - nil - ".pl"))) - (with-temp-file tempfile - (insert-buffer-substring buffer beg end)) - (iprolog--request-goal-output - (concat "\"" - tempfile - "\"= Path, xref_source('" - (buffer-file-name buffer) - "'), setup_call_cleanup(prolog_open_source(Path, Stream), prolog_colourise_stream(Stream, Path, [T, S, L]>>format(\"~w:~w:~w~n\", [S,L,T])), prolog_close_source(Stream))") - (lambda (o) - (with-current-buffer buffer - (with-silent-modifications - (dolist (line (string-lines o t)) - (when-let ((f (iprolog--parse-fontification-line line beg))) - (let ((fs (car f)) - (fe (cadr f)) - (ff (caddr f)) - (fm (cadddr f))) - (if ff - (put-text-property fs fe 'font-lock-face ff) - ;; (remove-text-properties fs fe '(font-lock-face)) - ) - (when fm - (put-text-property fs fe 'font-lock-multiline t)))))) - (setq iprolog-fontified t)) - (delete-file tempfile)))) - (font-lock-fontify-keywords-region beg end loudly) - `(jit-lock-bounds ,beg . ,end)))) - - -(defun iprolog-fontify-window () - (let ((buffer (current-buffer)) + (let ((beg (save-excursion + (goto-char beg0) + (beginning-of-defun 2) + (point))) + (end (save-excursion + (goto-char end0) + (beginning-of-defun -2) + (point))) + (buffer (current-buffer)) (default-directory (or (iprolog-project--root) default-directory))) + (when loudly (message "fontifying %s-%s" beg end)) + (font-lock-unfontify-region beg end) (iprolog--ensure-top-level) - (let ((start (save-mark-and-excursion - (save-match-data - (goto-char (window-start)) - (iprolog-beginning-of-term) - (point)))) - (end (save-mark-and-excursion - (save-match-data - (goto-char (window-end)) - (iprolog-beginning-of-next-term) - (point)))) - (tempfile (make-temp-file "iprolog--fontify"))) + (let* ((tempfile (make-temp-file + "iprolog--fontify" + nil + ".pl"))) (with-temp-file tempfile - (insert-buffer-substring buffer start end)) + (insert-buffer-substring buffer beg end)) (iprolog--request-goal-output - (concat "\"" - tempfile - "\"= Path, xref_source(Path), setup_call_cleanup(prolog_open_source(Path, Stream), prolog_colourise_stream(Stream, Path, [T, S, L]>>format(\"~w:~w:~w~n\", [S,L,T])), prolog_close_source(Stream))") + (concat "\"" (buffer-file-name buffer) "\"= Orig," + "\"" tempfile "\"= Path," + "ensure_loaded(Orig), xref_source(Orig), (source_file_property(Orig, module(Module)) -> true ; Module = prolog_colour), debug(iprolog, \"fontifying ~w as ~w\", [Path, Module]), setup_call_cleanup(prolog_open_source(Path, Stream), @(prolog_colourise_stream(Stream, Orig, [T, S, L]>>format(\"~w:~w:~w~n\", [S,L,T])), Module), prolog_close_source(Stream))") (lambda (o) (with-current-buffer buffer - (dolist (line (string-lines o t)) - (when-let ((f (iprolog--parse-fontification-line line start))) - (let ((fs (car f)) - (fe (cadr f)) - (ff (caddr f))) - (add-face-text-property fs fe ff)))))))))) + (with-silent-modifications + (dolist (line (string-lines o t)) + (when-let ((f (iprolog--parse-fontification-line line beg))) + (let ((fs (car f)) + (fe (cadr f)) + (ff (caddr f)) + (fm (cadddr f))) + (if ff + (put-text-property fs fe 'font-lock-face ff) + ;; (remove-text-properties fs fe '(font-lock-face)) + ) + (when fm + (put-text-property fs fe 'font-lock-multiline t))))))) + (delete-file tempfile)))) + (font-lock-fontify-keywords-region beg end loudly) + `(jit-lock-bounds ,beg . ,end))) + ;;; iprolog.el ends here