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

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

;;;;;;
;;; XML to tree projection

(def class* projection/xml-to-tree (projection)
  ())

;;;;;;
;;; XML to tree projection constructors

(def (function e) make-projection/xml-to-tree ()
  (make-instance 'projection/xml-to-tree))

;;;;;;
;;; XML to tree printer

(def method project-document (xml-document (projection projection/xml-to-tree))
  (bind ((mapping (make-mapping)))
    (labels ((recurse (input input-reference output-reference)
               (bind ((typed-input-reference `(the ,(form-type input) ,input-reference)))
                 (prog1-bind output
                     (etypecase input
                       (null
                        nil)
                       (document
                        (if (eq input xml-document)
                            (recurse (content-of input) `(content-of ,typed-input-reference) `(content-of (the document ,output-reference)))
                            input))
                       (xml/text
                        (make-tree/node (list (prog1-bind output (text-of input)
                                                (insert-string-mapping mapping `(text-of ,typed-input-reference) `(elt (the list (children-of (the tree/node ,output-reference))) 0) (length output))))))
                       (xml/attribute
                        (make-tree/node (list (prog1-bind output (name-of input)
                                                (insert-string-mapping mapping `(name-of ,typed-input-reference) `(elt (the list (children-of (the tree/node ,output-reference))) 0) (length output)))
                                              (prog1-bind output (value-of input)
                                                (insert-string-mapping mapping `(value-of ,typed-input-reference) `(elt (the list (children-of (the tree/node ,output-reference))) 1) (length output))))))
                       (xml/element
                        (make-tree/node (bind ((index 0)
                                               (attributes (attributes-of input))
                                               (children (children-of input)))
                                          (append (progn
                                                    (insert-string-mapping mapping `(name-of ,typed-input-reference) `(elt (the list (children-of (the tree/node ,output-reference))) ,index) (length (name-of input)))
                                                    (incf index)
                                                    (list (name-of input)))
                                                  (when attributes
                                                    (insert-mapping mapping `(the list (attributes-of ,typed-input-reference)) `(the tree/node (elt (the list (children-of (the tree/node ,output-reference))) ,index)))
                                                    (prog1 (list (make-tree/node (iter (for attribute :in attributes)
                                                                                       (for attribute-index :from 0)
                                                                                       (collect (recurse attribute
                                                                                                         `(elt (the list (attributes-of ,typed-input-reference)) ,attribute-index)
                                                                                                         `(elt (the list (children-of (the tree/node (elt (the list (children-of (the tree/node ,output-reference))) ,index)))) ,attribute-index))))))
                                                      (incf index)))
                                                  (when children
                                                    (insert-mapping mapping `(the list (children-of ,typed-input-reference)) `(the tree/node (elt (the list (children-of (the tree/node ,output-reference))) ,index)))
                                                    (prog1 (list (make-tree/node (iter (for child :in children)
                                                                                       (for child-index :from 0)
                                                                                       (collect (recurse child
                                                                                                         `(elt (the list (children-of ,typed-input-reference)) ,child-index)
                                                                                                         `(elt (the list (children-of (the tree/node (elt (the list (children-of (the tree/node ,output-reference))) ,index)))) ,child-index)))))
                                                                 (progn
                                                                   (incf index)
                                                                   (insert-string-mapping mapping `(name-of ,typed-input-reference) `(elt (the list (children-of (the tree/node ,output-reference))) ,index) (length (name-of input)))
                                                                   (name-of input)))
                                                      (incf index))))))))
                   (bind ((typed-output-reference `(the ,(form-type output) ,output-reference)))
                     (insert-mapping mapping typed-input-reference typed-output-reference))))))
      (bind ((tree-document (recurse xml-document 'document 'document)))
        (make-document tree-document
                       :selection (map-reference-forward mapping (selection-of xml-document))
                       :source (make-source xml-document projection mapping))))))

;;;;;;
;;; XML to tree reader

(def method read-operation (xml-document (projection projection/xml-to-tree) xxx)
  (bind ((operation (operation-of xxx)))
    (cond ((typep operation 'operation/replace-selection)
           (make-operation/replace-selection (map-reference-backward (mapping-of (source-of (document-of xxx))) (selection-of operation))))
          ((typep operation 'operation/sequence/replace-element-range)
           (make-operation/sequence/replace-element-range (map-reference-backward (mapping-of (source-of (document-of xxx))) (target-of operation)) (replacement-of operation)))
          (t operation))))