Added more if-member-of checks; added simplemde support.

resources/js/text-area-md-support.js

@@ -0,0 +1,17 @@
+          var simplemde = new SimpleMDE({
+            autosave: {
+              enabled: true,
+              uniqueId: "Smeagol-{{page}}",
+              delay: 1000,
+            },
+            indentWithTabs: true,
+            insertTexts: {
+              horizontalRule: ["", "\n\n-----\n\n"],
+              image: ["![](http://", ")"],
+              link: ["[", "](http://)"],
+              table: ["", "\n\n| Column 1 | Column 2 | Column 3 |\n| -------- | -------- | -------- |\n| Text     | Text      | Text     |\n\n"],
+            },
+            showIcons: ["code"], //, "table"], - sadly, markdown-clj does not support tables
+	          spellChecker: true,
+	          status: ["autosave", "lines", "words", "cursor"]
+          });

src/adl/to_selmer_templates.clj

@@ -59,27 +59,49 @@
 
 
 (defn emit-content
+  ([content]
+   (cond
+     (nil? content)
+     nil
+     (string? content)
+     content
+     (and (map? content) (:tag content))
+     (with-out-str
+       (x/emit-element content))
+     (seq? content)
+     (map emit-content content)
+     true
+     (str "<!-- don't know what to do with '" content "' -->")))
   ([filename application k]
    (emit-content filename nil nil application k))
   ([filename spec entity application k]
    (let [content
          (:content
-          (first
+           (first
-           (or (children-with-tag spec k)
+             (or (children-with-tag spec k)
-               (children-with-tag entity k)
+                 (children-with-tag entity k)
-               (children-with-tag
+                 (children-with-tag
-                (child-with-tag application :content)
+                   (child-with-tag application :content)
-                k))))]
+                   k))))]
      (if
        content
        (flatten
-        (list
+         (list
-         (str "{% block " (name k) " %}")
+           (str "{% block " (name k) " %}")
-         (doall
+           (doall
-          (map
+             (map
-           #(with-out-str (x/emit-element %))
+               emit-content
-           content))
+               content))
-         "{% endblock %}"))))))
+           "{% endblock %}"))))))
+
+;; {:tag :div, :content
+;;  [{:tag :div, :attrs {:class big-link-container}, :content
+;;    [{:tag :a, :attrs {:id next-selector, :role button, :class big-link},
+;;      :content [Next]}]}
+;;   [{% ifmemberof admin %}
+;;    {:tag :div, :attrs {:class big-link-container}, :content
+;;      [{:tag :a, :attrs {:href form-electors-Elector, :class big-link}, :content [Add a new Elector]}]}
+;;    {% endifmemberof %}]]}
 
 
 (defn file-header
@@ -141,22 +163,56 @@
   "{% csrf-field %}")
 
 
