X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=mudsync%2Fscrubl.scm;h=2fdd9227b71013309d264b532ee906524df46e19;hp=cf585b949f78d146b1de87a45025caad0ec120de;hb=bbf45570e7dfe20e132cc8e4601ccbf2de667ff3;hpb=c4a8d7380659f15dbeea2928773f1ec36bd35776

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 <http://www.gnu.org/licenses/>.
 
-;;; 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 <scrubl>
-  (make-scrubl field-writers meta-write)
+(define-record-type <scrubl>
+  (%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 <scrubl> 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))