ADDED: sweep-mode, a major mode for editing Prolog code

diff --git a/sweep.c b/sweep.c
index df6611c6296e0fbeef49a7c932c81968cb022e3d..e55496e15b5324a554abbc1181284e14b7421a3c 100644 (file)
--- a/sweep.c
+++ b/sweep.c
@@ -72,8 +72,7 @@ estring_to_pstring(emacs_env *eenv, emacs_value estring, term_t t) {
   int i = 0;
 
   if ((buf = estring_to_cstring(eenv, estring, &len)) == NULL) return -1;
-
-  i = PL_put_string_nchars(t, len - 1, buf);
+  i = PL_put_chars(t, PL_STRING|REP_UTF8, len - 1, buf);
   free(buf);
   return i;
 }

diff --git a/sweep.el b/sweep.el
index 42c00a0f7509544281fc56ef8e9d01a4f5d11c7c..ec94dd4f9fe2d41d0bd01d80c1f3a42cb19b6be1 100644 (file)
--- a/sweep.el
+++ b/sweep.el
@@ -553,6 +553,13 @@ module name, F is a functor name and N is its arity."
          (arg (cddr args)))
     (with-silent-modifications
       (pcase arg
+        (`("head" . ,h)
+         (put-text-property beg end 'font-lock-face
+                            (pcase h
+                              (`("unreferenced" . ,_) sweep-head-unreferenced-face)
+                              (`("exported" . ,_) sweep-head-exported-face)
+                              (`(,(rx (seq "local(")) . ,_) sweep-head-local-face)
+                              (other (message "unknown head color term %S" other) sweep-head-local-face))))
         (`("goal" . ,g)
          (put-text-property beg end 'font-lock-face
                             (pcase g
@@ -560,7 +567,11 @@ module name, F is a functor name and N is its arity."
                               (`("meta"      . ,_) sweep-meta-face)
                               (`("built_in"  . ,_) sweep-built-in-face)
                               (`("undefined" . ,_) sweep-undefined-face)
