Rewrote adl2psql into Clojure, because these days it's more comfortable.

resources/transforms/adl2psql.xslt

@@ -1,7 +1,7 @@
 <?xml version="1.0"?>
-<xsl:stylesheet version="1.0" 
+<xsl:stylesheet version="1.0"
-  xmlns="http://bowyer.journeyman.cc/adl/1.4/" 
+  xmlns="http://bowyer.journeyman.cc/adl/1.4.1/"
-  xmlns:adl="http://bowyer.journeyman.cc/adl/1.4/"
+  xmlns:adl="http://bowyer.journeyman.cc/adl/1.4.1/"
   xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
     <!--  ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::  -->
     <!--						    											-->
@@ -17,35 +17,35 @@
     <!--	This file is presently not up to date with changes in ADL   -->
     <!--																		-->
     <!--  ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::  -->
-    
+
     <!--
         JACQUARD 2 APPLICATION DESCRIPTION LANGUAGE FRAMEWORK
-        
+
         $Revision: 1.3 $
-        
+
         NOTES:
-        
+
         Needless to say this is all hugely experimental.
-        
+
-        Running the primary key field last is a hack which gets around the fact that 
+        Running the primary key field last is a hack which gets around the fact that
-        otherwise it's extremely complex to lose the comma after the last field. 
+        otherwise it's extremely complex to lose the comma after the last field.
-        Ideally where there is one 'distinct="system"' property of an entity that 
+        Ideally where there is one 'distinct="system"' property of an entity that
         should be the primary key and perhaps we'll achieve that in the long run...
-        
+
         Still to do:
