;;; -*- mode: Lisp; Syntax: Common-Lisp; -*- ;;; ;;; Copyright (c) 2009 by the authors. ;;; ;;; See LICENCE for details. (in-package :hu.dwim.projectional-editor) ;;;;;; ;;; Walked lisp form to lisp form projection (def class* projection/walked-lisp-form-to-lisp-form (projection) ()) (def (function e) make-projection/walked-lisp-form-to-lisp-form () (make-instance 'projection/walked-lisp-form-to-lisp-form)) ;;;;;; ;;; Walked lisp form to lisp form printer (def method project-document (walked-lisp-form-document (projection projection/walked-lisp-form-to-lisp-form)) (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 (document (if (eq input walked-lisp-form-document) (recurse (content-of input) `(content-of ,typed-input-reference) `(content-of (the document ,output-reference))) input)) (hu.dwim.walker:constant-form (bind ((value (hu.dwim.walker:value-of input))) (if (or (eq value t) (eq value nil) (keywordp value)) value (etypecase value (number (insert-string-mapping mapping `(write-to-string (the number (slot-value ,typed-input-reference 'hu.dwim.walker::value))) `(write-to-string (the number ,output-reference)) (length (write-to-string value))) value) (string (insert-string-mapping mapping `(slot-value ,typed-input-reference 'hu.dwim.walker::value) output-reference (length value)) value) (symbol (insert-string-mapping mapping `(string-downcase (the symbol (slot-value ,typed-input-reference 'hu.dwim.walker::value))) output-reference (length (symbol-name value))) `(quote ,value)) (cons `(quote ,value)))))) (hu.dwim.walker:variable-reference-form (insert-string-mapping mapping `(string-downcase (the symbol (slot-value ,typed-input-reference 'hu.dwim.walker::name))) `(string-downcase (the symbol ,output-reference)) (length (symbol-name (hu.dwim.walker:name-of input)))) (hu.dwim.walker:name-of input)) (hu.dwim.walker:if-form (insert-string-mapping mapping `(string-downcase (the symbol (slot-value ,typed-input-reference 'hu.dwim.walker::form-name))) `(string-downcase (the symbol (elt (the list ,output-reference) 0))) 2) `(if ,(recurse/slot input 'hu.dwim.walker::condition input-reference `(elt (the list ,output-reference) 1)) ,(recurse/slot input 'hu.dwim.walker::then input-reference `(elt (the list ,output-reference) 2)) ,@(awhen (recurse/slot input 'hu.dwim.walker::else input-reference `(elt (the list ,output-reference) 3)) (list it)))) (hu.dwim.walker:the-form (insert-string-mapping mapping `(string-downcase (the symbol (slot-value ,typed-input-reference 'hu.dwim.walker::form-name))) `(string-downcase (the symbol (elt (the list ,output-reference) 0))) 3) `(the ,(hu.dwim.walker::declared-type-of input) ,(recurse/slot input 'hu.dwim.walker::value input-reference `(elt (the list ,output-reference) 2)))) (hu.dwim.walker:application-form (insert-string-mapping mapping `(string-downcase (the symbol (slot-value ,typed-input-reference 'hu.dwim.walker::operator))) `(string-downcase (the symbol (elt (the list ,output-reference) 0))) (length (symbol-name (hu.dwim.walker:operator-of input)))) (cons (hu.dwim.walker:operator-of input) (recurse/slot input 'hu.dwim.walker::arguments input-reference output-reference 1))) (hu.dwim.walker:function-definition-form (bind ((docstring (hu.dwim.walker:docstring-of input))) (insert-string-mapping mapping `(string-downcase (the symbol (slot-value ,typed-input-reference 'hu.dwim.walker::form-name))) `(string-downcase (the symbol (elt (the list ,output-reference) 0))) 5) (insert-string-mapping mapping `(string-downcase (the symbol (slot-value ,typed-input-reference 'hu.dwim.walker::name))) `(string-downcase (the symbol (elt (the list ,output-reference) 1))) (length (symbol-name (hu.dwim.walker:name-of input)))) (insert-mapping mapping `(the symbol (slot-value ,typed-input-reference 'hu.dwim.walker::name)) `(the symbol (elt (the list ,output-reference) 1))) (insert-mapping mapping `(the list (slot-value ,typed-input-reference 'hu.dwim.walker::bindings)) `(the list (elt (the list ,output-reference) 2))) `(defun ,(hu.dwim.walker:name-of input) ,(recurse/ordinary-lambda-list input input-reference `(elt (the list ,output-reference) 2)) ,@(when docstring (insert-string-mapping mapping `(slot-value ,typed-input-reference 'hu.dwim.walker::docstring) `(elt (the list ,output-reference) 3) (length docstring)) (list docstring)) ,@(recurse/slot input 'hu.dwim.walker::body input-reference `(elt (the list ,output-reference) ,(if docstring 4 3)))))) (hu.dwim.walker:lambda-function-form (insert-string-mapping mapping `(string-downcase (the symbol (slot-value ,typed-input-reference 'hu.dwim.walker::form-name))) `(string-downcase (the symbol (elt (the list ,output-reference) 0))) 6) (insert-mapping mapping `(the list (slot-value ,typed-input-reference 'hu.dwim.walker::bindings)) `(the list (elt (the list ,output-reference) 1))) `(lambda ,(recurse/ordinary-lambda-list input input-reference `(elt (the list ,output-reference) 1)) ,@(recurse/slot input 'hu.dwim.walker::body input-reference output-reference 2))) (hu.dwim.walker:function-argument-form (insert-string-mapping mapping `(string-downcase (the symbol (slot-value ,typed-input-reference 'hu.dwim.walker::name))) `(string-downcase (the symbol ,output-reference)) (length (symbol-name (hu.dwim.walker:name-of input)))) (hu.dwim.walker:name-of input))) (bind ((typed-output-reference `(the ,(form-type output) ,output-reference))) (insert-mapping mapping typed-input-reference typed-output-reference))))) (recurse/slot (input slot input-reference output-reference &optional base-index) (bind ((typed-input-reference `(the ,(form-type input) ,input-reference)) (value (slot-value input slot)) (slot-path `(slot-value ,typed-input-reference ',slot))) (if (consp value) (loop for element :in (slot-value input slot) for index :from 0 collect (recurse element `(elt (the ,(form-type value) ,slot-path) ,index) (if base-index `(elt (the list ,output-reference) ,(+ base-index index)) output-reference))) (recurse value slot-path output-reference)))) (recurse/ordinary-lambda-list (input input-reference output-reference) (bind ((typed-input-reference `(the ,(form-type input) ,input-reference)) (arguments (hu.dwim.walker:bindings-of input)) (optional-seen? nil) (rest-seen? nil) (keyword-seen? nil) (allow-other-keys-seen? nil) (auxiliary-seen? nil)) (labels ((ensure-&key () (unless keyword-seen? (assert (not auxiliary-seen?)) (setq keyword-seen? t) (list '&key))) (ensure-&allow-other-keys () (when (and (not allow-other-keys-seen?) (hu.dwim.walker:allow-other-keys? input)) (setf allow-other-keys-seen? t) (nconc (ensure-&key) (list '&allow-other-keys))))) (loop :for index :from 0 :for argument :in arguments :appending (etypecase argument (hu.dwim.walker:required-function-argument-form (assert (not (or optional-seen? rest-seen? keyword-seen? auxiliary-seen?)))) (hu.dwim.walker:optional-function-argument-form (unless optional-seen? (assert (not (or rest-seen? keyword-seen? auxiliary-seen?))) (setq optional-seen? t) (list '&optional))) (hu.dwim.walker:rest-function-argument-form (unless rest-seen? (assert (not (or keyword-seen? auxiliary-seen?))) (setq rest-seen? t) (list '&rest))) (hu.dwim.walker:keyword-function-argument-form (ensure-&key)) (hu.dwim.walker:auxiliary-function-argument-form (unless auxiliary-seen? (setq auxiliary-seen? t) (nconc (ensure-&allow-other-keys) (list '&aux))))) :into result :collect (recurse argument `(elt ,typed-input-reference ,index) `(elt (the list ,output-reference) ,index)) :into result :finally (return (nconc result (ensure-&allow-other-keys)))))))) (bind ((lisp-form (recurse walked-lisp-form-document 'document 'document))) (make-document lisp-form :selection (map-reference-forward mapping (selection-of walked-lisp-form-document)) :source (make-source walked-lisp-form-document projection mapping)))))) ;;;;;; ;;; Walked lisp form to lisp form reader (def method read-operation (walked-lisp-form-document (projection projection/walked-lisp-form-to-lisp-form) 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))) ((typep operation 'operation/number/replace-range) (make-operation/number/replace-range (map-reference-backward (mapping-of (source-of (document-of xxx))) (target-of operation)) (replacement-of operation))) (t operation))))