;;; Mudsync --- Live hackable MUD ;;; Copyright © 2017 Christopher Allan Webber ;;; ;;; 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 . ;;; 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 (sxml simple) #: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" (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-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." (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 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 (hashq-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))) ;;; SXML scrubl writer (define (scrubl-sxml-write scrubl obj) (call-with-output-string (lambda (p) (sxml->xml (scrubl-write-obj scrubl obj) p)))) (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... (cons sym (map (lambda (arg) (scrubl-write-obj scrubl arg)) args)))) (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))