;;; 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)))



;;; 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))