# HG changeset patch # User Richard Westhaver # Date 1726625959 14400 # Node ID b499d4bcfc397ff6c1c2e85987242aab9ee58975 # Parent 65102f74d1ae6f787d40bccc37fb9929d6f5209e removed x.lisp diff -r 65102f74d1ae -r b499d4bcfc39 emacs/lib/graph.el --- a/emacs/lib/graph.el Mon Sep 16 21:28:33 2024 -0400 +++ b/emacs/lib/graph.el Tue Sep 17 22:19:19 2024 -0400 @@ -66,15 +66,13 @@ :type 'hook :group 'graph) -(defvar-local org-graph nil - "The currently active graph of org nodes.") - (defcustom org-graph-db-init-script (join-paths company-source-directory "infra/scripts/org-db-init.lisp") "Path to a lisp script responsible for initializing the `org-graph-db-directory'.") (cl-defstruct org-graph-db-handle (type :rocksdb) (name "org-graph-db") + init get put delete @@ -101,12 +99,70 @@ org-graph-locations)) org-graph)) -(defun org-dblock-write:links () - "Generate a 'links' block for the designated node.") +(defun org-graph-files () + (org-list-files org-graph-locations org-agenda-extensions)) + +(cl-defstruct org-graph + ;; TODO 2024-09-17: use integers instead of string + (nodes (make-hash-table :test 'equal)) + (edges (make-hash-table :test 'equal))) + +(defvar org-graph (make-org-graph) + "The Emacs-native org-graph. Should be assigned to an `org-graph' instance.") + +(cl-defstruct org-graph-node id name file point) +(cl-defstruct org-graph-edge (type 'link) in properties timestamp out) + +(defun org-graph--file-hash (file) + "Compute the hash of FILE." + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents-literally file) + (secure-hash 'md5 (current-buffer)))) -(defun org-dblock-write:graph () - "Generate a 'graph' block for the designated set of nodes.") +(defun org-graph-node-at-point (&optional update) + "Return the `org-graph-node' at point. When UPDATE is non-nil insert or +update the node into the currently active org-graph." + (let* ((file (buffer-file-name)) + (node (make-org-graph-node :point (point) :file file))) + (if (derived-mode-p 'org-mode) + (progn + (if (org-before-first-heading-p) + (setf (org-graph-node-name node) (org-get-title) + ;; use the filename, create a hash as id + (org-graph-node-id node) (org-graph--file-hash file)) + (setf (org-graph-node-id node) (org-id-get) + (org-graph-node-name node) (cadddr (org-heading-components))))) + (setf (org-graph-node-id node) (org-graph--file-hash file) + (org-graph-node-name node) (file-name-nondirectory file))) + (when update + (puthash (org-graph-node-id node) node (org-graph-nodes org-graph))) + (message "%s" node))) +;; TODO 2024-09-17: +(defun org-graph-edges-at-point (&optional update) + "Return a list of `org-graph-edge' instances associated with the node at +point. When UPDATE is non-nil insert or update the edges into the +currently active org-graph." + (interactive) + (let ((edges)) + (if (derived-mode-p 'org-mode)) + (when update + (dolist (edge edges) + (puthash (org-graph-edge-in edge) edge (org-graph-edges org-graph)))) + (message "%s" edge))) + +(defun org-graph-buffer-update (&optional buffer) + "Map over an org buffer adding all nodes to the active org-graph." + (interactive) + (save-excursion + (with-current-buffer (or buffer (current-buffer)) + ;; capture file node + (goto-char (point-min)) + (org-graph-node-at-point t) + (when (derived-mode-p 'org-mode) + (org-map-entries (lambda () (org-graph-node-at-point t))))))) + ;;; Links ;; See https://github.com/toshism/org-super-links/blob/develop/org-super-links.el (declare-function org-make-link-description-function "ext:org-mode") @@ -449,39 +505,31 @@ (message "No edge found. Deleting active only."))))))) (org-graph-edge--delete-link (org-element-context))) -;;;###autoload -(defun org-graph-edge-store-link (&optional GOTO KEYS) +(defvar org-graph-stored-mark nil + "mark stored with `org-graph-edge-store'.") + +(defun org-graph-edge-store () "Store a point to register for use in function `org-graph-edge-insert-link'. This is primarily intended to be called before `org-capture', but could possibly even be used to replace `org-store-link' IF function `org-graph-edge-insert-link' is used to replace `org-insert-link'. This has not been thoroughly tested outside -of links to/form org files. GOTO and KEYS are unused." +of links to/form org files." (interactive "P") - (ignore GOTO) - (ignore KEYS) - (save-excursion - ;; this is a hack. if the point is at the first char of a heading - ;; the marker is not updated as expected when text is inserted - ;; above the heading. for example a capture template inserted - ;; above. that results in the link being to the heading above the - ;; expected heading. - (goto-char (line-end-position)) - (let ((c1 (make-marker))) - (set-marker c1 (point) (current-buffer)) - (set-register ?^ c1) - (message "Link copied")))) + (let ((c1 (make-marker))) + (set-marker c1 (point) (current-buffer)) + (setq org-graph-stored-mark c1) + (message "Mark stored."))) ;;;###autoload (defun org-graph-edge-insert-link () - "Insert an edge link from the register." + "Insert an edge from the list `org-graph-stored-marks'." (interactive) - (let* ((target (get-register ?^))) - (if target - (progn - (org-graph-edge--insert-link target) - (set-register ?^ nil)) - (message "No link to insert!")))) + (if org-graph-stored-mark + (progn + (org-graph-edge--insert-link org-graph-stored-mark) + (setq org-graph-stored-mark nil)) + (org-graph-edge-link))) ;;;###autoload (defun org-graph-edge-link () @@ -489,5 +537,11 @@ (interactive) (org-graph-edge-search-function)) +(defun org-dblock-write:links () + "Generate a 'links' block for the designated node.") + +(defun org-dblock-write:graph () + "Generate a 'graph' block for the designated set of nodes.") + (provide 'graph) ;; graph.el ends here diff -r 65102f74d1ae -r b499d4bcfc39 lisp/lib/obj/graph/pkg.lisp --- a/lisp/lib/obj/graph/pkg.lisp Mon Sep 16 21:28:33 2024 -0400 +++ b/lisp/lib/obj/graph/pkg.lisp Tue Sep 17 22:19:19 2024 -0400 @@ -29,7 +29,7 @@ ;;; Edge (defclass edge (node) - ((a :initarg :in) (b :initarg :out)) + ((in :initarg :in) (out :initarg :out)) (:documentation "generic edge mixin. Compatible with the NODE and ID protocols.")) (defclass edgex (edge id) diff -r 65102f74d1ae -r b499d4bcfc39 readme.org --- a/readme.org Mon Sep 16 21:28:33 2024 -0400 +++ b/readme.org Tue Sep 17 22:19:19 2024 -0400 @@ -62,125 +62,30 @@ Building the core will produce its output to the =.stash= directory by default. You can then test, run, and install the resulting files or package them up to be shipped elsewhere. - -The core produces a collection of native program binaries, compiled -lisp modules in FASL format, as well as web distributions containing -the usual suspects (html, css, js) as well as wasm modules. - ** From Source *** Lisp The Lisp Core can be found under the =lisp= directory. It is the largest system, most actively developed, and is intended to cover the complete surface of the user-facing APIs contained in the core. -Starting from a standard Common Lisp environment with at least -[[https://www.quicklisp.org/beta/][Quicklisp]] installed, you can execute =./x.lisp build skel= to build -the project compiler and =./x.lisp run skel= to run it. This tool is a -convenience for building and testing different parts of the core from -a minimal dependency set. - -#+name: x-help -#+begin_src shell :exports both :results output -# bootstrap the core build tool -./x.lisp --help -#+end_src - -#+RESULTS: x-help -#+begin_example -This is SBCL 2.4.7:76bbecb68, an implementation of ANSI Common Lisp. -More information about SBCL is available at . - -SBCL is free software, provided as is, with absolutely no warranty. -It is mostly in the public domain; some portions are provided under -BSD-style licenses. See the CREDITS and COPYING files in the -distribution for more information. -To load "rt": - Load 1 ASDF system: - rt -; Loading "rt" - -x.lisp --- core build tool -x.lisp [CMD] -CMDS: -test -compile -build -make -test -run -save -install -#+end_example - -To test the lisp standard library: -#+begin_src shell :results output :exports both -# test systems -./x.lisp test std -#+end_src - -#+RESULTS: -#+begin_example -This is SBCL 2.4.7:dc890089a, an implementation of ANSI Common Lisp. -More information about SBCL is available at . +The core is self-hosted in the sense that it is intended to be built +from one of its own programs - the =skel= project compiler. You may +also load any part of the core individually as long as you have [[https://www.sbcl.org/][SBCL]] +and [[https://www.quicklisp.org/beta/][Quicklisp]] installed. +*** Rust +Today, the Rust components of the core are quite small and +isolated. We like Rust right now for the reasonable memory safety +guarantees, as an interface to (W)GPU, WASM, LLVM, etc, and because it +has an industry-sponsored ecosystem (guaranteed future). -SBCL is free software, provided as is, with absolutely no warranty. -It is mostly in the public domain; some portions are provided under -BSD-style licenses. See the CREDITS and COPYING files in the -distribution for more information. -To load "rt": - Load 1 ASDF system: - rt -; Loading "rt" - -To load "rt": - Load 1 ASDF system: - rt -; Loading "rt" - -To load "std/tests": - Load 1 ASDF system: - std/tests -; Loading "std/tests" - -in suite STD: -; with 15 tests -# -# -# -# -# -# -# -# -# -# -# -# -# -# -# -No tests failed. -#+end_example - -To save the prelude to =.stash/prelude.core=: -#+begin_src shell :results output :noeval t -# save cores -./x save prelude -#+end_src - -And to install binaries (defaults to =/usr/local/bin/=): -#+begin_src shell :results none :noeval t -# install binaries -sudo ./x install -#+end_src - -*** Rust -The Core Rust system can be found under the =rust= directory. +Our Rust code is far less concerned with being completely from +scratch - dependencies are imported freely and at will - adapting to +whatever FOTM is hot right now. A workspace is configured such that you can build all components with the following command (~NOTE~ - takes a long time): #+begin_src shell :exports both :results output - cd rust && cargo build --release + cd rust && cargo build #+end_src *** Emacs diff -r 65102f74d1ae -r b499d4bcfc39 skelfile --- a/skelfile Mon Sep 16 21:28:33 2024 -0400 +++ b/skelfile Tue Sep 17 22:19:19 2024 -0400 @@ -17,7 +17,7 @@ psl.dat parquet.json rgb.txt save-std save-prelude save-user save-infra save-core save-tests - build-tree-sitter-alien build-core fasl + build-tree-sitter-alien build-core fasls ;; build-skel build-organ build-homer build-packy build-rdb ;; rust-bin )) @@ -140,7 +140,7 @@ (:compile () (compile-lisp :core/tests :force t :verbose t))) (bench () (:compile () (compile-lisp :core/bench :force t :verbose t))) - (fasl (compile-core #+nil compile-tests compile-bench compile-user compile-prelude)) + (fasls (compile-core #+nil compile-tests compile-bench compile-user compile-prelude)) ;; rust (mailman () #$cd rust && cargo build -Z unstable-options --bin mailman --artifact-dir ../.stash/$#) (alik () #$cd rust && cargo build -Z unstable-options --bin alik --artifact-dir ../.stash/$#) diff -r 65102f74d1ae -r b499d4bcfc39 x.lisp --- a/x.lisp Mon Sep 16 21:28:33 2024 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,319 +0,0 @@ -#!/usr/bin/env -S sbcl --no-sysinit --no-userinit --script -;;; core build tool - -;; - -;;; Code: -(in-package :cl-user) -#-(or sbcl cl) (error "unsupported Lisp compiler") -#-quicklisp -(let ((quicklisp-init (or (probe-file #p"~/.stash/quicklisp/setup.lisp") - (probe-file #p"/usr/local/share/lisp/quicklisp/setup.lisp") - (probe-file #p "~/quicklisp/setup.lisp")))) - (when (probe-file quicklisp-init) - (load quicklisp-init))) -(require 'sb-rotate-byte) -(require 'sb-introspect) -(require 'sb-grovel) -(require 'sb-cltl2) -(require 'sb-cover) -(require 'sb-sprof) - -(asdf:load-system (asdf:find-system :cl-ppcre)) -(asdf:load-asd (probe-file (merge-pathnames "std.asd" "lisp/std/"))) -(asdf:load-system :std) - -(defpackage :x - (:use :cl :std :std/named-readtables :cl-user) - (:export :*core-path* :*lisp-path* :*lib-path* :*std-path* :*ffi-path* :*stash-path* :*web-path* :*bin-path* - :*compression-level*)) - -(in-package :x) -(use-package :sb-gray) -;; (require 'sb-aclrepl) -(sb-ext:enable-debugger) -(defvar *core-path* (directory-namestring #.(or *load-truename* *compile-file-truename* (error "run me as an executable!")))) - -(defvar *lisp-path* (merge-pathnames "lisp/" *core-path*)) -(defvar *bin-path* (merge-pathnames "bin/" *lisp-path*)) -(defvar *web-path* (merge-pathnames "web/" *lisp-path*)) -(defvar *lib-path* (merge-pathnames "lib/" *lisp-path*)) -(defvar *std-path* (merge-pathnames "std/" *lisp-path*)) -(defvar *ffi-path* (merge-pathnames "ffi/" *lisp-path*)) -(defvar *stash-path* (merge-pathnames ".stash/" *core-path*)) - -(defvar *compression-level* nil) - -(push *core-path* asdf:*central-registry*) -(push *lisp-path* ql:*local-project-directories*) -(push *lib-path* ql:*local-project-directories*) -(push *bin-path* ql:*local-project-directories*) -(push *ffi-path* ql:*local-project-directories*) - -(ql:register-local-projects) - -(unless (asdf:find-system :log nil) - (asdf:load-asd (probe-file (merge-pathnames "log/log.asd" *lib-path*)))) - -(asdf:load-system :log) -(use-package :log) - -(unless (asdf:find-system :rocksdb nil) - (asdf:load-asd (probe-file (merge-pathnames "rocksdb/rocksdb.asd" *ffi-path*))) - (asdf:load-system :rocksdb)) - -(unless (asdf:find-system :cli nil) - (asdf:load-asd (probe-file (merge-pathnames "cli/cli.asd" *lib-path*)))) - -(asdf:load-system :cli) -(use-package :cli) - -(defun done () (print :OK)) - -(defmethod asdf:perform ((o asdf:image-op) (c asdf:system)) - (uiop:dump-image (merge-pathnames (car (last (std::ssplit #\/ (asdf:component-name c)))) *stash-path*) :executable t :compression *compression-level*)) - -(defun compile-std (&optional force save) - (ql:quickload :std) - (when save - (in-package :std-user) - (sb-ext:save-lisp-and-die (merge-pathnames "std.core" *stash-path*) :compression *compression-level*))) - -(defun compile-prelude (&optional force save) - ;; (compile-std) - (asdf:compile-system :prelude :force force) - (asdf:load-system :prelude :force force) - ;; (rocksdb:load-rocksdb save) - (when save - (in-package :std-user) - (use-package :cl-user) - (sb-ext:save-lisp-and-die (merge-pathnames "prelude.core" *stash-path*) :compression *compression-level*))) - -(defun compile-user (&optional force save compression (name "user.core")) - (asdf:compile-system :user :force force) - (asdf:load-system :user :force force) - (when save - (in-package :user) - (use-package :cl-user) - (sb-ext:save-lisp-and-die (merge-pathnames name *stash-path*) :compression (or compression *compression-level*)))) - - -(defun compile-tests (&optional force save) - (asdf:compile-system :core/tests :force force) - (asdf:load-system :core/tests :force force) - (when save - (in-package :core/tests) - (sb-ext:save-lisp-and-die (merge-pathnames "tests.core" *stash-path*) :compression *compression-level*))) - -(defun compile-core (&optional force save) - (asdf:compile-system :core :force force) - (asdf:load-system :core :force force) - (when save - (in-package :core) - (sb-ext:save-lisp-and-die (merge-pathnames "core.core" *stash-path*) :compression *compression-level*))) - -(defun save-foreign (name exports &rest args) - (apply #'sb-ext:save-lisp-and-die name (append `(:executable nil :callable-exports ,exports) args))) - -(sb-alien:define-alien-callable compile-prelude sb-alien:void () (compile-prelude)) -(sb-alien:define-alien-callable compile-std sb-alien:void () (compile-std)) -(sb-alien:define-alien-callable compile-user sb-alien:void () (compile-user)) - -(defvar *thunk* nil) - -(setq *print-level* 32 - *print-length* 64) -;; collect args from shell -(defvar *args* (cdr sb-ext:*posix-argv*)) -(defvar *flags* - '((version "0.1.0") - (help "x.lisp --- core build tool -x.lisp [CMD] -CMDS: -test -compile -build -make -test -run -save -install"))) - -(defun getflag (k) - (cadar - (member - (string-upcase k) - *flags* - :test #'string= - :key #'car))) - -(defun bail (msg) - (log::fatal! msg)) - -(defun parse-flag (arg) - (flet ((f (k) - (if (or (characterp k) (= (length k) 1)) - (case (char-downcase (character k)) - (#\v "VERSION") - (#\h "HELP")) - k))) - (if (char-equal (aref arg 0) #\-) - (if (= (length arg) 2) ;; short - (f (aref arg 1)) - (if (char-equal (aref arg 1) #\-) ;; long - (f (subseq arg 2)) - (bail "invalid flag")))))) - -;; (defun parse-arg (arg)) -(defun x-compile (args) - (if args - (let ((name (car args))) - (ql:quickload name) - (asdf:compile-system name :force t)) - (compile-prelude t nil))) - -(defun %build (name) - (format t "saving ~A to: ~A~%" name (merge-pathnames name *stash-path*)) - (let ((sys (sb-int:keywordicate (format nil "BIN/~A" (string-upcase name))))) - (ql:quickload sys) - (push :ssl *features*) - ;; (std/sys:forget-shared-objects) - (asdf:make sys))) - -(defun x-build (args) - (if args - (let ((name (car args))) - (ensure-directories-exist *stash-path*) - (%build name)) - (std:wait-for-threads (mapcar - (lambda (x) - (sb-thread:make-thread - (lambda () - (sb-ext:run-program "x.lisp" (list "build" x) :wait t :output t)) - :name x)) - (list "skel" "rdb" "organ" "homer" "packy"))))) - -(defun stash-output (name) - (let* ((sys (asdf:find-system name)) - (fasl (make-pathname - :name (asdf/system:component-build-pathname sys) - :type (if (string-equal name "std") - "lisp" - "fasl")))) - (uiop:rename-file-overwriting-target - (merge-pathnames fasl (asdf:system-source-directory sys)) - (merge-pathnames fasl *stash-path*)))) - -(defun %make (name) - (let ((sys (sb-int:keywordicate (string-upcase name)))) - (std/sys:forget-shared-objects) - (asdf:load-system sys) - (in-package :std-user) - (asdf:make sys) - (stash-output sys) - (println :OK))) - -(defun x-make (args) - (if args - (let ((name (car args))) - (ensure-directories-exist *stash-path*) - (%make name)) - (std:wait-for-threads (mapcar - (lambda (x) - (sb-thread:make-thread - (lambda () - (sb-ext:run-program "x.lisp" (list "make" x) :wait t :output t)) - :name x)) - (list "core" "user" "prelude" "core/tests" "core/bench" "core/lib" "core/ffi"))))) - -(defun x-save (args) - (if args - (let ((name (car args))) - (ensure-directories-exist *stash-path*) - (format t "saving core to: ~A~%" (merge-pathnames name *stash-path*)) - (string-case (name) - ("prelude" (compile-prelude t t)) - ("core" (compile-core t t)) - ("std" (compile-std t t)) - ("user" (compile-user t t)) - ("infra" (compile-user t t 22 "infra.core")) - ("tests" (compile-tests t t)))) - ;; (sb-ext:run-program "x.lisp" nil :input t :output t) - )) - -(asdf:load-asd (probe-file (merge-pathnames "log.asd" "lisp/lib/log/"))) -(asdf:load-asd (probe-file (merge-pathnames "rt.asd" "lisp/lib/rt/"))) -(asdf:load-system :log) -(asdf:load-system :rt) -(ql:quickload :rt) - -(defun x-test (args) - (if args - (let ((name (car args))) - (ql:quickload :rt) - (ql:quickload (string-upcase (format nil "~A/tests" name))) - (rt:do-tests (string-upcase name) t)) - (bail "missing arg"))) - -(defun x-run (args) - (if args - (let* ((name (car args)) - (path (merge-pathnames name *stash-path*))) - (unless (probe-file path) - (sb-ext:run-program "x" (list "build" name) :wait t :output t)) - (sb-ext:run-program path (cdr args) :output t)) - (bail "missing arg"))) - -(defun %install (name) - (let ((path (merge-pathnames name *stash-path*))) - (unless (probe-file path) - (sb-ext:run-program "x" (list "build" name) :wait t :output t)) - (sb-ext:run-program "/bin/sudo" - (list "install" "-C" "-m" "755" (namestring path) "/usr/local/bin/") - :input t - :wait t - :output t) - (format t "installed ~A to ~A~%" name (merge-pathnames name "/usr/local/bin/")))) - -(defun x-install (args) - (mapc #'%install - (or args - (list "skel" "rdb" "organ" "homer" "packy")))) - -(defun x-parse-args () - (if (null *args*) - (progn - (println "Welcome to CORE/X") - (use-package :cl-user) - (use-package :sb-ext) - (use-package :std-user) - (sb-impl::toplevel-repl nil)) - (let ((cmd (pop *args*))) - (cond - ((equal cmd "compile") (setq *thunk* #'x-compile)) - ((equal cmd "build") (setq *thunk* #'x-build)) - ((equal cmd "run") (setq *thunk* #'x-run)) - ((equal cmd "test") (setq *thunk* #'x-test)) - ((equal cmd "save") (setq *thunk* #'x-save)) - ((equal cmd "make") (setq *thunk* #'x-make)) - ((equal cmd "install") (setq *thunk* #'x-install)) - (t (princ (getflag (parse-flag cmd))) (terpri) (sb-ext:exit :code 0)))))) - -(defun x-init () - (in-package :x) - (let ((*args* (cdr sb-ext:*posix-argv*)) - (*log-level* :info)) - (x-parse-args) - (log:debug! "running command" *thunk* *args*) - (funcall *thunk* *args*))) - -;; (format t "saving self to ./x~%") -;; (sb-ext:save-lisp-and-die -;; "x" -;; :toplevel #'x-init -;; ;; :callable-exports '("compile_std" "compile_prelude") -;; :purify nil -;; :executable t -;; :save-runtime-options t) - -(x-init)