1 ;;; Mudsync --- Live hackable MUD
2 ;;; Copyright © 2017 Christine Lemmer-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)
36 #:use-module (web uri)
38 scrubl? scrubl-extend-fields
40 scrubl-sxml scrubl-sxml-simple-field))
42 (define (order-symlist-args symlist-args)
43 "Orders the args in a symlist so keyword pairs are at the end"
45 (let lp ((remaining symlist-args)
49 ('() (cons (reverse args)
51 (((? keyword? kw) val rest ...)
54 (cons* kw val kwargs)))
61 (define-record-type <scrubl>
62 (%make-scrubl field-writers meta-write)
64 (field-writers scrubl-field-writers)
65 (meta-write scrubl-meta-write))
67 (define (make-scrubl field-writers meta-write)
68 (%make-scrubl (alist->hashq-table field-writers)
71 (define (scrubl-extend-fields scrubl new-field-writers)
72 "Returns a new <scrubl> instance extending SCRUBL's field-writers with
75 (let ((new-table (make-hash-table)))
76 ;; Add old fields from hashq
79 (hashq-set! new-table key val))
80 (scrubl-field-writers scrubl))
81 ;; Now add the new fields
85 (hashq-set! new-table key val)))
89 (%make-scrubl new-writers (scrubl-meta-write scrubl)))
91 (define (scrubl-write scrubl obj . args)
92 "Write out OBJ via SCRUBL
94 Pass in optional extra ARGS to the main META-WRITE"
95 (apply (scrubl-meta-write scrubl) scrubl obj args))
97 (define* (scrubl-write-obj scrubl obj)
99 (((? symbol? sym) args ...)
100 (let* ((field-writers (scrubl-field-writers scrubl))
101 (field-writer (hashq-ref field-writers sym))
102 (ordered-args (order-symlist-args args)))
103 (when (not field-writer)
104 (throw 'scrubl-unknown-field
107 (apply field-writer scrubl ordered-args)))
110 (scrubl-write-obj scrubl item))
116 ;;; SXML scrubl writer
118 (define (scrubl-sxml-write scrubl obj)
119 (call-with-output-string
122 (scrubl-write-obj scrubl obj)
126 (define (scrubl-sxml-simple-field sym)
127 (lambda (scrubl args)
128 ;; sxml handles inlining automatically in case we have nested
129 ;; lists of strings, so we don't have to worry about that...
130 (cons sym (map (lambda (arg)
131 (scrubl-write-obj scrubl arg))
134 (define (scrubl-sxml-pre scrubl args)
135 `(span (@ (class "pre-ish"))
138 ;; @@: For a text-only interface, we could put links at end of rendered
139 ;; text, similar to how orgmode does.
140 (define (scrubl-sxml-anchor scrubl args)
141 (define (maybe-uri->string obj)
146 (((= maybe-uri->string href) body1 body ...)
151 (make-scrubl `((p . ,(scrubl-sxml-simple-field 'p))
152 (strong . ,(scrubl-sxml-simple-field 'strong))
153 (bold . ,(scrubl-sxml-simple-field 'strong))
154 (b . ,(scrubl-sxml-simple-field 'strong))
155 (em . ,(scrubl-sxml-simple-field 'em))
156 (i . ,(scrubl-sxml-simple-field 'em))
157 (br . ,(scrubl-sxml-simple-field 'br))
158 (anchor . ,scrubl-sxml-anchor)
159 (a . ,scrubl-sxml-anchor)
160 (pre . ,scrubl-sxml-pre) ;; "pre" style whitespace handling.
161 (ul . ,(scrubl-sxml-simple-field 'ul))
162 (li . ,(scrubl-sxml-simple-field 'li)))