Coverage report: /home/ellis/comp/core/app/skel/core/obj.lisp

KindCoveredAll%
expression11293 3.8
branch228 7.1
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; skel/core/obj.lisp --- Skel Objects
2
 
3
 ;; SKEL classes and methods
4
 
5
 ;;; Code:
6
 (in-package :skel/core/obj)
7
 
8
 (defclass skel (id)
9
   ()
10
   (:documentation "Base class for skeleton objects."))
11
 
12
 (declaim (inline sk-slot-name sk-class-name))
13
 (defun sk-class-name (self &optional downcase)
14
   (let* ((class-name (string (class-name (class-of self))))
15
          (match (search "SK-" class-name :test 'equal :start1 0 :end1 3))
16
          (ret (if match
17
                   (subseq class-name 3)
18
                   class-name)))
19
     (if downcase
20
         (string-downcase ret)
21
         ret)))
22
 
23
 (defun sk-slot-name (self &optional downcase) 
24
   (keywordicate (sk-class-name self downcase)))
25
 
26
 (defmethod sk-new ((self t) &rest initargs)
27
   (apply #'make-instance self initargs))
28
 
29
 (defmethod print-object ((self skel) stream)
30
   (print-unreadable-object (self stream)
31
     (format stream "~A :ID ~A" (sk-class-name self t) (format-sxhash (id self)))))
32
 
33
 (defmethod initialize-instance :around ((self skel) &rest initargs &key &allow-other-keys)
34
   ;; TODO 2023-09-10: make fast 
35
   (unless (getf initargs :id)
36
     (setf (id self) (sxhash self)))
37
   (when (next-method-p)
38
     (call-next-method)))
39
 
40
 ;; TODO 2023-09-11: research other hashing strategies - maybe use the
41
 ;; sxhash as a nonce for UUID
42
 ;; note that the sk-meta class does not inherit from skel or ast.
43
 ;;; Meta
44
 (defclass sk-meta ()
45
   ((name :initarg :name :initform nil :type (or null string) :accessor name)
46
    (path :initarg :path :initform nil :type (or null pathname) :accessor path)
47
    (author :initform "" :initarg :author :type contact-designator :accessor sk-author)
48
    (version :initform "" :initarg :version :type string :accessor sk-version)
49
    (tags :initform nil :initarg :tags :accessor sk-tags)
50
    (description :initarg :description :initform nil :type (or null string) :accessor sk-description)
51
    (license :initarg :license :type license-designator :accessor sk-license))
52
   (:documentation "Skel Meta class."))
53
 
54
 (defmethod print-object ((self sk-meta) stream)
55
   (print-unreadable-object (self stream)
56
     (format stream "~A ~A :path ~A" (sk-class-name self t) (name self) (path self))
57
     ;; (unless (sequence:emptyp (sk-version self))
58
     ;;   (format stream " :version ~A" (sk-version self)))
59
     (format stream " :id ~A" (format-sxhash (id self)))))
60
 
61
 (defun sk-init (class &rest initargs)
62
   (apply #'make-instance class initargs))
63
 
64
 (defmacro sk-init-dir (class &rest initargs)
65
   `(let ((self (sk-init ',class ,@initargs)))
66
      (unless (getf ',initargs :path)
67
        (setf (path self) (sb-posix:getcwd)))
68
      self))
69
 
70
 (defmacro sk-init-file (class &rest initargs)
71
   `(let ((self (sk-init ',class ,@initargs)))
72
      (unless (getf ',initargs :path)
73
        (setf (path self) *default-skelfile*))
74
      self))
75
 
76
 ;;; Config
77
 (defconfig sk-config (skel ast) 
78
   ((vc :initform *default-vc-kind* :initarg :vc :type (or vc-repo vc-designator) :accessor sk-vc)
79
    (store :initform skel-store :initarg :store :type pathname :accessor sk-store)
80
    (stash :initform skel-stash :initarg :stash :type pathname :accessor sk-stash)
81
    (cache :initform skel-cache :initarg :cache :type pathname :accessor sk-cache)
82
    (data :initform skel-data :initarg :data :type pathname :accessor sk-data)
83
    (scripts :initform nil :initarg :scripts :type (or pathname list (vector pathname)) :accessor sk-scripts)
84
    (license :initform nil :initarg :license :type license-designator :accessor sk-license)
85
    (log-level :initform *log-level* :initarg :log-level :type log-level-designator)
86
    (fmt :initform :pretty :initarg :fmt :type symbol)
87
    (auto-insert :initform nil :initarg :auto-insert :type form))
88
   (: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."))
89
 
90
 (defmethod sk-new ((self (eql :config)) &rest args &key (type :user))
91
   (setf self
92
         (case type
93
           (:user 'sk-user-config)
94
           (:system 'sk-system-config)
95
           (t 'sk-config)))
96
   (apply #'sk-new self args))
97
 
98
 (defmethod make-config ((self (eql :skel)) &rest args)
99
   (apply 'make-instance 'sk-config args))
100
 
101
 (declaim (inline bound-string-p sk-dir))
102
 (defun bound-string-p (o s) (and (slot-boundp o s) (stringp (slot-value o s))))
103
 (defun sk-dir (o)
104
   (let ((str (directory-namestring (path o))))
105
     (if (sb-sequence:emptyp str)
106
         *default-pathname-defaults*
107
         (pathname str))))
108
 
109
 (defmethod load-ast ((self sk-config))
110
   ;; internal ast is never tagged
111
   (with-slots (ast) self
112
     (if (formp ast)
113
         ;; ast is valid, modify object, set ast nil
114
         (progn
115
           (sb-int:doplist (k v) ast
116
             (when-let ((s (find-sk-symbol k)))
117
               (setf (slot-value self s) v))) ;; needs to be the correct package
118
           (when (bound-string-p self 'stash) (setf (sk-stash self) (merge-pathnames (sk-stash self) (sk-dir self))))
119
           (when (bound-string-p self 'store) (setf (sk-store self) (merge-pathnames (sk-store self) (sk-dir self))))
120
           (when (bound-string-p self 'cache) (setf (sk-cache self) (sk-cache self)))
121
           (when (bound-string-p self 'data) (setf (sk-data self) (sk-data self)))
122
           ;; SCRIPTS
123
           (if (bound-string-p self 'scripts)
124
               (if-let* ((path (probe-file (pathname (the simple-string (sk-scripts self))))))
125
                        (setf (sk-scripts self)
126
                              (if (directory-path-p path)
127
                                  (find-files path)
128
                                  (list path)))
129
                        (warn! (format nil "ignoring missing scripts directory: ~A" (sk-scripts self)))))
130
           (unless *keep-ast* (setf (ast self) nil))
131
           self)
132
         ;; invalid ast, signal error
133
         (invalid-skel-ast ast))))
134
 
135
 (defmethod build-ast ((self sk-config) &key (nullp nil) (exclude '(ast id author version user)))
136
   (setf (ast self)
137
         (unwrap-object self
138
                        :slots t
139
                        :methods nil
140
                        :nullp nullp
141
                        :exclude exclude)))
142
 
143
 (defmethod sk-write-file ((self sk-config) 
144
                           &key (path *default-skelfile*) 
145
                                nullp
146
                                comment
147
                                (fmt :canonical)
148
                                (if-exists :error))
149
   (build-ast self :nullp nullp)
150
   (prog1 
151
       (with-open-file (out path
152
                            :direction :output
153
                            :if-exists if-exists
154
                            :if-does-not-exist :create)
155
         (when comment (princ
156
                       (make-source-header-comment
157
                        (name self)
158
                        :cchar #\;
159
                        :timestamp t
160
                        :description (sk-description self)
161
                        :opts '("mode:skel;"))
162
                       out))
163
         (write-ast self out :fmt fmt))
164
     (unless *keep-ast* (setf (ast self) nil))))
165
 
166
 (defmethod write-ast ((self sk-config) stream &key (pretty t) (case :downcase) (fmt :pretty))
167
   (ecase fmt
168
     (:pretty
169
      (if (listp (ast self))
170
          (with-open-stream (st stream)
171
            (loop for (k v . rest) on (ast self)
172
                  by #'cddr
173
                  unless (or (null v) (null k))
174
                  do 
175
                     (write k :stream stream :pretty pretty :case case :readably t :array t :escape t)
176
                     (write-char #\space st)
177
                     (if (or (eq (type-of v) 'skel) (subtypep (type-of v) 'structure-object))
178
                         (write-ast v stream :fmt fmt)
179
                         (write v :stream stream :pretty pretty :case case :readably t :array t :escape t))
180
                     (write-char #\newline st)))
181
          (skel-io-error)))
182
     (:canonical (write (ast self) :stream stream :pretty pretty :case case :readably t :array t :escape t))))
183
 
184
 (defclass sk-system-config (sk-config sk-meta) ())
185
 
186
 (defun default-sk-system-config ()
187
   (make-instance 'sk-system-config))
188
 
189
 (defclass sk-user-config (sk-config sk-meta)
190
   ((user :initarg :user :type string :accessor sk-user :initform *user*)
191
    (name :initarg :name :type string :accessor name)
192
    (email :initarg :email :type string :accessor sk-email))
193
   (:documentation "User configuration object, typically written to ~/.skelrc."))
194
 
195
 (defun default-sk-user-config () (make-instance 'sk-user-config))
196
 
197
 (declaim (type (or sk-user-config null) *skel-user-config*))
198
 (declaim (type (or sk-system-config null) *skel-system-config*))
199
 (defvar *skel-user-config* nil)
200
 (defvar *skel-system-config* nil)