quickref.lisp 3.57 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
  (:export :print-primary-systems
	   :get-primary-system-name
7
	   :print-columns
8
9
	   :get-directory-list
	   :build-index))
10

Antoine Martin's avatar
Antoine Martin committed
11
12
(in-package :quickref)

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

18
(defun get-release-name (system)
19
  (ql-dist:name (ql-dist:release system)))
20

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

30
31
32
33
34
35
36
(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
37
     (or (find project provided-systems
38
	       :key #'get-trimmed-system-name
39
40
41
	       :test #'string=
	       :from-end t)
	 (car (last provided-systems))))))
42

Antoine Martin's avatar
Antoine Martin committed
43
(defun print-primary-systems ()
44
45
  (dolist (release (ql-dist:provided-releases t))
    (print (get-primary-system-name (ql-dist:name release)))))
46
47

(defun get-columns-length (size)
48
49
50
51
52
53
  (if (equal size 1) (values 1 0 0)
      (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))))))
54

55
56
(defun print-columns (l size file)
  (multiple-value-bind (lfirst lsecond lthird)
57
58
59
60
61
62
      (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)
63
      (if (>= n lsecond)
64
	  (format file
65
66
67
68
69
70
71
72
73
		  "<tr><td></td><td>~a</td></tr>~%"
		  (car f))
          (if (>= n lthird)
	      (format file
		      "<tr><td></td><td>~a</td><td></td><td>~a</td></tr>~%"
		      (car f) (car s))
	      (format file
		      "<tr><td></td><td>~a</td><td></td><td>~a</td><td></td><td>~a</td></tr>~%"
		      (car f) (car s) (car th)))))))
74
75
76
77

(defun get-directory-list (path)
  (loop for dir in (directory path)
    collect (car (last (pathname-directory dir)))))
78
79
80
81

(defun get-first-letter (sequence)
  (subseq sequence 0 1))

Antoine Martin's avatar
Antoine Martin committed
82
83
84
85
86
87
88
89
90
91
92
(defun is-number (string)
  (let ((chara (char string 0)))
    (and (>= (char-code chara) (char-code #\0))
	 (<= (char-code chara) (char-code #\9)))))

(defun letter-has-changed (previous new)
  (if (and (is-number previous)
	   (is-number new))
      t
      (string= previous new)))

93
94
95
96
97
98
(defun print-index-letter (letter file)
  (if (is-number letter)
      (setq letter "#")
      (setq letter (string-upcase letter)))
  (format file "~%<tr><th><a name=\"~A\">~A</a></th></tr>~%~%" letter letter))

99
100
101
102
103
104
(defun build-index (path file-path)
  (with-open-file (file file-path
			:direction :output
			:if-exists :supersede
			:if-does-not-exist :create)
    (let* ((dir-list (get-directory-list path))
105
106
107
108
109
110
111
	   (first-letter (get-first-letter (first dir-list)))
	   (length 0)
	   (pos dir-list))
      (loop until (endp pos)
	 do (if (letter-has-changed first-letter (get-first-letter (car pos)))
		(progn (setq length (+ length 1))
		       (setq pos (cdr pos)))
112
		(progn
113
		  (print-index-letter first-letter file)
114
115
116
		  (print-columns dir-list length file)
		  (setq length 0)
		  (setq dir-list pos)
117
		  (setq first-letter (get-first-letter (car pos))))))
118
      (print-index-letter first-letter file)
119
      (print-columns dir-list length file))))