mudsync/mudsync/scrubl.scm

;;; Mudsync --- Live hackable MUD
;;; Copyright © 2017 Christine Lemmer-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 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)
  #:use-module (web uri)
  #: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 <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."
  (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-sxml-pre scrubl args)
  `(span (@ (class "pre-ish"))
         ,args))

;; @@: For a text-only interface, we could put links at end of rendered
;;  text, similar to how orgmode does.
(define (scrubl-sxml-anchor scrubl args)
  (define (maybe-uri->string obj)
    (if (uri? obj)
        (uri->string obj)
        obj))
  (match args
    (((= maybe-uri->string href) body1 body ...)
     `(a (@ (href ,href))
         ,body1 ,@body))))

(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))
                 (anchor . ,scrubl-sxml-anchor)
                 (a . ,scrubl-sxml-anchor)
                 (pre . ,scrubl-sxml-pre)  ;; "pre" style whitespace handling.
                 (ul . ,(scrubl-sxml-simple-field 'ul))
                 (li . ,(scrubl-sxml-simple-field 'li)))
               scrubl-sxml-write))