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

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

;;;;;;
;;; JSON to tree projection

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

;;;;;;
;;; JSON to tree projection constructors

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

;;;;;;
;;; JSON to tree printer

(def method project-document (json-document (projection projection/json-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 json-document)
                            (recurse (content-of input) `(content-of ,typed-input-reference) `(content-of (the document ,output-reference)))
                            input))
                       (json/null
                        (prog1-bind output "null"
                          (insert-character-mapping mapping `(name-of ,typed-input-reference) output-reference (length output))))
                       (json/boolean
                        (prog1-bind output (if (value-p input) "true" "false")
                          (insert-character-mapping mapping `(name-of ,typed-input-reference) output-reference (length output))))
                       (json/number
                        (prog1-bind output (write-to-string (value-of input))
                          (insert-character-mapping mapping `(write-to-string (the number (value-of ,typed-input-reference))) output-reference (length output))))
                       (json/string
                        (prog1-bind output (string+ "\"" (text-of input) "\"")
                          (insert-character-mapping mapping `(text-of ,typed-input-reference) output-reference (- (length output) 2) :output-offset 1)))
                       (json/array
                        (make-tree/node (iter (for element :in-sequence (elements-of input))
                                              (for index :from 0)
                                              (collect (recurse element
                                                                `(elt (the list (elements-of ,typed-input-reference)) ,index)
                                                                `(elt (the list (children-of (the tree/node ,output-reference))) ,index))))))
                       (json/object
                        (make-tree/node (iter (for (key value) :in-hashtable (key-value-map-of input))
                                              (for index :from 0)
                                              (collect (bind ((entry-node-reference `(the tree/node (elt (the list (children-of (the tree/node ,output-reference))) ,index)))
                                                              (value-node-reference `(the list (children-of ,entry-node-reference))))
                                                         (insert-mapping mapping `(the t (gethash-entry ,key ,typed-input-reference)) entry-node-reference)
                                                         (insert-character-mapping mapping
                                                                                   `(entry-key (gethash-entry ,key ,typed-input-reference))
                                                                                   `(elt ,value-node-reference 0)
                                                                                   (length key) :output-offset 1)
                                                         (make-tree/node (list (string+ "\"" key "\"")
                                                                               (recurse value
                                                                                        `(gethash ,key (key-value-map-of ,typed-input-reference))
                                                                                        `(elt ,value-node-reference 1))))))))))
                   (bind ((typed-output-reference `(the ,(form-type output) ,output-reference)))
                     (insert-mapping mapping typed-input-reference typed-output-reference))))))
      (bind ((tree-document (recurse json-document 'document 'document)))
        (make-document tree-document
                       :selection (map-reference-forward mapping (selection-of json-document))
                       :source (make-source json-document projection mapping))))))

;;;;;;
;;; JSON to tree reader

(def method read-operation (json-document (projection projection/json-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)
           (bind ((json-reference (map-reference-backward (mapping-of (source-of (document-of xxx))) (target-of operation))))
             (pattern-case json-reference
               ((sequence-position (the string (write-to-string (the number ?a))) ?b)
                (make-operation/number/replace-range json-reference (replacement-of operation)))
               (?a
                (make-operation/sequence/replace-element-range json-reference (replacement-of operation))))))
          ((typep operation 'operation/object/replace-place-value)
           (bind ((tree-replacement (replacement-of operation))
                  (json-replacement (if (digit-char-p (first-elt tree-replacement))
                                        (make-json/number (- (char-code (first-elt tree-replacement)) 48))
                                        (ecase (first-elt tree-replacement)
                                          (#\n (make-json/null))
                                          (#\f (make-json/boolean #f))
                                          (#\t (make-json/boolean #t))
                                          (#\s #+nil #\" (make-json/string ""))
                                          (#\a #+nil #\[ (make-json/array nil))
                                          (#\o #+nil #\{ (make-json/object (make-hash-table)))))))
             (when json-replacement
               (make-operation/object/replace-place-value (map-reference-backward (mapping-of (source-of (document-of xxx))) (target-of operation)) json-replacement))))
          (t operation))))