Coverage report: /home/ellis/comp/core/lib/doc/system.lisp

KindCoveredAll%
expression5136 3.7
branch018 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; lib/doc/system.lisp --- System Documentation
2
 
3
 ;; Documentation support for a Lisp System
4
 
5
 ;;; Code:
6
 (in-package :doc)
7
 
8
 (defclass system-documentation ()
9
   ((system :initarg :system :type system :accessor doc-system)))
10
 
11
 (defmethod name ((self system-documentation))
12
   (asdf:component-name (doc-system self)))
13
 
14
 (defun system-documentation (system)
15
   "Return the SYSTEM-DOCUMENTATION for a specified SYSTEM."
16
   (let ((s (find-system system)))
17
     (make-instance 'system-documentation
18
       :system s)))
19
 
20
 (defmethod print-object ((self system-documentation) stream)
21
   (with-slots (system) self
22
     (print-unreadable-object (self stream :type t)
23
       (format stream "~A" (component-name system)))))
24
 
25
 (defmethod doc-files ((self system-documentation))
26
   "Return a list of source file components from SELF."
27
   (flet ((%rec (s) (if (typep s 'asdf:module)
28
                        (doc-files s)
29
                        (component-pathname s))))
30
     (flatten (mapcar #'%rec (component-children (doc-system self))))))
31
 
32
 (defmethod doc-files ((self asdf:module))
33
   (flet ((%rec (s) (if (typep s 'asdf:module)
34
                        (doc-files s)
35
                        (component-pathname s))))
36
     (mapcar #'%rec (component-children self))))
37
   
38
 ;; TODO: to do this correctly we need to also check if SELF is a
39
 ;; prefix of a different system name. e.g. "DOC" and "DOC-UTILS"
40
 
41
 ;; TODO: system separator handling and optimizations
42
 (defmethod doc-packages ((self system-documentation))
43
   "Return a list of packages which can be traced back to SELF. This
44
 method will only return packages that are prefixed with the name of
45
 SELF."
46
   ;; (asdf:component-loaded-p
47
   (let ((s (component-name (doc-system self))))
48
     (mapcar
49
      #'package-documentation
50
      (remove-if #'null
51
                 (mapcar
52
                  (lambda (p)
53
                    (when (and (packagep p) 
54
                               (or
55
                                (string=
56
                                 (string-upcase s) 
57
                                 (package-name p))
58
                                (string-prefix-p 
59
                                 (concatenate 'string (string-upcase s) "-")
60
                                 (package-name p))
61
                                (string-prefix-p 
62
                                 (concatenate 'string (string-upcase s) "/")
63
                                 (package-name p))))
64
                      p))
65
                  (list-all-packages))))))
66
 
67
 ;; TODO 2025-03-02: handle (:feature :foo :sysname) in system-depends-on results
68
 (defmethod doc-dependencies ((self system-documentation))
69
   (mapcar (lambda (x) 
70
              (if (consp x)
71
                  (if (eql (pop x) :feature)
72
                      (when (sb-int:featurep (pop x))
73
                        (system-documentation (pop x))))
74
                  (system-documentation x)))
75
           (system-depends-on (doc-system self))))
76
 
77
 (defun find-system-dependents (system)
78
   "Return a list of systems which depend on SYSTEM by iterating over ASDF:REGISTER-SYSTEMS."
79
   (let ((r))
80
   (dolist (s (asdf:registered-systems))
81
     (setf s (find-system s))
82
     (when (and s (member (component-name system)
83
                          (mapcar
84
                           (lambda (dep)
85
                             (when (atom dep)
86
                               (string-downcase (format nil "~A" dep))))
87
                           (asdf:system-depends-on s))
88
                          :test #'equalp))
89
       (push s r)))
90
   r))
91
 
92
 (defmethod doc-dependents ((self system-documentation))
93
   (mapcar #'system-documentation (find-system-dependents (doc-system self))))