Commit 15f38376 authored by Dave Cooper's avatar Dave Cooper
Browse files

added xml2gdl/gdl2xml translators. Currently depend on Franz :pxml module.

parent 03005a25
(asdf:defsystem #:gdl-translators
:description
"Auto-generated asdf defsys from Genworks GDL cl-lite."
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license
"AGPL unless otherwise indicated"
:serial
t
:version
"2012031500"
:depends-on
nil
:components
((:file "xml/source/package")
(:file "xml/source/genworks")
(:file "xml/source/definition-tree")
(:file "xml/source/gdl2xml")
(:file "xml/source/xml2gdl")))
\ No newline at end of file
10
dir
803
svn://svn.genworks.com/rainforest/branches/1581/gdl/translators/xml
svn://svn.genworks.com/rainforest
2010-09-29T18:40:16.637689Z
26
dcooper8
a8dd3158-16c2-4b09-9e8e-1a0d18a46f2f
source
dir
(asdf:defsystem #:gdl-xml
:description
"Auto-generated asdf defsys from Genworks GDL cl-lite."
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license
"AGPL unless otherwise indicated"
:serial
t
:version
"2012031500"
:depends-on
nil
:components
((:file "source/package")
(:file "source/genworks")
(:file "source/definition-tree")
(:file "source/gdl2xml")
(:file "source/xml2gdl")))
\ No newline at end of file
10
dir
803
svn://svn.genworks.com/rainforest/branches/1581/gdl/translators/xml/source
svn://svn.genworks.com/rainforest
2010-09-29T18:40:16.637689Z
26
dcooper8
a8dd3158-16c2-4b09-9e8e-1a0d18a46f2f
gdl2xml.lisp
file
2011-10-20T20:00:41.000000Z
bfa08fcac2190ca4ae85bf65aaee0749
2010-09-29T18:40:16.637689Z
26
dcooper8
has-props
5321
xml2gdl.lisp
file
2011-10-20T20:00:41.000000Z
66ee0632b8aad898786d3a80f0622f72
2010-09-29T18:40:16.637689Z
26
dcooper8
has-props
12087
package.lisp
file
2011-10-20T20:00:41.000000Z
79001e6e7d3d5a407a6b508845d92e66
2010-09-29T18:40:16.637689Z
26
dcooper8
has-props
956
file-ordering.isc
file
2011-10-20T20:00:41.000000Z
a26072764dd65b1852c234048328fa1a
2010-09-29T18:40:16.637689Z
26
dcooper8
has-props
870
definition-tree.lisp
file
2011-10-20T20:00:41.000000Z
17aa0a3c456c3e85882f0b0520e61ca3
2010-09-29T18:40:16.637689Z
26
dcooper8
has-props
5152
;;
;; Copyright 2002, 2009 Genworks International and Genworks BV
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file 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
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdlxml)
(define-object definition-tree ()
:documentation (:description "Given a symbol naming a GDL object which is already defined in the system,
this object generates a tree of all the message categories and all the messages within each category.
This tree can then be used as the basis for generating a representation of the object definition in
an external format, such as GDLXML.")
:input-slots ((name-symbol 'gdl::vanilla-mixin*))
:computed-slots ((strings-for-display (format nil "Definition for ~s" (the name-symbol)))
(object-package (symbol-package (the name-symbol)))
(object-documentation (the canonical-instance documentation))
(class (find-class (the name-symbol)))
(canonical-instance (make-object (the name-symbol)))
;;
;; FLAG -- message-data should be defined on the meta-class (gdl-class).
;;
(message-data (the canonical-instance (message-list :category :all
:message-type :local
:return-category? t
:sort-order :by-category)))
;;
;; FLAG -- mixin-data should be defined on the meta-class (gdl-class).
;;
(mixin-data (the canonical-instance (mixins :local? t)))
(message-section-ht (let ((ht (make-hash-table)))
(mapc #'(lambda(message section) (push message (gethash section ht)))
(plist-keys (the message-data)) (plist-values (the message-data))) ht))
)
:trickle-down-slots (canonical-instance name-symbol)
:objects ((sections :type 'message-section
:sequence (:size (hash-table-count (the message-section-ht)))
:plist (list-hash (the message-section-ht))
:name (nth (the-child index) (plist-keys (the-child plist)))
:keys (nth (the-child index) (plist-values (the-child plist))))))
(define-object message-section ()
:input-slots (name keys)
:computed-slots ((strings-for-display (format nil "~a" (the name)))
(section-key-and-modifiers
(ecase (the name)
(:required-input-slots (list :input-slots))
(:optional-input-slots (list :input-slots))
(:settable-optional-input-slots (list :input-slots :settable))
(:defaulted-input-slots (list :input-slots :defaulting))
(:settable-defaulted-input-slots (list :input-slots :settable :defaulting))
(:computed-slots (list :computed-slots))
(:settable-computed-slots (list :computed-slots :settable))
(:uncached-computed-slots (list :computed-slots :uncached))
(:objects (list :objects))
(:quantified-objects (list :objects))
(:hidden-objects (list :hidden-objects))
(:quantified-hidden-objects (list :hidden-objects))
(:functions (list :functions)))))
:objects ((messages :type 'message
:category (the name)
:sequence (:size (length (the keys)))
:section-key (first (the section-key-and-modifiers))
:modifiers (rest (the section-key-and-modifiers))
:key (nth (the-child index) (the keys)))))
(define-object message ()
:input-slots (section-key category key modifiers)
:computed-slots ((strings-for-display (format nil "~a" (the key)))
(source-list (let ((source-list (the canonical-instance (slot-source (the key)))))
(when (eql (first source-list) (the name-symbol)) (second source-list))))
(source-code-body (case (the category)
(:functions (second (the source-list)))
(otherwise (the source-list))))
(source-code-argument-list (case (the category)
(:functions (first (the source-list)))
(otherwise nil)))
(remark-string (getf (the canonical-instance (slot-documentation (the key)))
(the name-symbol)))))
(eval-when (compile load eval) (export 'definition-tree))
(in-package :gdl-user)
(define-object table-def-tree (gdlxml:gdl2xml)
:computed-slots
((name-symbol 'gdl-user::table)))
(define-object table-platform-def-tree (gdlxml:gdl2xml)
:computed-slots
((name-symbol 'gdl-user::table-platform)))
(define-object table-leg-def-tree (gdlxml:gdl2xml)
:computed-slots
((name-symbol 'gdl-user::table-leg)))
;;
;; Copyright 2002, 2009 Genworks International and Genworks BV
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file 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
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
("package")
;;
;; Copyright 2002, 2009 Genworks International and Genworks BV
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file 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
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdlxml)
(define-object gdl2xml (definition-tree)
:input-slots (name-symbol
(output-file (format nil "/tmp/~a.xml" (string (the name-symbol)))))
:computed-slots
(
(xml-string (with-output-to-string(ss)
(with-format (xml ss)
(write-the gdlxml))))
(slot-plists (let (result)
(dolist (section (list-elements (the sections)) (nreverse result))
(dolist (message (list-elements (the-object section messages)))
(let ((section-key (the-object message section-key))
(keyword (the-object message key))
(source-code-body (the-object message source-code-body))
(source-code-argument-list (the-object message source-code-argument-list))
(remark-string (the-object message remark-string))
(modifiers (the-object message modifiers)))
(let ((object? (member section-key (list :objects :hidden-objects)))
(*package* (the object-package)))
(push (append
(list :section-key (format nil "~a" section-key)
:keyword (format nil "~a" keyword)
:default (unless object?
(when source-code-body (format nil "~s" source-code-body)))
:argument-list (when source-code-argument-list
(format nil "~s" source-code-argument-list))
:remark-string (when remark-string (format nil "~a" remark-string))
:type (when object? (format nil "~s" (getf source-code-body :type)))
:sequence (when (and object? (getf source-code-body :sequence))
(format nil "~s" (getf source-code-body :sequence)))
:pass-down (when (and object? (getf source-code-body :pass-down))
(format nil "~s" (getf source-code-body :pass-down)))
:inputs (when object? (remove-plist-keys source-code-body
(list :type :sequence :pass-down))))
(mapcan #'(lambda(modifier)
(list modifier (format nil "~a" modifier))) modifiers)) result)))))))
(mixin-lists (let ((*package* (the object-package)))
(mapcar #'(lambda(mixin)
`(:mixin :name ,(format nil "~s" mixin)))
(the mixin-data))))
(lxml `((:gdlxml :package ,(package-name (the object-package)))
((:define-object :name ,(string (the name-symbol)))
(:documentation ,@(mapcan #'(lambda(key value)
(list key `(escape-string ,value)))
(plist-keys (the object-documentation))
(plist-values (the object-documentation))))
(:mixins ,@(the mixin-lists))
(:slots
,@(mapcar #'(lambda(slot-plist)
(if (getf slot-plist :type)
`((:slot ,@(mapcan #'(lambda(key)
(let ((value (getf slot-plist key)))
`(,key ,(when value `(escape-string ,value)))))
(list :section-key :keyword :remark-string :type :sequence :pass-down)))
(:inputs ,@(mapcar #'(lambda(key value)
`(:input :keyword (escape-string ,(string key))
:default (escape-string ,(format nil "~s" value))))
(plist-keys (getf slot-plist :inputs))
(plist-values (getf slot-plist :inputs)))))
`(:slot
,@(mapcan #'(lambda(key)
(let ((value (getf slot-plist key)))
`(,key ,(when value `(escape-string ,value)))))
(list :section-key :keyword :default :argument-list :remark-string
:settable :defaulting)))))
(the slot-plists)))))))
:functions
((write-xml-file!
(&key (output-file (the output-file)))
(with-open-file (out output-file :direction :output
:if-exists :supersede :if-does-not-exist :create)
(write-string (the xml-string) out)
(values)))))
(define-format xml (base-format))
(define-lens (xml definition-tree)()
:output-functions
((gdlxml
()
(eval
`(cl-who:with-html-output (*stream* nil :indent t)
,(the lxml))))))
(defun gdl2xml (name-symbol &key (output-file (format nil "/tmp/~a.xml" (string name-symbol))))