[Step-toybox-commits] SF.net SVN: step-toybox:[14] trunk/src/apps/tool/gen/gen-flat.lisp

[<cla...@us...>]

Revision: 14
          http://step-toybox.svn.sourceforge.net/step-toybox/?rev=14&view=rev
Author:   clanning
Date:     2008-07-22 14:24:10 +0000 (Tue, 22 Jul 2008)

Log Message:
-----------
Add new file for writing a flattened schema

Added Paths:
-----------
    trunk/src/apps/tool/gen/gen-flat.lisp

Added: trunk/src/apps/tool/gen/gen-flat.lisp
===================================================================
--- trunk/src/apps/tool/gen/gen-flat.lisp	                        (rev 0)
+++ trunk/src/apps/tool/gen/gen-flat.lisp	2008-07-22 14:24:10 UTC (rev 14)
@@ -0,0 +1,357 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: EXP; Base: 10 -*-
+
+#-Genera
+(in-package :EXPRESS-TOOL)
+
+
+(defmethod generate ((view (eql :flat)) (schema schema-def) (file string) &rest options)
+  (apply #'generate view schema (pathname file) options))
+
+(defmethod generate ((view (eql :flat)) (schema schema-def) (file pathname) &rest options)
+  (with-open-file (str file :direction :output :if-exists :supersede)
+    (generate view :top str :schema schema)
+    (terpri str)
+    (generate view schema str)))
+
+(defmethod generate ((view (eql :flat)) (tag (eql :top)) stream
+		     &key combine quiet schema)
+  (princ "-- -*- Mode: EXPRESS -*-" stream) (terpri stream) (terpri stream)
+  (princ "-- Flattened EXPRESS file" stream) (terpri stream)
+  (generate :sys-ver nil stream :prefix "--")
+  (generate :header schema stream :prefix "--"))
+
+;;;
+;;; Generate Flat EXPRESS
+;;;
+
+(defmethod generate ((view (eql :flat)) (schema schema-def) stream &key)
+  (with-slots (constants types entities rules functions procedures) schema
+    (format stream "~&SCHEMA ~A;~%" schema)
+    ;; reference from
+    ;; use from
+    (when constants
+      (format stream "~% CONSTANT")
+      (loop for const in constants
+	do (format stream "~%    ")
+	(generate view const stream))
+      (format stream "~% END_CONSTANT;~%"))
+    (loop for type in types
+      do (terpri stream) (generate view type stream))
+    (loop for ent in entities
+      do (terpri stream) (generate view ent stream))
+    (loop for rule in rules
+      do (terpri stream) (generate view rule stream))
+    (loop for fun in functions
+      do (terpri stream) (generate view fun stream))
+    (loop for proc in procedures
+      do (terpri stream) (generate view proc stream))
+    (format stream "~2&END_SCHEMA; -- ~A~%" schema)))
+
+(defmethod generate ((view (eql :flat)) (obj constant-def) stream &key name-only-p)
+  (with-slots (name base-type value) obj
+    (if name-only-p (princ (string-downcase name) stream)
+      (progn
+	(generate view obj stream :name-only-p t)
+	(princ " : " stream)
+	(generate view base-type stream :name-only-p t)
+	(princ " := " stream)
+	(generate view value stream)
+	(princ #\; stream)))))
+
+(defmethod generate ((view (eql :flat)) (obj type-def) stream &key name-only-p)
+  (with-slots (name underlying where) obj
+    (if name-only-p (princ (string-downcase name) stream)
+      (progn
+	(format stream "TYPE ~A = " obj)
+	(generate view underlying stream :name-only-p t)
+	(princ #\; stream) (terpri stream)
+	(when where
+	  (princ " WHERE" stream)
+	  (loop for whr in where
+	    do (terpri stream) (princ "   " stream)
+	    (generate view whr stream))
+	  (terpri stream))
+	(princ "END_TYPE;" stream) (terpri stream)))))
+
+(defmethod generate ((view (eql :flat)) (obj entity-def) stream &key name-only-p)
+  (with-slots (name abstract supertype-of subtype-of explicit-attr
+		    derive inverse unique where) obj
+    (if name-only-p (princ (string-downcase name) stream)
+      (progn
+	(princ "ENTITY " stream)
+	(generate view obj stream :name-only-p t)
+	(when abstract
+	  (terpri stream) (princ "   ABSTRACT SUPERTYPE" stream))
+	(when supertype-of
+	  (unless abstract (terpri stream) (princ "   SUPERTYPE" stream))
+	  (princ " OF " stream)
+	  (generate view supertype-of stream :name-only-p t))
+	(when subtype-of
+	  (terpri stream) (princ "    SUBTYPE OF (" stream)
+	  (loop for subs on subtype-of
+	    as sub = (first subs)
+	    do (generate view sub stream :name-only-p t)
+	    when (rest subs) do (princ ", " stream))
+	  (princ ")" stream))
+	(princ ";" stream)
+
+	;; Explicit Attributes
+	(loop for attr in (collect-inherited :explicit obj)
+	  do (terpri stream) (princ "   " stream)
+	  (generate view attr stream :qualify-p (not (eql obj (entity attr)))))
+
+	;; Derived Attributes
+	(let ((derives (collect-inherited :derive obj)))
+	  (when derives
+	    (terpri stream) (princ " DERIVE" stream)
+	    (loop for attr in derives
+	      do (terpri stream) (princ "   " stream)
+	      (generate view attr stream :qualify-p (not (eql obj (entity attr)))))))
+
+	;; Inverse Attributes
+	(let ((inverses (collect-inherited :inverse obj)))
+	  (when inverses
+	    (terpri stream) (princ " INVERSE" stream)
+	    (loop for attr in inverses
+	      do (terpri stream) (princ "   " stream)
+	      (generate view attr stream :qualify-p (not (eql obj (entity attr)))))))
+
+	;; Unique Clauses
+	(let ((uniques (collect-inherited :unique obj)))
+	  (when uniques
+	    (terpri stream) (princ " UNIQUE" stream)
+	    (loop for attr in uniques
+	      do (terpri stream) (princ "   " stream)
+	      (generate view attr stream :qualify-p (not (eql obj (entity attr)))))))
+
+	;; Where Clauses
+	(let ((wheres (collect-inherited :where obj)))
+	  (when wheres
+	    (terpri stream) (princ " WHERE" stream)
+	    (loop for attr in wheres
+	      do (terpri stream) (princ "   " stream)
+	      (generate view attr stream :qualify-p (not (eql obj (definition attr)))))))
+	(terpri stream) (princ "END_ENTITY;" stream) (terpri stream)))))
+
+(defmethod generate ((view (eql :flat)) (obj rule-def) stream &key name-only-p)
+  (with-slots (name) obj
+    (if name-only-p (princ (string-downcase name) stream)
+      (progn
+	(princ "-- RULE " stream)
+	(generate view obj stream :name-only-p t)
+	(princ ";" stream) (terpri stream)))))
+
+(defmethod generate ((view (eql :flat)) (obj function-def) stream &key name-only-p)
+  (with-slots (name) obj
+    (if name-only-p (princ (string-downcase name) stream)
+      (progn
+	(princ "-- FUNCTION " stream)
+	(generate view obj stream :name-only-p t)
+	(princ ";" stream) (terpri stream)))))
+
+(defmethod generate ((view (eql :flat)) (obj procedure-def) stream &key name-only-p)
+  (with-slots (name) obj
+    (if name-only-p (princ (string-downcase name) stream)
+      (princ
+       (princ "-- PROCEDURE " stream)
+       (generate view obj stream :name-only-p t)
+       (princ ";" stream) (terpri stream)))))
+
+
+;; ----------------------------------------------------------------------
+
+(defmethod generate ((view (eql :flat)) (obj Simple-Type) stream &key)
+  (princ (type-of obj) stream))
+
+(defmethod generate ((view (eql :flat)) (obj Select-Type) stream &key)
+  (with-slots (types) obj
+    (princ "SELECT (" stream)
+    (loop for items on types
+      do (terpri stream) (princ "  " stream)
+      (generate view (first items) stream :name-only-p t)
+      when (rest items) do (princ ", " stream))
+    (princ ")" stream)))
+
+(defmethod generate ((view (eql :flat)) (obj Enumeration-Type) stream &key)
+  (with-slots (enum-vals) obj
+    (princ "ENUMERATION OF (" stream)
+    (loop for items on enum-vals
+      do (terpri stream) (princ "  " stream)
+      (princ (string-downcase (first items)) stream)
+      when (rest items) do (princ ", " stream))
+    (princ ")" stream)))
+
+(defmethod generate ((view (eql :flat)) (obj supertype-of) stream &key)
+  (with-slots (expression) obj
+    (unless (typep expression '(or super-and super-andor))
+      (princ #\( stream))
+    (generate view expression stream :name-only-p t)
+    (unless (typep expression '(or super-and super-andor))
+      (princ #\) stream))))
+
+(defmethod generate ((view (eql :flat)) (obj super-and) stream &key)
+  (with-slots (contents) obj
+    (princ #\( stream)
+    (loop for items on contents
+      as item = (first items)
+      do (generate view item stream :name-only-p t)
+      when (rest items) do (princ " AND " stream))
+    (princ #\) stream)))
+
+(defmethod generate ((view (eql :flat)) (obj super-andor) stream &key)
+  (with-slots (contents) obj
+    (princ #\( stream)
+    (loop for items on contents
+      as item = (first items)
+      do (generate view item stream :name-only-p t)
+      when (rest items) do (princ " ANDOR " stream))
+    (princ #\) stream)))
+
+(defmethod generate ((view (eql :flat)) (obj super-oneof) stream &key)
+  (with-slots (contents) obj
+    (princ "ONEOF(" stream)
+    (loop for items on contents
+      as item = (first items)
+      do (generate view item stream :name-only-p t)
+      when (rest items) do (princ ", " stream))
+    (princ #\) stream)))
+
+(defmethod generate ((view (eql :flat)) (obj attrib-def) stream &key qualify-p name-only-p)
+  (with-slots (optional? type) obj
+    (if name-only-p
+	(let ((name obj) (entity))
+	  (loop until (symbolp name)
+	    do (setf entity (entity name))
+	    (setf name (name name)))
+	  (format stream "~:[~(~A~).~;~*~]~(~A~)"
+		  (null qualify-p) (name entity) name))
+      (progn
+	(generate view obj stream :name-only-p t :qualify-p qualify-p)
+	(princ ": " stream)
+	(when optional? (princ "OPTIONAL " stream))
+	(generate view type stream :name-only-p t)
+	(princ #\; stream)))))
+
+(defmethod generate ((view (eql :flat)) (obj derive-attr) stream &key qualify-p name-only-p)
+  (with-slots (type computation) obj
+    (if name-only-p
+	(let ((name obj) (entity))
+	  (loop until (symbolp name)
+	    do (setf entity (entity name))
+	    (setf name (name name)))
+	  (format stream "~:[~(~A~).~;~*~]~(~A~)"
+		  (null qualify-p) (name entity) name))
+      (progn
+	(generate view obj stream :qualify-p qualify-p :name-only-p t)
+	(princ ": " stream)
+	(generate view type stream :name-only-p t)
+	(princ " := " stream)
+	(generate view computation stream)
+	(princ #\; stream)))))
+
+(defmethod generate ((view (eql :flat)) (obj inverse-attr) stream &key qualify-p name-only-p)
+  (with-slots (agg-name bound-1 bound-2 type attr-ref) obj
+    (if name-only-p
+	(let ((name obj) (entity))
+	  (loop until (symbolp name)
+	    do (setf entity (entity name))
+	    (setf name (name name)))
+	  (format stream "~:[~(~A~).~;~*~]~(~A~)"
+		  (null qualify-p) (name entity) name))
+      (progn
+	(generate view obj stream :qualify-p qualify-p :name-only-p t)
+	(princ ": " stream)
+	(when agg-name
+	  (format stream "~A~@[ [~A:~:[?~;~:*~A~]]~] OF "
+		  agg-name bound-1 bound-2))
+	(generate view type stream :name-only-p t)
+	(princ " FOR " stream)
+	(generate view attr-ref stream :name-only-p t)
+	(princ #\; stream)))))
+
+(defmethod generate ((view (eql :flat)) (obj aggregate) stream &key)
+  (with-slots (bound-1 bound-2 type) obj
+    (princ (type-of obj) stream)
+    (when bound-1 (format stream " [~D:~:[?~;~:*~D~]]" bound-1 bound-2))
+    (princ " OF " stream)
+    (generate view type stream :name-only-p t)))
+
+(defmethod generate ((view (eql :flat)) (obj unique-rule) stream &key qualify-p)
+  (with-slots (entity name attributes) obj
+    (when name (format stream "~:[~(~A~).~;~*~]~A: " (null qualify-p) (name entity) name))
+    (labels ((attr-name (obj)
+	       (if (symbolp (name obj)) (name obj) (attr-name (name obj))))
+	     (find-attr (name obj)
+	       (or (loop for super in (subtype-of obj)
+		     as attr = (find-attr name super)
+		     when attr return attr)
+		   (find name (explicit-attr obj) :key #'attr-name)
+		   (find name (derive obj) :key #'attr-name)
+		   (find name (inverse obj) :key #'attr-name))))
+      (loop for attrs on attributes
+	as attr = (first attrs)
+	as sattr = (find-attr (attr-name attr) entity) ;; qualifier)
+	do (generate view attr stream :name-only-p t)
+	when (rest attrs) do (princ ", " stream)))
+    (princ #\; stream)))
+
+(defmethod generate ((view (eql :flat)) (obj where-rule) stream &key qualify-p)
+  (with-slots (name definition expression) obj
+    (when (and (name-boundp obj) name)
+      (format stream "~:[~(~A~).~;~*~]~A: " (null qualify-p) (name definition) name))
+    (generate view expression stream)
+    (princ #\; stream)))
+
+(defmethod generate ((view (eql :flat)) (obj expression) stream &key)
+  (with-slots ((tkns tokens)) obj
+    (loop for tokens on tkns
+      as token = (first tokens)
+      do (generate view token stream))))
+
+
+;; ----------------------------------------------------------------------
+
+;(defmethod GENERATE-ATTR ((view (eql :flat)) (obj Entity-Def) stream
+;			  (type (eql :where-rule)) entity &key)
+;  (dolist (super (subtype-of obj))
+;    (generate-attr view super stream type entity))
+;  (dolist (attr (where obj))
+;    (format stream "~%   ~:[~A.~;~*~]" (eql obj entity)
+;	    (string-downcase (name obj)))
+;    (generate view attr stream)))
+
+;(defmethod GENERATE-ATTR ((view (eql :flat)) (obj Entity-Def) stream
+;			  (type (eql :explicit-attr)) entity &key)
+;  (dolist (super (subtype-of obj))
+;    (generate-attr view super stream type entity))
+;  (dolist (attr (explicit-attr obj))
+;    (format stream "~%   ~:[~A.~;~*~]" (eql obj entity)
+;	    (string-downcase (name obj)))
+;    (generate view attr stream)))
+
+;(defmethod GENERATE-ATTR ((view (eql :flat)) (obj Entity-Def) stream
+;			  (type (eql :derive)) entity &key)
+;  (dolist (super (subtype-of obj))
+;    (generate-attr view super stream type entity))
+;  (dolist (attr (derive obj))
+;    (format stream "~%   ~:[~A.~;~*~]" (eql obj entity)
+;	    (string-downcase (name obj)))
+;    (generate view attr stream)))
+
+;(defmethod GENERATE-ATTR ((view (eql :flat)) (obj Entity-Def) stream
+;			  (type (eql :inverse)) entity &key)
+;  (dolist (super (subtype-of obj))
+;    (generate-attr view super stream type entity))
+;  (dolist (attr (inverse obj))
+;    (format stream "~%   ~:[~A.~;~*~]" (eql obj entity)
+;	    (string-downcase (name obj)))
+;    (generate view attr stream)))
+
+;(defmethod GENERATE-ATTR ((view (eql :flat)) (obj Entity-Def) stream
+;			  (type (eql :unique)) entity &key)
+;  (dolist (super (subtype-of obj))
+;    (generate-attr view super stream type entity))
+;  (dolist (attr (unique obj))
+;    (format stream "~%   ~:[~A.~;~*~]" (eql obj entity)
+;	    (string-downcase (name obj)))
+;    (generate view attr stream)))


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.