-        
+
-        References in convenience views for fields which have their reference value at 
+        References in convenience views for fields which have their reference value at
         two removes (i.e. the 'distinguish' mechanism in ADL
     -->
-    
+
   <xsl:include href="base-type-include.xslt"/>
 
-  <!-- 
+  <!--
       The convention to use for naming auto-generated abstract primary keys. Known values are
       Id - the autogenerated primary key, if any, is called just 'Id'
       Name - the autogenerated primary key has the same name as the entity
       NameId - the name of the auto generated primary key is the name of the entity followed by 'Id'
-      Name_Id - the name of the auto generated primary key is the name of the entity followed by '_Id'  
+      Name_Id - the name of the auto generated primary key is the name of the entity followed by '_Id'
     -->
   <xsl:param name="abstract-key-name-convention" select="Id"/>
 
@@ -56,7 +56,7 @@
 		Name_Link  - the name of the foreign key is the same as the name of the table linked to, followed by '_Link'
 	-->
 	<xsl:param name="linktable-field-name-convention" select="Name"/>
-	
+
   <xsl:param name="database"/>
 	<!-- the name and version of the product being built -->
 	<xsl:param name="product-version" select="'Application Description Language Framework'"/>
@@ -128,7 +128,7 @@
   <xsl:variable name="sqlkeywords" select="concat(' ', normalize-space($sqlkeywords-multiline), ' ')"/>
 
 
-  <xsl:template match="adl:application"> 
+  <xsl:template match="adl:application">
         -------------------------------------------------------------------------------------------------
         --
         --    <xsl:value-of select="$product-version"/>
@@ -156,7 +156,7 @@
         --    tables, views and permissions
         -------------------------------------------------------------------------------------------------
         <xsl:apply-templates select="adl:entity"/>
-        
+
         -------------------------------------------------------------------------------------------------
         --    referential integrity constraints
         -------------------------------------------------------------------------------------------------
@@ -166,24 +166,24 @@
                 <xsl:call-template name="referentialintegrity">
                     <xsl:with-param name="nearside" select="$nearside"/>
                 </xsl:call-template>
-                
+
             </xsl:for-each>
             <xsl:for-each select="adl:property[@type='link']">
                 <xsl:call-template name="linkintegrity">
                     <xsl:with-param name="nearside" select="$nearside"/>
                 </xsl:call-template>
-                
+
             </xsl:for-each>
         </xsl:for-each>
         -------------------------------------------------------------------------------------------------
         --    end of file
         -------------------------------------------------------------------------------------------------
     </xsl:template>
-    
+
     	<xsl:template match="adl:documentation">
 		/*    <xsl:apply-templates/> */
 	</xsl:template>
-	
+
   	<xsl:template match="adl:group">
 		-------------------------------------------------------------------------------------------------
 		--    security group <xsl:value-of select="@name"/>
@@ -191,12 +191,12 @@
 	  	<xsl:apply-templates select="adl:documentation"/>
         CREATE GROUP <xsl:value-of select="@name"/>;
     </xsl:template>
-    
+
-    
+
     <xsl:template name="referentialintegrity">
         <xsl:param name="nearside"/>
         <!-- set up referential integrity constraints for primary tables -->
-        ALTER TABLE <xsl:value-of select="$nearside"/> ADD CONSTRAINT ri_<xsl:value-of select="$nearside"/><xsl:value-of select="concat( '_', @name)"/> 
+        ALTER TABLE <xsl:value-of select="$nearside"/> ADD CONSTRAINT ri_<xsl:value-of select="$nearside"/><xsl:value-of select="concat( '_', @name)"/>
             FOREIGN KEY ( <xsl:value-of select="@name"/>) REFERENCES <xsl:value-of select="@entity"/> ON DELETE NO ACTION;
     </xsl:template>
 
@@ -204,20 +204,20 @@
     <xsl:template name="linkintegrity">
         <xsl:param name="nearside"/>
         <!-- set up referential integrity constraints for link tables -->
-        ALTER TABLE ln_<xsl:value-of select="$nearside"/>_<xsl:value-of select="@entity"/> 
+        ALTER TABLE ln_<xsl:value-of select="$nearside"/>_<xsl:value-of select="@entity"/>
-            ADD CONSTRAINT ri_<xsl:value-of select="$nearside"/>_<xsl:value-of select="@entity"/>_<xsl:value-of select="$nearside"/>_id 
+            ADD CONSTRAINT ri_<xsl:value-of select="$nearside"/>_<xsl:value-of select="@entity"/>_<xsl:value-of select="$nearside"/>_id
             FOREIGN KEY ( <xsl:value-of select="$nearside"/>_id) REFERENCES <xsl:value-of select="$nearside"/> ON DELETE CASCADE;
 
-        ALTER TABLE ln_<xsl:value-of select="$nearside"/>_<xsl:value-of select="@entity"/> 
+        ALTER TABLE ln_<xsl:value-of select="$nearside"/>_<xsl:value-of select="@entity"/>
-            ADD CONSTRAINT ri_<xsl:value-of select="$nearside"/>_<xsl:value-of select="@entity"/>_<xsl:value-of select="@entity"/>_id 
+            ADD CONSTRAINT ri_<xsl:value-of select="$nearside"/>_<xsl:value-of select="@entity"/>_<xsl:value-of select="@entity"/>_id
             FOREIGN KEY ( <xsl:value-of select="@entity"/>_id) REFERENCES <xsl:value-of select="@entity"/> ON DELETE CASCADE;
-        
+
     </xsl:template>
-    
+
-    
+
     <xsl:template match="adl:entity">
          <xsl:variable name="table" select="@name"/>
-         
+
         -------------------------------------------------------------------------------------------------
         --    primary table <xsl:value-of select="@name"/>
         -------------------------------------------------------------------------------------------------
@@ -231,7 +231,7 @@
         		</xsl:choose>
         	</xsl:for-each>
         );
-        
+
         ----  permissions  ------------------------------------------------------------------------------
         <xsl:for-each select="adl:permission">
             <xsl:call-template name="permission">
@@ -266,7 +266,7 @@
             <xsl:choose>
             <xsl:when test="position() = 1">WHERE </xsl:when>
             <xsl:otherwise>AND   </xsl:otherwise>
-            </xsl:choose><xsl:value-of select="$table"/>.<xsl:value-of 
+            </xsl:choose><xsl:value-of select="$table"/>.<xsl:value-of
                 select="@name"/> = <xsl:value-of select="@name"/>.<xsl:value-of select="@entity"/>_id
         </xsl:for-each>;
 
@@ -276,7 +276,7 @@
                 <xsl:with-param name="table" select="$table"/>
             </xsl:call-template>
         </xsl:for-each>
-        
+
         <!-- link tables -->
         <xsl:for-each select="adl:property[@type='link']">
             <xsl:call-template name="linktable">
@@ -290,74 +290,74 @@
                 </xsl:call-template>
             </xsl:for-each>
         </xsl:for-each>
-        
+
     </xsl:template>
