simon/adl
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Small fixes

Browse source
This commit is contained in:
Simon Brooke 2018-06-11 01:06:16 +01:00
parent 6b3f6e58d2
commit f4330aad6b
3 changed files with 35 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

41
src/adl/to_hugsql_queries.clj
View file

@ -4,6 +4,7 @@
(:require [clojure.java.io :refer [file]]
[clojure.math.combinatorics :refer [combinations]]
[clojure.string :as s]
[clojure.xml :as x]
[clj-time.core :as t]
[clj-time.format :as f]
[adl.utils :refer :all]))
@ -36,8 +37,6 @@
"The path to which generated files will be written."
"resources/auto/")
(def electors {:tag :entity, :attrs {:magnitude "6", :name "electors", :table "electors"}, :content [{:tag :key, :attrs nil, :content [{:tag :property, :attrs {:distinct "system", :immutable "true", :column "id", :name "id", :type "integer", :required "true"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "id"}, :content nil}]}]} {:tag :property, :attrs {:distinct "user", :column "name", :name "name", :type "string", :required "true", :size "64"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "name"}, :content nil}]} {:tag :property, :attrs {:farkey "id", :entity "dwelling", :column "dwelling_id", :name "dwelling_id", :type "entity", :required "true"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "Flat"}, :content nil}]} {:tag :property, :attrs {:distinct "user", :column "phone", :name "phone", :type "string", :size "16"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "phone"}, :content nil}]} {:tag :property, :attrs {:distinct "user", :column "email", :name "email", :type "string", :size "128"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "email"}, :content nil}]} {:tag :property, :attrs {:default "Unknown", :farkey "id", :entity "genders", :column "gender", :type "entity", :name "gender"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "gender"}, :content nil}]} {:tag :list, :attrs {:name "Electors", :properties "listed"}, :content [{:tag :field, :attrs {:property "id"}, :content nil} {:tag :field, :attrs {:property "name"}, :content nil} {:tag :field, :attrs {:property "dwelling_id"}, :content nil} {:tag :field, :attrs {:property "phone"}, :content nil} {:tag :field, :attrs {:property "email"}, :content nil} {:tag :field, :attrs {:property "gender"}, :content nil}]} {:tag :form, :attrs {:name "Elector", :properties "listed"}, :content [{:tag :field, :attrs {:property "id"}, :content nil} {:tag :field, :attrs {:property "name"}, :content nil} {:tag :field, :attrs {:property "dwelling_id"}, :content nil} {:tag :field, :attrs {:property "phone"}, :content nil} {:tag :field, :attrs {:property "email"}, :content nil} {:tag :field, :attrs {:property "gender"}, :content nil}]}]})
(defn where-clause
"Generate an appropriate `where` clause for queries on this `entity`;
if `properties` are passed, filter on those properties, otherwise the key
@ -140,7 +139,7 @@
pretty-name (singularise entity-name)
query-name (str "search-strings-" pretty-name)
signature ":? :1"
properties (all-properties entity)]
properties (remove #(#{"link"}(:type (:attrs %))) (all-properties entity))]
(hash-map
(keyword query-name)
{:name query-name
@ -213,8 +212,6 @@
#(select-query entity %)
(combinations distinct-fields (count distinct-fields))))))))
(select-query electors)
(defn list-query
"Generate a query to list records in the table represented by this `entity`.
@ -246,15 +243,14 @@
(defn foreign-queries
[entity application]
(let [entity-name (:name (:attrs entity))
pretty-name (singularise entity-name)
links (filter #(-> % :attrs :entity) (children entity #(= (:tag %) :property)))]
links (filter #(#{"link" "entity"} (:type (:attrs %))) (children-with-tag entity :property))]
(apply
merge
(map
#(let [far-name (-> % :attrs :entity)
#(let [far-name (:entity (:attrs %))
far-entity (first
(children
application
@ -264,6 +260,7 @@
(= (:name (:attrs x)) far-name)))))
pretty-far (singularise far-name)
farkey (-> % :attrs :farkey)
link-type (-> % :attrs :type)
link-field (-> % :attrs :name)
query-name (str "list-" entity-name "-by-" pretty-far)
signature ":? :*"]
@ -279,15 +276,26 @@
"\n"
(remove
empty?
(list
(case link-type
"entity" (list
(str "-- :name " query-name " " signature)
(str "-- :doc lists all existing " pretty-name " records related to a given " pretty-far)
(str "SELECT * \nFROM " entity-name)
(str "WHERE " entity-name "." link-field " = :id")
(order-by-clause entity))))}))
(order-by-clause entity))
"link" (let [link-table-name
(link-table-name entity far-entity)]
(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 "WHERE " entity-name "." link-field " = " 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 " %)))))
}))
links))))
(defn link-table-query
"Generate a query which links across the entity passed as `link`
from the entity passed as `near` to the entity passed as `far`.
@ -328,8 +336,8 @@
(str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far )
(str "SELECT "near-name ".*")
(str "FROM " near-name ", " link-name )
(str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (-> (links (keyword near-name)) :attrs :name) )
("\tAND " link-name "." (-> (links (keyword far-name)) :attrs :name) " = :id")
(str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (singularise near-name) "_id" )
("\tAND " link-name "." (singularise far-name) "_id = :id")
(order-by-clause near))))}))))
@ -389,14 +397,13 @@
no entity is specified, generate all queris for the application."
([application entity]
(merge
{}
(insert-query entity)
(update-query entity)
(delete-query entity)
(if
(link-table? entity)
(link-table-queries entity application)
{})
(insert-query entity)
(update-query entity)
(delete-query entity)
(select-query entity)
(list-query entity)
(search-query entity)

8
src/adl/to_selmer_routes.clj
View file

@ -44,7 +44,7 @@
(list
'ns
(symbol (str (:name (:attrs application)) ".routes.auto"))
(str "JSON routes for " (pretty-name application)
(str "User interface routes for " (pretty-name application)
" auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
(f/unparse (f/formatters :basic-date-time) (t/now)))
(list
@ -55,7 +55,7 @@
'[ring.util.http-response :as response]
'[clojure.java.io :as io]
'[hugsql.core :as hugsql]
(vector (symbol (str parent-name ".db.core")) :as 'db)
(vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db)
(vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
(defn make-handler
@ -173,7 +173,3 @@
(pprint (make-defroutes application))
(println)))))
(def x (x/parse "../youyesyet/youyesyet.canonical.adl.xml"))
(to-selmer-routes x)

5
src/adl/utils.clj
View file

@ -27,6 +27,11 @@
;;;; Copyright (C) 2018 Simon Brooke
;;;;
(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)))))
(defn children
"Return the children of this `element`; if `predicate` is passed, return only those