Moved future stuff to future/.

Pascal J. Bourguignon [2021-05-09 00:44]
Moved future stuff to future/.
Filename
future/pjb-package.el
pjb-browser.el
pjb-package.el
diff --git a/future/pjb-package.el b/future/pjb-package.el
new file mode 100644
index 0000000..d5b7c68
--- /dev/null
+++ b/future/pjb-package.el
@@ -0,0 +1,184 @@
+;;;; -*- mode:emacs-lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               package.el
+;;;;LANGUAGE:           emacs lisp
+;;;;SYSTEM:             POSIX
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;NOTE
+;;;;
+;;;;    To implement a package system, we need foremost a hook in the
+;;;;    lisp reader, to be able to interpret symbol names and
+;;;;    qualified symbol names as we wish.
+;;;;
+;;;;    Given a reader hooks, we can use the native intern or
+;;;;    implement it otherwise (emacs:intern vs. cl:intern).
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-12-17 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(require 'cl)
+
+
+(defstruct cl:package
+  name
+  (external-table   (make-hash-table))
+  (present-table    (make-hash-table))
+  (shadowing-table  (make-hash-table))
+  (used-packs       '())
+  (used-by-packs    '())
+  (nicknames        '())
+  (documentation    nil)
+  obarray)
+
+(defun make-obarray (length) (make-vector length 0))
+
+(defvar cl::*emacs-lisp-package*
+  (make-cl:package
+   :name "EMACS-LISP"
+   :nicknames '("emacs-lisp"  "ELISP" "elisp")
+   :documentation "The package exporting the emacs lisp language symbols."
+   :obarray (make-obarray (length obarray))))
+
+(defvar cl::*emacs-package*
+  (make-cl:package
+   :name "EMACS"
+   :nicknames '("emacs")
+   :documentation "The package exporting the emacs symbols."
+   :obarray (make-obarray (length obarray))))
+
+(defvar cl::*emacs-user-package*
+  (make-cl:package
+   :name "EMACS-USER"
+   :nicknames '("emacs-user")
+   :documentation "The package where emacs user symbols are interned into."
+   :obarray obarray))
+
+
+(defvar cl:*package* cl::*emacs-user-package*)
+
+(defun cl:export (symbols &optional (package cl:*package*))
+  )
+
+(defun cl:use-package (used-package &optional (using-package cl:*package*))
+  )
+
+(defmacro cl:in-package (new-package)
+  `(eval-when (compile load eval)
+     (let ((new-package (cl:find-package new-package)))
+       (when new-package
+         (setf obarray (cl:package-obarray new-package)
+               cl:*package* new-package)))))
+
+(defvar cl::*package-list* (list
+                            cl::*emacs-lisp-package*
+                            cl::*emacs-package*
+                            cl::*emacs-user-package*))
+
+(defun cl:list-all-packages ()
+  (copy-list cl::*package-list*))
+
+
+(defun cl:intern (name &optional (package cl:*package*)))
+
+(cl:export '(lambda if cond car rplaca #| … |#)
+           cl::*emacs-lisp-package*)
+
+(cl:use-package cl::*emacs-lisp-package* cl::*emacs-package*)
+
+(cl:export '(buffer find-file make-frame #| … |#
+             )
+           cl::*emacs-package*)
+
+(cl:use-package cl::*emacs-package* cl::*emacs-user-package*)
+
+
+
+
+
+
+;; (defvar obarray (make-obarray 113) "Symbol table for use by `intern' and `read'.")
+
+
+;; (defun intern (STRING &optional OBARRAY))
+;; (defun intern-soft (STRING &optional OBARRAY))
+;; (defun mapatoms (FUNCTION &optional OBARRAY))
+;; (defun unintern (SYMBOL-OR-STRING OBARRAY))
+;;
+;; (defun read (&optional STREAM))
+;;
+;;
+;; (defun symbol-plist (symbol))
+;; (defun setplist (symbol plist))
+;; (defun get (symbol property))
+;; (defun put (symbol property value))
+
+
+(defun obarray-symbols (obarray)
+  (let ((symbols '()))
+    (mapatoms (lambda (symbol) (push symbol symbols)) obarray)
+    (sort symbols (function string<))))
+
+;; (length (obarray-symbols obarray))
+;; 89918
+
+
+;; (let ((results '()))
+;;   (do-symbols (n)
+;;     (when (and (fboundp n)
+;;                (not (symbolp (symbol-function n)))
+;;                (not (subrp   (symbol-function n))))
+;;       (let ((pl (function-parameter-list n)))
+;;         ;; (insert (format "%S %S\n" n pl))
+;;         (when (and (listp pl) (ignore-errors (member 'obarray pl)))
+;;           (push (cons n pl) results)))))
+;;   results)
+
+
+
+;; (defvar ob1 (make-obarray 113))
+;; (defvar ob2 (make-obarray 113))
+;;
+;; (defvar s1 (intern "Hello" ob1))
+;; (intern "World" ob1)
+;; (mapatoms 'print ob1)
+;; (eq 'Hello s1)
+
+;; (defparameter *table*
+;;   (let* ((symbols (obarray-symbols obarray))
+;;          (table (make-hash-table :test 'eql :size (* 3 (length symbols)))))
+;;     (dolist (sym symbols table)
+;;       (setf (gethash (symbol-name sym) table) sym))))
+;;
+;;
+;; (let* ((names (mapcar 'symbol-name (obarray-symbols obarray))))
+;;   (insert (time (dolist (name names)
+;;                   (intern name obarray)))
+;;           (time (dolist (name names)
+;;                   (gethash name *table*)))))
+;;
+;;
+;; (intern 'hello ob1)
+;; (hash-table-count *table*)
+
diff --git a/pjb-browser.el b/pjb-browser.el
new file mode 100644
index 0000000..79f0708
--- /dev/null
+++ b/pjb-browser.el
@@ -0,0 +1,229 @@
+;;;; -*- mode:emacs-lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               pjb-browser.el
+;;;;LANGUAGE:           emacs lisp
+;;;;SYSTEM:             POSIX
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    A column-based browser.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2021-05-08 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2021 - 2021
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+(require 'pjb-cl)
+(require 'org)
+(require 'org-table)
+
+;;;---------------------------------------------------------------------
+;;; Utilities
+;;;---------------------------------------------------------------------
+
+(defun emptyp (sequence)
+  "Predicate: the sequence is empty."
+  (or (null sequence)
+      (and (not (consp sequence))
+           (zerop (length sequence)))))
+
+(defmacro with-temp-mode (mode &body body)
+  (let ((saved-mode (gensym)))
+    `(let ((,saved-mode major-mode))
+       (unless (eq ,saved-mode ',mode)
+         (,mode))
+       (unwind-protect
+            (progn ,@body)
+         (unless (eq ,saved-mode ',mode)
+           (funcall ,saved-mode))))))
+
+
+;;;---------------------------------------------------------------------
+;;; Functions missing from org-table
+;;;---------------------------------------------------------------------
+
+(defun org-table-columns ()
+  "Return the number of column in the current org-table."
+  (org-table-analyze)
+  org-table-current-ncol)
+
+(defun org-table-clean-column (&optional column)
+  "Empty all the data cells in the `column` number or the current column."
+  (interactive)
+  ;; TODO: perhaps org-table would want to update computed stuff from the new table?
+  (let ((column (org-table-current-column)))
+    (org-table-goto-column column nil t)
+    (org-table-insert-column)
+    (org-table-goto-column (+ 1 column) nil t)
+    (org-table-delete-column)))
+
+(defun org-table-delete-row (&optional row)
+  "Delete the `row` number or the current row."
+  (interactive)
+  ;; TODO: perhaps org-table would want to update computed stuff from the new table?
+  (when row
+    (org-table-goto-line row))
+  (beginning-of-line)
+  (kill-line)
+  (org-table-next-field))
+
+(defun org-table-remove-empty-rows ()
+  "Delete all the rows in the current table that have only empty cells."
+  (interactive)
+  ;; TODO: perhaps org-table would want to update computed stuff from the new table?
+  (loop
+    with row = 1
+    while (ignore-errors (org-table-goto-line row))
+    if (loop for column from 1 to (org-table-columns)
+             for cell = (org-table-get row column)
+             ;; do (message "cell[%d,%d]= %S" row column cell)
+             always (emptyp cell))
+      do (org-table-delete-row row)
+    else
+      do (incf row)))
+
+
+;;;---------------------------------------------------------------------
+;;; Browser functions
+;;;---------------------------------------------------------------------
+
+(defun pjb-insert-browser-table ()
+  "Insert at the point a new empty browser table."
+  (org-table-create "1x1")
+  (org-table-next-field)
+  (org-table-hline-and-move nil)
+  (org-table-goto-line 2))
+
+(defun pjb-insert-browser-column (column title browser-items)
+  "Insert the `browser-items` in the `column` number in the current org-table, under the `title`.
+If the table dosn't have that number of columns, they're automatically created."
+  ;; browser-item ::= (title action data)
+  (org-table-clean-column column)
+  (when title
+    (org-table-goto-line 1)
+    (org-table-goto-column column)
+    (org-table-blank-field)
+    (insert title))
+  (org-table-goto-line 2)
+  (org-table-goto-column column)
+  (let ((head-pos (point)))
+    (loop
+      with first-row = t
+      for (title action data) in browser-items
+      do (if first-row
+             (setf first-row nil)
+             (org-table-next-row))
+         (org-table-blank-field)
+         (insert-text-button title
+                             'action action
+                             'button-data (cons title data)))
+    (org-table-remove-empty-rows)
+    (goto-char head-pos)
+    (org-table-align)))
+
+
+(defun pjb-browser-browser-window (name)
+  (switch-to-buffer (get-buffer-create (format "*%s Browser*" name)))
+  (org-mode)
+
+  (let ((map (make-sparse-keymap)))
+    (suppress-keymap map t)
+
+    (local-set-key "n" 'org-table-next-row)
+    (define-key map "p" 'org-table-previous-row)
+    (define-key map "n"   'next-item)
+    (define-key map "C-n" 'next-item)
+    (define-key map "p"   'previous-item)
+    (define-key map "C-p" 'previous-item)
+    map))
+
+(local-set-key (kbd "C-c i") *clage-mode-map*)
+  )
+
+(defun pjb-browser-item-window (fname)
+  "Locate the window for the file fname, or split the current window for it."
+  (let ((buffer (find fname (buffer-list)
+                      :key (function buffer-file-name)
+                      :test (function equal)))
+        (size -10))
+    (select-window
+     (or
+      ;; If there is already a window with the buffer for the file:
+      (and buffer (find buffer (window-list) :key (function window-buffer)))
+      ;; otherwise, find a good window:
+      (let ((window (or (window-in-direction 'below)
+                        (split-window (selected-window) size 'above))))
+        ;; and visit the buffer there:
+        (if buffer
+            (switch-to-buffer buffer)
+            (find-file fname))
+        window)))))
+
+
+(defun pjb-select-category-item (data)
+  (destructuring-bind (category-title &rest items-browser-items) data
+    (pjb-insert-browser-column 2 category-title items-browser-items)))
+
+(defun pjb-select-item (data)
+  (let ((item (cdr data)))
+    (pjb-browser-item-window (item-file item))
+    (with-current-buffer (current-buffer)
+      (goto-char (point-min))
+      (search-forward (item-code item) nil t))))
+
+
+
+
+
+(defvar *categories* '(requirement specification analysis
+                       design code unit-test integration-test
+                       documentation))
+
+(defun make-item-browser-tree (buffer)
+  (let ((categories (make-hash-table))
+        (result '()))
+    (dolist (category *categories*)
+      (setf (gethash category categories) '()))
+    (dolist (item (extract-trace-items-from-buffer buffer))
+      (push (list (item-identification item) 'pjb-select-item item)
+            (gethash  (item-category item) categories '())))
+    (maphash (lambda (category items)
+               (push (list (symbol-name category)
+                           'pjb-select-category-item
+                           (sort* items
+                                  (function string<)
+                                  :key (function first)))
+                     result))
+             categories)
+    (nreverse result)))
+
+(defun pjb-browse-items ()
+  (interactive)
+  (let ((item-buffer (current-buffer)))
+    (pjb-browser-browser-window (format "Items of %s" (buffer-name)))
+    (erase-buffer)
+    (pjb-insert-browser-table)
+    (pjb-insert-browser-column
+     1 "categories"
+     (make-item-browser-tree item-buffer))))
+
+
+;;;; THE END ;;;;
diff --git a/pjb-package.el b/pjb-package.el
deleted file mode 100644
index 4a01b20..0000000
--- a/pjb-package.el
+++ /dev/null
@@ -1,118 +0,0 @@
-;;;; -*- mode:emacs-lisp;coding:utf-8 -*-
-;;;;**************************************************************************
-;;;;FILE:               package.el
-;;;;LANGUAGE:           emacs lisp
-;;;;SYSTEM:             POSIX
-;;;;USER-INTERFACE:     NONE
-;;;;DESCRIPTION
-;;;;NOTE
-;;;;
-;;;;    To implement a package system, we need foremost a hook in the
-;;;;    lisp reader, to be able to interpret symbol names and
-;;;;    qualified symbol names as we wish.
-;;;;
-;;;;    Given a reader hooks, we can use the native intern or
-;;;;    implement it otherwise (emacs:intern vs. cl:intern).
-;;;;
-;;;;AUTHORS
-;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
-;;;;MODIFICATIONS
-;;;;    2012-12-17 <PJB> Created.
-;;;;BUGS
-;;;;LEGAL
-;;;;    AGPL3
-;;;;
-;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
-;;;;
-;;;;    This program is free software: you can redistribute it and/or modify
-;;;;    it under the terms of the GNU Affero General Public License as published by
-;;;;    the Free Software Foundation, either version 3 of the License, or
-;;;;    (at your option) any later version.
-;;;;
-;;;;    This program is distributed in the hope that it will be useful,
-;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;;;    GNU Affero General Public License for more details.
-;;;;
-;;;;    You should have received a copy of the GNU Affero General Public License
-;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
-;;;;**************************************************************************
-
-
-(defstruct package
-  name
-  (external-table   (make-hash-table))
-  (present-table    (make-hash-table))
-  (shadowing-table  (make-hash-table))
-  (used-packs       '())
-  (used-by-packs    '())
-  (nicknames        '())
-  (documentation    nil)
-  obarray)
-
-
-
-(defun make-obarray (length) (make-vector length 0))
-
-(defvar obarray (make-obarray 113) "Symbol table for use by `intern' and `read'.")
-
-(defun intern (STRING &optional OBARRAY))
-(defun intern-soft (STRING &optional OBARRAY))
-(defun mapatoms (FUNCTION &optional OBARRAY))
-(defun unintern (SYMBOL-OR-STRING OBARRAY))
-
-(defun read (&optional STREAM))
-
-
-(defun symbol-plist (symbol))
-(defun setplist (symbol plist))
-(defun get (symbol property))
-(defun put (symbol property value))
-
-
-
-(defun obarray-symbols (obarray)
-  (let ((symbols '()))
-    (mapatoms (lambda (symbol) (push symbol symbols)) obarray)
-    (sort symbols (function string<))))
-
-(obarray-symbols obarray)
-
-
-(let ((results '()))
-  (do-symbols (n)
-    (when (and (fboundp n)
-               (not (symbolp (symbol-function n)))
-               (not (subrp   (symbol-function n))))
-      (let ((pl (function-parameter-list n)))
-        ;; (insert (format "%S %S\n" n pl))
-        (when (member 'OBARRAY pl)
-          (push (cons n pl) results)))))
-  results)
-
-
-(defvar ob1 (make-obarray 113))
-(defvar ob2 (make-obarray 113))
-
-(defvar s1 (intern "Hello" ob1))
-(intern "World" ob1)
-(mapatoms 'print ob1)
-(eq 'Hello s1)
-
-(defparameter *table*
-  (let* ((symbols (obarray-symbols obarray))
-         (table (make-hash-table :test 'eql :size (* 3 (length symbols)))))
-    (dolist (sym symbols table)
-      (setf (gethash (symbol-name sym) table) sym))))
-
-
-(let* ((names (mapcar 'symbol-name (obarray-symbols obarray))))
-  (insert (time (dolist (name names)
-                  (intern name obarray)))
-          (time (dolist (name names)
-                  (gethash name *table*)))))
-
-
-(intern 'hello ob1)
-(hash-table-count *table*)
-
ViewGit