-     
+
     <xsl:template name="distinctfield">
         <xsl:param name="table"/>
         <xsl:param name="alias"/>
-        <!-- 
+        <!--
             print the names of the distinguishing fields in this table,
-            concatenating into a single string. 
+            concatenating into a single string.
         -->
-        <xsl:for-each select="/application/entity[@name=$table]">
+        Template distinctfield entered, table is <xsl:value-of select="$table"/>.
-            <xsl:for-each select="property[@distinct='user' or @distinct='all']">
+            <xsl:for-each select="//entity[@name=$table]/property[@distinct='user' or @distinct='all']">
                 <xsl:choose>
                     <xsl:when test="@type='entity'">
+                    Entity <xsl:value-of select="@name"/> detected.
                         <xsl:call-template name="distinctfield">
                             <xsl:with-param name="table" select="@entity"/>
                             <xsl:with-param name="alias" select="concat( $alias, '_', @name)"></xsl:with-param>
                         </xsl:call-template>
                     </xsl:when>
                     <xsl:otherwise>
-                        <xsl:value-of select="$alias"/>.<xsl:value-of 
+                        <xsl:value-of select="$alias"/>.<xsl:value-of
-                        select="@name"/><xsl:if test="position() != last()"> | ' ' | </xsl:if>
+                        select="@name"/><xsl:if test="position() != last()"> | ', ' | </xsl:if>
                     </xsl:otherwise>
                 </xsl:choose>
-                
+
             </xsl:for-each>
-        </xsl:for-each>
     </xsl:template>
-     
+
     <xsl:template name="permission">
         <xsl:param name="table"/>
         <!-- decode the permissions for a table -->
         <xsl:choose>
-            <xsl:when test="@permission='read'">GRANT SELECT ON <xsl:value-of 
+            <xsl:when test="@permission='read'">GRANT SELECT ON <xsl:value-of
                 select="$table"/> TO GROUP <xsl:value-of select="@group"/>;</xsl:when>
-            <xsl:when test="@permission='insert'">GRANT INSERT ON <xsl:value-of 
+            <xsl:when test="@permission='insert'">GRANT INSERT ON <xsl:value-of
                 select="$table"/> TO GROUP <xsl:value-of select="@group"/>;</xsl:when>
-            <xsl:when test="@permission='noedit'">GRANT SELECT, INSERT ON <xsl:value-of 
+            <xsl:when test="@permission='noedit'">GRANT SELECT, INSERT ON <xsl:value-of
                 select="$table"/> TO GROUP <xsl:value-of select="@group"/>;</xsl:when>
-            <xsl:when test="@permission='edit'">GRANT SELECT, INSERT, UPDATE ON <xsl:value-of 
+            <xsl:when test="@permission='edit'">GRANT SELECT, INSERT, UPDATE ON <xsl:value-of
                 select="$table"/> TO GROUP <xsl:value-of select="@group"/>;</xsl:when>
-            <xsl:when test="@permission='all'">GRANT SELECT, INSERT, UPDATE, DELETE ON <xsl:value-of 
+            <xsl:when test="@permission='all'">GRANT SELECT, INSERT, UPDATE, DELETE ON <xsl:value-of
                 select="$table"/> TO GROUP <xsl:value-of select="@group"/>;</xsl:when>
-            <xsl:otherwise>REVOKE ALL ON <xsl:value-of 
+            <xsl:otherwise>REVOKE ALL ON <xsl:value-of
                 select="$table"/> FROM GROUP <xsl:value-of select="@group"/>;</xsl:otherwise>
         </xsl:choose>
         <xsl:text>
-            
+
         </xsl:text>
     </xsl:template>
-     
+
     <xsl:template name="viewpermission">
         <xsl:param name="table"/>
         <!-- decode the permissions for a convenience view -->
         <xsl:choose>
-            <xsl:when test="@permission='none'">REVOKE ALL ON lv_<xsl:value-of 
+            <xsl:when test="@permission='none'">REVOKE ALL ON lv_<xsl:value-of
                 select="$table"/> FROM GROUP <xsl:value-of select="@group"/>;</xsl:when>
-            <xsl:when test="@permission='insert'">REVOKE ALL ON lv_<xsl:value-of 
+            <xsl:when test="@permission='insert'">REVOKE ALL ON lv_<xsl:value-of
                 select="$table"/> FROM GROUP <xsl:value-of select="@group"/>;</xsl:when>
