quickref.lisp 1.8 KB
Newer Older
Antoine Martin's avatar
Antoine Martin committed
1
(defpackage quickref
2
  (:use :cl :split-sequence)
Antoine Martin's avatar
Antoine Martin committed
3
  (:import-from :alexandria
4
   :starts-with-subseq)
5
6
7
  (:export :print-primary-systems
	   :get-primary-system-name
	   :print-columns))
8

Antoine Martin's avatar
Antoine Martin committed
9
10
(in-package :quickref)

Antoine Martin's avatar
Antoine Martin committed
11
12
13
14
15
(defun remove-cl-prefix (name)
  (if (starts-with-subseq "cl-" name)
      (subseq name 3)
      name))

16
(defun get-release-name (system)
17
  (ql-dist:name (ql-dist:release system)))
18

19
20
(defun get-provided-systems (release)
  (let* ((all-provided-systems (ql-dist:provided-systems t))
21
	 (first-system-found (find release all-provided-systems
22
23
				   :key #'get-release-name
				   :test #'string=)))
24
25
    (unless first-system-found
      (error "Release not found"))
26
    (ql-dist:provided-systems (ql-dist:release first-system-found))))
Antoine Martin's avatar
Antoine Martin committed
27

28
29
30
31
32
33
34
(defun get-trimmed-system-name (system)
  (remove-cl-prefix (ql-dist:name system)))

(defun get-primary-system-name (release)
  (let ((project (remove-cl-prefix release))
	(provided-systems (get-provided-systems release)))
    (ql-dist:name
35
     (or (find project provided-systems
36
	       :key #'get-trimmed-system-name
37
38
39
	       :test #'string=
	       :from-end t)
	 (car (last provided-systems))))))
40

Antoine Martin's avatar
Antoine Martin committed
41
(defun print-primary-systems ()
42
43
  (dolist (release (ql-dist:provided-releases t))
    (print (get-primary-system-name (ql-dist:name release)))))
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60

(defun get-columns-length (size)
  (multiple-value-bind (split remainder) (floor size 3)
    (case remainder
      (0 (values split split split))
      (1 (values (+ split 1) (+ split 1) (- split 1)))
      (2 (values (+ split 1) (+ split 1) split)))))

(defun print-columns (l size)
  (multiple-value-bind (lfirst lsecond)
      (get-columns-length size)
    (do ((n 0 (+ n 1))
	 (f l (cdr f))
	 (s (nthcdr lfirst l) (cdr s))
	 (th (nthcdr (+ lfirst lsecond) l) (cdr th)))
	((= n lfirst) nil)
      (format t "~a ~a ~a~%" (car f) (car s) (car th)))))