Add new basic scrubl system (not using it yet though)

diff --git a/mudsync/scrubl.scm b/mudsync/scrubl.scm
new file mode 100644 (file)
index 0000000..cf585b9
--- /dev/null
+++ b/mudsync/scrubl.scm
@@ -0,0 +1,106 @@
+;;; Mudsync --- Live hackable MUD
+;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
+;;;
+;;; This file is part of Mudsync.
+;;;
+;;; Mudsync is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Mudsync is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; 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
+
+(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))
+
+(define (order-symlist-args symlist-args)
+  "Orders the args in a symlist so keyword pairs are at the end"
+  (define new-args
+    (let lp ((remaining symlist-args)
+             (args '())
+             (kwargs '()))
+      (match remaining
+        ('() (cons (reverse args)
+                   kwargs))
+        (((? keyword? kw) val rest ...)
+         (lp rest
+             args
+             (cons* kw val kwargs)))
+        ((arg rest ...)
+         (lp rest
+             (cons arg args)
+             kwargs)))))
+  new-args)
+
+(define-immutable-record-type <scrubl>
+  (make-scrubl field-writers meta-write)
+  scrubl?
+  (field-writers scrubl-field-writers)
+  (meta-write scrubl-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 (scrubl-write scrubl obj . args)
+  "Write out OBJ via SCRUBL
+
+Pass in optional extra ARGS to the main META-WRITE" 
+ (apply (scrubl-meta-write scrubl) scrubl obj args))
+
+(define* (scrubl-write-obj scrubl obj)
+  (match obj
+    (((? symbol? sym) args ...)
+     (let* ((field-writers (scrubl-field-writers scrubl))
+            (field-writer (assoc-ref field-writers sym))
+            (ordered-args (order-symlist-args args)))
+       (when (not field-writer)
+         (throw 'scrubl-unknown-field
+                #:field sym
+                #:args args))
+       (apply field-writer scrubl ordered-args)))
+    ((items ...)
+     (map (lambda (item)
+            (scrubl-write-obj scrubl item))
+          items))
+    (any-obj any-obj)))
+
+
+\f
+;;; SXML scrubl writer
+
+(define (sxml-write scrubl obj)
+  (call-with-output-string
+    (lambda (p)
+      (sxml->xml (scrubl-write-obj scrubl obj) p))))
+
+
+(define (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...
+    (cons sym (map (lambda (arg)
+                     (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))