;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Copyright (c) 2009 by the authors.
;;;
;;; See LICENCE for details.

(in-package :hu.dwim.projectional-editor)

;;;;;;;;
;;;; XML domain provides:
;;;;  - element, attribute, text

;;;;;;
;;; XML document classes

(def class* xml/base ()
  ())

(def class* xml/element (xml/base)
  ((name :type string)
   (attributes :type sequence)
   (children :type sequence)))

(def class* xml/attribute (xml/base)
  ((name :type string)
   (value :type string)))

(def class* xml/text (xml/base)
  ((text :type string)))

;;;;;;
;;; XML document constructors

(def (function e) make-xml/element (name attributes children)
  (make-instance 'xml/element :name name :attributes attributes :children children))

(def (function e) make-xml/attribute (name value)
  (make-instance 'xml/attribute :name name :value value))

(def (function e) make-xml/text (text)
  (make-instance 'xml/text :text text))

;;;;;;
;;; XML provider

(def (function e) xml-color-provider (iomap reference)
  (map-backward iomap reference
                (lambda (iomap reference)
                  (declare (ignore iomap))
                  (pattern-case reference
                    ((the character (elt (the string (?or (opening-delimiter ?a)
                                                          (closing-delimiter ?a))) ?b))
                     (return-from xml-color-provider
                       (sdl:color :r 196 :g 196 :b 196)))
                    ((the character (elt (the string (name-of (the xml/attribute ?a))) ?b))
                     (return-from xml-color-provider
                       (sdl:color :r 196 :g 0 :b 0)))
                    ((the character (elt (the string (value-of (the xml/attribute ?a))) ?b))
                     (return-from xml-color-provider
                       (sdl:color :r 0 :g 196 :b 0)))
                    ((the character (elt (the string ((?or start-tag-of end-tag-of) (the xml/element ?a))) ?b))
                     (return-from xml-color-provider
                       (sdl:color :r 0 :g 0 :b 196)))))))

(def (function e) xml-delimiter-provider (xml-iomap xml-reference)
  (pattern-case xml-reference
    ((?or (opening-delimiter ?node)
          (closing-delimiter ?node))
     (bind ((delimiter (first xml-reference)))
       (map-backward xml-iomap (second xml-reference)
                     (lambda (iomap reference)
                       (declare (ignore iomap))
                       ;; TODO: this is so complicated, it shouldn't be
                       (pattern-case reference
                         ;; < or </ before element name, /> or > after element name
                         #+nil
                         ((the string ((?or start-tag-of end-tag-of) (the xml/element ?a)))
                          (return-from xml-delimiter-provider
                            (bind ((element (reference/find-value (make-document (input-of xml-iomap)) ?a))
                                   (index (pattern-case (second xml-reference)
                                            ((the string (elt (the list (children-of (the tree/node ?a))) ?b))
                                             ?b))))
                              (ecase delimiter
                                (opening-delimiter (if (zerop index) "<" "</"))
                                (closing-delimiter
                                 (if (zerop index)
                                     (cond ((and (not (attributes-of element))
                                                 (not (children-of element)))
                                            "/>")
                                           ((not (attributes-of element))
                                            ">"))
                                     ">"))))))
                         ;; /> or > after the list of attributes
                         #+nil
                         ((the list (attributes-of (the xml/element ?a)))
                          (return-from xml-delimiter-provider
                            (bind ((element (reference/find-value (make-document (input-of xml-iomap)) ?a)))
                              (when (eq delimiter 'closing-delimiter)
                                (if (children-of element) ">" "/>")))))
                         ;; " around attribute value
                         ((the string (value-of (the xml/attribute ?a)))
                          (return-from xml-delimiter-provider
                            "\"")))))))))

(def (function e) xml-separator-provider (iomap previous-child-reference next-child-reference)
  (declare (ignore previous-child-reference))
  (map-backward iomap next-child-reference
                (lambda (iomap reference)
                  (declare (ignore iomap))
                  (pattern-case reference
                    ;; = between attribute name and value
                    ((the string (value-of (the xml/attribute ?a)))
                     (return-from xml-separator-provider "="))
                    ;; space between two attributes
                    ((the xml/attribute ?a)
                     (return-from xml-separator-provider " "))
                    ;; space after the element name and before the list of attributes
                    ((the list (attributes-of ?a))
                     (return-from xml-separator-provider " "))))))

(def (function e) xml-indentation-provider (iomap previous-child-reference next-child-reference)
  (declare (ignore previous-child-reference))
  (map-backward iomap next-child-reference
                (lambda (iomap reference)
                  (declare (ignore iomap))
                  (pattern-case reference
                    ;; new line before element
                    ((the xml/element ?a)
                     (return-from xml-indentation-provider 2))
                    ((the string (end-tag-of (the xml/element ?a)))
                     (return-from xml-indentation-provider 0))))))