Support media file assets

40ants-doc-full.asd

@@ -13,6 +13,7 @@
   :pathname "full"
   :depends-on (;; "40ants-doc/full"
                "40ants-doc-full/builder"
+               "40ants-doc-full/assets"
                "40ants-doc-full/doc"
 
                ;; TODO: Все эти locatives надо сделать доступными в минимальном пакете

40ants-doc-test.asd

@@ -8,6 +8,7 @@
                "40ants-doc-full"
                "40ants-doc-test/test-transcribe"
                "40ants-doc-test/autodoc"
+               "40ants-doc-test/assets"
                "40ants-doc-test/test"
                "40ants-doc-test/xref"
                "40ants-doc-test/locatives"

AGENTS.md

@@ -6,6 +6,10 @@ This is a Common Lisp documentation library split into ASDF package-inferred sys
 
 Keep a feature in the smallest appropriate subsystem. For example, add a core locative in `src/locatives/` and a rendering-specific locative in `full/locatives/`.
 
+## Development Workflow
+
+Use the `atomic-spec-orchestrator` skill for all project work. Follow its Atomic Spec process, including the required role transitions and gate validation, when applicable.
+
 ## Build, Test, and Development Commands
 
 Install the locked dependencies once with:

full/assets.lisp

@@ -0,0 +1,156 @@
+(uiop:define-package #:40ants-doc-full/assets
+  (:use #:cl)
+  (:import-from #:40ants-doc-full/commondoc/image
+                #:local-image)
+  (:import-from #:40ants-doc-full/commondoc/mapper
+                #:map-nodes)
+  (:import-from #:40ants-doc-full/commondoc/xref
+                #:xref
+                #:xref-locative
+                #:xref-symbol)
+  (:export #:defasset))
+(in-package #:40ants-doc-full/assets)
+
+
+(defclass asset ()
+  ((name :initarg :name
+         :reader asset-name)
+   (source :initarg :source
+           :reader asset-source)
+   (target-filename :initarg :target-filename
+                    :reader asset-target-filename)
+   (description :initarg :description
+                :reader asset-description)
+   (width :initarg :width
+          :initform nil
+          :reader asset-width)
+   (height :initarg :height
+           :initform nil
+           :reader asset-height)))
+
+
+(defun make-asset (name source target-filename description &rest restargs
+                    &key width height)
+  (declare (ignore width height))
+  (apply #'make-instance 'asset
+         :name name
+         :source source
+         :target-filename target-filename
+         :description description
+         restargs))
+
+
+(defvar *assets* (make-hash-table :test #'eq))
+
+
+(defun asset-symbol-p (symbol)
+  (not (null (gethash symbol *assets*))))
+
+
+(defmethod 40ants-doc::transform-symbol-entry :around ((entry symbol))
+  (or (gethash entry *assets*)
+      (call-next-method)))
+
+
+(defmethod 40ants-doc/object-package::object-package ((asset asset))
+  (symbol-package (asset-name asset)))
+
+
+(defun pathname-designator-string (pathname-designator)
+  (namestring (pathname pathname-designator)))
+
+
+(defun register-asset (name source &key target-filename description width height)
+  (check-type name symbol)
+  (check-type source (or string pathname))
+
+  (let* ((source (pathname-designator-string source))
+         (target-filename (pathname-designator-string
+                           (or target-filename source)))
+         (description (or description
+                          (symbol-name name)))
+         (new-asset (make-asset name source target-filename description
+                                :width width
+                                :height height))
+         (old-asset (gethash name *assets*)))
+    (when (and old-asset
+               (not (and (string= (asset-source old-asset)
+                                  (asset-source new-asset))
+                         (string= (asset-target-filename old-asset)
+                                  (asset-target-filename new-asset))
+                         (string= (asset-description old-asset)
+                                  (asset-description new-asset))
+                         (equal (asset-width old-asset)
+                                (asset-width new-asset))
+                         (equal (asset-height old-asset)
+                                (asset-height new-asset)))))
+      (error "Asset ~S is already registered with different properties."
+             name))
+    (setf (gethash name *assets*) new-asset)
+    new-asset))
+
+
+(defmacro defasset (name source &rest args)
+  "Register NAME as a local image used in documentation.
+
+SOURCE is a pathname designator.  By default, the file is copied to the
+same relative pathname below the documentation output directory.  Use
+:TARGET-FILENAME to choose another relative output pathname.
+
+Every unqualified occurrence of NAME in prose is rendered as an image."
+  (check-type name symbol)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (register-asset ',name ,source ,@args)))
+
+
+(defun safe-target-filename-p (target-filename)
+  (let ((pathname (pathname target-filename)))
+    (and (not (uiop:absolute-pathname-p pathname))
+         (not (member :up (pathname-directory pathname))))))
+
+
+(defun validate-asset (asset)
+  (unless (probe-file
+           (40ants-doc-full/commondoc/image::resolve-local-image-path
+            (asset-source asset)))
+    (error "Asset ~S source file does not exist: ~A"
+           (asset-name asset)
+           (asset-source asset)))
+
+  (unless (safe-target-filename-p (asset-target-filename asset))
+    (error "Asset ~S target filename is not below the output directory: ~A"
+           (asset-name asset)
+           (asset-target-filename asset)))
+
+  (maphash (lambda (name other-asset)
+             (when (and (not (eq name (asset-name asset)))
+                        (string= (asset-target-filename other-asset)
+                                 (asset-target-filename asset)))
+               (error "Assets ~S and ~S use the same target filename: ~A"
+                      (asset-name asset)
+                      name
+                      (asset-target-filename asset))))
+           *assets*)
+  asset)
+
+
+(defun asset-to-local-image (asset)
+  (validate-asset asset)
+  (local-image (asset-source asset)
+               :target-filename (asset-target-filename asset)
+               :description (asset-description asset)
+               :width (asset-width asset)
+               :height (asset-height asset)))
+
+
+(defun replace-assets (document)
+  "Replace XREF nodes naming registered assets with local image nodes."
+  (map-nodes document
+             (lambda (node)
+               (if (and (typep node 'xref)
+                        (null (xref-locative node)))
+                   (let ((asset (gethash (xref-symbol node) *assets*)))
+                     (if asset
+                         (asset-to-local-image asset)
+                         node))
+                   node))))

full/builder.lisp

@@ -23,6 +23,7 @@
   (:import-from #:40ants-doc-full/commondoc/section)
   (:import-from #:40ants-doc-full/commondoc/xref)
   (:import-from #:40ants-doc-full/commondoc/image)
+  (:import-from #:40ants-doc-full/assets)
   (:import-from #:40ants-doc-full/external-index
                 #:write-references-index)
   (:import-from #:40ants-doc-full/commondoc/reference)
@@ -209,6 +210,11 @@
   40ants-doc-full/builder/vars::*current-asdf-system*)
 
 
+(defmethod 40ants-doc-full/commondoc/builder:to-commondoc
+    ((asset 40ants-doc-full/assets::asset))
+  (40ants-doc-full/assets::asset-to-local-image asset))
+
+
 ;;; Generate with the default HTML look
 
 (defun process-document (document &key base-url)
@@ -217,10 +223,13 @@
          (document (40ants-doc-full/commondoc/page:warn-on-undocumented-exports document
                                                                            references))
          (document (40ants-doc-full/commondoc/transcribe::warn-on-differences-in-transcriptions document))
-         (document (if 40ants-doc-full/builder/printer:*document-uppercase-is-code*
-                       (40ants-doc-full/commondoc/xref::extract-symbols document)
-                       document))
+         (document (40ants-doc-full/commondoc/xref::extract-symbols
+                    document
+                    :predicate (if 40ants-doc-full/builder/printer:*document-uppercase-is-code*
+                                   (constantly t)
+                                   #'40ants-doc-full/assets::asset-symbol-p)))
          (document (40ants-doc-full/commondoc/xref:fill-locatives document))
+         (document (40ants-doc-full/assets::replace-assets document))
          (document (40ants-doc-full/commondoc/section::fill-html-fragments document))
          (document (40ants-doc-full/commondoc/page::warn-on-references-to-internals document))
          (document (if 40ants-doc-full/link:*document-link-code*
@@ -347,6 +356,9 @@
 
                 (ensure-directories-exist absolute-dir)
 
+                (40ants-doc-full/commondoc/image::copy-local-images full-document
+                                                                      absolute-dir)
+
                 (when (eql 40ants-doc-full/commondoc/format::*current-format* 'common-html:html)
                   (write-references-index (uiop:merge-pathnames* "references.json" absolute-dir)
                                           references

full/commondoc/image.lisp

@@ -37,7 +37,8 @@
            :reader height)))
 
 
-(defun full-path (path)
+(defun resolve-local-image-path (path)
+  "Resolve PATH according to the current documented ASDF system."
   (cond
     ((str:starts-with-p "asdf:" path)
      (destructuring-bind (prefix asdf-system-name path)
@@ -135,7 +136,7 @@
    and then makes a paragraph with image, pointing to this temp file.
 "
 
-  (let ((full-path (full-path path)))
+  (let ((full-path (resolve-local-image-path path)))
     (unless (probe-file full-path)
       (error "Image file \"~A\" not found"
              full-path))
@@ -178,6 +179,41 @@
              (t node))))
     (map-nodes document #'replacer)))
 
+
+(defun target-path (image base-dir)
+  (uiop:merge-pathnames* (target-filename image)
+                         (uiop:ensure-directory-pathname base-dir)))
+
+
+(defun copy-local-image (image base-dir copied-targets)
+  (let* ((source-path (common-doc:source image))
+         (target-path (target-path image base-dir)))
+    (unless (gethash target-path copied-targets)
+      (unless (equal source-path target-path)
+        (log:info "Copying image from ~A to ~A" source-path target-path)
+        (ensure-directories-exist target-path)
+        (uiop:copy-file source-path target-path))
+      (setf (gethash target-path copied-targets) t))))
+
+
+(defun copy-local-images (document base-dir)
+  "Copy all local images in DOCUMENT to BASE-DIR exactly once per target."
+  (let ((copied-targets (make-hash-table :test #'equal)))
+    (map-nodes document
+               (lambda (node)
+                 (when (typep node 'local-image)
+                   (copy-local-image node base-dir copied-targets))
+                 node))))
+
+
+(defun image-source (image)
+  (let* ((base-dir (uiop:ensure-directory-pathname
+                    40ants-doc-full/builder/vars::*base-dir*))
+         (target-path (target-path image base-dir))
+         (page-uri (make-page-uri 40ants-doc-full/builder/vars::*current-page*))
+         (relative-path (namestring (uiop:enough-pathname target-path base-dir))))
+    (make-relative-path page-uri relative-path)))
+
 (defun extract-width-and-height (path)
   "Returns 3 values, real path, width and height. Width and height might be NIL.
 
@@ -209,41 +245,24 @@
 
 
 (define-emitter (obj local-image)
-  "Emit a local-image and move referenced image into the HTML documentation folder."
-  (let* ((source-path
-           ;; This is the path from where we will copy file:
-           (common-doc:source obj))
-         ;; Directory where we render all documentation files:
-         (base-dir
-           (uiop:ensure-directory-pathname 
-            40ants-doc-full/builder/vars::*base-dir*))
-         (target-path (uiop:merge-pathnames* (target-filename obj)
-                                             base-dir))
-         ;; Path of the current page:
-         (page-uri (make-page-uri 40ants-doc-full/builder/vars::*current-page*))
-         ;; This path will be used on the web page to refer the image:
-         (relative-path (namestring
-                         (uiop:enough-pathname target-path
-                                               base-dir)))
-         (new-source (make-relative-path page-uri
-                                         relative-path))
+  "Emit a local image already copied to the documentation output folder."
+  (let* ((new-source (image-source obj))
          (src (if common-html.emitter:*image-format-control*
                 (format nil common-html.emitter:*image-format-control*
                         new-source)
                 new-source))
          (description (common-doc:description obj)))
-
-    (unless (equal source-path
-                   target-path)
-      (log:info "Copying image from ~A to ~A" source-path target-path)
-      (ensure-directories-exist target-path)
-      (uiop:copy-file source-path
-                      target-path))
-
     (with-html
       (:img :src src
             :alt description
             :title description
             :width (width obj)
             :height (height obj)))))
 
+
+(defmethod common-doc.format:emit-document ((format commondoc-markdown:markdown)
+                                            (obj local-image)
+                                            stream)
+  (format stream "![~A](~A)"
+          (common-doc:description obj)
+          (image-source obj)))