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

Kind	Covered	All	%
expression	152	542	28.0
branch	5	40	12.5

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; project.lisp --- Skel Project

2

3

;;

4

5

;;; Code:

6

(in-package :skel/core/obj)

7

8

;;; Project

9

(defclass sk-project (skel ast sk-meta)

10

   ((name :initarg :name :initform (format nil "~A" (gensym "SK")) :type simple-base-string :accessor name

11

:documentation "The name of this project.")

12

(vc :initarg :vc :initform (vc-init *default-skel-vc-kind*)

13

:type vc-repo :accessor sk-vc)

14

(src :initarg :src :type pathname :accessor sk-src)

15

(stash :initarg :stash :accessor sk-stash :type pathname)

16

(store :initarg :store :accessor sk-store :type pathname)

17

(components :initform #() :initarg :components :accessor sk-components :type (vector sk-component)

18

:documentation "A vector of child components belonging to this project.")

19

(bind :initarg :bind :initform *default-skel-bindings* :accessor sk-bind :type list

20

:documentation "A list of dynamic bindings which are applied to rule definitions.")

21

(phases :initarg :phases

22

:initform (make-hash-table)

23

:accessor sk-phases

24

:type hash-table

25

:documentation "A hash-table containing PHASE-NAME : RULE-MEMBER-LIST pairs.")

26

(rules :initarg :rules

27

:initform (make-array 0 :element-type 'sk-rule :adjustable t)

28

:accessor sk-rules

29

:type (vector sk-rule)

30

           :documentation "A vector of rule objects containing individual units of work. Each rule is

31

implicitly linked to a phase in the PHASES hash-table slot.")

32

(include :initarg :include

33

:initform (make-array 0 :element-type 'pathname :adjustable t)

34

:accessor sk-include

35

:type (vector pathname)

36

             :documentation "A list of skelfiles to include in the current project. Files in this list may

37

define their own subprojects or extend the current one."))

38

(:documentation "Skel project base class, usually defined by skelfiles at a project's root

39

directory."))

40

41

(defmethod print-object ((self sk-project) stream)

42

(print-unreadable-object (self stream)

43

(format stream "~A ~A :components ~A :rules ~A"

44

(sk-class-name self t)

45

(name self)

46

(length (sk-components self))

47

(length (sk-rules self)))))

48

49

(defmethod sk-new ((self (eql :project)) &rest args)

50

(declare (ignore self))

51

(apply #'sk-new 'sk-project args))

52

53

(defun find-sk-symbol (s)

54

(find-symbol* (symbol-name s) :skel/core/obj t))

55

56

(defun %recipe-phase-p (form)

57

"Return non-nil if FORM looks like (:PHASE &BODY BODY)."

58

(and (listp form) (>= (length form) 2) (keywordp (car form))))

59

60

(defun sk-multi-recipe-p (recipe)

61

"Return T if RECIPE looks like a list of (:PHASE &BODY BODY)."

62

(when (consp recipe)

63

(every '%recipe-phase-p recipe)))

64

65

(defun sk-case-bind (key val &optional sym)

66

"Switch on keyword KEY, evaluating a skel binding."

67

(case key

68

(:dir-locals

69

;; nothing actually needs to be done here, the value itself can be parsed

70

;; directly from emacs via sk.el package. For convenience, when SYM is

71

;; present we bind it to the list of variables.

72

(when sym (list sym val)))

73

(:hook

74

;; process the remainder of the form as specializer+body

75

(destructuring-bind (spec &rest body) val

76

(declare (ignore spec body))

77

(nyi!)))

78

(:macro

79

(destructuring-bind (args &rest body) val

80

(push (list sym args body) *skel-project-macros*)))

81

(:symbol-macro

82

(push (list sym val) *skel-project-symbol-macros*))

83

(:function

84

(destructuring-bind (args &rest body) val

85

(push (list sym args body) *skel-project-functions*)))

86

;; (:cmd

87

;; ;; process the remainder as spec+defcmd-args+body

88

;; )

89

;; (:opt

90

;; ;; process the remainder as spec+defopt-args+body

91

;; )

92

(:env

93

;; process the remainder as a regular value but

94

;; associate the name with a shell environment which

95

;; is set to the value. If the cdr is of length 3

96

;; then we simply remember the value and set it during

97

;; any calls out from Lisp to the shell. When the form

98

;; length is > 3 we parse the next value as a shell

99

;; specification with additional options for checking

100

;; for pre-existing values and 'exporting' the

101

;; environment.

102

(unless (null val)

103

(let ((val (if (listp val) (eval val) val))

104

(_sym (substitute #\_ #\- (string sym))))

105

(setf (uiop:getenv _sym) (format nil "~A" val))

106

(log:trace! "env: ~A=~A~%" _sym val))))))

107

108

;; ast -> obj

109

(defmethod load-ast ((self sk-project))

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 correct package

118

;;; SRC

119

(if (bound-string-p self 'src)

120

(setf (sk-src self) (or (probe-file (sk-src self))

121

                                       (probe-file (merge-pathnames (sk-src self) skel-path))

122

                                       (error 'invalid-argument :reason "project source not found"

123

                                                                :item (sk-src self))))

124

(setf (sk-src self) (sk-dir self)))

125

(setq skel-path (or (sk-src self) *default-pathname-defaults*))

126

(let ((*default-pathname-defaults* (make-pathname :defaults (namestring skel-path))))

127

             (when (bound-string-p self 'stash) (setf (sk-stash self) (pathname (the simple-string (sk-stash self)))))

128

             (when (bound-string-p self 'store) (setf (sk-store self) (pathname (the simple-string (sk-store self)))))

129

;; VC

130

(when-let ((vc (sk-vc self)))

131

(etypecase vc

132

((or vc-repo null) nil)

133

(vc-designator (setf (sk-vc self) (vc-init vc)))

134

(list

135

(flet ((%vc-scan (lst)

136

(let* ((%type (if (typep (car lst) 'vc-designator)

137

(pop lst)

138

*default-vc-kind*))

139

(repo (vc-init %type)))

140

(setf (vc-remotes repo)

141

(map 'vector

142

(lambda (v)

143

(etypecase v

144

                                            (string (vc::make-vc-remote :name 'default :url v))

145

(list

146

(let ((name (pop v))

147

(val (pop v)))

148

(if (consp val)

149

                                                   (vc::make-vc-remote :name name

150

                                                                       :type (pop val)

151

                                                                       :url (pop val))

152

                                                   (vc::make-vc-remote :name name

153

                                                                       :url val))))))

154

lst))

155

repo)))

156

(setf (sk-vc self) (%vc-scan vc))))))

157

;; INCLUDE

158

(when-let ((include (sk-include self)))

159

(setf (sk-include self) (map 'vector

160

                                            ;; recursively load included projects

161

(lambda (i)

162

(load-ast

163

(sk-read-file

164

                                                (make-instance 'sk-project)

165

i)))

166

include)))

167

;; COMPONENTS

168

(when (slot-boundp self 'components)

169

(setf (sk-components self) (map 'vector

170

(lambda (c)

171

(sk-load-component

172

(pop c)

173

                                                  (if (= 1 (length c))

174

                                                      (pathname (car c))

175

c)

176

                                                  *default-pathname-defaults*))

177

(sk-components self)))))

178

;; BIND contains a list of forms which are bound dynamically based

179

;; on the contents of the cdr

180

(when-let ((bind (sk-bind self)))

181

(setf (sk-bind self)

182

(let ((ret))

183

;; TODO 2024-09-21:

184

(dolist (b bind ret)

185

                       ;; if this is a list of length > 2 we parse the form as either

186

;; (key &rest val) or (var param &rest val)

187

(let ((sym (car b))

188

(form (cdr b)))

189

;; (form (cddr b)))

190

(let ((key (car form))

191

                               (val (if (= (length #1=(cdr form)) 1) (cadr form) #1#)))

192

(if (keywordp key)

193

(sk-case-bind key val sym)

194

(cond

195

;; (sym param &rest val) detected

196

((> (length (cdr form)) 0)

197

(let ((key (cadr b)))

198

(if (keywordp key)

199

(sk-case-bind key (cdr form) sym)

200

                                        ;; if nothing else must be a lambda

201

(push `(,sym

202

                                                ,(compile sym `(lambda ,(car b) ,@(cddr b))))

203

ret))))

204

(t

205

(push b ret))))))))))

206

;; RULES

207

(when-let ((rules (sk-rules self)))

208

(setf (sk-rules self)

209

(coerce

210

(flatten

211

(mapcar

212

(lambda (x)

213

(destructuring-bind (target source &rest recipe) x

214

;; TODO 2024-07-30: check for phases

215

(if (sk-multi-recipe-p recipe)

216

(flatten

217

(mapcar

218

(lambda (y)

219

                                  (destructuring-bind (phase source &rest recipe) y

220

                                    (let ((%target (keywordicate phase '- (string-upcase target))))

221

                                      (let ((ph (gethash phase (sk-phases self))))

222

                                        (setf (gethash phase (sk-phases self))

223

                                              (push (make-sk-rule %target source recipe) ph))))))

224

recipe))

225

(make-sk-rule target source recipe))))

226

(coerce rules 'list)))

227

'(vector sk-rule))))

228

(unless *keep-ast* (setf (ast self) nil))

229

(setf (id self) (sxhash (cons (name self) (sk-version self))))

230

self)

231

;; invalid ast, signal error

232

(invalid-skel-ast ast))))

233

234

;; obj -> ast

235

(defmethod build-ast ((self sk-project) &key (nullp nil) (exclude '(ast id phases)))

236

(setf (ast self)

237

(unwrap-object self

238

:slots t

239

:methods nil

240

:nullp nullp

241

:exclude exclude)))

242

243

;; TODO 2023-09-26: This belongs in AST

244

(defmethod write-ast ((self sk-project) stream &key (pretty t) (case :downcase) (fmt :pretty))

245

(case fmt

246

(:pretty

247

(if (listp (ast self))

248

(with-open-stream (st stream)

249

(loop for (k v . rest) on (ast self)

250

by #'cddr

251

unless (or (null v) (null k))

252

do

253

                     (write k :stream stream :pretty pretty :case case :readably t :array t :escape t)

254

(write-char #\space st)

255

                     (if (or (eq (type-of v) 'skel) (subtypep (type-of v) 'structure-object))

256

(write-ast v stream :pretty pretty :case case)

257

                         (write v :stream stream :pretty pretty :case case :readably t :array t :escape t))

258

(write-char #\newline st)))

259

(skel-io-error)))

260

     (t (write (ast self) :stream stream :pretty pretty :case case :readably t :array t :escape t))))

261

262

;; file -> ast

263

(defmethod sk-read-file ((self sk-project) path)

264

(wrap self (file-read-forms path))

265

(setf (path self) (ensure-absolute-pathname path *default-pathname-defaults*))

266

;; TODO 2024-04-18: make generic

267

self)

268

269

;; ast -> file

270

(defmethod sk-write-file ((self sk-project)

271

&key

272

                           (path *default-skelfile*) (nullp nil) (comment t) (fmt :canonical)

273

(if-exists :error))

274

(build-ast self :nullp nullp)

275

(prog1

276

(with-open-file (out path

277

:direction :output

278

:if-exists if-exists

279

:if-does-not-exist :create)

280

(when comment (princ

281

(make-source-header-comment

282

(name self)

283

:cchar #\;

284

:timestamp t

285

:description (sk-description self)

286

:opts '("mode:skel;"))

287

out))

288

(write-ast self out :fmt fmt))

289

(unless *keep-ast* (setf (ast self) nil))))

290

291

(defmethod sk-install-user-config ((self sk-project) (config sk-user-config))

292

(with-slots (vc store stash license author) (debug! config) ;; log-level, custom, fmt

293

(setf (sk-vc self) vc)

294

(setf (sk-stash self) stash)

295

(setf (sk-store self) store)

296

(setf (sk-license self) license)

297

(setf (sk-author self) author)))

298

299

(defmethod sk-find ((item sk-rule) (self skel) &key)

300

(find (string-upcase (sk-rule-target item))

301

(sk-rules self) :test 'string-equal :key 'sk-rule-target))

302

303

(defmethod sk-find ((item t) (self skel) &key)

304

(find (string-upcase item) (sk-rules self) :test 'string-equal :key #'sk-rule-target))

305

306

(defmethod sk-find ((name string) (self sk-config) &key)

307

(find name (sk-scripts self) :test 'equal :key #'name))

308

309

(defmethod sk-call ((self sk-project) (arg sk-rule))

310

(sk-make self arg))

311

312

(defmethod sk-call ((self sk-project) (arg t))

313

(sk-make self (sk-find arg self)))

314

315

(defmethod sk-call ((self sk-project) (arg (eql :compile)))

316

(loop for c across (sk-components self)

317

collect (sk-compile self)))

318

319

(defmethod sk-call ((self sk-project) (arg (eql :build)))

320

(loop for c across (sk-components self)

321

collect (sk-build self)))

322

323

(defmethod sk-call ((self sk-project) (arg (eql :load)))

324

(loop for c across (sk-components self)

325

collect (sk-load self)))

326

327

(defmethod sk-call* ((self sk-project) &rest args)

328

(mapcar (lambda (arg) (sk-call self arg)) args))

329

330

(defmethod sk-build ((self sk-project) &key)

331

(loop for c across (sk-components self)

332

collect (sk-build c)))

333

334

(defmethod sk-compile ((self sk-project) &key)

335

(loop for c across (sk-components self)

336

collect (sk-compile c)))

337

338

(defmethod sk-load ((self sk-project) &key)

339

(loop for c across (sk-components self)

340

collect (sk-load c)))