1 ;;; Mudsync --- Live hackable MUD
2 ;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
4 ;;; This file is part of Mudsync.
6 ;;; Mudsync is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or
9 ;;; (at your option) any later version.
11 ;;; Mudsync is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with Mudsync. If not, see <http://www.gnu.org/licenses/>.
19 ;;; SCRUBL: S-exps Craftily/Crappily Rendering Underlying Basic Language
20 ;;; a micro-"skribe-like" system (kinda ugly tho)
21 ;;; Turns quasiquoted structures into something rendered.
23 ;;; This is an immutable interface but it does use mutation under the
24 ;;; hood for expediency.
25 ;;; To make a new scrubl that extends an existing scrubl, use the exported
26 ;;; scrubl-extend-fields.
28 (define-module (mudsync scrubl)
29 #:use-module (ice-9 match)
30 #:use-module (srfi srfi-9)
31 #:use-module (sxml simple)
32 #:use-module (oop goops)
34 scrubl? scrubl-extend-fields
35 scrubl-sxml scrubl-sxml-simple-field))
37 (define (order-symlist-args symlist-args)
38 "Orders the args in a symlist so keyword pairs are at the end"
40 (let lp ((remaining symlist-args)
44 ('() (cons (reverse args)
46 (((? keyword? kw) val rest ...)
49 (cons* kw val kwargs)))
56 (define-record-type <scrubl>
57 (%make-scrubl field-writers meta-write)
59 (field-writers scrubl-field-writers)
60 (meta-write scrubl-meta-write))
62 (define (make-scrubl field-writers meta-write)
63 (%make-scrubl (alist->hashq-table field-writers)
66 (define (scrubl-extend-fields scrubl new-field-writers)
67 "Returns a new <scrubl> instance extending SCRUBL's field-writers with
70 (let ((new-table (make-hash-table)))
71 ;; Add old fields from hashq
74 (hashq-set! new-table key val))
75 (scrubl-field-writers scrubl))
76 ;; Now add the new fields
80 (hashq-set! new-table key val)))
84 (%make-scrubl new-writers (scrubl-meta-write scrubl)))
86 (define (scrubl-write scrubl obj . args)
87 "Write out OBJ via SCRUBL
89 Pass in optional extra ARGS to the main META-WRITE"
90 (apply (scrubl-meta-write scrubl) scrubl obj args))
92 (define* (scrubl-write-obj scrubl obj)
94 (((? symbol? sym) args ...)
95 (let* ((field-writers (scrubl-field-writers scrubl))
96 (field-writer (hashq-ref field-writers sym))
97 (ordered-args (order-symlist-args args)))
98 (when (not field-writer)
99 (throw 'scrubl-unknown-field
102 (apply field-writer scrubl ordered-args)))
105 (scrubl-write-obj scrubl item))
111 ;;; SXML scrubl writer
113 (define (scrubl-sxml-write scrubl obj)
114 (call-with-output-string
116 (sxml->xml (scrubl-write-obj scrubl obj) p))))
119 (define (scrubl-sxml-simple-field sym)
120 (lambda (scrubl args)
121 ;; sxml handles inlining automatically in case we have nested
122 ;; lists of strings, so we don't have to worry about that...
123 (cons sym (map (lambda (arg)
124 (scrubl-write-obj scrubl arg))
128 (make-scrubl `((p . ,(scrubl-sxml-simple-field 'p))
129 (strong . ,(scrubl-sxml-simple-field 'strong)) ; usually bold
130 (emph . ,(scrubl-sxml-simple-field 'em))) ; usually italicized