-
Notifications
You must be signed in to change notification settings - Fork 0
/
unboxed-decls.el
2115 lines (1893 loc) · 73.1 KB
/
unboxed-decls.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; unboxed-decls.el --- Structure declarations for unboxed -*- lexical-binding: t; -*-
;; Copyright (C) 2023 Onnie Winebarger
;; Author: Onnie Winebarger
;; Copyright (C) 2023 by Onnie Lynn Winebarger <[email protected]>
;; Keywords: extensions, lisp
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Data structures declarations for unboxed package management
;;; Code:
(require 'package)
(require 'queue)
(require 'async-job-queue)
(defvar unboxed--buffer-name "*Unboxed*"
"Name of unboxed logging buffer.")
(defvar unboxed--buffer (get-buffer-create unboxed--buffer-name)
"The unboxed logging buffer.")
(defun queue-map (f q)
"Map function F over queue Q, returning a queue."
(let ((q1 (make-queue))
(ls (queue-all q)))
(while ls
(queue-enqueue q1 (funcall f (pop ls))))
q1))
(defun queue-remq (q elt)
"Remove all occurence of ELT from queue Q."
(let ((ls (delq elt (queue-all q)))
tail0 tail1)
(setq tail0 ls)
(when (consp tail0)
(setq tail1 (cdr tail0)))
(while tail1
(setq tail1 (cdr (setq tail0 (cdr tail0)))))
(setf (queue-head q) ls)
(setf (queue-tail q) tail0))
q)
(defun queue-remove (q elt)
"Remove all occurence of ELT from queue Q."
(let ((head (queue-all q))
ls
tail0 tail1)
(setq ls (delete elt head)
tail0 ls)
(when (consp tail0)
(setq tail1 (cdr tail0)))
(while tail1
(setq tail1 (cdr (setq tail0 (cdr tail0)))))
(setf (queue-head q) ls)
(setf (queue-tail q) tail0))
q)
(defun queue-filter (q pred)
"Remove all elements satisfying PRED from queue Q."
(let ((head (queue-all q))
ls
tail0 tail1)
(setq ls (seq-filter pred head)
tail0 ls)
(when (consp tail0)
(setq tail1 (cdr tail0)))
(while tail1
(setq tail1 (cdr (setq tail0 (cdr tail0)))))
(setf (queue-head q) ls)
(setf (queue-tail q) tail0))
q)
(defun unboxed--get-package-desc-version (pd)
"Get the version string from package-desc PD directory name."
(let ((version "")
pkg pkg-dir pkg-prefix)
(setq pkg-dir (package-desc-dir pd))
(setq pkg (package-desc-name pd))
(setq pkg-prefix (concat (symbol-name pkg) "-"))
(when (stringp pkg-dir)
(when (directory-name-p pkg-dir)
(setq pkg-dir (directory-file-name pkg-dir)))
(setq pkg-dir (file-name-nondirectory pkg-dir))
(when (string-prefix-p pkg-prefix pkg-dir)
(setq version (substring pkg-dir (length pkg-prefix)))))
version))
(cl-defstruct (unboxed--area
(:constructor unboxed--area-create)
(:copier unboxed--area-copy))
"Structure recording the parameters for an unboxed area, e.g. for user
or site packages
Slots:
`name' Name of the package area, e.g. user or site
`boxes' Directories containing the boxed packages
`db-path' Path to the db file
`pred' Predicate to determine whether to a package in this area should
be unboxed
`excluded' Packages that are never unboxed in this area
`excluded-regex' Regular expression derived from excluded
`theme-libraries' ELisp libraries ending in `-theme' in this area
`datadir-pats' Data directory pcase patterns for rewriting
`patches' Package-specific patches in this area
`autoloads-file' Name of generated autoloads file for unboxed libraries
`system-load-path' load-path set in \"emacs -Q\" invocation
`categories' Assoc list of file-categories."
name
boxes
db-path
pred
excluded
excluded-regex
theme-libraries
datadir-pats
patches
autoloads-file
system-load-path
categories)
(defun unboxed--summarize-area (area)
"Summarize unboxing area AREA."
(when area
`(area
(name ,(unboxed--area-name area))
(boxes ,(unboxed--area-boxes area))
(db-path ,(unboxed--area-db-path area))
(pred ,(and (unboxed--area-pred area) t))
(excluded ,(unboxed--area-excluded area))
(excluded-regex ,(unboxed--area-excluded-regex area))
(theme-libraries ,(unboxed--area-theme-libraries area))
(datadir-pats ,(unboxed--area-datadir-pats area))
(patches ,(unboxed--area-patches area))
(autoloads-file ,(unboxed--area-autoloads-file area))
(system-load-path ,(unboxed--area-system-load-path area))
(categories
,(mapcar (lambda (pr)
`(,(car pr)
,(unboxed--summarize-file-category (cdr pr))))
(unboxed--area-categories area))))))
(cl-defstruct (unboxed--db-files
(:constructor unboxed--db-files-create)
(:copier unboxed--db-files-copy))
"Collection of files associated with packages in db.
Slots:
`files' - set of unboxed source- or installed- file objects
`locations' - list of source- or installed- files associated to each category"
(files (make-hash-table))
(locations (make-queue)))
(defun unboxed--summarize-source-file-cat-queue (cq)
"Summarize category queue CQ with source-file entries"
(when cq
`(source-file-category-queue
,(mapcar (lambda (pr)
(let ((cat (car pr))
(q (cdr pr)))
`(,cat (queue ,(mapcar #'unboxed--summarize-source-file (queue-all q))))))
(queue-all cq)))))
(defun unboxed--summarize-source-db-files (srcs)
"Summarize db-files collection of source files SRCS."
(when srcs
`(db-files
(files ,(let ((r (make-queue)))
(maphash (lambda (id q)
(queue-enqueue r `(,id (queue ,(mapcar #'unboxed--summarize-source-file (queue-all q))))))
(unboxed--db-files-files srcs))
(queue-all r)))
(locations
,(unboxed--summarize-source-file-cat-queue (unboxed--db-files-locations srcs))))))
(defun unboxed--summarize-installed-db-files (insts)
"Summarize db-files collection of installed files INSTS."
(when insts
`(db-files
(files ,(let ((r (make-queue)))
(maphash (lambda (id q)
(queue-enqueue r `(,id (queue ,(mapcar #'unboxed--summarize-installed-file (queue-all q))))))
(unboxed--db-files-files insts))
(queue-all r)))
(locations
(queue
,(let ((r (make-queue)))
(mapc (lambda (pr)
(let ((cat (car pr))
(q (cdr pr)))
(queue-enqueue r `(,cat (queue ,(mapcar #'unboxed--summarize-installed-file (queue-all q)))))))
(unboxed--db-files-locations insts))
(queue-all r)))))))
(cl-defstruct (unboxed--db-packages
(:constructor unboxed--db-packages-create)
(:copier unboxed--db-packages-copy))
"Collection of package descriptors which all belong to the same db.
Slots:
`descs' map of versioned package names to unboxed package desc object
`named' - map package symbols to queue of versions in boxed area"
(descs (make-hash-table))
(named (make-hash-table)))
(defun unboxed--summarize-db-packages (pkgs)
"Summarize db-packages collection PKGS."
(when pkgs
`(db-packages
(descs ,(let ((r (make-queue)))
(maphash (lambda (id q)
(queue-enqueue r `(,id ,(queue-length q) (queue ,(mapcar #'unboxed--summarize-package-desc (queue-all q))))))
(unboxed--db-packages-descs pkgs))
(queue-all r)))
(named ,(let ((r (make-queue)))
(maphash (lambda (id q)
(queue-enqueue r `(,id ,(queue-length q) (queue ,(mapcar #'unboxed--summarize-package-desc (queue-all q))))))
(unboxed--db-packages-named pkgs))
(queue-all r))))))
(cl-defstruct (unboxed--db-state
(:constructor unboxed--db-state-create)
(:copier unboxed--db-state-copy))
"Database state
Slots:
`packages' - unboxed--db-packages collection
`files' - unboxed--db-files collection"
(packages (unboxed--db-packages-create))
(files (unboxed--db-files-create)))
(defun unboxed--summarize-db-state (state)
"Summarize db-state STATE."
(when state
`(db-state
(packages ,(unboxed--summarize-db-packages (unboxed--db-state-packages state)))
(files ,(unboxed--summarize-installed-db-files (unboxed--db-state-files state))))))
;;; this delta is for changes against activated packages
(cl-defstruct (unboxed--db-delta
(:constructor unboxed--db-delta-create)
(:copier unboxed--db-delta-copy))
"The difference between two database states.
Slots:
`remove' the db state to eliminate
`install' the db state requiring installation"
(remove (unboxed--db-state-create))
(install (unboxed--db-state-create)))
(defun unboxed--summarize-db-delta (delta)
"Summarize db-delta DELTA."
(when delta
`(db-delta
(remove ,(unboxed--summarize-db-state (unboxed--db-delta-remove delta)))
(install ,(unboxed--summarize-db-state (unboxed--db-delta-install delta))))))
;;; this delta is for changes in available packages
(cl-defstruct (unboxed--db-packages-delta
(:constructor unboxed--db-packages-delta-create)
(:copier unboxed--db-packages-delta-copy))
"The difference between two sets of packages.
Slots:
`remove' the db-packages to eliminate
`install' the db-packages requiring installation"
(remove (unboxed--db-packages-create))
(install (unboxed--db-packages-create)))
(defun unboxed--summarize-db-packages-delta (delta)
"Summarize db-packages-delta DELTA."
(when delta
`(db-packages-delta
(remove ,(unboxed--summarize-db-packages (unboxed--db-packages-delta-remove delta)))
(install ,(unboxed--summarize-db-packages (unboxed--db-packages-delta-install delta))))))
;;; this delta is for changes in installed files not involving changes in packages
;;; e.g. byte-compiling libraries or updating the dir info file
(cl-defstruct (unboxed--db-files-delta
(:constructor unboxed--db-files-delta-create)
(:copier unboxed--db-files-delta-copy))
"The difference between two sets of installed files.
Slots:
`remove' the db-files to eliminate
`install' the db-files requiring installation"
(remove (unboxed--db-files-create))
(install (unboxed--db-files-create)))
(defun unboxed--summarize-source-db-files-delta (delta)
"Summarize source db-files-delta DELTA."
(when delta
`(db-files-delta
(remove ,(unboxed--summarize-source-db-files (unboxed--db-files-delta-remove delta)))
(install ,(unboxed--summarize-source-db-files (unboxed--db-files-delta-install delta))))))
(defun unboxed--summarize-installed-db-files-delta (delta)
"Summarize installed db-files-delta DELTA."
(when delta
`(db-files-delta
(remove ,(unboxed--summarize-installed-db-files (unboxed--db-files-delta-remove delta)))
(install ,(unboxed--summarize-installed-db-files (unboxed--db-files-delta-install delta))))))
(cl-defstruct (unboxed--db-files-transaction
(:constructor unboxed--db-files-transaction-create)
(:copier unboxed--db-files-transaction-copy))
"Structure holding data for packages transaction in-progress.
Slots:
`db' Database subject to the transaction
`initial' The initial files collection as a db-files
`todo' The changes to be made by the transaction as a db-files-delta
`done' The changes already made by the transaction as a db-files-delta
`final' The final files collection as a db-files
`on-completion' continuation invoked when transaction is complete"
db
(initial (unboxed--db-files-create))
(todo (unboxed--db-files-delta-create))
(done (unboxed--db-files-delta-create))
(final (unboxed--db-files-create))
on-completion)
(defun unboxed--summarize-db-source-files-transaction (txn)
"Summarize source db-files-transaction TXN."
(when txn
`(db-files-transaction
(db ,(unboxed--area-name (unboxed--sexpr-db-area (unboxed--db-files-transaction-db txn))))
(initial ,(unboxed--summarize-source-db-files (unboxed--db-files-transaction-initial txn)))
(todo ,(unboxed--summarize-source-db-files-delta (unboxed--db-files-transaction-todo txn)))
(done ,(unboxed--summarize-source-db-files-delta (unboxed--db-files-transaction-done txn)))
(final ,(unboxed--summarize-source-db-files (unboxed--db-files-transaction-final txn)))
(on-completion ,(and (unboxed--db-files-transaction-on-completion txn) t)))))
(defun unboxed--summarize-db-installed-files-transaction (txn)
"Summarize source db-files-transaction TXN."
(when txn
`(db-files-transaction
(db ,(unboxed--area-name (unboxed--sexpr-db-area (unboxed--db-files-transaction-db txn))))
(initial ,(unboxed--summarize-installed-db-files (unboxed--db-files-transaction-initial txn)))
(todo ,(unboxed--summarize-installed-db-files-delta (unboxed--db-files-transaction-todo txn)))
(done ,(unboxed--summarize-installed-db-files-delta (unboxed--db-files-transaction-done txn)))
(final ,(unboxed--summarize-installed-db-files (unboxed--db-files-transaction-final txn)))
(on-completion ,(and (unboxed--db-files-transaction-on-completion txn) t)))))
(defun unboxed--make-db-files-delta (files-remove files-add)
"Make a db-files-delta removing FILES-REMOVE and installing FILES-ADD."
(let ((delta (unboxed--db-files-delta-create))
ls file files)
(when (or files-remove files-add)
(setq ls files-remove
files (unboxed--db-files-delta-remove delta))
(while ls
(setq file (pop ls))
(unboxed--add-installed-file-to-db-files files file))
(setq ls files-add
files (unboxed--db-files-delta-install delta))
(while ls
(setq file (pop ls))
(unboxed--add-installed-file-to-db-files files file)))
delta))
(defun unboxed--make-db-files-transaction (db &optional files-remove files-add on-completion)
"Make a files-only transaction for database DB.
Arguments:
`DB' - database subject to transaction
`FILES-REMOVE' - list of package descriptors to remove from available set
`FILES-ADD' - list of package descriptor to install into available set
`ON-COMPLETION' - continuation to invoke after removals and installations
are completed"
(let ((txn (unboxed--packages-transaction-create
:db db
:on-completion on-completion
:initial (unboxed--copy-installed-db-files
(unboxed--sexpr-db-active db))
:todo (unboxed--make-db-files-delta files-remove files-add))))
txn))
(cl-defstruct (unboxed--packages-transaction
(:constructor unboxed--packages-transaction-create)
(:copier unboxed--packages-transaction-copy))
"Structure holding data for packages transaction in-progress.
Slots:
`db' Database subject to the transaction
`initial' The initial packages collection as a db-packages
`todo' The changes to be made by the transaction as a db-packages-delta
`done' The changes already made by the transaction as a db-packages-delta
`final' The final packages collection as a db-packages
`on-completion' continuation invoked when transaction is complete"
db
(initial (unboxed--db-packages-create))
(todo (unboxed--db-packages-delta-create))
(done (unboxed--db-packages-delta-create))
(final (unboxed--db-packages-create))
on-completion)
(defun unboxed--summarize-db-packages-transaction (txn)
"Summarize db-packages-transaction TXN."
(when txn
`(db-packages-transaction
(db ,(unboxed--area-name (unboxed--sexpr-db-area (unboxed--packages-transaction-db txn))))
(initial ,(unboxed--summarize-db-packages (unboxed--packages-transaction-initial txn)))
(todo ,(unboxed--summarize-db-packages-delta (unboxed--packages-transaction-todo txn)))
(done ,(unboxed--summarize-db-packages-delta (unboxed--packages-transaction-done txn)))
(final ,(unboxed--summarize-db-packages (unboxed--packages-transaction-final txn)))
(on-completion ,(and (unboxed--packages-transaction-on-completion txn) t)))))
(defun unboxed--make-db-packages-delta (pkgs-remove pkgs-add)
"Make a db-packages-delta removing PKGS-REMOVE and installing PKGS-ADD."
(let ((delta (unboxed--db-packages-delta-create))
ls pkg packages)
(when (or pkgs-remove pkgs-add)
(setq ls pkgs-remove
packages (unboxed--db-packages-delta-remove delta))
(while ls
(setq pkg (pop ls))
(unboxed--add-package-to-db-packages packages pkg))
(setq ls pkgs-add
packages (unboxed--db-packages-delta-install delta))
(while ls
(setq pkg (pop ls))
(unboxed--add-package-to-db-packages packages pkg)))
delta))
(defun unboxed--make-packages-transaction (db &optional pkgs-remove pkgs-add on-completion)
"Make a transaction for database DB.
Arguments:
`DB' - database subject to transaction
`PKGS-REMOVE' - list of package descriptors to remove from available set
`PKGS-ADD' - list of package descriptor to install into available set
`ON-COMPLETION' - continuation to invoke after removals and installations
are completed"
(let ((txn (unboxed--packages-transaction-create
:db db
:on-completion on-completion
:initial (unboxed--sexpr-db-available db)
:todo (unboxed--make-db-packages-delta pkgs-remove pkgs-add))))
txn))
(cl-defstruct (unboxed--transaction
(:constructor unboxed--transaction-create)
(:copier unboxed--transaction-copy))
"Structure holding data for database transaction in-progress.
Slots:
`db' Database subject to the transaction
`initial' The initial database state as a transaction-state
`todo' The changes to be made by the transaction as a transaction-delta
`done' The changes already made by the transaction as a transaction-delta
`final' The final database state as a transaction-state
`on-completion' continuation invoked when transaction is complete"
db
(initial (unboxed--db-state-create))
(todo (unboxed--db-delta-create))
(done (unboxed--db-delta-create))
(final (unboxed--db-state-create))
on-completion)
(defun unboxed--summarize-db-transaction (txn)
"Summarize db-transaction TXN."
(when txn
`(db-transaction
(db ,(unboxed--area-name (unboxed--sexpr-db-area (unboxed--transaction-db txn))))
(initial ,(unboxed--summarize-db-state (unboxed--transaction-initial txn)))
(todo ,(unboxed--summarize-db-delta (unboxed--transaction-todo txn)))
(done ,(unboxed--summarize-db-delta (unboxed--transaction-done txn)))
(final ,(unboxed--summarize-db-state (unboxed--transaction-final txn)))
(on-completion ,(and (unboxed--transaction-on-completion txn) t)))))
(defun unboxed--make-db-delta (pkgs-remove pkgs-add)
"Make a transaction-delta removing PKGS-REMOVE and installing PKGS-ADD."
(let ((delta (unboxed--db-delta-create))
ls pkg state)
(when (or pkgs-remove pkgs-add)
(setq ls pkgs-remove
state (unboxed--db-delta-remove delta))
(while ls
(setq pkg (pop ls))
(unboxed--add-package-to-db-state state pkg))
(setq ls pkgs-add
state (unboxed--db-delta-install delta))
(while ls
(setq pkg (pop ls))
(unboxed--add-package-to-db-state state pkg)))
delta))
(defun unboxed--make-transaction (db &optional pkgs-remove pkgs-add on-completion)
"Make a transaction for database DB.
Arguments:
`DB' - database subject to transaction
`PKGS-REMOVE' - list of package descriptors to remove from active set
`PKGS-ADD' - list of package descriptor to install into active set
`ON-COMPLETION' - continuation to invoke after removals and installations
are completed"
(let ((txn (unboxed--transaction-create
:db db
:on-completion on-completion
:initial (unboxed--copy-db-state
(unboxed--sexpr-db-active db))
:todo (unboxed--make-db-delta pkgs-remove pkgs-add))))
txn))
;; note - it's entirely possible for a site to have one version of unboxed installed
;; and for a user to have another version installed. Therefore, we record
;; the layout of structures in structure itself to allow some forward/backward
;; compatibility - eventually
(cl-defstruct (unboxed--sexpr-db
(:constructor unboxed--sexpr-db-create)
(:copier unboxed--sexpr-db-copy))
"Structure holding the tables of data for unboxed in sexpr db representation.
The available db state may include multiple versions of a package, or
incompatible packages. The active db state includes only those packages
available for loading.
Slots:
`layouts' Association list of data structure layouts used in this db
`areas' Association list of area structs in scope for dependency calculations
`area' area struct for this database
`available' db packages for all boxed packages of area on disk
`active' db state for all boxed packages of area available for package loading"
layouts
areas
area
(available (unboxed--db-packages-create))
(active (unboxed--db-state-create)))
(defun unboxed--sexpr-db-name (db)
"Return the name of DB."
(unboxed--area-name
(unboxed--sexpr-db-area db)))
(defun unboxed--sexpr-db-boxes (db)
"Return the box paths of DB."
(unboxed--area-boxes
(unboxed--sexpr-db-area db)))
(defun unboxed--sexpr-db-path (db)
"Return the path to the file for DB."
(unboxed--area-db-path
(unboxed--sexpr-db-area db)))
(defun unboxed--summarize-sexpr-db (db)
"Summarize database DB."
(when db
`(sexpr-db
(layouts ,(and (unboxed--sexpr-db-layouts db) t))
(areas ,(mapcar #'car (unboxed--sexpr-db-areas db)))
(area ,(unboxed--summarize-area (unboxed--sexpr-db-area db)))
(available ,(let ((q (make-queue)))
(maphash (lambda (id pq) (queue-enqueue q `(,id ,(queue-length pq))))
(unboxed--db-packages-descs (unboxed--sexpr-db-available db)))
(queue-all q)))
(active ,(unboxed--summarize-db-state
(unboxed--sexpr-db-active db))))))
;; (defun unboxed--sexpr-db-datadir-patterns (db)
;; "Return the of DB"
;; (unboxed--area-datadir-pats
;; (unboxed--sexpr-db-area db)))
(defun unboxed--sexpr-db-categories (db)
"Return the file categories of DB."
(unboxed--area-categories
(unboxed--sexpr-db-area db)))
(defun unboxed--sexpr-db-category-location (db catname)
"Return the location category CATNAME of DB."
(let ((cats (unboxed--sexpr-db-categories db))
result)
(setq result (assq catname cats)
result (and result
(unboxed-file-category-location (cdr result))))
result))
(defun unboxed--area-category-location (area catname)
"Return the location category CATNAME of AREA."
(let ((cats (unboxed--area-categories area))
result)
(setq result (assq catname cats)
result (and result
(unboxed-file-category-location (cdr result))))
result))
(defun unboxed--area-category (area cat-name)
"Return the category CAT-NAME of AREA."
(let ((result (assq cat-name (unboxed--area-categories area))))
(and result (cdr result))))
(cl-defstruct (unboxed-file-category
(:constructor unboxed-file-category-create)
(:copier unboxed-file-category-copy))
"Structure for contents of package and each is installed.
Other than predicate, the function slots may be nil.
Slots:
`name' name of file category as symbol
`area' name of the area using this category definition
`path-variable' elisp variable for path associated with this
file category, nil if none
`location' path for installing this file category
`libraries' list of absolute library paths that must be loaded
for unboxing operations"
name
area
path-variable
location
libraries)
(defun unboxed--summarize-file-category (cat)
"Construct non-recursive summary of category CAT."
`(file-category
(name ,(unboxed-file-category-name cat))
(area ,(if (symbolp (unboxed-file-category-area cat))
`',(unboxed-file-category-area cat)
(unboxed--area-name (unboxed-file-category-area cat))))
(path-variable ,(unboxed-file-category-path-variable cat))
(predicate ,(and (unboxed-file-category-predicate cat) t))
(location ,(unboxed-file-category-location cat))
(install-files ,(and (unboxed-file-category-install-files cat) t))
(finalize-install-files ,(and (unboxed-file-category-finalize-install-files cat) t))
(remove-files ,(and (unboxed-file-category-remove-files cat) t))
(finalize-remove-files ,(and (unboxed-file-category-finalize-remove-files cat) t))))
(cl-defstruct (unboxed-source-file
(:constructor unboxed-source-file-create)
(:copier unboxed-source-file-struct-copy))
"Structure for a file that exists in the boxed package directory tree.
Slots:
`id' symbol used as unique key for package + file
`package-desc' unboxed-package-desc of package containing the file
`db-category' unboxed-file-category to which the file belongs
`file' location of file relative to package box directory"
id
package-desc
db-category
file)
(cl-defstruct (unboxed--Csource-file
(:constructor unboxed--Csource-file-create)
(:copier unboxed--Csource-file-struct-copy))
"Concrete source-file structure for async operations.
Slots:
`id' symbol used as unique key for package + file
`package' package id (versioned)
`category' name of unboxed-file-category to which the file belongs
`file' location of file relative to package box directory"
id
package
category
file)
(defun unboxed--summarize-source-file (src)
"Summarize source file SRC."
`(source-file
(id ,(unboxed-source-file-id src))
(pkg ,(unboxed-package-desc-name (unboxed-source-file-package-desc src)))
(cat ,(unboxed-file-category-name (unboxed-source-file-db-category src)))
(file ,(unboxed-source-file-file src))))
(cl-defstruct (unboxed-installed-file
(:constructor unboxed-installed-file-create)
(:copier unboxed-installed-file-struct-copy))
"Structure for a file that is installed for a package.
An installed-file record may be created even if the installation of
the file failed, so that the messages/warnings/log will be kept
for reference.
Slots:
`source' source-file from which this is derived
`id' symbol used as unique key for category + file
`file' location of file relative to category-location
may not be identical to source file, or even have the same
base name, e.g. byte-compiled files
Stored as symbol
`package-desc' unboxed-package-desc of package file derives from
`db-category' unboxed-file-category to which the file belongs
`created' boolean indicated whether installing this file succeeded
`log' Any relevant data generated during the installation process
for this specific file
`warnings' *Warnings* buffer during install process
`messages' *Messages* buffer during install process"
source
id
file
package-desc
db-category
created
log
warnings
messages)
(cl-defstruct (unboxed--Cinstalled-file
(:constructor unboxed--Cinstalled-file-create)
(:copier unboxed--Cinstalled-file-struct-copy))
"Concrete form of installed-file for async operations.
Slots:
`source' id of concrete source file
'package' id of concrete package-desc
`id' symbol used as unique key for category + file
`file' location of file relative to category-location
may not be identical to source file, or even have the same
base name, e.g. byte-compiled files
Stored as symbol
`category' category name of file
`created' boolean indicated whether installing this file succeeded
`log' Any relevant data generated during the installation process
for this specific file
`warnings' *Warnings* buffer during install process
`messages' *Messages* buffer during install process"
source
package
id
file
category
created
log
warnings
messages)
(defun unboxed--summarize-installed-file (inst)
"Summarize installed file INST."
`(installed-file
(source
,(unboxed--file-id (unboxed-installed-file-source inst)))
(id ,(unboxed-installed-file-id inst))
(file ,(unboxed-installed-file-file inst))
(created ,(unboxed-installed-file-created inst))
(log ,(and (unboxed-installed-file-log inst) t))
(warnings ,(and (unboxed-installed-file-warnings inst) t))
(messages ,(and (unboxed-installed-file-messages inst) t))))
(defun unboxed--concretize-installed-file (inst)
"Summarize installed file INST."
(unboxed--Cinstalled-file-create
:source (unboxed--file-id (unboxed-installed-file-source inst))
:package (unboxed-package-desc-id (unboxed-installed-file-package inst))
:id (unboxed-installed-file-id inst)
:file (unboxed-installed-file-file inst)
:created (unboxed-installed-file-created inst)
:log (unboxed-installed-file-log inst)
:warnings (unboxed-installed-file-warnings inst)
:messages (unboxed-installed-file-messages inst)))
(cl-defstruct (unboxed--struct-layout
(:constructor unboxed--struct-layout-create)
(:copier unboxed--struct-layout-copy))
"Record of struct layout for instantiating structs
from a file.
Slots:
`version' version of this struct
`seq-type' Value of (cl-struct-sequence-type 'package-desc)
`keys' Keywords for use with constructor for the slot at
the corresponding index
`slot-info' Value of (cl-struct-slot-info 'pacakge-desc)"
(version 1 :read-only t)
seq-type
keys
slot-info)
(cl-defstruct (unboxed-package-desc
(:constructor unboxed-package-desc-create)
(:copier unboxed-package-desc-copy)
(:include package-desc))
"Package desc structure extended with fields recording its
installation manager.
Slots:
`db' unboxed database that owns this package-desc
`id' symbol that is unique for package name + version string
`single' boolean which is t if the package is for a single library file
`simple' boolean which is t if the package directory has no subdirectories
`version-string' version string for this package
`manager' name of installation manager for this package
`files' unboxed--db-files collection of source files in the package box"
db
id
single
simple
(version-string "0")
(manager 'package)
files)
(cl-defstruct (unboxed-Cpackage-desc
(:constructor unboxed-Cpackage-desc-create)
(:copier unboxed-Cpackage-desc-copy))
"Concrete form of unboxed-package-desc.
Slots:
`name' package name
`id' symbol that is unique for package name + version string
`area' area containing the package
`dir' path to boxed files
`single' boolean which is t if the package is for a single library file
`simple' boolean which is t if the package directory has no subdirectories
`version-string' version string for this package
`manager' name of installation manager for this package
`files' unboxed--db-files collection of source files in the package box"
name
id
area
dir
single
simple
(version-string "0")
(manager 'package)
files)
(defun unboxed--summarize-package-desc (pd)
"Summarize unboxed package descriptor PD."
(when pd
`(unboxed-package-desc
(db ,(unboxed--area-name (unboxed-package-desc-area pd)))
(id ,(unboxed-package-desc-id pd))
(single ,(unboxed-package-desc-single pd))
(simple ,(unboxed-package-desc-simple pd))
(version-string ,(unboxed-package-desc-version-string pd))
(manager ,(unboxed-package-desc-manager pd))
(files ,(unboxed--summarize-source-db-files (unboxed-package-desc-files pd))))))
(defun unboxed-package-desc-area (pd)
"Area of package descriptor PD."
(unboxed--sexpr-db-area
(unboxed-package-desc-db pd)))
(defun unboxed-package-desc-areas (pd)
"Areas of package descriptor PD."
(unboxed--sexpr-db-areas
(unboxed-package-desc-db pd)))
(defun unboxed--make-package-desc-id (pd)
"Construct identifier of package descriptor PD."
(let ((name (unboxed-package-desc-name pd))
(vs (unboxed-package-desc-version-string pd)))
(intern (concat (symbol-name name) "#" vs))))
(defun unboxed--make-file-id (inst-or-src)
"Construct identifier of installed file INST."
(let ((name (unboxed--file-file inst-or-src))
(pkg (unboxed--file-package inst-or-src)))
(intern (format "%s#%s" pkg name))))
(defun unboxed--make-source-file-id (src)
"Construct identifier of source file SRC."
(let ((name (symbol-name (unboxed-source-file-file src)))
(vs (unboxed-source-file-version src))
(pkg (symbol-name (unboxed-source-file-package src))))
(intern (concat pkg "#" vs "@" name))))
(defun unboxed-package-single-p (pd)
"Test whether package descriptor PD is for a single file package."
(let ((d (package-desc-dir pd))
(name (symbol-name (package-desc-name pd)))
re-name all main auto pkg r)
(when (and d (file-accessible-directory-p d))
(setq re-name (regexp-quote name)
all (directory-files d nil "^[^.].*$")
main (directory-files d nil (concat "^" re-name "\\.elc?$"))
auto (directory-files d nil (concat "^" re-name "-autoloads\\.elc?$"))
pkg (directory-files d nil (concat "^" re-name "-pkg\\.elc?$")))
(when (= (length all) (+ (length main) (length auto) (length pkg)))
(setq r t)))
r))
(defun unboxed-package-simple-p (pd)
"Test whether package descriptor PD is for a package with no subdirectories."
(let ((d (package-desc-dir pd))
(no-subdirs t)
all fn)
(setq all (directory-files d t "^[^.].*$"))
(while (and no-subdirs all)
(setq fn (pop all)
no-subdirs (not (file-directory-p fn))))
no-subdirs))
(defun unboxed-package-any-p (_pd)
"Test that succeeds for any package descriptor PD."
;; shut up byte-compiler
t)
(defun unboxed-package-none-p (_pd)
"Test that fails for any package descriptor PD."
;; shut up byte-compiler
nil)
(defun unboxed-source-file-version (src)
"Get version string of package containing source file SRC."
(unboxed-package-desc-version-string
(unboxed-source-file-package-desc src)))
(defun unboxed-source-file-package-location (src)
"Get location of package containing source file SRC."
(unboxed-package-desc-dir
(unboxed-source-file-package-desc src)))
(defun unboxed-source-file-package (src)
"Get name of package containing source file SRC."
(unboxed-package-desc-name
(unboxed-source-file-package-desc src)))
(defun unboxed-source-file-category (src)
"Get category name of package containing source file SRC."
(unboxed-file-category-name
(unboxed-source-file-db-category src)))
(defun unboxed-source-file-category-location (src)
"Get category location of package containing source file SRC."
(unboxed-file-category-location
(unboxed-source-file-db-category src)))
(defun unboxed-installed-file-version (inst)
"Get version string of package containing installed file INST."
(unboxed-package-desc-version-string
(unboxed-installed-file-package-desc inst)))
(defun unboxed-installed-file-package-location (inst)
"Get location of package containing installed file INST."
(unboxed-package-desc-dir
(unboxed-installed-file-package-desc inst)))
(defun unboxed-installed-file-package (inst)
"Get name of package containing installed file INST."
(unboxed-package-desc-name
(unboxed-installed-file-package-desc inst)))
(defun unboxed-installed-file-category (inst)
"Get name of category containing installed file INST."
(unboxed-file-category-name
(unboxed-installed-file-db-category inst)))
(defun unboxed-installed-file-category-location (inst)
"Get location of category containing installed file INST."
(unboxed-file-category-location
(unboxed-installed-file-db-category inst)))
(defun unboxed--make-category-queue-aqueue (cats)
"Make an aqueue of queues for category set CATS."
(let ((q (make-queue))
(ls cats)
c-pr)
(while ls
(setq c-pr (pop ls))
(queue-enqueue q
`(,(unboxed-file-category-name (cdr c-pr))
.
,(ajq--make-queue))))
q))
(defun unboxed--exists-source-file-in-cat-queue-p (src aq)
"Test whether source-file with same category and file as SRC exists in aqueue AQ."
(let ((cat (unboxed-source-file-category src))
(file (unboxed-source-file-file src))
pr)
(setq pr (assq cat (queue-all aq)))
;; (unless pr
;; (signal 'unboxed-invalid-category `(,inst ,als)))
(when pr
(seq-some (cdr pr)
(lambda (src1)
(eq file
(unboxed-source-file-file src1)))))))
(defun unboxed--exists-installed-file-in-cat-queue-p (inst aq)
"Test whether INST exists in category aqueue AQ."
(let ((cat (unboxed-installed-file-category inst))
(file (unboxed-installed-file-file inst))
pr)
(setq pr (assq cat (queue-all aq)))
;; (unless pr
;; (signal 'unboxed-invalid-category `(,inst ,als)))
(when pr
(seq-some (cdr pr)
(lambda (inst)
(eq file
(unboxed-installed-file-file inst)))))))
(defun unboxed--add-source-file-to-cat-queue (aq src)
"Add src-file SRC to aqueue AQ."
;; (message "Adding \n%s\n to \n%s"
;; (pp (unboxed--summarize-
(let ((cat (unboxed-source-file-category src))
cat-name pr)
(setq cat-name cat ;(unboxed-file-category-name cat)