-            <xsl:otherwise>GRANT SELECT ON lv_<xsl:value-of 
+            <xsl:otherwise>GRANT SELECT ON lv_<xsl:value-of
                 select="$table"/> TO GROUP <xsl:value-of select="@group"/>;</xsl:otherwise>
         </xsl:choose>
         <xsl:text>
-            
+
         </xsl:text>
     </xsl:template>
-    
+
-    
+
     <xsl:template name="linktable">
         <xsl:param name="nearside"/>
       <xsl:variable name="farside">
@@ -369,7 +369,7 @@
         </xsl:choose>
       </xsl:variable>
         <!-- create a linking table -->
-        
+
         -------------------------------------------------------------------------------------------------
         --    link table joining <xsl:value-of select="$nearside"/> with <xsl:value-of select="@entity"/>
         -------------------------------------------------------------------------------------------------
@@ -379,15 +379,15 @@
             <xsl:value-of select="$farside"/>_id INT NOT NULL,
         );
         <xsl:text>
-            
+
         </xsl:text>
         <!-- TODO: permissions for link tables! -->
-        
+
     </xsl:template>
-    
+
     <xsl:template match="adl:property[@type='entity']">
-        <xsl:value-of select="@name"/> INT<xsl:if 
+        <xsl:value-of select="@name"/> INT<xsl:if
-            test="string(@default)"> DEFAULT <xsl:value-of select="@default"/></xsl:if><xsl:if 
+            test="string(@default)"> DEFAULT <xsl:value-of select="@default"/></xsl:if><xsl:if
                 test="@required='true'"> NOT NULL</xsl:if>
     </xsl:template>
 
@@ -395,46 +395,46 @@
         <xsl:variable name="name"><xsl:value-of select="@definition"/></xsl:variable>
         <xsl:variable name="definitiontype"><xsl:value-of select="/application/definition[@name=$name]/@type"/></xsl:variable>
         <xsl:value-of select="@name"/><xsl:text> </xsl:text><xsl:choose>
-            <xsl:when test="$definitiontype='string'">VARCHAR( <xsl:value-of 
+            <xsl:when test="$definitiontype='string'">VARCHAR( <xsl:value-of
                 select="/application/definition[@name=$name]/@size"/>)</xsl:when>
             <xsl:when test="$definitiontype='integer'">INT</xsl:when>
             <xsl:when test="$definitiontype='real'">DOUBLE PRECISION</xsl:when>
             <xsl:otherwise><xsl:value-of select="$definitiontype"/></xsl:otherwise>
-        </xsl:choose><xsl:if 
+        </xsl:choose><xsl:if
         test="string(@default)"> DEFAULT <xsl:value-of select="@default"/></xsl:if><xsl:choose>
 			<xsl:when test="parent::adl:key"> NOT NULL PRIMARY KEY</xsl:when>
 			<xsl:when test="@required='true'"> NOT NULL</xsl:when>
 		</xsl:choose>
     </xsl:template>
-    
+
     <xsl:template match="adl:property[@type='string']">
-        <xsl:value-of select="@name"/> VARCHAR( <xsl:value-of select="@size"/>)<xsl:if 
+        <xsl:value-of select="@name"/> VARCHAR( <xsl:value-of select="@size"/>)<xsl:if
             test="string(@default)"> DEFAULT <xsl:value-of select="@default"/></xsl:if><xsl:choose>
 			<xsl:when test="parent::adl:key"> NOT NULL PRIMARY KEY</xsl:when>
 			<xsl:when test="@required='true'"> NOT NULL</xsl:when>
 		</xsl:choose>
     </xsl:template>
-        
+
     <xsl:template match="adl:property[@type='integer']">
-        <xsl:value-of select="@name"/> INT<xsl:if 
+        <xsl:value-of select="@name"/> INT<xsl:if
             test="string(@default)"> DEFAULT <xsl:value-of select="@default"/></xsl:if><xsl:choose>
 			<xsl:when test="parent::adl:key"> NOT NULL PRIMARY KEY</xsl:when>
 			<xsl:when test="@required='true'"> NOT NULL</xsl:when>
         </xsl:choose>
     </xsl:template>
-    
+
     <xsl:template match="adl:property[@type='real']">
-        <xsl:value-of select="@name"/> DOUBLE PRECISION<xsl:if 
+        <xsl:value-of select="@name"/> DOUBLE PRECISION<xsl:if
-            test="string(@default)"> DEFAULT <xsl:value-of select="@default"/></xsl:if><xsl:if 
+            test="string(@default)"> DEFAULT <xsl:value-of select="@default"/></xsl:if><xsl:if
                 test="@required='true'"> NOT NULL</xsl:if>
     </xsl:template>
-    
+
     <xsl:template match="adl:property">
-        <xsl:value-of select="@name"/> <xsl:text> </xsl:text><xsl:value-of select="@type"/><xsl:if 
+        <xsl:value-of select="@name"/> <xsl:text> </xsl:text><xsl:value-of select="@type"/><xsl:if
             test="string(@default)"> DEFAULT <xsl:value-of select="@default"/></xsl:if><xsl:choose>
 			<xsl:when test="parent::adl:key"> NOT NULL PRIMARY KEY</xsl:when>
 			<xsl:when test="@required='true'"> NOT NULL</xsl:when>
 		</xsl:choose>
     </xsl:template>
-    
+
 </xsl:stylesheet>

src/adl/to_hugsql_queries.clj

@@ -284,8 +284,10 @@
                              (list
                                (str "-- :name " query-name " " signature)
                                (str "-- :doc links all existing " pretty-name " records related to a given " pretty-far)
-                               (str "SELECT * \nFROM " entity-name)
+                               (str "SELECT * \nFROM " entity-name ", " link-table-name)
-                               (str "WHERE " entity-name "." link-field " = " link-table-name "." (singularise entity-name) "_id")
+                               (str "WHERE " entity-name "."
+                                    (first (key-names entity))
+                                    " = " link-table-name "." (singularise entity-name) "_id")
                                (str "\tAND " link-table-name "." (singularise far-name) "_id = :id")
                                (order-by-clause entity)))
                     (list (str "ERROR: unexpected type " link-type " of property " %)))))

