Newer
Older
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
#+xcvb
(module
(:depends-on
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
"exscribe/packages"
"exscribe/macros"
"exscribe/specials")))
(in-package :exscribe)
;;; pathname munging
(defun add-exscribe-path (d)
(setf *exscribe-path* (append *exscribe-path* (list (ensure-directory-pathname d)))))
(defun maybe-error (user-default if-error)
(flet ((f (x)
(typecase x
(function (funcall x))
(t x))))
(if (eq user-default :error) (f if-error) (f user-default))))
(defmacro on-error (user-default &body body)
`(maybe-error ,user-default #'(lambda () ,@body)))
(defun find-file-in-path (f l &optional types (if-error :error))
(let ((p (parse-namestring f))
(tp (mapcar #'(lambda (type) (make-pathname :type type))
(typecase types
(list types)
((or string pathname) (list types))))))
(if (absolute-pathname-p p) p
(or
(loop for d in l
for x = (merge-pathnames p d)
thereis (or (probe-file x)
(loop for tx in tp
thereis (probe-file (merge-pathnames x tx)))))
(on-error if-error
(error "Cannot find file ~A in search path ~A" f l))))))
(defun find-exscribe-file (f &optional (if-error :error))
(etypecase f
(stream f)
(symbol (find-exscribe-file (string-downcase (symbol-name f))))
((or string pathname)
(find-file-in-path f *exscribe-path* "scr" if-error))))
(defun read-eval-stream (s &key &allow-other-keys)
(let ((forms (xxtime ("<== reading ~A~%" s)
(loop with eof = '#:eof
for i = (read s nil eof) until (eq i eof)
collect i))))
(xxtime ("<== evaluating ~A~%" s)
(loop for i in forms do (eval i)))))
(defun do-load (s &key &allow-other-keys)
(typecase s
(stream (read-eval-stream s))
((or string pathname)
(with-open-file (i s :direction :input :if-does-not-exist :error)
(read-eval-stream i)))))
(defun file-optimization ()
(proclaim `(optimize (speed 1) (space 2)
#-sbcl (debug 2)
#+sbcl (compilation-speed 3)
,@(if *exscribe-verbose*
'((safety 3) #+sbcl (debug 2))
'((safety 1) #+sbcl (debug 1))))))
(defun style-optimization ()
(proclaim `(optimize (speed 3) (space 2)
#-sbcl (debug 2)
#+sbcl (compilation-speed 3)
,@(if *exscribe-verbose*
'((safety 3) #+sbcl (debug 2))
'((safety 1) #+sbcl (debug 1))))))
(defun exscribe-load-file (file)
(file-optimization)
;;(cl-launch:compile-and-load-file
(load
(find-exscribe-file file)
:print *exscribe-verbose*
:verbose *exscribe-verbose*))
(defun exscribe-load-style (style)
(unless (member style *loaded-styles*)
(push style *loaded-styles*)
#+ecl (load (find-exscribe-file style)) #-ecl ;; recursive calls to compile-file seem to fail silently
(let* ((file (find-exscribe-file style))
(date (file-write-date file))
(force (and *latest-style-date* (< date *latest-style-date*)))
(object (cl-launch:compile-and-load-file
file :force-recompile force :verbose *exscribe-verbose*))
(object-date (file-write-date object)))
(setf *latest-style-date*
(if *latest-style-date*
(max *latest-style-date* object-date)
object-date)))))
(defmacro style (f)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(exscribe-load-style ,f)))
;;; Syntax setup
(defun recreate-user-package ()
(let ((use-list '(:exscribe-data :exscribe :fare-utils :scheme-makeup))
(eu (find-package :exscribe-user)))
(case *exscribe-mode*
(html (push :exscribe-html use-list))
(pdf (push :exscribe-typeset use-list)))
(dolist (p (package-use-list eu)) (unuse-package p eu))
(do-all-symbols (x eu) (unintern x eu))
(dolist (p use-list) (use-package p eu))
;(shadowing-import 'scheme-makeup:map eu)
(use-package :common-lisp eu)
(setf *scribble-package* eu)
(setf *loaded-styles* nil)
(setf *latest-style-date* nil)
t))
(defun klist (&rest r) (cons 'list r))
(defun configure-scribble-for-exscribe ()
"This will make Scribble work with exscribe"
(configure-scribble :package :exscribe-user
:cons 'default-scribble-cons
:list 'default-scribble-list
:default-head 'klist
:preprocess nil))
(defun init-exscribe ()
(recreate-user-package)
(configure-scribble-for-exscribe)
(enable-scribble-at-syntax :scribe t)
(scheme-compat::set-scheme-macro-characters)
(setf *exscribe-initialized* t))
(defun ensure-exscribe ()
(unless *exscribe-initialized* (init-exscribe)))
(defun reset-exscribe ()
(ensure-exscribe)
(recreate-user-package)
(reenable-scribble-at-syntax :scribe t)
(set-exscribe-mode *exscribe-mode*)
t)
(defun set-exscribe-mode (mode)
(ecase mode
(html (exscribe-html::init))
(txt (exscribe-txt::init))
#+exscribe-typeset (pdf (exscribe-typeset::init))))
(defun call-with-exscribe-environment (thunk)
(let ((*package* (find-package :exscribe-user))
(*footnotes* nil)
(*footnote-counter* 0)
(*footnotes-title* "Notes")
(*header* nil)
(*footer* nil)
(*section-counter* 0)
(*subsection-counter* 0)
(*subsubsection-counter* 0)
(*generate-label-counter* 0)
(*sections-by-label* (make-hash-table :test 'equal))
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
(*bibliography* (exscribe-data::make-bib-table))
(*bibliography-options* nil)
(*bibliography-location* nil)
(*bibliography-header* nil)
(*toc* nil)
(*postprocess-hooks* nil)
(*print-pretty* nil)
(*document* nil))
(reset-exscribe)
(funcall thunk)))
(defmacro with-exscribe-environment (&body body)
`(call-with-exscribe-environment #'(lambda () ,@body)))
(defun exscribe-load-document (f)
(with-exscribe-environment ()
(exscribe-load-file f)))
(defun process-file (from
&key into translator
(verbose *exscribe-verbose*) (mode *exscribe-mode*))
(let* ((input (find-exscribe-file from))
(suffix (second (assoc mode *mode-suffixes*)))
(output (or into
(let ((pn (make-pathname :type suffix :defaults input)))
(if translator (funcall translator pn) pn)))))
(if (equal output "-")
(exscribe-load-document input)
(progn
(ensure-directories-exist output :verbose verbose)
(when verbose
(format t "Exscribe: compiling~% ~A~% into ~A~%" input output))
(with-open-file (*standard-output*
output
:direction :output
:if-exists :supersede
:element-type #+pdf-binary #+sbcl :default #-sbcl '(unsigned-byte 8)
#-pdf-binary #+sbcl 'character #-sbcl 'base-char
)
(exscribe-load-document input))))))
(defparameter *wild-path*
(make-pathname :directory '(:relative :wild-inferiors)
:name :wild :type :wild :version :wild))
(defun wilden (path)
(merge-pathnames *wild-path* path))
(defun process-many (src dst &rest files)
(add-exscribe-path src)
(loop with source = (wilden (ensure-directory-pathname src))
with destination = (wilden (ensure-directory-pathname dst))
with translator = #'(lambda (pn) (translate-pathname pn source destination))
for f in files
for input = (find-exscribe-file f) do
(process-file input :translator translator :verbose t)))
(defun help (&optional (s *standard-output*))
(format s
"exscribe ~A -- Lisp-programmable document authoring system.
Usage: exscribe [-I include]... [-v]~A [-o output] input
Homepage: http://www.cliki.net/Exscribe
Options:
-h -? --help show some help
-v --verbose output some information along the way
-I --include /PATH/to/style/ add directory to include path
-o --output destination-file which file to create
-H --html select the html backend
-P --pdf select the PDF backend
-M --many src dst files... compile files from src to dst
-D --debug enable the Lisp debugger
--repl provide the user a REPL
" *exscribe-version*
#+exscribe-typeset " [-H|-P]" #-exscribe-typeset ""))
(defun enable-debugging ()
#+sbcl (sb-ext:enable-debugger)
#+cmu (setf ext:*batch-mode* nil)
nil)
(defun repl ()
(enable-debugging)
(loop do
(format t "~&* ") (finish-output)
(format t "~&~S~%" (eval (read)))))
(defun process-command-line (args)
(if (null args)
(help)
(loop
with inputs = nil with output = nil
for a = (pop args) while a do
(macrolet ((x (&rest l) `(member a ',l :test 'equal)))
(cond
((x "-h" "-?" "--help") (return (help)))
((x "-H" "--html")
(setf *exscribe-mode* 'html))
#+exscribe-typeset
((x "-P" "--pdf")
(setf *exscribe-mode* 'pdf))
((x "-v" "--verbose")
(setf *exscribe-verbose* t))
((x "-D" "--debug")
(enable-debugging))
((x "-M" "--many")
(when output (error "option --many invalid after option --output"))
(when inputs (error "option --many invalid after inputs are specified"))
(return (apply 'process-many args)))
((x "-I" "--include")
(if args
(add-exscribe-path (pop args))
(error "missing include path argument")))
((x "-o" "--output")
(if args (setf output (pop args))
(error "missing output argument")))
((x "--repl")
(let ((*standard-input* *terminal-io*)
(*standard-output* *terminal-io*))
(repl))
(return))
((equal (char a 0) #\-)
(error "Unrecognized option ~A" a))
(t (push a inputs))))
finally
(progn
(unless (length=n-p inputs 1)
(error "Requiring a unique input, got ~A" inputs))
(unless output
(error "No output specified"))
(process-file (car inputs) :into output)))))
#+cl-launch
(defun main ()
(add-exscribe-path *default-pathname-defaults*)
(process-command-line cl-launch:*arguments*))