#+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
#+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
(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
(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)))
(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."
;; (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'."
(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."
(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."
(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.")
"-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
(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."
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)
(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)
(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))
(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
"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.")
(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
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))
(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
")"))
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)
")"))
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
((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
projects / dotfiles.git / commitdiff