switch room "tell" to not use string-apend
[mudsync.git] / mudsync / scrubl.scm
1 ;;; Mudsync --- Live hackable MUD
2 ;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
3 ;;;
4 ;;; This file is part of Mudsync.
5 ;;;
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.
10 ;;;
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.
15 ;;;
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/>.
18
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.
22 ;;;
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.
27
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   #:export (make-scrubl
37             scrubl? scrubl-extend-fields
38             scrubl-write
39             scrubl-sxml scrubl-sxml-simple-field))
40
41 (define (order-symlist-args symlist-args)
42   "Orders the args in a symlist so keyword pairs are at the end"
43   (define new-args
44     (let lp ((remaining symlist-args)
45              (args '())
46              (kwargs '()))
47       (match remaining
48         ('() (cons (reverse args)
49                    kwargs))
50         (((? keyword? kw) val rest ...)
51          (lp rest
52              args
53              (cons* kw val kwargs)))
54         ((arg rest ...)
55          (lp rest
56              (cons arg args)
57              kwargs)))))
58   new-args)
59
60 (define-record-type <scrubl>
61   (%make-scrubl field-writers meta-write)
62   scrubl?
63   (field-writers scrubl-field-writers)
64   (meta-write scrubl-meta-write))
65
66 (define (make-scrubl field-writers meta-write)
67   (%make-scrubl (alist->hashq-table field-writers)
68                 meta-write))
69
70 (define (scrubl-extend-fields scrubl new-field-writers)
71   "Returns a new <scrubl> instance extending SCRUBL's field-writers with
72 NEW-FIELD-WRITERS."
73   (define new-writers
74     (let ((new-table (make-hash-table)))
75       ;; Add old fields from hashq
76       (hash-for-each
77        (lambda (key val)
78          (hashq-set! new-table key val))
79        (scrubl-field-writers scrubl))
80       ;; Now add the new fields
81       (for-each
82        (match-lambda
83          ((key . val)
84           (hashq-set! new-table key val)))
85        new-field-writers)
86       new-table))
87
88   (%make-scrubl new-writers (scrubl-meta-write scrubl)))
89
90 (define (scrubl-write scrubl obj . args)
91   "Write out OBJ via SCRUBL
92
93 Pass in optional extra ARGS to the main META-WRITE" 
94  (apply (scrubl-meta-write scrubl) scrubl obj args))
95
96 (define* (scrubl-write-obj scrubl obj)
97   (match 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
104                 #:field sym
105                 #:args args))
106        (apply field-writer scrubl ordered-args)))
107     ((items ...)
108      (map (lambda (item)
109             (scrubl-write-obj scrubl item))
110           items))
111     (any-obj any-obj)))
112
113
114 \f
115 ;;; SXML scrubl writer
116
117 (define (scrubl-sxml-write scrubl obj)
118   (call-with-output-string
119     (lambda (p)
120       (sxml->xml
121        (scrubl-write-obj scrubl obj)
122        p))))
123
124
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))
131                    args))))
132
133 (define (scrubl-pre scrubl args)
134   `(span (@ (class "pre-ish"))
135          ,args))
136
137 (define scrubl-sxml
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)))
148                scrubl-sxml-write))