Mercurial > core / lisp/lib/skel/core/obj.lisp
changeset 670: |
6856c021d084 |
parent: |
cc89b337384b
|
child: |
2bad47888dbf |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Mon, 23 Sep 2024 21:14:10 -0400 |
permissions: |
-rw-r--r-- |
description: |
add dir-locals to skel, fix package lock violation in castable, move .sk files |
1 ;;; skel/core/obj.lisp --- Skel Objects 4 (in-package :skel/core/obj) 8 (:documentation "Base class for skeleton objects. Inherits from `sxp'.")) 10 (defmethod sk-new ((self t) &rest initargs) 11 (apply #'make-instance self initargs)) 13 (defmethod print-object ((self skel) stream) 14 (print-unreadable-object (self stream :type t) 15 (format stream ":ID ~A" (format-sxhash (id self))))) 17 (defmethod initialize-instance :around ((self skel) &rest initargs &key &allow-other-keys) 18 ;; TODO 2023-09-10: make fast 19 (unless (getf initargs :id) 20 (setf (id self) (sxhash self))) 24 ;; TODO 2023-09-11: research other hashing strategies - maybe use the 25 ;; sxhash as a nonce for UUID 26 ;; note that the sk-meta class does not inherit from skel or sxp. 29 ((name :initarg :name :initform nil :type (or null string) :accessor sk-name) 30 (path :initarg :path :initform nil :type (or null pathname) :accessor sk-path) 31 (author :initform "" :initarg :author :type contact-designator :accessor sk-author) 32 (version :initform "" :initarg :version :type string :accessor sk-version) 33 (tags :initform nil :initarg :tags :accessor sk-tags) 34 (description :initarg :description :initform nil :type (or null string) :accessor sk-description) 35 (license :initarg :license :type license-designator :accessor sk-license)) 36 (:documentation "Skel Meta class.")) 38 (defun sk-init (class &rest initargs) 39 (apply #'make-instance class initargs)) 41 (defmacro sk-init-dir (class &rest initargs) 42 `(let ((self (sk-init ',class ,@initargs))) 43 (unless (getf ',initargs :path) 44 (setf (sk-path self) (sb-posix:getcwd))) 47 (defmacro sk-init-file (class &rest initargs) 48 `(let ((self (sk-init ',class ,@initargs))) 49 (unless (getf ',initargs :path) 50 (setf (sk-path self) *default-skelfile*)) 55 ;; SK-COMPONENTs are similar in nature to ASDF/COMPONENT:COMPONENT objects but 56 ;; much more lightweight. We use this class with the assumption that whatever 57 ;; it's wrapping is contained within another SKEL object, such as in the 58 ;; :COMPONENTS slots of SK-PROJECTs. 60 ;; Container objects such as SK-PROJECT are NOT subclasses of SK-COMPONENT, 61 ;; unlike in ASDF where systems are subclasses of components. 63 (defclass sk-component (skel) 64 ((parent :initarg :parent :accessor sk-parent))) 68 ;; Again just like ASDF, we define a SK-MOD class which subclasses 69 ;; SK-COMPONENT. The SK-MOD class is used for components which have 70 ;; sub-components themselves. 72 (defclass sk-mod (sk-component sk-meta) 73 ((components :initarg :components :accessor sk-components))) 75 (defun make-sk-mod (form) 78 (apply #'make-instance 'sk-mod 79 (let ((name (pop form)) 83 (sk-load-component (car f) (cdr f))) 85 `(:name ,name :components ,components))) 86 (make-instance 'sk-mod :name form :components nil))) 88 (defmethod sk-new ((self (eql :mod)) &key form path) 89 (let ((mod (make-sk-mod form))) 90 (when path (setf (sk-path mod) path)) 93 (defmethod sk-load-component ((kind (eql :mod)) (form t) &optional (path *default-pathname-defaults*)) 94 (sk-new kind :form form :path path)) 98 ;; Scripts are always assumed to point to an executable file. They can be ran 99 ;; directly with SK-RUN. 101 (defclass sk-script (sk-component sk-meta sxp) 102 ((kind :initform nil :initarg :kind :type (or null script-designator) :accessor sk-kind))) 104 (defmethod sk-new ((self (eql :script)) &key form path) 105 (let ((script (make-sk-script form))) 106 (setf (sk-path script) path) 109 (defmethod sk-load-component ((kind (eql :script)) (form t) &optional (path *default-pathname-defaults*)) 110 (sk-new kind :form form :path path)) 112 (defmethod write-sxp-stream ((self sk-script) stream &key (pretty t) (case :downcase) &allow-other-keys) 113 (write `(,(sk-path self)) :stream stream :pretty pretty :case case :readably t :array t :escape t)) 115 (defun make-sk-script (script) 116 "Make a new SK-SCRIPT." 117 (apply #'make-instance 'sk-script 119 (let ((kind (first script)) 120 (path (second script))) 122 :name (pathname-name path) 125 :name (pathname-name script) 126 :kind (when-let ((ext (pathname-type script))) 127 (keywordicate ext)))))) 129 (defmethod sk-run ((self sk-script)) 130 (sb-ext:run-program (sk-path self) nil :output t)) 132 (defmethod sk-write ((self sk-script) stream) 133 (with-slots (path) self 134 (write-string path))) 136 (defmethod print-object ((self sk-script) stream) 137 (print-unreadable-object (self stream :type t) 138 (format stream ":~A ~A" (sk-kind self) (sk-name self)))) 141 (defclass sk-config (skel sxp) 142 ((vc :initform *default-skel-vc-kind* :initarg :vc :type (or vc-designator sk-vc-meta) :accessor sk-vc) 143 (store :initform *skel-store* :initarg :store :type pathname :accessor sk-store) 144 (stash :initform *skel-stash* :initarg :stash :type pathname :accessor sk-stash) 145 (cache :initform *skel-cache* :initarg :cache :type pathname :accessor sk-cache) 146 (registry :initform *skel-registry* :initarg :registry :type pathname :accessor sk-registry) 147 (scripts :initform nil :initarg :scripts :type (or pathname list (vector pathname)) :accessor sk-scripts) 148 (license :initform nil :initarg :license :type license-designator :accessor sk-license) 149 (log-level :initform *log-level* :initarg :log-level :type log-level-designator) 150 (fmt :initform :pretty :initarg :fmt :type symbol) 151 (auto-insert :initform nil :initarg :auto-insert :type form)) 152 (:documentation "Root configuration class for the SKEL system. This class doesn't need to be exposed externally, but specifies all shared fields of SK-*-CONFIG types.")) 154 (defmethod sk-new ((self (eql :config)) &rest args &key (type :user)) 157 (:user 'sk-user-config) 158 (:system 'sk-system-config) 160 (apply #'sk-new self args)) 162 (declaim (inline bound-string-p sk-dir)) 163 (defun bound-string-p (o s) (and (slot-boundp o s) (stringp (slot-value o s)))) 165 (let ((str (directory-namestring (sk-path o)))) 166 (if (sb-sequence:emptyp str) 167 *default-pathname-defaults* 170 (defmethod load-ast ((self sk-config)) 171 ;; internal ast is never tagged 172 (with-slots (ast) self 174 ;; ast is valid, modify object, set ast nil 176 (sb-int:doplist (k v) ast 177 (when-let ((s (find-sk-symbol k))) 178 (setf (slot-value self s) v))) ;; needs to be the correct package 179 (when (bound-string-p self 'stash) (setf (sk-stash self) (merge-pathnames (sk-stash self) (sk-dir self)))) 180 (when (bound-string-p self 'store) (setf (sk-store self) (merge-pathnames (sk-store self) (sk-dir self)))) 181 (when (bound-string-p self 'cache) (setf (sk-cache self) (merge-pathnames (sk-cache self) (sk-dir self)))) 182 (when (bound-string-p self 'registry) (setf (sk-registry self) (merge-pathnames (sk-registry self) (sk-dir self)))) 184 (if (bound-string-p self 'scripts) 185 (if-let* ((path (probe-file (pathname (the simple-string (sk-scripts self)))))) 186 (setf (sk-scripts self) 187 (if (directory-path-p path) 190 (warn! (format nil "ignoring missing scripts directory: ~A" (sk-scripts self))))) 191 (unless *keep-ast* (setf (ast self) nil)) 193 ;; invalid ast, signal error 194 (invalid-skel-ast ast)))) 196 (defmethod build-ast ((self sk-config) &key (nullp nil) (exclude '(ast id))) 204 (defmethod sk-write-file ((self sk-config) 205 &key (path *default-skelfile*) 210 (build-ast self :nullp nullp) 212 (with-open-file (out path 215 :if-does-not-exist :create) 217 (make-source-header-comment 221 :description (sk-description self) 222 :opts '("mode:skel;")) 224 (write-sxp-stream self out :fmt fmt)) 225 (unless *keep-ast* (setf (ast self) nil)))) 227 (defmethod write-sxp-stream ((self sk-config) stream &key (pretty t) (case :downcase) (fmt :pretty)) 230 (if (listp (ast self)) 231 (with-open-stream (st stream) 232 (loop for (k v . rest) on (ast self) 234 unless (or (null v) (null k)) 236 (write k :stream stream :pretty pretty :case case :readably t :array t :escape t) 237 (write-char #\space st) 238 (if (or (eq (type-of v) 'skel) (subtypep (type-of v) 'structure-object)) 239 (write-sxp-stream v stream :fmt fmt) 240 (write v :stream stream :pretty pretty :case case :readably t :array t :escape t)) 241 (write-char #\newline st))) 243 (t (write (ast self) :stream stream :pretty pretty :case case :readably t :array t :escape t)))) 245 (defclass sk-system-config (sk-config sk-meta) ()) 247 (defun default-sk-system-config () 248 (make-instance 'sk-system-config)) 250 (defclass sk-user-config (sk-config sk-meta) 251 ((user :initarg :user :type string :accessor sk-user) 252 (name :initarg :name :type string :accessor sk-name) 253 (email :initarg :email :type string :accessor sk-email)) 254 (:documentation "User configuration object, typically written to ~/.skelrc.")) 256 (defun default-sk-user-config () (make-instance 'sk-user-config)) 258 (declaim (type (or sk-user-config null) *skel-user-config*)) 259 (declaim (type (or sk-system-config null) *skel-system-config*)) 260 (defvar *skel-user-config* nil) 261 (defvar *skel-system-config* nil) 264 (defstruct (sk-rule (:constructor %make-sk-rule (target source recipe))) 265 "Maps a SOURCE to a corresponding TARGET 266 via the special form stored in RECIPE." 267 (target "" :type string) 268 (source nil :type list) 269 (recipe nil :type list)) 271 (declaim (inline make-sk-rule)) 272 (defun make-sk-rule (target &optional source recipe) 273 (%make-sk-rule (string target) source recipe)) 275 (defmethod sk-new ((self (eql :rule)) &rest args) 276 (declare (ignore self)) 277 (apply #'sk-new 'sk-rule args)) 279 (defmethod id ((self sk-rule)) 280 (sxhash (list (sk-rule-target self) (sk-rule-source self)))) 282 (defmethod write-sxp-stream ((self sk-rule) stream &key (pretty t) (case :downcase) &allow-other-keys) 283 (write `(,(sk-rule-target self) ,(sk-rule-source self) ,@(sk-rule-recipe self)) :stream stream :pretty pretty :case case :readably t :array t :escape t)) 285 (defmethod print-object ((self sk-rule) stream) 286 (print-unreadable-object (self stream :type t) 287 (format stream "~A" (sk-rule-target self)) 288 (when-let ((source (sk-rule-source self))) 289 (format stream " :source ~A" source)))) 291 ;; Note that SK-RUN directly on a rule currently does NOT touch the sources. 292 (defmethod sk-run ((self sk-rule)) 293 (with-slots (recipe) self 296 ((or symbol function) (funcall x :output t)) 300 (defmethod sk-write ((self sk-rule) stream) 301 (with-slots (target source recipe) self 302 (write-string (sk-rule-target target) stream) ;; target isn't typep SK-OBJECT 303 (write (sk-rule-source self) :stream stream) 304 (write (sk-rule-recipe self) :stream stream))) 306 (defun sk-run-with-sources (obj rule) 307 (when-let ((sources (sk-rule-source rule))) 310 (if-let* ((sr (sk-find-rule src obj))) 311 ;; TODO: check if we need to rerun sources 313 (warn! "unhandled source:" src "for rule:" rule))) 317 (defun sk-make (obj &rest rules) 320 (lambda (r) (sk-run-with-sources obj r)) 322 (unless (sequence:emptyp (sk-rules obj)) 323 (let ((rule (aref (sk-rules obj) 0))) 324 (if (sk-rule-source rule) 329 (defstruct sk-vc-remote-meta 330 (name :default :type keyword) 331 (path nil :type (or symbol string))) 333 (defmethod write-sxp-stream ((self sk-vc-remote-meta) stream &key (pretty t) (case :downcase) &allow-other-keys) 334 (write `(,(sk-vc-remote-meta-name self) ,(sk-vc-remote-meta-path self)) :stream stream :pretty pretty :case case :readably t :array t :escape t)) 336 (defstruct (sk-vc-meta (:constructor make-sk-vc-meta (kind &optional remotes))) 337 (kind *default-skel-vc-kind* :type vc-designator) 338 (remotes nil :type (or string list))) 340 (defmethod write-sxp-stream ((self sk-vc-meta) stream &key (pretty t) (case :downcase) (fmt :pretty)) 341 (if (= 0 (length (sk-vc-meta-remotes self))) 342 (write (sk-vc-meta-kind self) :stream stream :pretty pretty :case case :readably t :array t :escape t) 345 (write (sk-vc-meta-kind self) :stream stream :pretty pretty :case case :readably t :array t :escape t) 347 (loop for x in (sk-vc-meta-remotes self) 349 (write-sxp-stream x stream :pretty pretty :case case :fmt fmt)) 350 (format stream ")")))) 352 (defmethod print-object ((self sk-vc-meta) stream) 353 (print-unreadable-object (self stream :type t) 354 (format stream "~S" (sk-vc-meta-kind self)) 355 (when-let ((remotes (sk-vc-meta-remotes self))) 356 (format stream " ~A" remotes)))) 359 (defclass sk-project (skel sxp sk-meta) 360 ((name :initarg :name :initform "" :type string) 361 (vc :initarg :vc :initform (make-sk-vc-meta *default-skel-vc-kind*) :type sk-vc-meta :accessor sk-vc) 362 (src :initarg :src :type pathname :accessor sk-src) 363 (stash :initarg :stash :accessor sk-stash :type pathname) 364 (store :initarg :store :accessor sk-store :type pathname) 365 (components :initform #() :initarg :components :accessor sk-components :type (vector sk-component)) 366 (bind :initarg :bind :initform nil :accessor sk-bind :type list) 367 (phases :initarg :phases 368 :initform (make-hash-table) 371 (rules :initarg :rules 372 :initform (make-array 0 :element-type 'sk-rule :adjustable t) 374 :type (vector sk-rule)) 375 (include :initarg :include 376 :initform (make-array 0 :element-type 'pathname :adjustable t) 378 :type (vector pathname)))) 380 (defmethod print-object ((self sk-project) stream) 381 (print-unreadable-object (self stream :type t) 382 (format stream "~A [c=~A;i=~A;r=~A] :id ~A" 384 (length (sk-components self)) 385 (length (sk-include self)) 386 (length (sk-rules self)) 387 (format-sxhash (id self))))) 389 (defmethod sk-new ((self (eql :project)) &rest args) 390 (declare (ignore self)) 391 (apply #'sk-new 'sk-project args)) 393 (defun find-sk-symbol (s) 394 (find-symbol* (symbol-name s) :skel/core/obj t)) 396 (defun %recipe-phase-p (form) 397 "Return non-nil if FORM looks like (:PHASE &BODY BODY)." 398 (and (listp form) (>= (length form) 2) (keywordp (car form)))) 400 (defun sk-multi-recipe-p (recipe) 401 "Return T if RECIPE looks like a list of (:PHASE &BODY BODY)." 403 (every '%recipe-phase-p recipe))) 405 (defun sk-case-bind (key val &optional sym) 406 "Switch on keyword KEY, evaluating a skel binding." 409 ;; nothing actually needs to be done here, the value itself can be parsed 410 ;; directly from emacs via sk.el package. For convenience, when SYM is 411 ;; present we bind it to the list of variables. 412 (when sym (list sym val))) 414 ;; process the remainder of the form as specializer+body 415 (destructuring-bind (spec &rest body) val 416 (declare (ignore spec body)) 419 ;; process the remainder as spec+defcmd-args+body 422 ;; process the remainder as spec+defcmd-args+body 425 ;; process the remainder as a regular value but 426 ;; associate the name with a shell environment which 427 ;; is set to the value. If the cdr is of length 3 428 ;; then we simply remember the value and set it during 429 ;; any calls out from Lisp to the shell. When the form 430 ;; length is > 3 we parse the next value as a shell 431 ;; specification with additional options for checking 432 ;; for pre-existing values and 'exporting' the 434 (if (= (length val) 1) 435 ;; TODO 2024-09-21: setenv 437 ;; process additional shell opts 441 (defmethod load-ast ((self sk-project)) 442 ;; internal ast is never tagged 443 (with-slots (ast) self 445 ;; ast is valid, modify object, set ast nil 447 (sb-int:doplist (k v) ast 448 (when-let ((s (find-sk-symbol k))) 449 (setf (slot-value self s) v))) ;; needs to be correct package 451 (if (bound-string-p self 'src) 452 (setf (sk-src self) (or (probe-file (sk-src self)) 453 (probe-file (merge-pathnames (sk-src self) *skel-path*)) 454 (error 'invalid-argument :reason "project source not found" 455 :item (sk-src self)))) 456 (setf (sk-src self) (sk-dir self))) 457 (setq *skel-path* (or (sk-src self) *default-pathname-defaults*)) 458 (let ((*default-pathname-defaults* (make-pathname :defaults (namestring *skel-path*)))) 459 (when (bound-string-p self 'stash) (setf (sk-stash self) (pathname (the simple-string (sk-stash self))))) 460 (when (bound-string-p self 'store) (setf (sk-store self) (pathname (the simple-string (sk-store self))))) 462 (when-let ((vc (sk-vc self))) 464 ((or sk-vc-meta null) nil) 465 (vc-designator (setf (sk-vc self) (make-sk-vc-meta vc))) 466 (list (setf (sk-vc self) (apply #'make-sk-vc-meta vc))))) 468 (when-let ((include (sk-include self))) 469 (setf (sk-include self) (map 'vector 470 ;; recursively load included projects 471 (lambda (i) (load-ast 473 (make-instance 'sk-project) 477 (when (slot-boundp self 'components) 478 (setf (sk-components self) (map 'vector 482 (let ((val (cadr c))) 483 (if (listp val) val (pathname val))) 484 *default-pathname-defaults*)) 485 (sk-components self))))) 488 ;; (when-let ((env (sk-env self))) 489 ;; (setf (sk-env self) (mapcar 493 ;; (sb-int:keywordicate e) 494 ;; (sb-posix:getenv (format nil "~a" (symbol-name e))))) 496 ;; (sb-int:keywordicate e) 497 ;; (sb-posix:getenv (string-upcase e)))) 499 ;; (cons (sb-int:keywordicate (car e)) (cadr e))))) 501 ;; BIND contains a list of forms which are bound dynamically based 502 ;; on the contents of the cdr 503 (when-let ((bind (sk-bind self))) 508 ;; if this is a list of length > 2 we parse the form as either 509 ;; (key &rest val) or (var param &rest val) 514 (sk-case-bind sym form) 516 ;; (sym param &rest val) detected 517 ((> (length (cdr form)) 0) 518 (let ((key (cadr b))) 520 (sk-case-bind key form sym) 521 ;; if nothing else mube be a lambda 522 (push `(,sym ,(compile sym `(lambda ,(cadr b) ,@(cddr b)))) ret)))) 526 (when-let ((rules (sk-rules self))) 527 (setf (sk-rules self) 532 (destructuring-bind (target source &rest recipe) x 533 ;; TODO 2024-07-30: check for phases 534 (if (sk-multi-recipe-p recipe) 538 (destructuring-bind (phase source &rest recipe) y 539 (let ((%target (keywordicate phase '- (string-upcase target)))) 540 (let ((ph (gethash phase (sk-phases self)))) 541 (setf (gethash phase (sk-phases self)) 542 (push (make-sk-rule %target source recipe) ph)))))) 544 (make-sk-rule target source recipe)))) 545 (coerce rules 'list))) 547 (unless *keep-ast* (setf (ast self) nil)) 548 (setf (id self) (sxhash (cons (sk-name self) (sk-version self)))) 550 ;; invalid ast, signal error 551 (invalid-skel-ast ast)))) 554 (defmethod build-ast ((self sk-project) &key (nullp nil) (exclude '(ast id phases))) 562 ;; TODO 2023-09-26: This belongs in sxp 563 (defmethod write-sxp-stream ((self sk-project) stream &key (pretty t) (case :downcase) (fmt :pretty)) 566 (if (listp (ast self)) 567 (with-open-stream (st stream) 568 (loop for (k v . rest) on (ast self) 570 unless (or (null v) (null k)) 572 (write k :stream stream :pretty pretty :case case :readably t :array t :escape t) 573 (write-char #\space st) 574 (if (or (eq (type-of v) 'skel) (subtypep (type-of v) 'structure-object)) 575 (write-sxp-stream v stream :pretty pretty :case case) 576 (write v :stream stream :pretty pretty :case case :readably t :array t :escape t)) 577 (write-char #\newline st))) 579 (t (write (ast self) :stream stream :pretty pretty :case case :readably t :array t :escape t)))) 582 (defmethod sk-read-file ((self sk-project) path) 583 (wrap self (file-read-forms path)) 584 (setf (sk-path self) (ensure-absolute-pathname path *default-pathname-defaults*)) 585 ;; TODO 2024-04-18: make generic 589 (defmethod sk-write-file ((self sk-project) 591 (path *default-skelfile*) (nullp nil) (header t) (fmt :canonical) 593 (build-ast self :nullp nullp) 595 (with-open-file (out path 598 :if-does-not-exist :create) 600 (make-source-header-comment 604 :description (sk-description self) 605 :opts '("mode:skel;")) 607 (write-sxp-stream self out :fmt fmt)) 608 (unless *keep-ast* (setf (ast self) nil)))) 610 (defmethod sk-install-user-config ((self sk-project) (cfg sk-user-config)) 611 (with-slots (vc store stash license author) (debug! cfg) ;; log-level, custom, fmt 612 (setf (sk-vc self) vc) 613 (setf (sk-stash self) stash) 614 (setf (sk-store self) store) 615 (setf (sk-license self) license) 616 (setf (sk-author self) author))) 618 (defmethod sk-find-rule (name self) 619 (find (string-upcase name) (sk-rules self) :test 'equalp :key #'sk-rule-target)) 621 (defmethod sk-find-script ((name string) (self skel) &key) 622 (find name (sk-scripts self) :test 'equal :key #'sk-name)) 624 (defmethod sk-call ((self sk-project) (arg sk-rule)) 627 (defmethod sk-call ((self sk-project) (arg t)) 628 (sk-make self (sk-find-rule arg self))) 630 (defmethod sk-call ((self sk-project) (arg (eql :compile))) 631 (loop for c across (sk-components self) 632 collect (sk-compile self))) 634 (defmethod sk-call ((self sk-project) (arg (eql :build))) 635 (loop for c across (sk-components self) 636 collect (sk-build self))) 638 (defmethod sk-call ((self sk-project) (arg (eql :load))) 639 (loop for c across (sk-components self) 640 collect (sk-load self))) 642 (defmethod sk-call* ((self sk-project) &rest args) 643 (mapcar (lambda (arg) (sk-call self arg)) args))