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)
33 #:use-module (ice-9 vlist)
34 #:use-module (ice-9 vlist)
35 #:use-module (ice-9 hash-table)
37 scrubl? scrubl-extend-fields
39 scrubl-sxml scrubl-sxml-simple-field))
41 (define (order-symlist-args symlist-args)
42 "Orders the args in a symlist so keyword pairs are at the end"
44 (let lp ((remaining symlist-args)
48 ('() (cons (reverse args)
50 (((? keyword? kw) val rest ...)
53 (cons* kw val kwargs)))
60 (define-record-type <scrubl>
61 (%make-scrubl field-writers meta-write)
63 (field-writers scrubl-field-writers)
64 (meta-write scrubl-meta-write))
66 (define (make-scrubl field-writers meta-write)
67 (%make-scrubl (alist->hashq-table field-writers)
70 (define (scrubl-extend-fields scrubl new-field-writers)
71 "Returns a new <scrubl> instance extending SCRUBL's field-writers with
74 (let ((new-table (make-hash-table)))
75 ;; Add old fields from hashq
78 (hashq-set! new-table key val))
79 (scrubl-field-writers scrubl))
80 ;; Now add the new fields
84 (hashq-set! new-table key val)))
88 (%make-scrubl new-writers (scrubl-meta-write scrubl)))
90 (define (scrubl-write scrubl obj . args)
91 "Write out OBJ via SCRUBL
93 Pass in optional extra ARGS to the main META-WRITE"
94 (apply (scrubl-meta-write scrubl) scrubl obj args))
96 (define* (scrubl-write-obj scrubl obj)
98 (((? symbol? sym) args ...)
99 (let* ((field-writers (scrubl-field-writers scrubl))
100 (field-writer (hashq-ref field-writers sym))
101 (ordered-args (order-symlist-args args)))
102 (when (not field-writer)
103 (throw 'scrubl-unknown-field
106 (apply field-writer scrubl ordered-args)))
109 (scrubl-write-obj scrubl item))
115 ;;; SXML scrubl writer
117 (define (scrubl-sxml-write scrubl obj)
118 (call-with-output-string
121 (scrubl-write-obj scrubl obj)
125 (define (scrubl-sxml-simple-field sym)
126 (lambda (scrubl args)
127 ;; sxml handles inlining automatically in case we have nested
128 ;; lists of strings, so we don't have to worry about that...
129 (cons sym (map (lambda (arg)
130 (scrubl-write-obj scrubl arg))
133 (define (scrubl-pre scrubl args)
134 `(span (@ (class "pre-ish"))
138 (make-scrubl `((p . ,(scrubl-sxml-simple-field 'p))
139 (strong . ,(scrubl-sxml-simple-field 'strong))
140 (bold . ,(scrubl-sxml-simple-field 'strong))
141 (b . ,(scrubl-sxml-simple-field 'strong))
142 (em . ,(scrubl-sxml-simple-field 'em))
143 (i . ,(scrubl-sxml-simple-field 'em))
144 (br . ,(scrubl-sxml-simple-field 'br))
145 (pre . ,scrubl-pre) ;; "pre" style whitespace handling.
146 (ul . ,(scrubl-sxml-simple-field 'ul))
147 (li . ,(scrubl-sxml-simple-field 'li)))