MY MONSTER IT LIVES!

src/adl/main.clj

@@ -44,7 +44,7 @@
     (.exists (java.io.File. (first args)))
     (let [application (x/parse (first args))]
       (h/to-hugsql-queries application)
-      ;; (j/to-json-routes application)
+      (j/to-json-routes application)
       (s/to-selmer-routes application)
       (t/to-selmer-templates application))))
 

src/adl/to_json_routes.clj

@@ -1,11 +1,14 @@
 (ns ^{:doc "Application Description Language: generate RING routes for REST requests."
       :author "Simon Brooke"}
   adl.to-json-routes
-  (:require [clojure.java.io :refer [file]]
+  (: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.utils :refer :all]
+            [adl.to-hugsql-queries :refer [queries]]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;
@@ -34,11 +37,12 @@
 ;;; to-hugsql-queries, because essentially we need one JSON entry point to wrap
 ;;; each query.
 
-(defn file-header [parent-name this-name]
+
+(defn file-header [application]
   (list
     'ns
-    (symbol (str parent-name ".routes." this-name))
+    (symbol (str (safe-name (:name (:attrs application))) ".routes.auto-json"))
-    (str "JSON routes for " parent-name
+    (str "JSON routes for " (:name (:attrs 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
@@ -49,15 +53,11 @@
       '[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 (safe-name (:name (:attrs application))) ".db.core")) :as 'db))))
-
-
-(defn make-safe-name [string]
-  (s/replace string #"[^a-zA-Z0-9-]" ""))
 
 
 (defn declarations [handlers-map]
-  (cons 'declare (sort (map #(symbol (make-safe-name (name %))) (keys handlers-map)))))
+  (cons 'declare (sort (map #(symbol (name %)) (keys handlers-map)))))
 
 
 (defn generate-handler-src
@@ -81,12 +81,12 @@
 
 
 (defn handler
-  "Generate declarations for handlers from query with this `query-key` in this `queries-map` taken from within
+  "Generate declarations for handlers from query with this `query-key` in this `queries-map`
-  this `entities-map`. This method must follow the structure of
+  taken from within this `application`. This method must follow the structure of
   `to-hugsql-queries/queries` quite closely, because we must generate the same names."
-  [query-key queries-map entities-map]
+  [query-key queries-map application]
   (let [query (query-key queries-map)
-        handler-name (symbol (make-safe-name (name query-key)))]
+        handler-name (symbol (name query-key))]
     (hash-map
       (keyword handler-name)
       (merge
@@ -182,6 +182,7 @@
 
 
 (defn defroutes [handlers-map]
+  "Generate JSON routes for all queries implied by this ADL `application` spec."
   (cons
     'defroutes
     (cons
@@ -190,7 +191,7 @@
         #(let [handler (handlers-map %)]
            (list
              (symbol (s/upper-case (name (:method handler))))
-             (str "/json/auto/" (:name handler))
+             (str "/json/auto/" (safe-name (:name handler)))
              'request
               (list
                 'route/restricted
@@ -199,39 +200,46 @@
           (keys handlers-map))))))
 
 
-;; (defn migrations-to-json-routes
+(defn make-handlers-map
-;;   ([migrations-path parent-namespace-name]
+  [application]
-;;    (migrations-to-json-routes migrations-path parent-namespace-name "auto-json-routes"))
+  (reduce
-;;   ([migrations-path parent-namespace-name namespace-name]
+    merge
-;;    (let [output (str (s/replace namespace-name #"-" "_") ".clj")
+    {}
-;;          adl-struct (migrations-to-xml migrations-path "Ignored")
+    (map
-;;          q (reduce
+      (fn [e]
-;;              merge
+        (let [qmap (queries application e)]
-;;              {}
+          (reduce
-;;              (map
+            merge
-;;                #(queries % adl-struct)
+            {}
-;;                (vals adl-struct)))
+            (map
-;;          h (reduce
+              (fn [k]
-;;              merge
+                (handler k qmap application))
-;;              {}
+              (keys qmap)))))
-;;              (map
+      (children-with-tag application :entity))))
-;;                #(handler % q adl-struct)
+
-;;                (keys q)))
+
-;;          f (cons
+(defn to-json-routes
-;;              (file-header parent-namespace-name namespace-name)
+  [application]
-;;              ;;                          (pre-declare
+  (let [handlers-map (make-handlers-map application)
-;;              (cons
+        filepath (str *output-path* (:name (:attrs application)) "/routes/auto_json.clj")]
-;;                (declarations h)
+    (make-parents filepath)
-;;                (cons
+    (with-open [output (writer filepath)]
-;;                  (defroutes h)
+      (binding [*out* output]
-;;                  (map #(:src (h %)) (sort (keys h))))))]
+        (doall
-;;      (spit
+          (map
-;;        output
+            (fn [f]
-;;        (with-out-str
+              (pprint f)
-;;          (doall
+              (println "\n"))
-;;            (for [expr f]
+            (list
-;;              (do
+              (file-header application)
-;;                (pprint expr)
+              (declarations handlers-map)
-;;                (print "\n\n"))))))
+              (defroutes handlers-map))))
-;;      f
+        (doall
-;;      )))
+          (map
+            (fn [h]
+              (pprint (:src (handlers-map h)))
+              (println)
+              h)
+            (sort (keys handlers-map))))))))
+
+

src/adl/to_selmer_routes.clj

@@ -50,6 +50,7 @@
       '[ring.util.http-response :as response]
       '[clojure.java.io :as io]
       '[hugsql.core :as hugsql]
+      (vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l)
       (vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db)
       (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
 
@@ -62,7 +63,7 @@
       (vector 'r)
       (list 'let (vector 'p (list :form-params 'r))
             (list
-              'layout/render
+              'l/render
               (list 'resolve-template (str n ".html"))
               (merge
                 {:title (capitalise (:name (:attrs f)))
@@ -79,7 +80,7 @@
                    (list
                      (symbol
                        (str
-                         "db/search-"
+                         "db/search-strings-"
                          (singularise (:name (:attrs e)))))
                      'p)})))))))
 
@@ -111,13 +112,38 @@
       'defroutes
       (cons
         'auto-selmer-routes
-        (interleave
+        (cons
-          (map
+          '(GET
-            (fn [r] (make-route 'GET r))
+             "/index"
-            (sort routes))
+             request
-        (map
+             (route/restricted
-          (fn [r] (make-route 'POST r))
+               (apply (resolve-handler "index") (list request))))
-          (sort routes)))))))
+          (interleave
+            (map
+              (fn [r] (make-route 'GET r))
+              (sort routes))
+            (map
+              (fn [r] (make-route 'POST r))
+              (sort routes))))))))
+
+
+(defn generate-handler-resolver
+  "Dodgy, dodgy, dodgy. Generate code which will look up functions in the
+  manual and in this namespace. I'm sure someone who really knew what they
+  were doing could write this more elegantly."
+  [application]
+  (list
+    'defn
+    'raw-resolve-handler
+    "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one"
+    (vector 'n)
+    (list 'try
+          (list 'eval (list 'symbol (list 'str (:name (:attrs application)) ".routes.manual/" 'n)))
+          (list 'catch
+                'Exception '_
+                (list 'eval
+                      (list 'symbol
+                            (list 'str (:name (:attrs application)) ".routes.auto/" 'n)))))))
 
 
 (defn to-selmer-routes
@@ -134,13 +160,13 @@
                      n
                      (str "auto/" n))))
         (println)
-        (pprint '(def resolve-template (memoise raw-resolve-template)))
+        (pprint '(def resolve-template (memoize raw-resolve-template)))
         (println)
         (pprint '(defn index
                    [r]
-                   (layout/render
+                   (l/render
                      (resolve-template
-                       "application-index")
+                       "application-index.html")
                      {:title "Administrative menu"})))
         (println)
         (doall
@@ -153,14 +179,8 @@
                     (println))
                   (filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))))
             (children-with-tag application :entity)))
-        (pprint '(defn raw-resolve-handler
+        (pprint
-                   "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one"
+          (generate-handler-resolver application))
-                   [n]
-                   (let [s (symbol (str "m." n))]
-                     (if
-                       (bound? s)
-                       (eval s)
-                       (eval (symbol n))))))
         (println)
         (pprint '(def resolve-handler
                    (memoize raw-resolve-handler)))

src/adl/to_selmer_templates.clj

@@ -90,7 +90,7 @@
      "\n"
      (flatten
        (list
-         "{% extends \"templates/base.html\" %}"
+         "{% extends \"base.html\" %}"
          (str "<!-- File "
               filename
               " generated "

src/adl/utils.clj

@@ -181,6 +181,19 @@
 
 
 
+(defn safe-name
+  ([string]
+    (s/replace string #"[^a-zA-Z0-9-]" ""))
+  ([string convention]
+   (case convention
+     (:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_")
+     :c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")
+     :java (let
+             [camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")]
+             (apply str (cons (Character/toUpperCase (first camel)) (rest camel))))
+     (safe-name string))))
+
+
 (defn link-table?
   "Return true if this `entity` represents a link table."
   [entity]