-                              (_ sweep-goal-face))))
+                              (`(,(rx (seq "autoload(")) . ,_) sweep-autoload-face)
+                              (`(,(rx (seq "imported(")) . ,_) sweep-imported-face)
+                              (`(,(rx (seq "local(")) . ,_) sweep-local-face)
+                              (other (message "unknown goal color term %S" other) sweep-goal-face))))
+        ("syntax_error"        (put-text-property beg end 'font-lock-face sweep-syntax-error-face))
         ("unused_import"       (put-text-property beg end 'font-lock-face sweep-unused-import-face))
         ("undefined_import"    (put-text-property beg end 'font-lock-face sweep-undefined-import-face))
         ("dict_tag"            (put-text-property beg end 'font-lock-face sweep-dict-tag-face))
@@ -581,9 +592,51 @@ module name, F is a functor name and N is its arity."
         ("predicate_indicator" (put-text-property beg end 'font-lock-face sweep-predicate-indicator-face))
         ("string"              (put-text-property beg end 'font-lock-face sweep-string-face))
         ("module"              (put-text-property beg end 'font-lock-face sweep-module-face))
-        ;; (other (message "Unknown color term %S" other))
+        ("neck"                (put-text-property beg end 'font-lock-face sweep-neck-face))
+        ("comment"             (put-text-property beg end 'font-lock-face sweep-comment-face))
+        ("hook"                (put-text-property beg end 'font-lock-face sweep-hook-face))
+        ("qq_type"             (put-text-property beg end 'font-lock-face sweep-qq-type-face))
+        ("qq_sep"              (put-text-property beg end 'font-lock-face sweep-qq-sep-face))
+        ("qq_open"             (put-text-property beg end 'font-lock-face sweep-qq-open-face))
+        ("qq_close"            (put-text-property beg end 'font-lock-face sweep-qq-close-face))
+        ("identifier"          (put-text-property beg end 'font-lock-face sweep-identifier-face))
+        ("file"                (put-text-property beg end 'font-lock-face sweep-file-face))
+        ("file_no_depend"      (put-text-property beg end 'font-lock-face sweep-file-no-depend-face))
+        (`("goal_term" . ,_)   nil)
+        (`("head_term" . ,_)   nil)
+        ("clause"              nil)
+        ("directive"           nil)
+        ("parentheses"         nil)
+        ("term"                nil)
+        ("expanded"            nil)
+        ("list"                nil)
+        ("grammar_rule"        nil)
+        ("dict"                nil)
+        ("brace_term"          nil)
+        ("rule_condition"      nil)
+        ("exported_operator"   nil)
+        ("empty_list"          nil)
+        ("dcg"                 nil)
+        ("qq"                  nil)
+        (other (message "Unknown color term %S" other))
         ))))
 
+(defun sweep-colourise-buffer (&optional buffer)
+  (interactive)
+  (with-current-buffer (or buffer (current-buffer))
+    (let* ((beg (point-min))
+           (end (point-max))
+           (contents (buffer-substring-no-properties beg end)))
+      (with-silent-modifications
+        (font-lock-unfontify-region beg end))
+      (sweep-open-query "user"
+                        "sweep"
+                        "sweep_colourise_buffer"
+                        (cons contents (buffer-file-name)))
+      (let ((sol (sweep-next-solution)))
+        (sweep-close-query)
+        sol))))
+
 (defun sweep-colourise-query (buffer)
   (when (buffer-live-p buffer)
     (with-current-buffer buffer
@@ -702,16 +755,32 @@ Interactively, a prefix arg means to prompt for BUFFER."
              (cons (rx (seq bol (one-or-more lower) "("))
                    #'sweep-file-name-handler))
 
-(defun sweep-beginning-of-top-term ()
-  (unless (bobp)
-    (when-let ((safe-start (nth 8 (syntax-ppss))))
-      (goto-char safe-start))
-    (re-search-backward (rx (seq bol graph)) nil t)
-    (let ((safe-start (nth 8 (syntax-ppss))))
-      (while (and safe-start (not (bobp)))
-        (goto-char safe-start)
-        (re-search-backward (rx (seq bol graph)) nil t)
-        (setq safe-start (nth 8 (syntax-ppss)))))))
+(defun sweep-beginning-of-top-term (&optional arg)
+  (let ((times (or arg 1)))
+    (if (< 0 times)
+        (let ((p (point)))
+          (while (and (< 0 times) (not (bobp)))
+            (setq times (1- times))
+            (when-let ((safe-start (nth 8 (syntax-ppss))))
+              (goto-char safe-start))
+            (re-search-backward (rx (seq bol graph)) nil t)
+            (let ((safe-start (nth 8 (syntax-ppss))))
+              (while (and safe-start (not (bobp)))
+                (goto-char safe-start)
+                (re-search-backward (rx (seq bol graph)) nil t)
+                (setq safe-start (nth 8 (syntax-ppss))))))
+          (not (= p (point))))
+      (sweep-beginning-of-next-top-term (- times)))))
+
+(defun sweep-beginning-of-next-top-term (times)
+  (let ((p (point)))
+    (while (and (< 0 times) (not (eobp)))
+      (setq times (1- times))
+      (unless (eobp)
+        (re-search-forward (rx (seq bol graph)) nil t))
+      (while (and (nth 8 (syntax-ppss)) (not (eobp)))
+        (re-search-forward (rx (seq bol graph)) nil t)))
+    (not (= p (point)))))
 
 (defun sweep-end-of-top-term ()
   (unless (eobp)
@@ -719,6 +788,43 @@ Interactively, a prefix arg means to prompt for BUFFER."
       (forward-char))
     (or (re-search-forward (rx (seq "." (or white "\n"))) nil t)
         (goto-char (point-max)))))
+
+(defvar sweep-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 ?% "<" table)
+    (modify-syntax-entry ?\n ">" table)
+    (modify-syntax-entry ?* ". 23b" table)
+    (modify-syntax-entry ?/ ". 14" table)
+    table))
+
+(defvar-keymap sweep-mode-map
+  :doc "Keymap for `sweep-mode'."
+  "C-c C-c" #'sweep-colourise-buffer)
+
+;;;###autoload
+(define-derived-mode sweep-mode prog-mode "sweep"
+  "Major mode for reading and editing Prolog code."
+  :group 'sweep
+  (setq-local comment-start "%")
+  (setq-local comment-start-skip "\\(?:/\\*+ *\\|%+ *\\)")
+  (setq-local parens-require-spaces nil)
+  (setq-local beginning-of-defun-function #'sweep-beginning-of-top-term)
+  (setq-local font-lock-defaults
+              '((("\\<\\([_A-Z][a-zA-Z0-9_]*\\)" 1 sweep-variable-face))
+                nil
+                nil
+                nil
+                nil)))
+
 ;;;; Testing:
 
 ;; (add-to-list 'load-path (file-name-directory (buffer-file-name)))

diff --git a/sweep.pl b/sweep.pl
index 9f9987b7973b4c4eebae549e4494b53538e041fd..dfb152ed87ea11df554fc5f9604954b2f8b917d7 100644 (file)
--- a/sweep.pl
+++ b/sweep.pl
@@ -31,7 +31,7 @@
 */
 
 :- module(sweep,
-          [ sweep_colors/2,
+          [ sweep_colourise_buffer/2,
             sweep_documentation/2,
             sweep_expand_file_name/2,
             sweep_predicate_location/2,
@@ -76,37 +76,29 @@ prolog:xref_open_source(Source, Stream) :-
 prolog:xref_close_source(Source, Stream) :-
     sweep_open(Source, Stream).
 
-sweep_colors([Path, String], Colors) :-
+sweep_colourise_buffer([String|Path], Colors) :-
     setup_call_cleanup(( new_memory_file(H),
                          insert_memory_file(H, 0, String),
-                         open_memory_file(H, read, Contents)
+                         open_memory_file(H, read, Contents, [encoding(utf8)])
                        ),
-                       sweep_colors(Path, Contents, Colors),
+                       sweep_colourise_buffer_(Path, Contents, Colors),
                        ( close(Contents),
                          free_memory_file(H)
                        )).
-sweep_colors(Path, Contents, Colors) :-
+sweep_colourise_buffer_(Path0, Contents, []) :-
+    atom_string(Path, Path0),
     set_stream(Contents, encoding(utf8)),
     set_stream(Contents, file_name(Path)),
     get_time(Time),
     asserta(sweep_open(Path, Contents), Ref0),
     asserta(sweep_source_time(Path, Time), Ref1),
     xref_source(Path, []),
-    retractall(sweep_current_color(_, _, _)),
-    retractall(sweep_current_comment(_, _, _)),
     seek(Contents, 0, bof, _),
     prolog_colourise_stream(Contents,
                             Path,
-                            sweep_handle_color),
+                            sweep_handle_query_color(1)),
     erase(Ref0),
-    erase(Ref1),
-    findall([B,L,T],
-            sweep_current_color(B, L, T),
-            Colors,
-            Comments),
-    findall([B,L,T],
-            sweep_current_comment(B, L, T),
-            Comments).
+    erase(Ref1).
 
 sweep_handle_color(comment(C), B0, L) =>
     B is B0 + 1,