From 89733a1b7fa8a445caee8633ee7fe8e5d23ce498 Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Fri, 26 Aug 2022 23:27:56 +0300 Subject: [PATCH] Initial commit --- .gitignore | 2 + Makefile | 24 +++ sweep.c | 594 +++++++++++++++++++++++++++++++++++++++++++++++++++++ sweep.el | 120 +++++++++++ sweep.h | 15 ++ sweep.pl | 197 ++++++++++++++++++ 6 files changed, 952 insertions(+) create mode 100644 .gitignore create mode 100644 Makefile create mode 100644 sweep.c create mode 100644 sweep.el create mode 100644 sweep.h create mode 100644 sweep.pl diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..42073c2 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +/.iprolog_history +/sweep-module.dylib diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..59a4c35 --- /dev/null +++ b/Makefile @@ -0,0 +1,24 @@ +BASENAME = sweep +SOEXT = dylib + +TARGET = $(BASENAME)-module.$(SOEXT) +SOURCE = $(BASENAME).c + +LDFLAGS += -shared +LDFLAGS += -lswipl + +CFLAGS += -fPIC +CFLAGS += -fdiagnostics-absolute-paths +CFLAGS += -Wall +CFLAGS += -Wextra +CFLAGS += -O2 + +.PHONY: clean all + +all: $(TARGET) + +$(TARGET): $(SOURCE) + $(CC) $(CFLAGS) -o $@ $^ $(LDFLAGS) + +clean: + rm -f $(TARGET) diff --git a/sweep.c b/sweep.c new file mode 100644 index 0000000..2b5612f --- /dev/null +++ b/sweep.c @@ -0,0 +1,594 @@ +#include "sweep.h" +#include +#include +#include + +int plugin_is_GPL_compatible; + +term_t o = 0; + +char* +estring_to_cstring(emacs_env *eenv, emacs_value estring, ptrdiff_t *len_p) { + char * buf = NULL; + ptrdiff_t len = 0; + + if (len_p == NULL) len_p = &len; + + if (!eenv->copy_string_contents(eenv, estring, NULL, len_p)) { + ethrow(eenv, "Failed to get string length"); + return NULL; + } + if ((buf = (char*)malloc((*len_p))) == NULL) { + ethrow(eenv, "malloc failed"); + return NULL; + } + memset(buf, 0, (*len_p)); + if (!eenv->copy_string_contents(eenv, estring, buf, len_p)) { + ethrow(eenv, "Failed to copy string contents"); + free(buf); + buf = NULL; + } + + return buf; +} + +int +estring_to_atom(emacs_env *eenv, emacs_value estring, term_t t) { + ptrdiff_t len = 0; + char *buf = NULL; + int i = 0; + + if ((buf = estring_to_cstring(eenv, estring, &len)) == NULL) return -1; + + i = PL_put_atom_nchars(t, len - 1, buf); + free(buf); + return i; +} + +int +estring_to_pstring(emacs_env *eenv, emacs_value estring, term_t t) { + ptrdiff_t len = 0; + char *buf = NULL; + int i = 0; + + if ((buf = estring_to_cstring(eenv, estring, &len)) == NULL) return -1; + + i = PL_put_string_nchars(t, len - 1, buf); + free(buf); + return i; +} + +static IOSTREAM * +estring_to_stream(emacs_env *eenv, emacs_value estring) { + ptrdiff_t len = 0; + size_t slen = 0; + char *buf = NULL; + + if ((buf = estring_to_cstring(eenv, estring, &len)) == NULL) return NULL; + + slen = len - 1; + return Sopenmem(&buf, &slen, "r"); +} + +static emacs_value +econs(emacs_env *env, emacs_value car, emacs_value cdr) { + emacs_value args[2] = {car, cdr}; + return env->funcall (env, env->intern (env, "cons"), 2, args); +} + +static emacs_value +ecar(emacs_env *env, emacs_value cons) { + return env->funcall (env, env->intern (env, "car"), 1, &cons); +} + +static emacs_value +ecdr(emacs_env *env, emacs_value cons) { + return env->funcall (env, env->intern (env, "cdr"), 1, &cons); +} + +void +ethrow(emacs_env *env, const char * message) { + ptrdiff_t len = strlen(message); + + emacs_value str = env->make_string(env, message, len); + emacs_value arg = env->funcall (env, env->intern (env, "list"), 1, &str); + env->non_local_exit_signal(env, env->intern(env, "error"), arg); +} + +emacs_value +enil(emacs_env *env) { return env->intern(env, "nil"); } + +emacs_value +et(emacs_env *env) { return env->intern(env, "t"); } + +static emacs_value +term_to_value_list(emacs_env *eenv, term_t l) { + term_t ph = PL_new_term_ref(); + term_t pt = PL_new_term_ref(); + + if (PL_get_list(l, ph, pt)) { + return econs(eenv, term_to_value(eenv, ph), term_to_value(eenv, pt)); + } else return NULL; +} + +static emacs_value +term_to_value_integer(emacs_env *eenv, term_t t) { + emacs_value v = NULL; + int64_t l = -1; + if (PL_get_int64(t, &l)) { + + v = eenv->make_integer(eenv, l); + } + return v; +} + +emacs_value +term_to_value_string(emacs_env *eenv, term_t t) { + char * string = NULL; + emacs_value v = NULL; + size_t l = -1; + if (PL_get_string_chars(t, &string, &l)) { + v = eenv->make_string(eenv, string, l); + } + return v; +} + +emacs_value +term_to_value_atom(emacs_env *eenv, term_t t) { + char * string = NULL; + emacs_value v = NULL; + emacs_value s = NULL; + size_t l = -1; + + if (PL_get_nchars(t, &l, &string, CVT_ATOM|REP_UTF8)) { + s = eenv->make_string(eenv, string, l); + v = econs(eenv, eenv->intern(eenv, "atom"), s); + } + return v; +} + +emacs_value +term_to_value_variable(emacs_env *env, term_t t) { + (void)t; + return env->intern(env, "variable"); +} + +emacs_value +term_to_value_dict(emacs_env *env, term_t t) { + (void)t; + return env->intern(env, "dict"); +} + +emacs_value +term_to_value_blob(emacs_env *env, term_t t) { + (void)t; + return env->intern(env, "blob"); +} + +emacs_value +term_to_value_float(emacs_env *env, term_t t) { + (void)t; + return env->intern(env, "float"); +} + +emacs_value +term_to_value_compound(emacs_env *env, term_t t) { + atom_t name = 0; + size_t arity = 0; + term_t arg = PL_new_term_ref(); + const char * chars = NULL; + size_t len = 0; + emacs_value * vals = NULL; + size_t n = 0; + PL_get_compound_name_arity(t, &name, &arity); + chars = PL_atom_nchars(name, &len); + vals = (emacs_value*)malloc(sizeof(emacs_value)*arity + 1); + if (vals == NULL) { + ethrow(env, "malloc failed"); + return NULL; + } + memset(vals, 0, sizeof(emacs_value)*arity + 1); + + vals[0] = env->make_string(env, chars, len); + + for(n=1; n<=arity; n++) { + + PL_get_arg(n, t, arg); + vals[n] = term_to_value(env, arg); + } + + return econs(env, env->intern(env, "compound"), env->funcall(env, env->intern(env, "list"), arity + 1, vals)); +} + +emacs_value +term_to_value(emacs_env *env, term_t t) { + switch (PL_term_type(t)) { + case PL_VARIABLE: + return term_to_value_variable(env, t); + case PL_ATOM: + return term_to_value_atom(env, t); + case PL_STRING: + return term_to_value_string(env, t); + case PL_NIL: + return enil(env); + case PL_LIST_PAIR: + return term_to_value_list(env, t); + case PL_INTEGER: + return term_to_value_integer(env, t); + case PL_TERM: + return term_to_value_compound(env, t); + case PL_DICT: + return term_to_value_dict(env, t); + case PL_BLOB: + return term_to_value_blob(env, t); + case PL_FLOAT: + return term_to_value_blob(env, t); + default: + /* ethrow(env, "Prolog to Elisp conversion failed"); */ + /* return NULL; */ + return env->intern(env, "unconvertable"); + } +} + +int +value_to_term_string(emacs_env *env, emacs_value v, term_t t) { + return estring_to_pstring(env, v, t); +} + +int +value_to_term_integer(emacs_env *env, emacs_value v, term_t t) { + intmax_t l = env->extract_integer(env, v); + return PL_put_int64(t, l); +} + +int +value_to_term_list(emacs_env *env, emacs_value v, term_t t) { + int r = -1; + term_t head = PL_new_term_ref(); + term_t tail = PL_new_term_ref(); + emacs_value car = ecar(env, v); + emacs_value cdr = ecdr(env, v); + if ((r = value_to_term(env, car, head)) < 0) { + return r; + } + if ((r = value_to_term(env, cdr, tail)) < 0) { + return r; + } + return PL_cons_list(t, head, tail); +} + +int +value_to_term(emacs_env *env, emacs_value v, term_t t) { + int r = -1; + emacs_value vt = env->type_of(env, v); + + if (env->is_not_nil(env, v)) { + if (env->eq(env, vt, env->intern(env, "string"))) { + r = value_to_term_string(env, v, t); + } else if (env->eq(env, vt, env->intern(env, "integer"))) { + r = value_to_term_integer(env, v, t); + } else if (env->eq(env, vt, env->intern(env, "cons"))) { + r = value_to_term_list(env, v, t); + } else r = -1; + } else r = PL_put_nil(t); + + return r; +} + +emacs_value +sweep_close_query(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) +{ + qid_t d = PL_current_query(); + + (void)data; + (void)nargs; + (void)args; + + if (d == 0) { + ethrow(env, "No current query"); + return NULL; + } + + switch (PL_close_query(d)) { + case FALSE: + return term_to_value(env, PL_exception(d)); + default: + return et(env); + } +} + +emacs_value +sweep_cut_query(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) +{ + qid_t d = PL_current_query(); + + (void)data; + (void)nargs; + (void)args; + + if (d == 0) { + ethrow(env, "No current query"); + return NULL; + } + + switch (PL_cut_query(d)) { + case FALSE: + return term_to_value(env, PL_exception(d)); + default: + return et(env); + } +} + +emacs_value +sweep_next_solution(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) +{ + qid_t d = PL_current_query(); + + (void)data; + (void)nargs; + (void)args; + + if (d == 0) { + ethrow(env, "No current query"); + return NULL; + } + + switch (PL_next_solution(d)) { + case PL_S_EXCEPTION: + return econs(env, env->intern(env, "exception"), term_to_value(env, PL_exception(d))); + case PL_S_FALSE: + return enil(env); + case PL_S_TRUE: + return econs(env, et(env), term_to_value(env, o)); + case PL_S_LAST: + return econs(env, env->intern(env, "!"), term_to_value(env, o)); + default: + return NULL; + } +} + +emacs_value +sweep_open_query(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) +{ + predicate_t p = NULL; + IOSTREAM * s = NULL; + char * m = NULL; + module_t n = NULL; + char * c = NULL; + char * f = NULL; + term_t a = PL_new_term_refs(2); + + (void)data; + (void)nargs; + + if (PL_current_query() != 0) { + ethrow(env, "Prolog is already executing a query"); + goto cleanup; + } + + if ((c = estring_to_cstring(env, args[0], NULL)) == NULL) { + goto cleanup; + } + + n = PL_new_module(PL_new_atom(c)); + + if ((m = estring_to_cstring(env, args[1], NULL)) == NULL) { + goto cleanup; + } + + if ((f = estring_to_cstring(env, args[2], NULL)) == NULL) { + goto cleanup; + } + + p = PL_predicate(f, 2, m); + + if (value_to_term(env, args[3], a+0) < 0) { + goto cleanup; + } + PL_open_query(n, PL_Q_NODEBUG | PL_Q_EXT_STATUS | PL_Q_CATCH_EXCEPTION, p, a); + + o = a+1; + + cleanup: + if (c != NULL) free(c); + if (m != NULL) free(m); + if (f != NULL) free(f); + // if (s != NULL) Sclose(s); + + return et(env); +} + +/* emacs_value */ +/* sweep_open_query(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) */ +/* { */ +/* predicate_t p = NULL; */ +/* IOSTREAM * s = NULL; */ +/* char * m = NULL; */ +/* module_t n = NULL; */ +/* char * c = NULL; */ +/* char * f = NULL; */ +/* term_t a = PL_new_term_refs(3); */ + +/* (void)data; */ +/* (void)nargs; */ + +/* if (PL_current_query() != 0) { */ +/* ethrow(env, "Prolog is already executing a query"); */ +/* goto cleanup; */ +/* } */ + +/* if ((c = estring_to_cstring(env, args[0], NULL)) == NULL) { */ +/* goto cleanup; */ +/* } */ + +/* n = PL_new_module(PL_new_atom(c)); */ + +/* if ((m = estring_to_cstring(env, args[1], NULL)) == NULL) { */ +/* goto cleanup; */ +/* } */ + +/* if ((f = estring_to_cstring(env, args[2], NULL)) == NULL) { */ +/* goto cleanup; */ +/* } */ + +/* p = PL_predicate(f, 3, m); */ + +/* if (estring_to_atom(env, args[3], a+0) < 0) { */ +/* goto cleanup; */ +/* } */ + +/* if ((s = estring_to_stream(env, args[4])) == NULL) { */ +/* goto cleanup; */ +/* } */ + +/* PL_unify_stream(a+1, s); */ + +/* PL_open_query(n, PL_Q_NODEBUG | PL_Q_EXT_STATUS | PL_Q_CATCH_EXCEPTION, p, a); */ +/* o = a+2; */ + +/* cleanup: */ +/* if (c != NULL) free(c); */ +/* if (m != NULL) free(m); */ +/* if (f != NULL) free(f); */ +/* // if (s != NULL) Sclose(s); */ + +/* return et(env); */ +/* } */ + +static emacs_value +sweep_initialize(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) +{ + (void)data; + int i = 0, r = 0; + char **argv = (char**)malloc(sizeof(char*)*nargs); + if (argv == NULL) { + ethrow(env, "malloc failed"); + return NULL; + } + for (i = 0; i < nargs; i++) { + if ((argv[i] = estring_to_cstring(env, args[i], NULL)) == NULL) { + free(argv); + return NULL; + } + } + r = PL_initialise(nargs, argv); + for (i = 0; i < nargs; i++) { + free(argv[i]); + } + free(argv); + return env->intern(env, r ? "t" : "nil"); +} + + +static emacs_value +sweep_is_initialized(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) +{ + (void)nargs; + (void)args; + (void)data; + if (PL_is_initialised(NULL, NULL) == FALSE) { + return enil(env); + } else return et(env); +} + +static emacs_value +sweep_cleanup(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) +{ + (void)nargs; + (void)data; + (void)args; + 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"); + + env->funcall(env, Qprovide, 1, (emacs_value[]){Qfeat}); +} + +int +emacs_module_init (struct emacs_runtime *runtime) +{ + emacs_env *env = runtime->get_environment (runtime); + + emacs_value symbol_initialize = env->intern (env, "sweep-initialize"); + emacs_value func_initialize = + env->make_function(env, + 1, emacs_variadic_function, + sweep_initialize, + "Initialize Prolog.\ +ARG1 is passed as argv[0] to `PL_initialise()', which see.\ +REST is passed as the rest of the command line arguments to Prolog.", + NULL); + emacs_value args_initialize[] = {symbol_initialize, func_initialize}; + env->funcall (env, env->intern (env, "defalias"), 2, args_initialize); + + emacs_value symbol_is_initialized = env->intern (env, "sweep-initialized-p"); + emacs_value func_is_initialized = + env->make_function(env, + 0, 0, + sweep_is_initialized, + "Return t if Prolog is initialized, else return nil.", + NULL); + emacs_value args_is_initialized[] = {symbol_is_initialized, func_is_initialized}; + env->funcall (env, env->intern (env, "defalias"), 2, args_is_initialized); + + emacs_value symbol_open_query = env->intern (env, "sweep-open-query"); + emacs_value func_open_query = + env->make_function(env, + 4, 4, + sweep_open_query, + "Query Prolog.\ +ARG1 is a string denoting the context module for the query.\ +ARG2 and ARG3 are strings designating the module and predicate name of the Prolog predicate to invoke, which must be of arity 3.\ +ARG4 is a string that is converted to an atom and passed as the first argument of the invoked predicate.\ +ARG5 is a string that is converted to a Prolog stream and passed as the second argument of the invoked predicate.\ +The third and final argument of the predicate is left unbound and is assumed to be an output variable, whose further instantiations can be examined via `sweep-next-solution'.", + NULL); + emacs_value args_open_query[] = {symbol_open_query, func_open_query}; + env->funcall (env, env->intern (env, "defalias"), 2, args_open_query); + + emacs_value symbol_next_solution = env->intern (env, "sweep-next-solution"); + emacs_value func_next_solution = + env->make_function(env, + 0, 0, + sweep_next_solution, + "Return the next solution from Prolog, or nil if there are none.\ +See also `sweep-open-query'.", + NULL); + emacs_value args_next_solution[] = {symbol_next_solution, func_next_solution}; + env->funcall (env, env->intern (env, "defalias"), 2, args_next_solution); + + emacs_value symbol_cut_query = env->intern (env, "sweep-cut-query"); + emacs_value func_cut_query = + env->make_function(env, + 0, 0, + sweep_cut_query, + "Finalize the current Prolog query.\ +This function retains the current instantiation of the query variables.", + NULL); + emacs_value args_cut_query[] = {symbol_cut_query, func_cut_query}; + env->funcall (env, env->intern (env, "defalias"), 2, args_cut_query); + + emacs_value symbol_close_query = env->intern (env, "sweep-close-query"); + emacs_value func_close_query = + env->make_function(env, + 0, 0, + sweep_close_query, + "Finalize the current Prolog query.\ +This function drops the current instantiation of the query variables.", + NULL); + emacs_value args_close_query[] = {symbol_close_query, func_close_query}; + env->funcall (env, env->intern (env, "defalias"), 2, args_close_query); + + + emacs_value symbol_cleanup = env->intern (env, "sweep-cleanup"); + emacs_value func_cleanup = env->make_function (env, 0, 0, sweep_cleanup, "Cleanup Prolog.", NULL); + emacs_value args_cleanup[] = {symbol_cleanup, func_cleanup}; + env->funcall (env, env->intern (env, "defalias"), 2, args_cleanup); + + provide(env, "sweep-module"); + + return 0; +} diff --git a/sweep.el b/sweep.el new file mode 100644 index 0000000..961eac9 --- /dev/null +++ b/sweep.el @@ -0,0 +1,120 @@ +;;; sweep.el --- SWI-Prolog Embedded in Emacs -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Eshel Yaron + +;; Authors: Eshel Yaron +;; Maintainer: Eshel Yaron +;; Keywords: prolog programming + +;; This file is NOT part of GNU Emacs. + +;;; Package-Version: 0.1.0 +;;; Package-Requires: ((emacs "28")) + +;;; Commentary: + +;;; Code: + +(defvar sweep-install-buffer-name "*Install sweep*" + "Name of the buffer used for compiling sweep-module.") + +;;;###autoload +(defun sweep-module-compile () + "Compile sweep-module." + (interactive) + (let* ((sweep-directory + (shell-quote-argument + (file-name-directory (locate-library "sweep.el" t)))) + (make-commands + (concat + "cd " sweep-directory "; make; cd -")) + (buffer (get-buffer-create sweep-install-buffer-name))) + (pop-to-buffer buffer) + (compilation-mode) + (if (zerop (let ((inhibit-read-only t)) + (call-process "sh" nil buffer t "-c" make-commands))) + (message "Compilation of `sweep' module succeeded") + (error "Compilation of `sweep' module failed!")))) + +(unless (require 'sweep-module nil t) + (if (y-or-n-p "Sweep needs `sweep-module' to work. Compile it now? ") + (progn + (sweep-module-compile) + (require 'sweep-module)) + (error "Sweep will not work until `sweep-module' is compiled!"))) + +(declare-function sweep-initialize "sweep-module") +(declare-function sweep-initialized-p "sweep-module") +(declare-function sweep-open-query "sweep-module") +(declare-function sweep-cut-query "sweep-module") +(declare-function sweep-close-query "sweep-module") +(declare-function sweep-cleanup "sweep-module") + +(defun sweep-predicates-collection () + (sweep-open-query "user" "sweep" "sweep_predicates_collection" nil) + (let ((sol (sweep-next-solution))) + (sweep-close-query) + (when (eq '! (car sol)) + (cdr sol)))) + +(defun sweep-predicate-location (mfn) + (sweep-open-query "user" "sweep" "sweep_predicate_location" mfn) + (let ((sol (sweep-next-solution))) + (sweep-close-query) + (let ((car (car sol))) + (when (or (eq car '!) + (eq car t)) + (cdr sol))))) + +(defun sweep-read-predicate () + "Read a Prolog predicate (M:F/N) from the minibuffer, with completion." + (let* ((col (sweep-predicates-collection))) + (completing-read "Predicate: " col))) + +(defun sweep-find-predicate (mfn) + (interactive (list (sweep-read-predicate))) + (let* ((loc (sweep-predicate-location mfn)) + (path (car loc)) + (line (cdr loc))) + (find-file path) + (goto-char (point-min)) + (forward-line (1- line)))) + +(defun sweep-modules-collection () + (sweep-open-query "user" "sweep" "sweep_modules_collection" nil) + (let ((sol (sweep-next-solution))) + (sweep-close-query) + (when (eq '! (car sol)) + (cdr sol)))) + +(defun sweep-module-path (mod) + (sweep-open-query "user" "sweep" "sweep_module_path" mod) + (let ((sol (sweep-next-solution))) + (sweep-close-query) + (when (eq '! (car sol)) + (cdr sol)))) + +(defun sweep-read-module-name () + "Read a Prolog module name from the minibuffer, with completion." + (let* ((col (sweep-modules-collection)) + (completion-extra-properties + (list :annotation-function + (lambda (key) + (concat (make-string (- 32 (length key)) ? ) + (cdr (assoc-string key col))))))) + (completing-read "Module: " col))) + +(defun sweep-find-module (mod) + (interactive (list (sweep-read-module-name))) + (find-file (sweep-module-path mod))) + +;; (add-to-list 'load-path (expand-file-name "~/checkouts/sweep/")) + +;; (require 'sweep) + +;; (sweep-initialized-p) +;; (sweep-initialize (executable-find "swipl") "-q" (expand-file-name "sweep.pl" (file-name-directory (locate-library "sweep.el" t)))) + + +(provide 'sweep) +;;; sweep.el ends here diff --git a/sweep.h b/sweep.h new file mode 100644 index 0000000..4566ad2 --- /dev/null +++ b/sweep.h @@ -0,0 +1,15 @@ +#ifndef _SWEEP_H +#define _SWEEP_H + +#include +#include +#include + +static int value_to_term(emacs_env*, emacs_value, term_t); +static emacs_value term_to_value(emacs_env*, term_t); +static char * estring_to_cstring(emacs_env*, emacs_value, ptrdiff_t*); +static int estring_to_atom(emacs_env*, emacs_value, term_t); +static IOSTREAM * estring_to_stream(emacs_env*, emacs_value); +static void ethrow(emacs_env*, const char*); + +#endif /*_SWEEP_H*/ diff --git a/sweep.pl b/sweep.pl new file mode 100644 index 0000000..3ecbd0f --- /dev/null +++ b/sweep.pl @@ -0,0 +1,197 @@ +:- module(sweep, [ sweep_colors/2, + sweep_documentation/2, + sweep_predicate_location/2, + sweep_predicates_collection/2, + sweep_modules_collection/2, + sweep_module_path/2]). + +:- use_module(library(pldoc)). +:- use_module(library(listing)). +:- use_module(library(prolog_source)). +:- use_module(library(prolog_colour)). +:- use_module(library(pldoc/doc_process)). +:- use_module(library(pldoc/doc_wiki)). +:- use_module(library(pldoc/doc_modes)). +:- use_module(library(pldoc/doc_man)). +:- use_module(library(lynx/html_text)). + +:- dynamic sweep_current_color/3, + sweep_open/2, + sweep_source_time/2, + sweep_current_comment/3. + +:- multifile prolog:xref_source_time/2, + prolog:xref_open_source/2, + prolog:xref_open_source/2, + prolog:quasi_quotation_syntax/2. + +prolog:quasi_quotation_syntax(graphql, library(http/graphql)). + +prolog:xref_source_time(Source, Time) :- + sweep_source_time(Source, Time). + +prolog:xref_open_source(Source, Stream) :- + sweep_open(Source, Stream). + +prolog:xref_close_source(Source, Stream) :- + sweep_open(Source, Stream). + +sweep_colors([Path, String], Colors) :- + setup_call_cleanup(( new_memory_file(H), + insert_memory_file(H, 0, String), + open_memory_file(H, read, Contents) + ), + sweep_colors(Path, Contents, Colors), + ( close(Contents), + free_memory_file(H) + )). +sweep_colors(Path, Contents, Colors) :- + 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_server_handle_color), + 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). + +sweep_server_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) => + 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) => + B is B0 + 1, + assertz(sweep_current_color(B, L, head_term(meta, Head))). +sweep_server_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) => + 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) => + 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) => + B is B0 + 1, + assertz(sweep_current_color(B, L, goal_term(meta, Goal))). +sweep_server_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) => + B is B0 + 1, + assertz(sweep_current_color(B, L, T)). + +sweep_documentation([Path, Functor, Arity], Docs) :- + atom_string(P, Path), + atom_string(F, Functor), + PI = F/Arity, + pi_head(PI, Head), + ( module_property(M, file(P)), + \+ predicate_property(M:Head, imported_from(_)) + -> true + ; module_property(M0, file(P)), + predicate_property(M0:Head, imported_from(M)) + -> true + ; M=user + ), + findall(Doc, sweep_documentation_(M, PI, Doc), Docs). + +sweep_documentation_(M, PI, Docs) :- + doc_comment(M:PI, Pos, OneLiner, Comment), + is_structured_comment(Comment, Prefixes), + string_codes(Comment, Codes), + indented_lines(Codes, Prefixes, Lines), + pldoc_modes:mode_lines(Lines, ModeText, [], _), + pldoc_modes:modes(ModeText, M, Pos, Modes), + sweep_documentation_modes(Modes, OneLiner, Docs). +sweep_documentation_(_, PI, Docs) :- + pldoc_man:load_man_object(PI, _, _, Dom), + with_output_to(string(DomS), html_text(Dom, [])), + sub_string(DomS, EOL, _, _, '\n'), + sub_string(DomS, 0, EOL, _, FLine), + sub_string(DomS, EOL, _, 0, Rest), + ( sub_string(Rest, EOS, _, _, '. ') + -> sub_string(Rest, 0, EOS, _, OneLiner2) + ; OneLiner2=Rest + ), + format(string(Docs), '~w. ~w.~n', [FLine, OneLiner2]), + !. + +sweep_documentation_modes([mode(Mode0, Args)|_], OneLiner, Docs) :- + maplist([Name=Var]>>(Var='$VAR'(Name)), Args), + ( Mode0=(Mode1 is Det) + -> true + ; Mode1=Mode0, + Det=unspec + ), + format(string(Docs), + '~W is ~w.~n ~w~n', + [ Mode1, + [module(pldoc_modes), numbervars(true)], + Det, + OneLiner + ]). +sweep_documentation_modes([_|T], OneLiner, Docs) :- + sweep_documentation_modes(T, OneLiner, Docs). + + +sweep_module_path(ModuleName, Path) :- + atom_string(Module, ModuleName), + sweep_module_path_(Module, Path0), + atom_string(Path0, Path). + +sweep_module_path_(Module, Path) :- + module_property(Module, file(Path)), !. +sweep_module_path_(Module, Path) :- + '$autoload':library_index(_, Module, Path), !. + +sweep_modules_collection([], Modules) :- + findall([M|P], ( module_property(M0, file(P0)), atom_string(M0, M), atom_string(P0, P) ), Modules0, Tail), + setof([M|P], M0^P0^N^('$autoload':library_index(N, M0, P0), atom_string(M0, M), atom_string(P0, P) ), Tail), + list_to_set(Modules0, Modules). + +sweep_predicate_location(MFN, [Path|Line]) :- + term_string(M:F/N, MFN), + pi_head(F/N, H), + predicate_property(M:H, line_count(Line)), + predicate_property(M:H, file(Path0)), atom_string(Path0, Path). + +sweep_predicates_collection([], Preds) :- + findall(Pred, + ( current_predicate(M0:P0/N), + pi_head(P0/N, H), + \+ (predicate_property(M0:H, imported_from(M)), M \= M0), + format(string(Pred), '~w:~w/~w', [M0, P0, N]) + ), + Preds0, + Tail), + findall(Pred, + ( '$autoload':library_index(F, M0, _), + pi_head(P0/N, F), + format(string(Pred), '~w:~w/~w', [M0, P0, N]) + ), + Tail), + list_to_set(Preds0, Preds). -- 2.39.2