X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=mudsync%2Fscrubl.scm;h=2fdd9227b71013309d264b532ee906524df46e19;hb=f3e31bf75eb6da69f50a2824050c240ae2a9cc9f;hp=cf585b949f78d146b1de87a45025caad0ec120de;hpb=c4a8d7380659f15dbeea2928773f1ec36bd35776;p=mudsync.git
diff --git a/mudsync/scrubl.scm b/mudsync/scrubl.scm
index cf585b9..2fdd922 100644
--- a/mudsync/scrubl.scm
+++ b/mudsync/scrubl.scm
@@ -16,15 +16,27 @@
;;; You should have received a copy of the GNU General Public License
;;; along with Mudsync. If not, see .
-;;; SCRUBL: S-exps Can Really Undermine Basic Language
-;;; a micro-"skribe-like" system
+;;; SCRUBL: S-exps Craftily/Crappily Rendering Underlying Basic Language
+;;; a micro-"skribe-like" system (kinda ugly tho)
+;;; Turns quasiquoted structures into something rendered.
+;;;
+;;; This is an immutable interface but it does use mutation under the
+;;; hood for expediency.
+;;; To make a new scrubl that extends an existing scrubl, use the exported
+;;; scrubl-extend-fields.
(define-module (mudsync scrubl)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
- #:use-module (srfi srfi-9 gnu)
#:use-module (sxml simple)
- #:use-module (oop goops))
+ #:use-module (oop goops)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 hash-table)
+ #:export (make-scrubl
+ scrubl? scrubl-extend-fields
+ scrubl-write
+ scrubl-sxml scrubl-sxml-simple-field))
(define (order-symlist-args symlist-args)
"Orders the args in a symlist so keyword pairs are at the end"
@@ -45,17 +57,35 @@
kwargs)))))
new-args)
-(define-immutable-record-type
- (make-scrubl field-writers meta-write)
+(define-record-type
+ (%make-scrubl field-writers meta-write)
scrubl?
(field-writers scrubl-field-writers)
(meta-write scrubl-meta-write))
+(define (make-scrubl field-writers meta-write)
+ (%make-scrubl (alist->hashq-table field-writers)
+ meta-write))
+
(define (scrubl-extend-fields scrubl new-field-writers)
"Returns a new instance extending SCRUBL's field-writers with
NEW-FIELD-WRITERS."
- (set-field scrubl (scrubl-field-writers)
- (append new-field-writers (scrubl-field-writers scrubl))))
+ (define new-writers
+ (let ((new-table (make-hash-table)))
+ ;; Add old fields from hashq
+ (hash-for-each
+ (lambda (key val)
+ (hashq-set! new-table key val))
+ (scrubl-field-writers scrubl))
+ ;; Now add the new fields
+ (for-each
+ (match-lambda
+ ((key . val)
+ (hashq-set! new-table key val)))
+ new-field-writers)
+ new-table))
+
+ (%make-scrubl new-writers (scrubl-meta-write scrubl)))
(define (scrubl-write scrubl obj . args)
"Write out OBJ via SCRUBL
@@ -67,7 +97,7 @@ Pass in optional extra ARGS to the main META-WRITE"
(match obj
(((? symbol? sym) args ...)
(let* ((field-writers (scrubl-field-writers scrubl))
- (field-writer (assoc-ref field-writers sym))
+ (field-writer (hashq-ref field-writers sym))
(ordered-args (order-symlist-args args)))
(when (not field-writer)
(throw 'scrubl-unknown-field
@@ -84,13 +114,15 @@ Pass in optional extra ARGS to the main META-WRITE"
;;; SXML scrubl writer
-(define (sxml-write scrubl obj)
+(define (scrubl-sxml-write scrubl obj)
(call-with-output-string
(lambda (p)
- (sxml->xml (scrubl-write-obj scrubl obj) p))))
+ (sxml->xml
+ (scrubl-write-obj scrubl obj)
+ p))))
-(define (sxml-simple-field sym)
+(define (scrubl-sxml-simple-field sym)
(lambda (scrubl args)
;; sxml handles inlining automatically in case we have nested
;; lists of strings, so we don't have to worry about that...
@@ -98,9 +130,19 @@ Pass in optional extra ARGS to the main META-WRITE"
(scrubl-write-obj scrubl arg))
args))))
-(define sxml-scrubl
- (make-scrubl `((p . ,(sxml-simple-field 'p))
- (bold . ,(sxml-simple-field 'b))
- (it . ,(sxml-simple-field 'it))
- (emph . ,(sxml-simple-field 'it)))
- sxml-write))
+(define (scrubl-pre scrubl args)
+ `(span (@ (class "pre-ish"))
+ ,args))
+
+(define scrubl-sxml
+ (make-scrubl `((p . ,(scrubl-sxml-simple-field 'p))
+ (strong . ,(scrubl-sxml-simple-field 'strong))
+ (bold . ,(scrubl-sxml-simple-field 'strong))
+ (b . ,(scrubl-sxml-simple-field 'strong))
+ (em . ,(scrubl-sxml-simple-field 'em))
+ (i . ,(scrubl-sxml-simple-field 'em))
+ (br . ,(scrubl-sxml-simple-field 'br))
+ (pre . ,scrubl-pre) ;; "pre" style whitespace handling.
+ (ul . ,(scrubl-sxml-simple-field 'ul))
+ (li . ,(scrubl-sxml-simple-field 'li)))
+ scrubl-sxml-write))