+(defn compose-if-member-of-tag
+  [writable? & elts]
+  (let
+    [all-permissions (distinct (apply find-permissions elts))
+     permissions (map
+                   s/lower-case
+                   (if
+                     writable?
+                     (writable-by all-permissions)
+                     (visible-to all-permissions)))]
+    (s/join
+     " "
+     (flatten
+      (list
+       "{% ifmemberof"
+       permissions
+       "%}")))))
+
+
+(defn wrap-in-if-member-of
+  "Wrap this `content` in an if-member-of tag; if `writable?` is true,
+  allow those groups by whom it is writable, else those by whom it is
+  readable. `context` should be a sequence of adl elements from which
+  permissions may be obtained."
+  [content writable? & context]
+  [(apply compose-if-member-of-tag (cons writable? context))
+   content
+   "{% endifmemberof %}"])
+
+
 (defn save-widget
   "Return an appropriate 'save' widget for this `form` operating on this `entity` taken
   from this `application`.
   TODO: should be suppressed unless a member of a group which can insert or edit."
   [form entity application]
-  {:tag :p
+  (wrap-in-if-member-of
-   :attrs {:class "widget action-safe"}
+    {:tag :p
-   :content [{:tag :label
+     :attrs {:class "widget action-safe"}
-              :attrs {:for "save-button" :class "action-safe"}
+     :content [{:tag :label
-              :content [(str "To save this " (:name (:attrs entity)) " record")]}
+                :attrs {:for "save-button" :class "action-safe"}
-             {:tag :input
+                :content [(str "To save this " (:name (:attrs entity)) " record")]}
-              :attrs {:id "save-button"
+               {:tag :input
-                      :name "save-button"
+                :attrs {:id "save-button"
-                      :class "action-safe"
+                        :name "save-button"
-                      :type "submit"
+                        :class "action-safe"
-                      :value (str "Save!")}}]})
+                        :type "submit"
+                        :value (str "Save!")}}]}
+    true
+    entity
+    application))
 
 
 (defn delete-widget
@@ -164,17 +220,21 @@
   from this `application`.
   TODO: should be suppressed unless member of a group which can delete."
   [form entity application]
-  {:tag :p
+  (wrap-in-if-member-of
-   :attrs {:class "widget action-dangerous"}
+    {:tag :p
-   :content [{:tag :label
+     :attrs {:class "widget action-dangerous"}
-              :attrs {:for "delete-button" :class "action-dangerous"}
+     :content [{:tag :label
-              :content [(str "To delete this " (:name (:attrs entity)) " record")]}
+                :attrs {:for "delete-button" :class "action-dangerous"}
-             {:tag :input
+                :content [(str "To delete this " (:name (:attrs entity)) " record")]}
-              :attrs {:id "delete-button"
+               {:tag :input
-                      :name "delete-button"
+                :attrs {:id "delete-button"
-                      :class "action-dangerous"
+                        :name "delete-button"
-                      :type "submit"
+                        :class "action-dangerous"
-                      :value (str "Delete!")}}]})
+                        :type "submit"
+                        :value (str "Delete!")}}]}
+    true
+    entity
+    application))
 
 
 (defn get-options
@@ -224,7 +284,8 @@
          "boolean" "checkbox"
          "date" "date"
          "time" "time"
-         "text" ;; default
+         "text" "text-area"
+         "string" ;; default
          )))))
 
 
@@ -275,25 +336,6 @@
               :content (apply vector (get-options property form entity application))}))))}))
 
 
-(defn compose-if-member-of-tag
-  [property entity application writable?]
-  (let
-    [all-permissions (find-permissions property entity application)
-     permissions (map
-                   s/lower-case
-                   (if
-                     writable?
-                     (writable-by all-permissions)
-                     (visible-to all-permissions)))]
-    (s/join
-     " "
-     (flatten
-      (list
-       "{% ifmemberof"
-       permissions
-       "%}")))))
-
-
 (defn compose-widget-para
   [p f e a w content]
   {:tag :p
@@ -301,10 +343,10 @@
    :content [{:tag :label
               :attrs {:for w}
               :content [(prompt p f e a)]}
-             (compose-if-member-of-tag p e a true)
+             (compose-if-member-of-tag true p e a)
              content
              "{% else %}"
-             (compose-if-member-of-tag p e a false)
+             (compose-if-member-of-tag false p e a)
              {:tag :span
               :attrs {:id w
                       :name w
@@ -352,6 +394,12 @@
       "select"
       (compose-widget-para field-or-property form entity application widget-name
                            (select-widget property form entity application))
+      "text-area"
+      (compose-widget-para
+        field-or-property form entity application widget-name
+        {:tag :textarea
+         :attrs {:rows "8" :cols "60" :id widget-name :name widget-name}
+         :content [(str "{{record." widget-name "}}")]})
       ;; all others
       (compose-widget-para
         field-or-property form entity application widget-name
@@ -380,18 +428,23 @@
                     {:max (:maximum (:attrs typedef))}))}))))
 
 