src/adl/to_psql.clj

@@ -0,0 +1,400 @@
+(ns ^{:doc "Application Description Language: generate Postgres database definition."
+      :author "Simon Brooke"}
+  adl.to-psql
+  (:require [clojure.java.io :refer [file make-parents writer]]
+            [clojure.pprint :refer [pprint]]
+            [clojure.string :as s]
+            [clojure.xml :as x]
+            [clj-time.core :as t]
+            [clj-time.format :as f]
+            [adl.utils :refer :all]
+            [adl.to-hugsql-queries :refer [queries]]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; adl.to-psql: generate Postgres database definition.
+;;;;
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public License
+;;;; as published by the Free Software Foundation; either version 2
+;;;; of the License, or (at your option) any later version.
+;;;;
+;;;; This program 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 General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
+;;;; USA.
+;;;;
+;;;; Copyright (C) 2018 Simon Brooke
+;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;; this is a pretty straight translation of adl2psql.xslt, and was written because
+;;; Clojure is easier to debug
+
+(declare emit-field-type emit-property)
+
+(def comment-rule (apply str (repeat 79 "-")))
+
+(defn emit-defined-field-type
+  [property application]
+  (let [typedef (typedef property application)]
+    ;; this is a hack based on the fact that emit-field-type doesn't check
+    ;; that the argument passed as `property` is indeed a property.
+    (emit-field-type typedef nil application false)))
+
+(defn emit-entity-field-type
+  [property application]
+  (let [farside (child
+                  application
+                  #(and
+                     (entity? %)
+                     (= (:name (:attrs %)) (:entity (:attrs property)))))
+        key-properties (children-with-tag
+                         (first (children-with-tag farside :key))
+                         :property)]
+    (if
+      (> (count key-properties) 1)
+      (str
+        "-- ERROR: cannot generate link to entity "
+        (:name (:attrs farside))
+        " with compound primary key\n")
+      (list
+        (emit-field-type (first key-properties) farside application false)
+        "REFERENCES"
+        (str
+          (:table (:attrs farside)) "(" (:name (:attrs (first key-properties))) ) ")"
+        ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used
+        ))))
+
+
+(defn emit-field-type
+  [property entity application key?]
+  (case (:type (:attrs property))
+    "integer" (if key? "serial" "INTEGER")
+    "real" "DOUBLE PRECISION"
+    ("string" "image" "uploadable") (str "VARCHAR(" (:size (:attrs property)) ")")
+    "defined" (emit-defined-field-type property application)
+    "entity" (emit-entity-field-type property application)
+    ("date" "time" "timestamp" "boolean" "text" "money") (.toUpperCase (:type (:attrs property)))
+    (str "-- ERROR: unknown type " (:type (:attrs property)))
+    ))
+
+
+(defn emit-link-field
+  [property entity application]
+  (emit-property
+    {:tag :property
+     :attrs {:name (str (:name (:attrs entity)) "_id")
+             :type "entity"
+             :entity (:name (:attrs entity))
+             :cascade (:cascade (:attrs property))}}
+    entity
+    application))
+
+
+(defn emit-permissions-grant
+  [table-name privilege permissions]
+  (let [selector
+        (case privilege
+          :SELECT #{"read" "noedit" "edit" "all"}
+          :INSERT #{"insert" "noedit" "edit" "all"}
+          :UPDATE #{"edit" "all"}
+          (:DELETE :ALL) #{"all"})
+        group-names
+        (set
+          (remove
+            nil?
+            (map
+              #(if (selector (:permission (:attrs %)))
+                 (:name (:attrs %)))
+              permissions)))]
+    (if
+      (not (empty? group-names))
+      (s/join " " (list "GRANT" (name privilege) "ON"  table-name "TO" (s/join "," group-names) ";")))))
+
+
+(defn emit-link-table
+  [property e1 application emitted-link-tables]
+  (let [e2 (child
+             application
+             #(and
+                (entity? %)
+                (= (:name (:attrs %)) (:entity (:attrs property)))))
+        link-table-name (link-table-name e1 e2)
+        permissions (flatten
+                      (list
+                        (children-with-tag e1 :permission)
+                        (children-with-tag e1 :permission)))]
+    (if
+      true ;;(not (@emitted-link-tables link-table-name))
+      (do
+        ;; (swap! emitted-link-tables (conj @emitted-link-tables link-table-name))
+        (s/join
+          "\n"
+          (list
+            comment-rule
+            (str "--\tlink table joining " (:name (:attrs e1)) " with " (:name (:attrs e2)))
+            comment-rule
+            (s/join " " (list "CREATE TABLE" link-table-name))
+            "("
+            (emit-link-field property e1 application)
+            (emit-link-field property e2 application)
+            ");"
+            (emit-permissions-grant link-table-name :SELECT permissions)
+            (emit-permissions-grant link-table-name :INSERT permissions)))))))
+
+
+(defn emit-link-tables
+  [entity application emitted-link-tables]
+  (map
+    #(emit-link-table % entity application emitted-link-tables)
+    (children entity #(and (= (:tag %) :property) (= (:type (:attrs %)) "link")))))
+
+
+(defn emit-property
+  ([property entity application]
+   (emit-property property entity application false))
+  ([property entity application key?]
+   (let [default (:default (:attrs property))]
+     (if
+       (and
+         (= (:tag property) :property)
+         (not (#{"link"} (:type (:attrs property)))))
+       (s/join
+         " "
+         (flatten
+           (list
+             "\t"
+             (:name (:attrs property))
+             (emit-field-type property entity application key?)
+             (if default (list "DEFAULT" default))
+             (if
+               key?
+               "NOT NULL PRIMARY KEY"
+               (if (= (:required (:attrs property)) "true") "NOT NULL")))))))))
+
+
+(defn compose-convenience-entity-field
+  ;; TODO: this is not recursing properly
+  [field entity application]
+  (let [farside (child
+                  application
+                  #(and
+                     (entity? %)
+                     (= (:name (:attrs %)) (:entity (:attrs field)))))]
+    (flatten
+      (map
+        (fn [f]
+          (if
+            (= (:type (:attrs f)) "entity")
+            (compose-convenience-entity-field f farside application)
+            (str (:table (:attrs farside)) "." (:name (:attrs f)))))
+        (user-distinct-properties farside)))))
+
+
+(defn compose-convenience-view-select-list
+  [entity application top-level?]
+  (remove
+    nil?
+    (flatten
+      (cons
+        (:name (:attrs entity))
+        (map
+          (fn [f]
+            (if
+              (= (:type (:attrs f)) "entity")
+              (compose-convenience-view-select-list
+                (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f)))))
+                application
+                false)))
+          (if
+            top-level?
+            (all-properties entity)
+            (user-distinct-properties entity)))))))
+
+
+(defn compose-convenience-where-clause
+  [entity application top-level?]
+  (remove
+    nil?
+    (flatten
+      (map
+        (fn [f]
+          (if
+            (= (:type (:attrs f)) "entity")
+            (let [farside (entity-for-property f application)]
+              (cons
+                (str
+                  (:table (:attrs entity))
+                  "."
+                  (:name (:attrs f))
+                  " = "
+                  (:table (:attrs farside))
+                  "."
+                  (first (key-names farside)))
+                #(compose-convenience-where-clause farside application false)))))
+        (if
+          top-level?
+          (all-properties entity)
+          (user-distinct-properties entity))))))
+
+
+
+(defn emit-convenience-entity-field
+  [field entity application]
+  (str
+    (s/join
+      " |', '| "
+      (compose-convenience-entity-field field entity application))
+    " AS "
+    (:name (:attrs field))))
+
+
+(defn emit-convenience-view
+  "Emit a convenience view of this `entity` of this `application` for use in generating lists,
+  menus, et cetera."
+  [entity application]
+  (let [view-name (str "lv_" (:table (:attrs entity)))
+        entity-fields (filter
+                        #(= (:type (:attrs %)) "entity")
+                        (properties entity))]
+    (s/join
+      "\n"
+      (remove
+        nil?
+        (flatten
+          (list
+            comment-rule
+            (str "--\tconvenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera")
+            comment-rule
+            (s/join
+              " "
+              (list "CREATE VIEW" view-name "AS"))
+            (str
+              "SELECT "
+              (s/join
+                ",\n\t"
+                (map
+                  #(if
+                     (= (:type (:attrs %)) "entity")
+                     (emit-convenience-entity-field % entity application)
+                     (:name (:attrs %)))
+                  (filter
+                    #(and (= (:tag %) :property) (not (= (:type (:attrs %)) "link")))
+                    (all-properties entity) ))))
+            (str
+              "FROM " (s/join ", " (compose-convenience-view-select-list entity application true)))
+            (if
+              (not (empty? entity-fields))
+              (str
+                "WHERE "
+                (s/join
+                  "\n\tAND "
+                  (map
+                    (fn [f]
+                      (let
+                        [farside (child
+                                   application
+                                   #(and
+                                      (entity? %)
+                                      (= (:name (:attrs %)) (:entity (:attrs f)))))]
+                        (str
+                          (:table (:attrs entity))
+                          "."
+                          (:name (:attrs f))
+                          " = "
+                          (:table (:attrs farside))
+                          "."
+                          (first (key-names farside)))))
+                    entity-fields))))
+            ";"
+            (emit-permissions-grant view-name :SELECT (permissions entity application))))))))
+
+
+(defn emit-table
+  [entity application emitted-link-tables]
+  (let [table-name (:table (:attrs entity))
+        permissions (children-with-tag entity :permission)]
+    (s/join
+      "\n"
+      (flatten
+        (list
+          comment-rule
+          (str "--\tprimary table " table-name " for entity " (:name (:attrs entity)))
+          comment-rule
+          (s/join
+            " "
+            (list "CREATE TABLE " table-name))
+          "("
+          (map
+            #(emit-property % entity application true)
+            (children-with-tag (child-with-tag entity :key) :property))
+          (map
+            #(emit-property % entity application false)
+            (children-with-tag entity :property))
+          ");"
+          (map
+            #(emit-permissions-grant table-name % permissions)
+            '(:SELECT :INSERT :UPDATE :DELETE)))))))
+
+
+(defn emit-entity
+  [entity application emitted-link-tables]
+  (emit-table entity application emitted-link-tables)
+  (emit-convenience-view entity application))
+
+
+(defn emit-group-declaration
+  [group application]
+  (s/join
+    "\n"
+    (list
+      comment-rule
+      (str "--\tsecurity group " (:name (:attrs group)))
+      comment-rule
+      (str "CREATE GROUP IF NOT EXISTS " (:name (:attrs group))))))
+
+
+(defn emit-file-header
+  [application]
+  (s/join
+    "\n"
+    (list
+      comment-rule
+      (str
+        "--\tDatabase definition for application "
+        (:name (:attrs application))
+        " version "
+        (:version (:attrs application)))
+      (str
+        "--\tauto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
+        (f/unparse (f/formatters :basic-date-time) (t/now)))
+      comment-rule)))
+
+
+(defn emit-application
+  [application]
+  (let [emitted-link-tables (atom #{})]
+    (s/join
+      "\n\n"
+      (flatten
+        (list
+          (emit-file-header application)
+          (map #(emit-group-declaration % application) (children-with-tag application :group))
+          (map #(emit-entity % application emitted-link-tables) (children-with-tag application :entity))
+          (map #(emit-link-tables % application emitted-link-tables) (children-with-tag application :entity)))))))
+
+
+(defn to-psql
+  [application]
+  (let [filepath (str *output-path* "/resources/sql/" (:name (:attrs application)) ".postgres.sql")]
+    (make-parents filepath)
+    (spit filepath (emit-application application))))
+
+

src/adl/utils.clj

@@ -41,7 +41,13 @@
 (defn link-table-name
   "Canonical name of a link table between entity `e1` and entity `e2`."
   [e1 e2]
-  (s/join "_" (list "link" (:name (:attrs e1)) (:name (:attrs e2)))))
+  (s/join
+    "_"
+    (cons
+      "ln"
+      (sort
+        (list
+          (:name (:attrs e1)) (:name (:attrs e2)))))))
 
 
 (defn children
@@ -57,6 +63,12 @@
      (children element))))
 
 
+(defn child
+  "Return the first child of this `element` satisfying this `predicate`."
+  [element predicate]
+  (first (children element predicate)))
+
+
 (defn attributes
   "Return the attributes of this `element`; if `predicate` is passed, return only those
   attributes satisfying the predicate."
@@ -87,7 +99,7 @@
 (defn permissions
   "Return appropriate permissions of this `property`, taken from this `entity` of this
   `application`, in the context of this `page`."
-  [property page entity application]
+  ([property page entity application]
   (first
     (remove
       empty?
@@ -96,6 +108,10 @@
         (children property #(= (:tag %) :permission))
         (children entity #(= (:tag %) :permission))
         (children application #(= (:tag %) :permission))))))
+  ([property entity application]
+   (permissions property nil entity application))
+  ([entity application]
+   (permissions nil nil entity application)))
 
 
 (defn permission-groups
@@ -135,6 +151,24 @@
   (= (:tag x) :entity))
 
 
+(defn property?
+  "True if `o` is a property."
+  [o]
+  (= (:tag o) :property))
+
+
+(defn entity-for-property
+  "If this `property` references an entity, return that entity from this `application`"
+  [property application]
+  (if
+    (and (property? property) (:entity (:attrs property)))
+    (child
+      application
+      #(and
+         (entity? %)
+         (= (:name (:attrs %))(:entity (:attrs property)))))))
+
+
 (defn visible-to
   "Return a list of names of groups to which are granted read access,
   given these `permissions`, else nil."
@@ -216,6 +250,12 @@
     element
     (children element #(= (:tag %) tag))))
 
+(defn child-with-tag
+  "Return the first child of this `element` which has this `tag`;
+  if `element` is `nil`, return `nil`."
+  [element tag]
+  (first (children-with-tag element tag)))
+
 (defmacro properties
   "Return all the properties of this `entity`."
   [entity]
@@ -242,11 +282,19 @@
     (not (#{"link"} (:type (:attrs property))))
     (not (= (:distinct (:attrs property)) "system"))))
 
+
 (defmacro all-properties
   "Return all properties of this `entity` (including key properties)."
   [entity]
   `(descendants-with-tag ~entity :property))
 
+
+(defn user-distinct-properties
+  "Return the properties of this `entity` which are user distinct"
+  [entity]
+  (filter #(#{"user" "all"} (:distinct (:attrs %))) (all-properties entity)))
+
+
 (defmacro insertable-properties
   "Return all the properties of this `entity` (including key properties) into
   which user-supplied data can be inserted"
@@ -309,3 +357,16 @@
   assumes the editor form is the first form listed for the entity."
   [entity application]
   (path-part :form entity application))
+
+(defn typedef
+  [property application]
+  (first
+    (children application
+              #(and
+                 (= (:tag %) :typedef)
+                 (= (:name (:attrs %))
+                    (:definition (:attrs property)))))))
+
+(defn type-for-defined
+  [property application]
+  (:type (:attrs (typedef property application))))