file.lisp 3.95 KB
Newer Older
1
2
(in-package :quickref)

3
4
5
6
7
8
9
(defparameter *quickref-basedir* (user-homedir-pathname))

(defun from-quickref-dir (relative-path)
  (merge-pathnames relative-path (quickref-dir)))

(defun quickref-dir ()
  (merge-pathnames "quickref/" *quickref-basedir*))
Antoine Martin's avatar
Antoine Martin committed
10

11
12
(defun clean-directory (path)
  (dolist (dir (directory (merge-pathnames "*/" (truename path))))
13
    (sb-ext:delete-directory dir :recursive t))
14
15
16
17
18
19
  (dolist (file (directory (merge-pathnames "*.*" (truename path))))
    (delete-file file)))

(defun all-directories (path)
  (merge-pathnames "*/" (truename path)))

20
21
22
(defun all-files (path)
  (merge-pathnames "*.*" (truename path)))

23
24
25
26
(defun get-directory-list (path)
  (loop for dir in (directory (all-directories path))
     collect (car (last (pathname-directory dir)))))

27
28
29
30
31
32
(defun get-file-list (path)
  (loop for file in (directory (all-files path))
     nconc (if (string= (pathname-name file) "index")
	       nil
	       (list (pathname-name file)))))

33
(defun get-texi-pathnames ()
Antoine Martin's avatar
Antoine Martin committed
34
35
36
  (loop for pathname in (directory
			 (all-files (from-quickref-dir "texis/")))
     collect pathname))
Antoine Martin's avatar
Antoine Martin committed
37
38
39
40
41

(defun clean-or-create (directory)
  (if (probe-file directory)
      (clean-directory directory)
      (ensure-directories-exist directory)))
42
43

(defun log-texi-error (err texi)
44
45
  (let ((filepathname (from-quickref-dir
		       (format nil "logs/makeinfo/~A.log"
46
47
48
49
50
51
			       (pathname-name texi)))))
    (with-open-file (file filepathname
			  :direction :output
			  :if-exists :supersede
			  :if-does-not-exist :create)
      (format file err))))
52
53
54

(defun setup-quickref-dir (&key declt makeinfo)
  (when declt
55
56
    (clean-or-create (from-quickref-dir "logs/declt-map/"))
    (clean-or-create (from-quickref-dir "texis/")))
57
58
59
  (when makeinfo
    (clean-or-create (from-quickref-dir "logs/makeinfo/"))
    (clean-or-create (from-quickref-dir "website/"))))
60
61

(defun find-readme (release-name)
62
63
64
65
  (let* ((release (ql-dist:find-release release-name))
	 (asd-file (if release
		       (ql-dist:base-directory release)
		       (asdf:system-source-directory release-name))))
66
67
68
69
    (car (directory (merge-pathnames "README.*"
				     asd-file)))))
(defun file-to-string (pathname)
  (with-open-file (file pathname)
70
71
72
73
74
75
76
77
78
79
80
81
82
    (handler-case
	(alexandria:read-file-into-string
	 file
	 :external-format :utf-8)
      (error ()
	(handler-case
	    (alexandria:read-file-into-string
	     file
	     :external-format :latin-1)
	  (error ()
	    (alexandria:read-file-into-string
	     file
	     :external-format '(:utf-8 :replacement #\?))))))))
83
84
85
86
87
88
89
90
91

(defmacro read-write-file ((pathname content stream) &body body)
  `(let ((,content (file-to-string ,pathname)))
     (with-open-file (,stream
		      ,pathname
		      :direction :output
		      :if-exists :supersede)
       ,@body)))

92
93
(defun format-readme (readme)
  (let ((readme-txt (file-to-string readme)))
94
    (if (find (string-downcase (pathname-type readme))
95
96
	      '("md" "markdown" "mdown" "mkdn" "mdwn" "mkd")
	      :test #'string=)
97
98
99
100
101
	(handler-case
	    (cmark-markdown-to-html readme-txt (length readme-txt) 0)
	  (error ()
	    (with-output-to-string (out)
	      (parse-string-and-print-to-stream readme-txt out))))
102
103
104
	(format nil "<pre style=\"white-space: pre-wrap;\">~%~A~%</pre>"
		readme-txt))))

105
106
107
108
(defun use-readme-intro (html-pathname readme-pathname)
  (read-write-file (html-pathname html-text stream)
    (write-sequence
     (regex-replace
109
      "\\<h2 class=\\\"chapter\\\"\\>1 Introduction\\<\\/h2\\>\\n"
110
      html-text
111
      (list :match
112
	    (format-readme readme-pathname)))
113
     stream)))
114
115
116
117
118
119
120
121
122
123
124
125
126
127

(defun file-copy (source destination)
  (with-open-file (in source :direction :input)
    (with-open-file (out destination :direction :output)
      (uiop:copy-stream-to-stream in out))))

(defun copy-stylesheets ()
  (let ((styles '("main.css" "document.css"))
	(css-dir (merge-pathnames "css/"
				  (asdf:system-source-directory "quickref")))
	(website-dir (from-quickref-dir "website/")))
    (dolist (file styles)
      (file-copy (merge-pathnames file css-dir)
		 (merge-pathnames file website-dir)))))