[nongnu] elpa/sweeprolog a06906287f 036/166: ADDED: sweep_funcall/2, 3 for calling Elisp functions from Prolog

[ELPA Syncer]

branch: elpa/sweeprolog
commit a06906287f0f415a7695c846bb9004291ee5993f
Author: Eshel Yaron <me@eshelyaron.com>
Commit: Eshel Yaron <me@eshelyaron.com>

    ADDED: sweep_funcall/2,3 for calling Elisp functions from Prolog
---
 sweep.c  |  52 +++++++++++-
 sweep.el | 289 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 sweep.pl |  59 +++++++++----
 3 files changed, 381 insertions(+), 19 deletions(-)

diff --git a/sweep.c b/sweep.c
index df14b49db1..188ada6f55 100644
--- a/sweep.c
+++ b/sweep.c
@@ -6,6 +6,7 @@
 int plugin_is_GPL_compatible;
 
 term_t o = 0;
+emacs_env * current_env = NULL;
 
 char*
 estring_to_cstring(emacs_env *eenv, emacs_value estring, ptrdiff_t *len_p) {
@@ -113,8 +114,6 @@ term_to_value_string(emacs_env *eenv, term_t t) {
   size_t      l = -1;
   if (PL_get_nchars(t, &l, &string, CVT_STRING|REP_UTF8)) {
     v = eenv->make_string(eenv, string, l);
-  } else {
-    v = eenv->make_string(eenv, "sweep conversion error", 22);
   }
   return v;
 }
@@ -335,6 +334,8 @@ sweep_next_solution(emacs_env *env, ptrdiff_t nargs, 
emacs_value *args, void *da
     return NULL;
   }
 
+  current_env = env;
+
   switch (PL_next_solution(d)) {
   case PL_S_EXCEPTION:
     return econs(env, env->intern(env, "exception"), term_to_value(env, 
PL_exception(d)));
@@ -392,6 +393,9 @@ sweep_open_query(emacs_env *env, ptrdiff_t nargs, 
emacs_value *args, void *data)
   if (value_to_term(env, args[3], a+(env->is_not_nil(env, s) ? 1 : 0)) < 0) {
     goto cleanup;
   }
+
+  current_env = env;
+
   PL_open_query(n, PL_Q_NODEBUG | PL_Q_EXT_STATUS | PL_Q_CATCH_EXCEPTION, p, 
a);
 
   o = a+(env->is_not_nil(env, s) ? 0 : 1);
@@ -451,6 +455,7 @@ sweep_cleanup(emacs_env *env, ptrdiff_t nargs, emacs_value 
*args, void *data)
   return env->intern(env, (PL_cleanup(PL_CLEANUP_SUCCESS) ? "t" : "nil"));
 }
 
+
 static void provide(emacs_env *env, const char *feature) {
   emacs_value Qfeat = env->intern(env, feature);
   emacs_value Qprovide = env->intern(env, "provide");
@@ -458,6 +463,46 @@ static void provide(emacs_env *env, const char *feature) {
   env->funcall(env, Qprovide, 1, (emacs_value[]){Qfeat});
 }
 
+static foreign_t
+sweep_funcall0(term_t f, term_t v) {
+  char * string = NULL;
+  emacs_value r = NULL;
+  size_t      l = -1;
+  term_t      n = PL_new_term_ref();
+
+  if (PL_get_nchars(f, &l, &string, CVT_STRING|REP_UTF8)) {
+    r = current_env->funcall(current_env, current_env->intern(current_env, 
string), 0, NULL);
+    if (value_to_term(current_env, r, n) >= 0) {
+      if (PL_unify(n, v)) {
+        return TRUE;
+      }
+    }
+  }
+  return FALSE;
+}
+
+static foreign_t
+sweep_funcall1(term_t f, term_t a, term_t v) {
+  char * string = NULL;
+  emacs_value e = NULL;
+  emacs_value r = NULL;
+  size_t      l = -1;
+  term_t      n = PL_new_term_ref();
+
+  if (PL_get_nchars(f, &l, &string, CVT_STRING|REP_UTF8)) {
+    e = term_to_value(current_env, a);
+    if (e != NULL) {
+      r = current_env->funcall(current_env, current_env->intern(current_env, 
string), 1, &e);
+      if (value_to_term(current_env, r, n) >= 0) {
+        if (PL_unify(n, v)) {
+          return TRUE;
+        }
+      }
+    }
+  }
+  return FALSE;
+}
+
 int
 emacs_module_init (struct emacs_runtime *runtime)
 {
@@ -540,6 +585,9 @@ This function drops the current instantiation of the query 
variables.",
   emacs_value args_cleanup[] = {symbol_cleanup, func_cleanup};
   env->funcall (env, env->intern (env, "defalias"), 2, args_cleanup);
 
+  PL_register_foreign("sweep_funcall", 3, sweep_funcall1, 0);
+  PL_register_foreign("sweep_funcall", 2, sweep_funcall0, 0);
+
   provide(env, "sweep-module");
 
   return 0;
diff --git a/sweep.el b/sweep.el
index 2fd69541a2..f778a56806 100644
--- a/sweep.el
+++ b/sweep.el
@@ -200,7 +200,6 @@ module name, F is a functor name and N is its arity."
          (completion-extra-properties
           (list :annotation-function
                 (lambda (key)
-                  (message key)
                   (let* ((val (cdr (assoc-string key col)))
                          (des (car val))
                          (ver (cadr val)))
@@ -243,6 +242,284 @@ module name, F is a functor name and N is its arity."
 ;;     (when (sweep-true-p sol)
 ;;       (cdr sol))))
 
+(defgroup sweep-faces nil
+  "Faces used to highlight Prolog code."
+  :group 'sweep)
+
+(eval-when-compile
+  (defmacro sweep-defface (name def doc)
+    "Define sweep face FACE with doc DOC."
+    (declare
+     (indent defun)
+     (doc-string 3))
+    (let ((face (intern (concat "sweep-" (symbol-name name) "-face"))))
+      `(progn
+         (defface ,face
+           '((default :inherit ,def))
+           ,(concat "Face used to highlight " (downcase doc))
+           :group 'sweep-faces)
+         (defvar ,face ',face
+           ,(concat "Name of the face used to highlight " (downcase doc)))))))
+
+(sweep-defface functor font-lock-function-name-face
+  "Functors.")
+
+(sweep-defface arity font-lock-function-name-face
+  "Arities.")
+
+(sweep-defface predicate-indicator font-lock-function-name-face
+  "Predicate indicators.")
+
+(sweep-defface built-in font-lock-keyword-face
+  "Built in predicate calls.")
+
+(sweep-defface neck font-lock-preprocessor-face
+  "Necks.")
+
+(sweep-defface goal font-lock-function-name-face
+  "Unspecified predicate goals.")
+
+(sweep-defface string font-lock-string-face
+  "Strings.")
+
+(sweep-defface comment font-lock-comment-face
+  "Comments.")
+
+(sweep-defface head-local font-lock-builtin-face
+  "Local predicate definitions.")
+
+(sweep-defface head-meta font-lock-preprocessor-face
+  "Meta predicate definitions.")
+
+(sweep-defface head-multifile font-lock-type-face
+  "Multifile predicate definitions.")
+
+(sweep-defface head-extern font-lock-type-face
+  "External predicate definitions.")
+
+(sweep-defface head-unreferenced font-lock-warning-face
+  "Unreferenced predicate definitions.")
+
+(sweep-defface head-exported font-lock-builtin-face
+  "Exported predicate definitions.")
+
+(sweep-defface head-hook font-lock-type-face
+  "Hook definitions.")
+
+(sweep-defface head-iso font-lock-keyword-face
+  "Hook definitions.")
+
+(sweep-defface head-undefined font-lock-warning-face
+  "Undefind head terms.")
+
+(sweep-defface head-public font-lock-builtin-face
+  "Public definitions.")
+
+(sweep-defface meta-spec font-lock-preprocessor-face
+  "Meta argument specifiers.")
+
+(sweep-defface recursion font-lock-builtin-face
+  "Recursive calls.")
+
+(sweep-defface local font-lock-function-name-face
+  "Local predicate calls.")
+
+(sweep-defface autoload font-lock-function-name-face
+  "Autoloaded predicate calls.")
+
+(sweep-defface imported font-lock-function-name-face
+  "Imported predicate calls.")
+
+(sweep-defface extern font-lock-function-name-face
+  "External predicate calls.")
+
+(sweep-defface foreign font-lock-keyword-face
+  "Foreign predicate calls.")
+
+(sweep-defface meta font-lock-type-face
+  "Meta predicate calls.")
+
+(sweep-defface undefined font-lock-warning-face
+  "Undefined predicate calls.")
+
+(sweep-defface thread-local font-lock-constant-face
+  "Thread local predicate calls.")
+
+(sweep-defface global font-lock-keyword-face
+  "Global predicate calls.")
+
+(sweep-defface multifile font-lock-function-name-face
+  "Multifile predicate calls.")
+
+(sweep-defface dynamic font-lock-constant-face
+  "Dynamic predicate calls.")
+
+(sweep-defface undefined-import font-lock-warning-face
+  "Undefined imports.")
+
+(sweep-defface html-attribute font-lock-function-name-face
+  "HTML attributes.")
+
+(sweep-defface html-call font-lock-keyword-face
+  "Multifile predicate calls.")
+
+(sweep-defface option-name font-lock-constant-face
+  "Option names.")
+
+(sweep-defface no-option-name font-lock-warning-face
+  "Non-existent option names.")
+
+(sweep-defface flag-name font-lock-constant-face
+  "Flag names.")
+
+(sweep-defface no-flag-name font-lock-warning-face
+  "Non-existent flag names.")
+
+(sweep-defface qq-type font-lock-type-face
+  "Quasi-quotation types.")
+
+(sweep-defface qq-sep font-lock-type-face
+  "Quasi-quotation separators.")
+
+(sweep-defface qq-open font-lock-type-face
+  "Quasi-quotation open sequences.")
+
+(sweep-defface qq-close font-lock-type-face
+  "Quasi-quotation close sequences.")
+
+(sweep-defface op-type font-lock-type-face
+  "Operator types.")
+
+(sweep-defface dict-tag font-lock-constant-face
+  "Dict tags.")
+
+(sweep-defface dict-key font-lock-keyword-face
+  "Dict keys.")
+
+(sweep-defface dict-sep font-lock-keyword-face
+  "Dict separators.")
+
+(sweep-defface type-error font-lock-warning-face
+  "Type errors.")
+
+(sweep-defface instantiation-error font-lock-warning-face
+  "Instantiation errors.")
+
+(sweep-defface file button
+  "File specifiers.")
+
+(sweep-defface no-file font-lock-warning-face
+  "Non-existent file specifiers.")
+
+(sweep-defface file-no-depend font-lock-warning-face
+  "Unused file specifiers.")
+
+(sweep-defface unused-import font-lock-warning-face
+  "Unused imports.")
+
+(sweep-defface identifier font-lock-type-face
+  "Identifiers.")
+
+(sweep-defface hook font-lock-preprocessor-face
+  "Hooks.")
+
+(sweep-defface module font-lock-type-face
+  "Module names.")
+
+(sweep-defface singleton font-lock-warning-face
+  "Singletons.")
+
+(sweep-defface fullstop font-lock-negation-char-face
+  "Fullstops.")
+
+(sweep-defface nil font-lock-keyword-face
+  "The empty list.")
+
+(sweep-defface variable font-lock-variable-name-face
+  "Variables.")
+
+(sweep-defface ext-quant font-lock-keyword-face
+  "Existential quantifiers.")
+
+(sweep-defface control font-lock-keyword-face
+  "Control constructs.")
+
+(sweep-defface atom font-lock-constant-face
+  "Atoms.")
+
+(sweep-defface int font-lock-constant-face
+  "Integers.")
+
+(sweep-defface float font-lock-constant-face
+  "Floats.")
+
+(sweep-defface codes font-lock-constant-face
+  "Codes.")
+
+(sweep-defface error font-lock-warning-face
+  "Unspecified errors.")
+
+(sweep-defface syntax-error error
+  "Syntax errors.")
+
+(sweep-defface structured-comment font-lock-doc-face
+  "Structured comments.")
+
+(defun sweep--colourise (args)
+  "ARGS is a list of the form (BEG LEN . SEM)."
+  (let* ((beg (car  args))
+         (end (+ beg (cadr args)))
+         (arg (cddr args)))
+    (with-silent-modifications
+      (pcase arg
+        (`("goal" . ,g)
+         (put-text-property beg end 'font-lock-face
+                            (pcase g
+                              (`("recursion" . ,_) sweep-recursion-face)
+                              (`("meta" . ,_) sweep-meta-face)
+                              (`("built_in" . ,_) sweep-built-in-face)
+                              (`("undefined" . ,_) sweep-undefined-face)
+                              (_ sweep-goal-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))
+        ("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))
+        ("singleton"           (put-text-property beg end 'font-lock-face 
sweep-singleton-face))
+        ("option_name"         (put-text-property beg end 'font-lock-face 
sweep-option-name-face))
+        ("no_option_name"      (put-text-property beg end 'font-lock-face 
sweep-no-option-name-face))
+        ("control"             (put-text-property beg end 'font-lock-face 
sweep-control-face))
+        ("var"                 (put-text-property beg end 'font-lock-face 
sweep-variable-face))
+        ("body"                (put-text-property beg end 'font-lock-face 
'default))
+        ("fullstop"            (put-text-property beg end 'font-lock-face 
sweep-fullstop-face))
+        ("functor"             (put-text-property beg end 'font-lock-face 
sweep-functor-face))
+        ("arity"               (put-text-property beg end 'font-lock-face 
sweep-arity-face))
+        ("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))
+        ))))
+
+(defun sweep-colourise-query (buffer)
+  (interactive)
+  (when (buffer-live-p buffer)
+    (with-current-buffer buffer
+      (let* ((beg (cdr comint-last-prompt))
+             (end (point-max))
+             (query (buffer-substring-no-properties beg end)))
+        (with-silent-modifications
+          (font-lock-unfontify-region beg end))
+        (sweep-open-query "user"
+                          "sweep"
+                          "sweep_colourise_query"
+                          (cons query (marker-position beg)))
+        (let ((sol (sweep-next-solution)))
+          (sweep-close-query)
+          sol)))))
+
 ;;;###autoload
 (defun sweep-top-level ()
   "Start an interactive Prolog top-level."
@@ -269,6 +546,8 @@ module name, F is a functor name and N is its arity."
                  (not (string= "|    " prompt)))
         (comint-send-input)))))
 
+(defvar-local sweep-top-level-timer nil "Buffer-local timer.")
+
 ;;;###autoload
 (define-derived-mode sweep-top-level-mode comint-mode "sweep Top-level"
   "Major mode for interacting with an inferior Prolog interpreter."
@@ -278,8 +557,12 @@ module name, F is a functor name and N is its arity."
               comint-prompt-read-only        t
               comint-delimiter-argument-list '(?,)
               comment-start "%")
-  (add-hook 'post-self-insert-hook 
#'sweep-top-level--post-self-insert-function nil t))
-
+  (add-hook 'post-self-insert-hook 
#'sweep-top-level--post-self-insert-function nil t)
+  (setq sweep-top-level-timer (run-with-idle-timer 0.2 t 
#'sweep-colourise-query (current-buffer)))
+  (add-hook 'kill-buffer-hook
+            (lambda ()
+              (when (timerp sweep-top-level-timer)
+                (cancel-timer sweep-top-level-timer)))))
 
 (sweep--ensure-module)
 (when sweep-init-on-load (sweep-init))
diff --git a/sweep.pl b/sweep.pl
index c423dd5c9d..68ea5792f8 100644
--- a/sweep.pl
+++ b/sweep.pl
@@ -65,7 +65,7 @@ sweep_colors(Path, Contents, Colors) :-
     seek(Contents, 0, bof, _),
     prolog_colourise_stream(Contents,
                             Path,
-                            sweep_server_handle_color),
+                            sweep_handle_color),
     erase(Ref0),
     erase(Ref1),
     findall([B,L,T],
@@ -76,39 +76,39 @@ sweep_colors(Path, Contents, Colors) :-
             sweep_current_comment(B, L, T),
             Comments).
 
-sweep_server_handle_color(comment(C), B0, L) =>
+sweep_handle_color(comment(C), B0, L) =>
     B is B0 + 1,
     assertz(sweep_current_comment(B, L, C)).
-sweep_server_handle_color(syntax_error(D, EB-EE), _B, _L) =>
+sweep_handle_color(syntax_error(D, EB-EE), _B, _L) =>
     EL is EE-EB,
     assertz(sweep_current_color(EB,
                                   EL,
                                   syntax_error(D, EB-EE))).
-sweep_server_handle_color(head_term(meta, Head), B0, L) =>
+sweep_handle_color(head_term(meta, Head), B0, L) =>
     B is B0 + 1,
     assertz(sweep_current_color(B, L, head_term(meta, Head))).
-sweep_server_handle_color(head_term(Kind, Head), B0, L) =>
+sweep_handle_color(head_term(Kind, Head), B0, L) =>
     B is B0+1,
     pi_head(PI, Head),
     assertz(sweep_current_color(B,
                                 L,
                                 head_term(Kind, PI))).
-sweep_server_handle_color(head(Kind, Head), B0, L) =>
+sweep_handle_color(head(Kind, Head), B0, L) =>
     B is B0+1,
     pi_head(PI, Head),
     assertz(sweep_current_color(B, L, head(Kind, PI))).
-sweep_server_handle_color(goal(Kind, Head), B0, L) =>
+sweep_handle_color(goal(Kind, Head), B0, L) =>
     B is B0+1,
     pi_head(PI, Head),
     assertz(sweep_current_color(B, L, goal(Kind, PI))).
-sweep_server_handle_color(goal_term(meta, Goal), B0, L) =>
+sweep_handle_color(goal_term(meta, Goal), B0, L) =>
     B is B0 + 1,
     assertz(sweep_current_color(B, L, goal_term(meta, Goal))).
-sweep_server_handle_color(goal_term(Kind, Goal), B0, L) =>
+sweep_handle_color(goal_term(Kind, Goal), B0, L) =>
     B is B0 + 1,
     pi_head(PI, Goal),
     assertz(sweep_current_color(B, L, goal_term(Kind, PI))).
-sweep_server_handle_color(T, B0, L) =>
+sweep_handle_color(T, B0, L) =>
     B is B0 + 1,
     assertz(sweep_current_color(B, L, T)).
 
@@ -195,6 +195,14 @@ sweep_predicate_location(MFN, [Path|Line]) :-
     predicate_property(M:H, line_count(Line)),
     predicate_property(M:H, file(Path0)), atom_string(Path0, Path).
 
+% sweep_predicates_try_completion(Match, "match") :-
+%     term_string(M:F/N, Match, [syntax_errors(quiet)]),
+%     current_predicate(M:F/N), !.
+% sweep_predicates_try_completion(Prefix, "match") :-
+%     term_string(M:F,   Prefix, [syntax_errors(quiet)]),
+%     findall(M:F/N, current_predicate(M:F/N),
+%     current_predicate(M:F/N), !.
+
 sweep_predicates_collection([], Preds) :-
     findall(M:F/N,
             ( current_predicate(M:F/N),
@@ -234,9 +242,32 @@ sweep_pack_install(PackName, []) :-
     atom_string(Pack, PackName), pack_install(Pack, [silent(true), 
upgrade(true), interactive(false)]).
 
 
-% sweep_expand_file_name([SpecString|_Dir], Path) :-
-%     term_string(Spec, String),
-%     absolute_file_name(library(lists), Path, [access(exist), 
extensions(['pl', '']), solutions(all)]).
-
 sweep_start_prolog_server(Port, []) :-
     prolog_server(Port, []).
+
+sweep_colourise_query([String|Offset], _) :-
+    prolog_colourise_query(String, module(sweep), 
sweep_handle_query_color(Offset)).
+
+sweep_handle_query_color(Offset, Col, Beg, Len) :-
+    sweep_color_normalized(Col, Nom),
+    Start is Beg + Offset,
+    sweep_funcall("sweep--colourise", [Start,Len|Nom], _).
+
+sweep_color_normalized(Col, Nom) :-
+    Col =.. [Nom0|Rest],
+    sweep_color_normalized_(Nom0, Rest, Nom).
+
+sweep_color_normalized_(Goal0, [Kind0,Head|_], [Goal,Kind,F,N]) :-
+    sweep_color_goal(Goal0),
+    !,
+    atom_string(Goal0, Goal),
+    term_string(Kind0, Kind),
+    pi_head(F0/N, Head),
+    atom_string(F0, F).
+sweep_color_normalized_(Nom0, _, Nom) :-
+    atom_string(Nom0, Nom).
+
+sweep_color_goal(goal).
+sweep_color_goal(goal_term).
+sweep_color_goal(head).
+sweep_color_goal(head_term).