From: Eshel Yaron <me@eshelyaron.com>
Date: Sun, 4 Sep 2022 19:04:16 +0000 (+0300)
Subject: ADDED: custom font-lock-fontify-region-function for sweep-mode
X-Git-Tag: v0.2.0~41
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=face064afaaf5206fc5cb289c5c6ca5dabf3ebd3;p=dict.git

ADDED: custom font-lock-fontify-region-function for sweep-mode
---

diff --git a/sweep.el b/sweep.el
index 46ea566..bf3aff1 100644
--- a/sweep.el
+++ b/sweep.el
@@ -548,8 +548,8 @@ module name, F is a functor name and N is its arity."
 
 (defun sweep--colourise (args)
   "ARGS is a list of the form (BEG LEN . SEM)."
-  (let* ((beg (car  args))
-         (end (+ beg (cadr args)))
+  (let* ((beg (max (point-min) (car  args)))
+         (end (min (point-max) (+ beg (cadr args))))
          (arg (cddr args)))
     (with-silent-modifications
       (pcase arg
@@ -558,6 +558,7 @@ module name, F is a functor name and N is its arity."
                             (pcase h
                               (`("unreferenced" . ,_) sweep-head-unreferenced-face)
                               (`("exported" . ,_) sweep-head-exported-face)
+                              (`("hook" . ,_) sweep-head-hook-face)
                               (`(,(rx (seq "local(")) . ,_) sweep-head-local-face)
                               (other (message "unknown head color term %S" other) sweep-head-local-face))))
         (`("goal" . ,g)
@@ -567,17 +568,22 @@ 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)
+                              (`(,(rx (seq "dynamic ")) . ,_) sweep-dynamic-face)
+                              (`(,(rx (seq "extern(")) . ,_) sweep-extern-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" ,message ,eb ,ee)
+        (`("syntax_error" ,_message ,_eb ,_ee)
          (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))
         ("dict_key"            (put-text-property beg end 'font-lock-face sweep-dict-key-face))
         ("dict_sep"            (put-text-property beg end 'font-lock-face sweep-dict-sep-face))
+        ("flag_name"           (put-text-property beg end 'font-lock-face sweep-flag-name-face))
+        ("no_flag_name"        (put-text-property beg end 'font-lock-face sweep-flag-name-face))
+        ("ext_quant"           (put-text-property beg end 'font-lock-face sweep-ext-quant-face))
         ("atom"                (put-text-property beg end 'font-lock-face sweep-atom-face))
         ("float"               (put-text-property beg end 'font-lock-face sweep-float-face))
         ("int"                 (put-text-property beg end 'font-lock-face sweep-int-face))
@@ -640,6 +646,29 @@ module name, F is a functor name and N is its arity."
         (sweep-close-query)
         sol))))
 
+(defun sweep-colourise-some-terms (beg0 end0 &optional _verbose)
+  (let* ((beg (save-mark-and-excursion
+                (goto-char beg0)
+                (sweep-beginning-of-top-term)
+                (point)))
+         (end (save-mark-and-excursion
+                (goto-char end0)
+                (sweep-end-of-top-term)
+                (point)))
+         (contents (buffer-substring-no-properties beg end)))
+    (with-silent-modifications
+      (font-lock-unfontify-region beg end))
+    (sweep-open-query "user"
+                      "sweep"
+                      "sweep_colourise_some_terms"
+                      (list contents
+                            (buffer-file-name)
+                            beg))
+    (let ((sol (sweep-next-solution)))
+      (sweep-close-query)
+      (when (sweep-true-p sol)
+        `(jit-lock-bounds ,beg . ,end)))))
+
 (defun sweep-colourise-query (buffer)
   (when (buffer-live-p buffer)
     (with-current-buffer buffer
@@ -939,7 +968,9 @@ Interactively, a prefix arg means to prompt for BUFFER."
                 nil
                 nil
                 nil
-                nil)))
+                nil
+                (font-lock-fontify-region-function . sweep-colourise-some-terms)))
+  (sweep-colourise-buffer))
 
 ;;;; Testing:
 
diff --git a/sweep.pl b/sweep.pl
index 0a475ef..3d65efa 100644
--- a/sweep.pl
+++ b/sweep.pl
@@ -32,6 +32,7 @@
 
 :- module(sweep,
           [ sweep_colourise_buffer/2,
+            sweep_colourise_some_terms/2,
             sweep_documentation/2,
             sweep_expand_file_name/2,
             sweep_predicate_location/2,
@@ -85,6 +86,7 @@ sweep_colourise_buffer([String|Path], Colors) :-
                        ( close(Contents),
                          free_memory_file(H)
                        )).
+
 sweep_colourise_buffer_(Path0, Contents, []) :-
     atom_string(Path, Path0),
     set_stream(Contents, encoding(utf8)),
@@ -100,6 +102,25 @@ sweep_colourise_buffer_(Path0, Contents, []) :-
     erase(Ref0),
     erase(Ref1).
 
+sweep_colourise_some_terms([String,Path,Offset], Colors) :-
+    setup_call_cleanup(( new_memory_file(H),
+                         insert_memory_file(H, 0, String),
+                         open_memory_file(H, read, Contents, [encoding(utf8)])
+                       ),
+                       sweep_colourise_some_terms_(Path, Offset, Contents, Colors),
+                       ( close(Contents),
+                         free_memory_file(H)
+                       )).
+
+sweep_colourise_some_terms_(Path0, Offset, Contents, []) :-
+    atom_string(Path, Path0),
+    set_stream(Contents, encoding(utf8)),
+    set_stream(Contents, file_name(Path)),
+    seek(Contents, 0, bof, _),
+    prolog_colourise_stream(Contents,
+                            Path,
+                            sweep_handle_query_color(Offset)).
+
 sweep_documentation([Path, Functor, Arity], Docs) :-
     atom_string(P, Path),
     atom_string(F, Functor),