##// END OF EJS Templates
Remove qlot
naryl -
r52:42f15972 default
parent child Browse files
Show More
@@ -0,0 +1,4 b''
1
2 1. Install sbcl using your distribution's package manager, or download it from https://sbcl.org
3 2. Install quicklisp from https://quicklisp.org E.g. `wget https://beta.quicklisp.org/quicklisp.lisp && sbcl --load quicklisp.org` then follow instructions.
4 3. `make`
@@ -1,7 +1,8 b''
1 1 .*~
2 2 .qlot
3 3 .html
4 4 .png
5 .orig
5 6 tests
6 sugar-qsp
7 sugar-qsp.tar.xz
7 txt2web
8 txt2web.tar.xz
@@ -1,39 +1,32 b''
1 1
2 2 BIN = txt2web
3 3 DIST = $(BIN).tar.xz
4 4
5 5 all: $(BIN)
6 6
7 7 dist: $(DIST)
8 8
9 9 graphs: diagrams.png
10 10
11 11 $(BIN): *.asd src/*.lisp src/*.ps strings/*.sexp
12 12 sbcl --load build.lisp -- $(BIN)
13 13
14 install-deps:
15 sbcl --load install-deps.lisp
16
17 update-deps:
18 sbcl --load update-deps.lisp
19
20 14 %.png: %.dot
21 15 dot $< -T png -o $@
22 16
23 17 $(DIST): $(BIN) extras/*
24 18 tar cfvJ $@ $< extras
25 19
26 20 upload: $(DIST)
27 21 curl --upload-file $(DIST) https://transfer.sh/$(DIST)
28 22 @echo
29 23
30 distclean: clean clean-deps
31
32 24 clean:
33 25 rm -f $(BIN) $(DIST)
34 26
35 clean-deps:
36 -rm qlfile.lock
37 -rm -rf .qlot
27 clean-cache:
28 -rm -rf ~/.cache/common-lisp
38 29
39 .PHONY: all graphs install-deps update-deps clean upload
30 fresh: clean clean-cache all
31
32 .PHONY: all graphs upload clean clean-cache fresh
@@ -1,10 +1,4 b''
1 (let ((root (asdf:system-source-directory :txt2web)))
2 (asdf:initialize-source-registry
3 `(:source-registry
4 :ignore-inherited-configuration
5 (:directory ,root)
6 (:tree ,(format nil "~A~A" root ".qlot/dists")))))
1 (ql:quickload :txt2web)
7 2
8 (asdf:load-system :txt2web)
9 3 (uiop:register-image-restore-hook 'txt2web::entry-point-no-args nil)
10 4 (uiop:dump-image "txt2web" :executable t)
@@ -1,531 +1,531 b''
1 1
2 2 (in-package txt2web)
3 3
4 4 ;;; API deals with DOM manipulation and some bookkeeping for the
5 5 ;;; intrinsics, namely variables
6 6 ;;; API is an implementation detail and has no QSP documentation. It
7 7 ;;; doesn't call intrinsics
8 8
9 9 ;;; Utils
10 10
11 11 (defun make-act-html (title img)
12 12 (+ "<a class='qsp-act' href='" (href-call call-act title) "' onmouseover='" (inline-call select-act title) "'>"
13 13 (if img (+ "<img src='" img "'>") "")
14 14 title
15 15 "</a>"))
16 16
17 17 (defun make-menu-item-html (num title img loc)
18 18 (+ "<a href='" (href-call finish-menu loc) "'>"
19 19 (if img (+ "<img src='" img "'>") "")
20 20 title
21 21 "</a>"))
22 22
23 23 (defun make-obj (title img selected)
24 24 (+ "<li onclick='" (inline-call select-obj title img) "'>"
25 25 "<a class='qsp-obj" (if selected " qsp-obj-selected" "") "'>"
26 26 (if img (+ "<img src='" img "'>") "")
27 27 title
28 28 "</a>"))
29 29
30 30 (defun make-menu-delimiter ()
31 31 "<hr>")
32 32
33 33 (defun copy-obj (obj)
34 34 (chain *j-s-o-n (parse (chain *j-s-o-n (stringify obj)))))
35 35
36 36 (defun report-error (text)
37 37 (alert text))
38 38
39 39 (defun start-sleeping ()
40 40 (chain (by-id "qsp") class-list (add "disable")))
41 41
42 42 (defun finish-sleeping ()
43 43 (chain (by-id "qsp") class-list (remove "disable")))
44 44
45 45 (defun sleep (msec)
46 46 (with-sleep (resume)
47 47 (set-timeout resume msec)))
48 48
49 49 (defun init-dom ()
50 50 ;; Save/load buttons
51 51 (let ((btn (by-id "qsp-btn-save")))
52 52 (setf (@ btn onclick) savegame)
53 53 (setf (@ btn href) "#"))
54 54 (let ((btn (by-id "qsp-btn-open")))
55 55 (setf (@ btn onclick) opengame)
56 56 (setf (@ btn href) "#"))
57 57 ;; Close image on click
58 58 (setf (@ (by-id "qsp-image-container") onclick)
59 59 show-image)
60 60 ;; Enter in input field
61 61 (setf (@ (get-frame :input) onkeyup)
62 62 on-input-key)
63 63 ;; Close the dropdown on any click
64 64 (setf (@ window onclick)
65 65 (lambda (event)
66 66 (setf (@ window mouse)
67 67 (list (@ event page-x)
68 68 (@ event page-y)))
69 69 (finish-menu nil))))
70 70
71 71 (defun call-serv-loc (var-name &rest args)
72 72 (let ((loc-name (get-global var-name 0)))
73 73 (when loc-name
74 74 (let ((loc (getprop *locs loc-name)))
75 75 (when loc
76 76 (call-loc loc-name args))))))
77 77
78 78 (defun filename-game (filename)
79 79 (let ((game-name (chain filename (match "(.*/)?([^.]+)(\\.[a-zA-Z]+)?") 2))))
80 80 (getprop *games game-name))
81 81
82 82 (defun run-game (name)
83 83 (let ((game (filename-game name)))
84 84 (setf *main-game name)
85 85 ;; Replace locations with the new game's
86 86 (setf *locs game)
87 87 (funcall (getprop game
88 88 (chain *object (keys game) 0))
89 89 (list))))
90 90
91 91 ;;; Misc
92 92
93 93 (defun newline (key)
94 94 (append-id (key-to-id key) "<br>" t))
95 95
96 96 (defun clear-id (id)
97 97 (setf (inner-html (by-id id)) ""))
98 98
99 99 (defun escape-html (text)
100 100 (chain text
101 101 (replace (regex "/&/g") "&amp;")
102 102 (replace (regex "/</g") "&lt;")
103 103 (replace (regex "/>/g") "&gt;")
104 104 (replace (regex "/\"/g") "&quot;")
105 105 (replace (regex "/'/g") "&apos;")))
106 106
107 107 (defun prepare-contents (s &optional force-html)
108 108 (setf s (chain s (to-string)))
109 109 (if (or force-html (get-global "USEHTML" 0))
110 110 s
111 111 (escape-html s)))
112 112
113 113 (defun get-id (id &optional force-html)
114 114 (inner-html (by-id id)))
115 115
116 116 (defun set-id (id contents &optional force-html)
117 117 (setf (inner-html (by-id id)) (prepare-contents contents force-html)))
118 118
119 119 (defun append-id (id contents &optional force-html)
120 120 (when contents
121 121 (incf (inner-html (by-id id)) (prepare-contents contents force-html))))
122 122
123 123 (defun on-input-key (ev)
124 124 (when (= 13 (@ ev key-code))
125 125 (chain ev (prevent-default))
126 126 (call-serv-loc "$USERCOM")))
127 127
128 128 ;;; Function calls
129 129
130 130 (defun init-args (args)
131 131 (dotimes (i (length args))
132 132 (let ((arg (elt args i)))
133 133 (if (numberp arg)
134 134 (set-var args i :num arg)
135 135 (set-var args i :str arg)))))
136 136
137 137 (defun get-result ()
138 138 (or (get-global "$RESULT" 0)
139 139 (get-global "RESULT" 0)))
140 140
141 141 (defun call-loc (name args)
142 142 (setf name (chain name (to-upper-case)))
143 143 (with-frame
144 144 (with-call-args args
145 145 (funcall (getprop *locs name))))
146 146 (void))
147 147
148 148 (defun call-act (title)
149 149 (with-frame
150 150 (funcall (getprop *acts title :act)))
151 151 (void))
152 152
153 153 ;;; Text windows
154 154
155 155 (defun key-to-id (key)
156 156 (case key
157 157 (:all "qsp")
158 158 (:main "qsp-main")
159 159 (:stat "qsp-stat")
160 160 (:objs "qsp-objs")
161 161 (:acts "qsp-acts")
162 162 (:input "qsp-input")
163 163 (:image "qsp-image")
164 164 (:dropdown "qsp-dropdown")
165 165 (t (report-error "Internal error!"))))
166 166
167 167 (defun get-frame (key)
168 168 (by-id (key-to-id key)))
169 169
170 170 (defun add-text (key text)
171 171 (append-id (key-to-id key) text))
172 172
173 173 (defun get-text (key)
174 174 (get-id (key-to-id key)))
175 175
176 176 (defun clear-text (key)
177 177 (clear-id (key-to-id key)))
178 178
179 179 (defun enable-frame (key enable)
180 180 (let ((obj (get-frame key)))
181 181 (setf (@ obj style display) (if enable "block" "none"))
182 182 (void)))
183 183
184 184 ;;; Actions
185 185
186 186 (defun add-act (title img act)
187 187 (setf (getprop *acts title)
188 188 (create :title title :img img :act act :selected nil))
189 189 (update-acts))
190 190
191 191 (defun del-act (title)
192 192 (delete (getprop *acts title))
193 193 (update-acts))
194 194
195 195 (defun clear-act ()
196 196 (setf *acts (create))
197 197 (update-acts))
198 198
199 199 (defun update-acts ()
200 200 (clear-id "qsp-acts")
201 201 (let ((elt (by-id "qsp-acts")))
202 202 (for-in (title *acts)
203 203 (let ((obj (getprop *acts title)))
204 204 (incf (inner-html elt) (make-act-html title (getprop obj :img)))))))
205 205
206 206 (defun select-act (title)
207 207 (loop :for (k v) :of *acts
208 208 :do (setf (getprop v :selected) nil))
209 209 (setf (getprop *acts title :selected) t)
210 210 (call-serv-loc "$ONACTSEL"))
211 211
212 212 ;;; "Syntax"
213 213
214 214 (defun qspfor (name index from to step body)
215 (for ((i from))
216 ((< i to))
217 ((incf i step))
215 (ps:for ((i from))
216 ((< i to))
217 ((incf i step))
218 218 (set-var name index :num i)
219 219 (unless (await (funcall body))
220 220 (return-from qspfor))))
221 221
222 222 ;;; Variables
223 223
224 224 (defun new-var (slot &rest indexes)
225 225 (let ((v (list)))
226 226 (dolist (index indexes)
227 227 (setf (elt v index) (if (eq #\$ (elt slot 0)) "" 0)))
228 228 (setf (@ v :indexes) (create))
229 229 v))
230 230
231 231 (defun set-str-element (slot index value)
232 232 (if (has index (getprop slot :indexes))
233 233 (setf (elt (getprop slot)
234 234 (getprop slot :indexes index))
235 235 value)
236 236 (progn
237 237 (chain slot (push value))
238 238 (setf (elt slot index)
239 239 (length slot))))
240 240 (void))
241 241
242 242 (defun set-any-element (slot index value)
243 243 (cond ((null index)
244 244 (chain (elt slot) (push value)))
245 245 ((numberp index)
246 246 (setf (elt slot index) value))
247 247 ((stringp index)
248 248 (set-str-element slot index value))
249 249 (t (report-error "INTERNAL ERROR")))
250 250 (void))
251 251
252 252 (defun set-serv-var (name index value)
253 253 (let ((slot (getprop *globals name)))
254 254 (set-any-element slot index value))
255 255 (funcall (getprop serv-vars name :body) value index)
256 256 (void))
257 257
258 258 (defun get-element (slot index)
259 259 (if (numberp index)
260 260 (elt slot index)
261 261 (elt slot (getprop slot :indexes index))))
262 262
263 263 (defun get-global (name index)
264 264 (elt (getprop *globals name) index))
265 265
266 266 (defun kill-var (store name &optional index)
267 267 (setf name (chain name (to-upper-case)))
268 268 (if (and index (not (= 0 index)))
269 269 (chain (getprop *globals name) (kill index))
270 270 (delete (getprop *globals name)))
271 271 (void))
272 272
273 273 (defun array-size (name)
274 274 (@ (var-ref name) :values length))
275 275
276 276 ;;; Locals
277 277
278 278 (defun push-local-frame ()
279 279 (chain *locals (push (create)))
280 280 (void))
281 281
282 282 (defun pop-local-frame ()
283 283 (chain *locals (pop))
284 284 (void))
285 285
286 286 (defun current-local-frame ()
287 287 (elt *locals (1- (length *locals))))
288 288
289 289 ;;; Objects
290 290
291 291 (defun select-obj (title img)
292 292 (loop :for (k v) :of *objs
293 293 :do (setf (getprop v :selected) nil))
294 294 (setf (getprop *objs title :selected) t)
295 295 (call-serv-loc "$ONOBJSEL" title img))
296 296
297 297 (defun update-objs ()
298 298 (let ((elt (by-id "qsp-objs")))
299 299 (setf (inner-html elt) "<ul>")
300 300 (loop :for (name obj) :of *objs
301 301 :do (incf (inner-html elt)
302 302 (make-obj name (@ obj :img) (@ obj :selected))))
303 303 (incf (inner-html elt) "</ul>")))
304 304
305 305 ;;; Menu
306 306
307 307 (defun open-menu (menu-data)
308 308 (let ((elt (get-frame :dropdown))
309 309 (i 0))
310 310 (loop :for item :in menu-data
311 311 :do (incf i)
312 312 :do (incf (inner-html elt)
313 313 (if (eq item :delimiter)
314 314 (make-menu-delimiter i)
315 315 (make-menu-item-html i
316 316 (@ item :text)
317 317 (@ item :icon)
318 318 (@ item :loc)))))
319 319 (let ((mouse (@ window mouse)))
320 320 (setf (@ elt style left) (+ (elt mouse 0) "px"))
321 321 (setf (@ elt style top) (+ (elt mouse 1) "px"))
322 322 ;; Make sure it's inside the viewport
323 323 (when (> (@ document body inner-width)
324 324 (+ (elt mouse 0) (@ elt inner-width)))
325 325 (incf (@ elt style left) (@ elt inner-width)))
326 326 (when (> (@ document body inner-height)
327 327 (+ (elt mouse 0) (@ elt inner-height)))
328 328 (incf (@ elt style top) (@ elt inner-height))))
329 329 (setf (@ elt style display) "block")))
330 330
331 331 (defun finish-menu (loc)
332 332 (when *menu-resume
333 333 (let ((elt (get-frame :dropdown)))
334 334 (setf (inner-html elt) "")
335 335 (setf (@ elt style display) "none")
336 336 (funcall *menu-resume)
337 337 (setf *menu-resume nil))
338 338 (when loc
339 339 (call-loc loc)))
340 340 (void))
341 341
342 342 (defun menu (menu-data)
343 343 (with-sleep (resume)
344 344 (open-menu menu-data)
345 345 (setf *menu-resume resume))
346 346 (void))
347 347
348 348 ;;; Content
349 349
350 350 (defun clean-audio ()
351 351 (loop :for k :in (chain *object (keys *playing))
352 352 :for v := (getprop *playing k)
353 353 :do (when (@ v ended)
354 354 (delete (@ *playing k)))))
355 355
356 356 (defun show-image (path)
357 357 (let ((img (get-frame :image)))
358 358 (cond (path
359 359 (setf (@ img src) path)
360 360 (setf (@ img style display) "flex"))
361 361 (t
362 362 (setf (@ img src) "")
363 363 (setf (@ img style display) "hidden")))))
364 364
365 365 (defun show-inline-images (frame-name images)
366 366 (let ((frame (get-frame frame-name))
367 367 (text ""))
368 368 (incf text "<div style='position:relative; display: inline-block'>")
369 369 (incf text (+ "<img src='" (@ images 0) "'>"))
370 370 (loop :for image :in (chain images (slice 1))
371 371 :do (incf text
372 372 (+ "<img style='position:absolute' src='" image "'>")))
373 373 (incf text "</div>")
374 374 (incf (inner-html frame) text)))
375 375
376 376 (defun rgb-string (rgb)
377 377 (let ((red (ps::>> rgb 16))
378 378 (green (logand (ps::>> rgb 8) 255))
379 379 (blue (logand rgb 255)))
380 380 (flet ((rgb-to-hex (comp)
381 381 (let ((hex (chain (*number comp) (to-string 16))))
382 382 (if (< (length hex) 2)
383 383 (+ "0" hex)
384 384 hex))))
385 385 (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex blue)))))
386 386
387 387 (defun store-obj (key obj)
388 388 (store-str key (btoa (encode-u-r-i-component (chain *j-s-o-n (stringify obj)))))
389 389 (void))
390 390 (defun store-str (key str)
391 391 (chain local-storage (set-item (+ "qsp_" key) str))
392 392 (void))
393 393
394 394 (defun load-obj (key)
395 395 (chain *j-s-o-n (parse (encode-u-r-i-component (atob (load-str key))))))
396 396 (defun load-str (key)
397 397 (chain local-storage (get-item (+ "qsp_" key))))
398 398
399 399 ;;; Saves
400 400
401 401 (defun slot-savegame (slot comment)
402 402 (let ((saves (load-obj "saves")))
403 403 (setf (@ saves slot) comment)
404 404 (store-obj saves))
405 405 (store-str slot (state-to-base64))
406 406 (void))
407 407
408 408 (defun slot-loadgame (slot)
409 409 (base64-to-state (load-str slot))
410 410 (void))
411 411
412 412 (defun slot-deletegame (slot)
413 413 (let ((saves (load-obj "saves")))
414 414 (setf (@ saves slot) undefined)
415 415 (store-obj saves))
416 416 (store-str slot undefined)
417 417 (void))
418 418
419 419 (defun slot-listgames ()
420 420 (load-obj "saves"))
421 421
422 422 (defun opengame ()
423 423 (let ((element (chain document (create-element :input))))
424 424 (chain element (set-attribute :type :file))
425 425 (chain element (set-attribute :id :qsp-opengame))
426 426 (chain element (set-attribute :tabindex -1))
427 427 (chain element (set-attribute "aria-hidden" t))
428 428 (setf (@ element style display) :block)
429 429 (setf (@ element style visibility) :hidden)
430 430 (setf (@ element style position) :fixed)
431 431 (setf (@ element onchange)
432 432 (lambda (event)
433 433 (let* ((file (@ event target files 0))
434 434 (reader (new (*file-reader))))
435 435 (setf (@ reader onload)
436 436 (lambda (ev)
437 437 (block nil
438 438 (let ((target (@ ev current-target)))
439 439 (unless (@ target result)
440 440 (return))
441 441 (base64-to-state (@ target result))
442 442 (unstash-state)))))
443 443 (chain reader (read-as-text file)))))
444 444 (chain document body (append-child element))
445 445 (chain element (click))
446 446 (chain document body (remove-child element))))
447 447
448 448 (defun savegame ()
449 449 (let ((element (chain document (create-element :a))))
450 450 (chain element (set-attribute :href (+ "data:text/plain;charset=utf-8," (state-to-base64))))
451 451 (chain element (set-attribute :download "savegame.sav"))
452 452 (setf (@ element style display) :none)
453 453 (chain document body (append-child element))
454 454 (chain element (click))
455 455 (chain document body (remove-child element))))
456 456
457 457 (defun stash-state (args)
458 458 (call-serv-loc "$ONGSAVE")
459 459 (setf *state-stash
460 460 (chain *j-s-o-n (stringify
461 461 (create :vars *globals
462 462 :objs *objs
463 463 :loc-args args
464 464 :msecs (- (chain *date (now)) *started-at)
465 465 :timer-interval *timer-interval
466 466 :main-html (inner-html
467 467 (get-frame :main))
468 468 :stat-html (inner-html
469 469 (get-frame :stat))
470 470 :next-location *current-location))))
471 471 (void))
472 472
473 473 (defun unstash-state ()
474 474 (let ((data (chain *j-s-o-n (parse *state-stash))))
475 475 (clear-act)
476 476 (setf *globals (@ data :vars))
477 477 (loop :for k :in (chain *object (keys *globals))
478 478 :do (chain *object (set-prototype-of (getprop *globals k)
479 479 (@ *var prototype))))
480 480 (setf *started-at (- (chain *date (now)) (@ data :msecs)))
481 481 (setf *objs (@ data :objs))
482 482 (setf *current-location (@ data :next-location))
483 483 (setf (inner-html (get-frame :main))
484 484 (@ data :main-html))
485 485 (setf (inner-html (get-frame :stat))
486 486 (@ data :stat-html))
487 487 (update-objs)
488 488 (set-timer (@ data :timer-interval))
489 489 (call-serv-loc "$ONGLOAD")
490 490 (call-loc *current-location (@ data :loc-args))
491 491 (void)))
492 492
493 493 (defun state-to-base64 ()
494 494 (btoa (encode-u-r-i-component *state-stash)))
495 495
496 496 (defun base64-to-state (data)
497 497 (setf *state-stash (decode-u-r-i-component (atob data))))
498 498
499 499 ;;; Timers
500 500
501 501 (defun set-timer (interval)
502 502 (setf *timer-interval interval)
503 503 (clear-interval *timer-obj)
504 504 (setf *timer-obj
505 505 (set-interval
506 506 (lambda ()
507 507 (call-serv-loc "$COUNTER"))
508 508 interval)))
509 509
510 510 ;;; Special variables
511 511
512 512 (defvar serv-vars (create))
513 513
514 514 (define-serv-var $backimage (path)
515 515 (setf (@ (get-frame :main) style background-image) path))
516 516
517 517 (define-serv-var bcolor (color)
518 518 (setf (@ (get-frame :all) style background-color) (rgb-string color)))
519 519
520 520 (define-serv-var fcolor (color)
521 521 (setf (@ (get-frame :all) style color) (rgb-string color)))
522 522
523 523 (define-serv-var lcolor (color)
524 524 (setf (@ (get-frame :style) inner-text)
525 525 (+ "a { color: " (rgb-string color) ";}")))
526 526
527 527 (define-serv-var fsize (size)
528 528 (setf (@ (get-frame :all) style font-size) size))
529 529
530 530 (define-serv-var $fname (font-name)
531 531 (setf (@ (get-frame :all) style font-family) (+ font-name ",serif")))
@@ -1,153 +1,153 b''
1 1
2 2 (in-package txt2web)
3 3
4 4 (defvar *app-name* "")
5 5
6 6 (defun entry-point-no-args ()
7 7 (entry-point uiop:*command-line-arguments*))
8 8
9 9 (defun entry-point (args)
10 10 (setf *app-name* (uiop:argv0))
11 11 (let ((*package* (find-package :txt2web)))
12 12 (catch :terminate
13 13 (let ((compiler (apply #'make-instance 'compiler (parse-opts args))))
14 14 (write-compiled-file compiler))))
15 15 (values))
16 16
17 17 (defun parse-opts (args)
18 18 (let ((mode :sources)
19 19 (data (list :sources nil :target nil :js nil :css nil :body nil :compile nil :beautify nil)))
20 20 (loop :for arg :in args
21 21 :do (alexandria:switch (arg :test #'string=)
22 22 ("-o" (setf mode :target))
23 23 ("--js" (setf mode :js))
24 24 ("--css" (setf mode :css))
25 25 ("--body" (setf mode :body))
26 26 ("-c" (setf (getf data :compile) t))
27 27 ("--beautify" (setf (getf data :beautify) t))
28 28 (t (push arg (getf data mode)))))
29 29 (unless (< 0 (length (getf data :sources)))
30 30 (report-error "There should be at least one source"))
31 31 (unless (> 1 (length (getf data :target)))
32 32 (report-error "There should be no more than one target"))
33 33 (unless (> 1 (length (getf data :body)))
34 34 (report-error "There should be no more than one body"))
35 35 (unless (getf data :target)
36 36 (setf (getf data :target)
37 37 (let* ((sources (first (getf data :sources)))
38 38 (tokens (uiop:split-string sources :separator "."))
39 39 (target (format nil "~{~A~^.~}.html"
40 40 (butlast tokens))))
41 41 (list target))))
42 42 (list :sources (getf data :sources)
43 43 :target (first (getf data :target))
44 44 :js (getf data :js)
45 45 :css (getf data :css)
46 46 :body (first (getf data :body))
47 47 :compile (getf data :compile)
48 48 :beautify (getf data :beautify))))
49 49
50 50 (defun print-usage ()
51 51 (lformat t :usage *app-name*))
52 52
53 53 (defun parse-file (filename)
54 54 (p:parse 'txt2web-grammar
55 55 (alexandria:read-file-into-string filename)))
56 56
57 57 (defun report-error (fmt &rest args)
58 58 (format t "ERROR: ~A~%" (apply #'format nil fmt args))
59 59 (print-usage)
60 60 (throw :terminate nil))
61 61
62 62 ;;; JS
63 63
64 64 (defun minify-package (package-designator minify prefix)
65 65 (setf (ps:ps-package-prefix package-designator) prefix)
66 66 (if minify
67 67 (ps:obfuscate-package package-designator)
68 68 (ps:unobfuscate-package package-designator)))
69 69
70 70 (defmethod js-sources ((compiler compiler))
71 71 (let ((ps:*ps-print-pretty* (beautify compiler)))
72 72 (cond ((beautify compiler)
73 73 (minify-package "TXT2WEB.MAIN" nil "qsp_")
74 74 (minify-package "TXT2WEB.API" nil "qsp_api_")
75 75 (minify-package "TXT2WEB.LIB" nil "qsp_lib_"))
76 76 (t
77 77 (minify-package "TXT2WEB.MAIN" t "_")
78 78 (minify-package "TXT2WEB.API" t "a_")
79 79 (minify-package "TXT2WEB.LIB" t "l_")))
80 80 (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler))))))
81 81
82 82 ;;; CSS
83 83
84 84 (defmethod css-sources ((compiler compiler))
85 85 (format nil "~{~A~^~%~%~}" (css compiler)))
86 86
87 87 ;;; HTML
88 88
89 89 (defmethod html-sources ((compiler compiler))
90 90 (let ((flute:*escape-html* nil)
91 91 (body-template (body compiler))
92 92 (js (js-sources compiler))
93 93 (css (css-sources compiler)))
94 94 (with-output-to-string (out)
95 95 (write
96 96 (flute:h
97 97 (html
98 98 (head
99 (title "SugarQSP"))
99 (title "txt2web"))
100 100 (body
101 101 body-template
102 102 (style css)
103 103 (script js))))
104 104 :stream out
105 105 :pretty nil))))
106 106
107 107 (defun filename-game (filename)
108 108 (let ((filename (alexandria:lastcar (uiop:split-string filename :separator "/"))))
109 109 (format nil "~{~A~^.~}" (butlast (uiop:split-string filename :separator ".")))))
110 110
111 111 (defmethod initialize-instance ((compiler compiler) &key sources ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys)
112 112 (call-next-method)
113 113 (with-slots (body css js)
114 114 compiler
115 115 ;; Compile the game's JS
116 116 (dolist (source sources)
117 117 (let ((ps (parse-file source))
118 118 (game-name (filename-game source)))
119 119 (destructuring-bind (kw &rest locations)
120 120 ps
121 121 (unless (eq kw 'lib:game)
122 122 (report-error "Internal error!"))
123 123 (push
124 124 `(lib:game (,game-name) ,@locations)
125 125 js))))
126 126 ;; Does the user need us to do anything else
127 127 (unless compile
128 128 ;; Read in body
129 129 (when body-file
130 130 (setf body
131 131 (alexandria:read-file-into-string body-file)))
132 132 ;; Include js files
133 133 (dolist (js-file js-files)
134 134 (push (format nil "////// Included file ~A~%~A" js-file
135 135 (alexandria:read-file-into-string js-file))
136 136 js))
137 137 ;; Include css files
138 138 (when css-files
139 139 ;; User option overrides the default css
140 140 (setf css nil)
141 141 (dolist (css-file css-files)
142 142 (push (format nil "////// Included file ~A~%~A" css-file
143 143 (alexandria:read-file-into-string css-file))
144 144 css))))))
145 145
146 146 (defmethod write-compiled-file ((compiler compiler))
147 147 (alexandria:write-string-into-file
148 148 (if (compile-only compiler)
149 149 ;; Just the JS
150 150 (js-sources compiler)
151 151 ;; All of it
152 152 (html-sources compiler))
153 153 (target compiler) :if-exists :supersede))
1 NO CONTENT: file was removed
1 NO CONTENT: file was removed
1 NO CONTENT: file was removed
1 NO CONTENT: file was removed
General Comments 0
You need to be logged in to leave comments. Login now