-(defn compose-select-script-header [entity application]
+(defn embed-script-fragment
-  {:tag :script :attrs {:type "text/javascript"}
+  "Return the content of the file at `fielpath`, with these `substitutions`
-    :content
+  made into it in order. Substitutions should be pairss [`pattern` `value`],
-    [(slurp "resources/js/select-widget-support.js")]})
+  where `pattern` is a string, a char, or a regular expression."
+  ([filepath substitutions]
+   (let [v (slurp filepath)]
+     (reduce
+       (fn [s [pattern value]]
+         (s/replace s pattern value))
+       v
+       substitutions)))
+  ([filepath]
+   (embed-script-fragment filepath [])))
 
 
-(defn form-to-template
+(defn compose-form-content
-  "Generate a template as specified by this `form` element for this `entity`,
-  taken from this `application`. If `form` is nill, generate a default form
-  template for the entity."
   [form entity application]
-  (merge
     {:content
      {:tag :div
       :attrs {:id "content" :class "edit"}
@@ -415,11 +468,48 @@
                             (= (:distict (:attrs property)) :system))
                          (children-with-tag form :field)))
                      (save-widget form entity application)
-                     (delete-widget form entity application)))}]}}
+                     (delete-widget form entity application)))}]}})
-     (if
+
-       (some #(= "select" (widget-type % application)) (properties entity))
+
-       {:extra-head (compose-select-script-header entity application)}
+(defn compose-form-extra-head
-       {})))
+  [form entity application]
+  {:extra-head
+   (if
+     (some
+       #(= "text-area" (widget-type % application)) (properties entity))
+     "{% script \"js/lib/node_modules/simplemde/dist/simplemde.min.js\" %}
+     {% style \"js/lib/node_modules/simplemde/dist/simplemde.min.css\" %}")})
+
+
+ (defn compose-form-extra-tail
+   [form entity application]
+   {:extra-tail
+    {:tag :script :attrs {:type "text/javascript"}
+     :content
+     (apply
+       vector
+       (remove
+         nil?
+         (list
+           (if
+             (some
+               #(= "select" (widget-type % application)) (properties entity))
+             (embed-script-fragment  "resources/js/select-widget-support.js"))
+           (if
+             (some
+               #(= "text-area" (widget-type % application)) (properties entity))
+             (embed-script-fragment  "resources/js/text-area-md-support.js")))))}})
+
+
+(defn form-to-template
+  "Generate a template as specified by this `form` element for this `entity`,
+  taken from this `application`. If `form` is nill, generate a default form
+  template for the entity."
+  [form entity application]
+  (merge
+    (compose-form-extra-head form entity application)
+    (compose-form-content form entity application)
+    (compose-form-extra-tail form entity application)))
 
 
 (defn page-to-template
@@ -552,33 +642,43 @@
   [list-spec entity application]
   (let [form-name
         (str
-         "list-"
+          "list-"
-         (:name (:attrs entity))
+          (:name (:attrs entity))
-         "-"
+          "-"
-         (:name (:attrs list-spec)))]
+          (:name (:attrs list-spec)))]
     {:back-links
      {:tag :div
       :content
       [
-       {:tag :div :attrs {:class "back-link-container"}
+        {:tag :div :attrs {:class "back-link-container"}
-        :content
+         :content
-        ["{% ifequal params.offset \"0\" %}"
+         ["{% ifequal params.offset \"0\" %}"
           {:tag :a
-          :attrs {:id "back-link" :class "back-link" :href "{{servlet-context}}/admin"}
+           :attrs {:id "back-link" :class "back-link" :href "{{servlet-context}}/admin"}
-          :content ["Back"]}
+           :content ["Back"]}
-         "{% else %}"
+          "{% else %}"
           {:tag :a :attrs {:id "prev-selector" :class "back-link"}
-          :content ["Previous"]}
+           :content ["Previous"]}
-         "{% endifunequal %}"]}
+          "{% endifunequal %}"]}
-       ]}
+        ]}
      :big-links
      {:tag :div
       :content
-      [{:tag :div :attrs {:class "big-link-container"}
+      (apply
-        :content
+        vector
-        [{:tag :a :attrs {:id "next-selector" :role "button" :class "big-link"}
+        (remove
-          :content ["Next"]}]}
+          nil?
-       (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))]}
+          (flatten
+            (list
+              {:tag :div :attrs {:class "big-link-container"}
+               :content
+               [{:tag :a :attrs {:id "next-selector" :role "button" :class "big-link"}
+                 :content ["Next"]}]}
+              (wrap-in-if-member-of
+                (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))
+                true
+                entity
+                application)))))}
      :content
      {:tag :form
       :attrs {:id form-name :class "list"
@@ -591,30 +691,30 @@
        {:tag :table
         :attrs {:caption (:name (:attrs entity))}
         :content
-          [(list-thead list-spec entity application)
+        [(list-thead list-spec entity application)
-           (list-tbody list-spec entity application)
+         (list-tbody list-spec entity application)
-           ]}]}
+         ]}]}
      :extra-script
      (str "
           var form = document.getElementById('" form-name "');
           var ow = document.getElementById('offset');
           var lw = document.getElementById('limit');
           form.addEventListener('submit', function() {
-            ow.value='0';
+          ow.value='0';
           });
 
           {% ifunequal params.offset \"0\" %}
           document.getElementById('prev-selector').addEventListener('click', function () {
-            ow.value=(parseInt(ow.value)-parseInt(lw.value));
+          ow.value=(parseInt(ow.value)-parseInt(lw.value));
-            console.log('Updated offset to ' + ow.value);
+          console.log('Updated offset to ' + ow.value);
-            form.submit();
+          form.submit();
           });
           {% endifunequal %}
 
           document.getElementById('next-selector').addEventListener('click', function () {
-            ow.value=(parseInt(ow.value)+parseInt(lw.value));
+          ow.value=(parseInt(ow.value)+parseInt(lw.value));
-            console.log('Updated offset to ' + ow.value);
+          console.log('Updated offset to ' + ow.value);
-            form.submit();
+          form.submit();
           });")}))
 
 
@@ -654,43 +754,63 @@
            (form-to-template nil entity application)})))))
 
 
