From: Eshel Yaron Date: Tue, 30 Aug 2022 16:29:37 +0000 (+0300) Subject: ADDED: sweep_funcall/2,3 for calling Elisp functions from Prolog X-Git-Tag: v0.2.0~67 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=a06906287f0f415a7695c846bb9004291ee5993f;p=sweep.git ADDED: sweep_funcall/2,3 for calling Elisp functions from Prolog --- diff --git a/sweep.c b/sweep.c index df14b49..188ada6 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 2fd6954..f778a56 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 c423dd5..68ea579 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).