From c81524f4606c337e5282b22850dc4b1b93868eb7 Mon Sep 17 00:00:00 2001
From: Christopher Allan Webber <cwebber@dustycloud.org>
Date: Mon, 23 Jan 2017 12:20:42 -0600
Subject: [PATCH] New backronym for SCRUBL, export stuff, make faster

Now uses hashes under the hood, but still an immutable interface
---
 mudsync/scrubl.scm | 60 +++++++++++++++++++++++++++++++++-------------
 1 file changed, 43 insertions(+), 17 deletions(-)

diff --git a/mudsync/scrubl.scm b/mudsync/scrubl.scm
index cf585b9..1d82338 100644
--- a/mudsync/scrubl.scm
+++ b/mudsync/scrubl.scm
@@ -16,15 +16,23 @@
 ;;; 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 Representing the 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)
+  #:export (make-scrubl
+            scrubl? scrubl-extend-fields
+            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 +53,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 +93,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 +110,13 @@ 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))))
 
 
-(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 +124,9 @@ 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-sxml
+  (make-scrubl `((p . ,(scrubl-sxml-simple-field 'p))
+                 (bold . ,(scrubl-sxml-simple-field 'b))
+                 (it . ,(scrubl-sxml-simple-field 'it))
+                 (emph . ,(scrubl-sxml-simple-field 'it)))
+               scrubl-sxml-write))
-- 
2.31.1