-(defn application-to-template
+(defn emit-entity-dt
-  [application]
+  [entity application]
-  (let
+  (wrap-in-if-member-of
-    [first-class-entities
+   {:tag :dt
-     (sort-by
+    :content
-      #(:name (:attrs %))
+    [{:tag :a
-      (filter
+      :attrs {:href (path-part :list entity application)}
-       #(children-with-tag % :list)
+      :content [(pretty-name entity)]}]}
-       (children-with-tag application :entity)))]
+    false
-    {:application-index
+    entity
-     {:content
+    application))
-      {:tag :dl
+
-       :attrs {:class "index"}
+
-       :content
+(defn emit-entity-dd
-       (apply
+  [entity application]
-        vector
+  (wrap-in-if-member-of
-        (interleave
+    {:tag :dd
-         (map
+     :content
-          #(hash-map
+     (apply
-            :tag :dt
+       vector
-            :content
+       (map
-            [{:tag :a
+         (fn [d]
-              :attrs {:href (path-part :list % application)}
+           (hash-map
-              :content [(pretty-name %)]}])
+             :tag :p
-          first-class-entities)
+             :content (:content d)))
-         (map
+         (children-with-tag entity :documentation)))}
-          #(hash-map
+    false
-            :tag :dd
+    entity
-            :content (apply
+    application))
-                      vector
+
-                      (map
+
-                       (fn [d]
+    (defn application-to-template
-                         (hash-map
+      [application]
-                          :tag :p
+      (let
-                          :content (:content d)))
+        [first-class-entities
-                       (children-with-tag % :documentation))))
+         (sort-by
-          first-class-entities)))}}}))
+           #(:name (:attrs %))
+           (filter
+             #(children-with-tag % :list)
+             (children-with-tag application :entity)))]
+        {:application-index
+         {:content
+          {:tag :dl
+           :attrs {:class "index"}
+           :content
+           (apply
+             vector
+             (remove
+               nil?
+               (flatten
+                 (interleave
+                   (map
+                     #(emit-entity-dt % application)
+                     first-class-entities)
+                   (map
+                     #(emit-entity-dd % application)
+                     first-class-entities)))))}}}))
 
 
 (defn write-template-file
@@ -712,13 +832,7 @@
                 #(let [content (template %)]
                    (list
                     (str "{% block " (name %) " %}")
-                    (cond (string? content)
+                    (emit-content content)
-                          content
-                          (map? content)
-                          (with-out-str
-                            (x/emit-element content))
-                          true
-                          (str "<!-- don't know what to do with '" content "' -->"))
                     "{% endblock %}"))
                    (keys template)))
               (file-footer filename application)))))