New backronym for SCRUBL, export stuff, make faster

Now uses hashes under the hood, but still an immutable interface

diff --git a/mudsync/scrubl.scm b/mudsync/scrubl.scm
index cf585b949f78d146b1de87a45025caad0ec120de..1d82338e6d9999672fb1fa078438ce424ea009e2 100644 (file)
--- 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/>.
 
 ;;; 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)
 
 (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 (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"
 
 (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)
 
              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))
 
   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."
 (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
 
 (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))
   (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
             (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"
 \f
 ;;; SXML scrubl writer
 
 \f
 ;;; 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))))
 
 
   (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...
   (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))))
 
                      (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))