Commits

Anonymous committed 179b0e1

Moved source files to new locations.

Comments (0)

Files changed (21)

neman/cells/src/net/ksojat/neman/cells.clj

+;; Copyright (c) 2009 Krešimir Šojat. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns net.ksojat.neman.cells
+  (:import (clojure.lang IRef)))
+
+;;
+;; Cell class
+;;
+
+(gen-class
+  :name        net.ksojat.neman.cells.Cell
+  :implements  [clojure.lang.IRef]
+  :state        state
+  :init         Cell-init
+  :constructors {[clojure.lang.IPersistentMap] []})
+
+(defn -Cell-init [init]
+  [[] (ref (merge {:value nil :parents {} :triggers []} init))])
+
+(defn -get [this]
+  (get @(.state this) :value))
+
+(defn -setValidator [this validator-fn]
+  (.. this state (setValidator validator-fn)))
+
+(defn -getValidator [this]
+  (.. this state getValidator))
+
+(defn -addWatch [this watcher action send-off]
+  (.. this state (addWatch watcher action send-off)))
+
+(defn -removeWatch [this watcher]
+  (.. this state (removeWatch watcher)))
+
+(defn -notifyWatches [this]
+  (.. this state notifyWatches))
+
+;;
+;; Property Listeners
+;;
+
+(defmulti add-listener
+  (fn [object property callback] [(class object) property]))
+
+(defmulti remove-listener
+  (fn [object listener] [(class object) (class listener)]))
+
+(import '(javax.swing JTextField)
+        '(java.awt.event ActionListener ActionEvent))
+
+(defmethod add-listener [JTextField :text] [object _ callback]
+  (let [listener (proxy [ActionListener] []
+                   (actionPerformed [#^ActionEvent e]
+                     (callback)))]
+    (.addActionListener object listener)
+    listener))
+
+(defmethod remove-listener [JTextField ActionListener] [object listener]
+  (.removeActionListener object listener))
+
+;;
+;;
+;;
+
+(defn add-parent-watcher [parent update-fn]
+  (if (vector? parent)
+    (let [[object property] parent]
+      (add-listener object property update-fn))
+    (let [watcher (agent nil)]
+      (add-watcher parent :send watcher (fn [& _] (update-fn)))
+      watcher)))
+
+(defn remove-parent-watcher [parent watcher]
+  (if (instance? IRef parent)
+    (remove-watcher  parent watcher)
+    (remove-listener parent watcher)))
+
+(defn parent-value [parent]
+  (if (vector? parent)
+    (let [[object property] parent]
+      (property (bean object)))
+    (deref parent)))
+
+(defmacro alter-cell [cell parents bindings expr]
+  `(let [cell# ~cell
+         f# (fn []
+              (let
+                ~(vec (interleave bindings (map #(do `(parent-value ~%)) parents)))
+                ~expr))
+         update# (fn []
+                   (let [ov# (deref cell#), nv# (f#)]
+                     (when (not= ov# nv#)
+                       (dosync (alter (.state cell#) assoc :value nv#))
+                       (doseq [t# (:triggers @(.state cell#))] (t# ov# nv#)))))]
+     ; Remove watchers from old parents
+     (doseq [[r# w#] (:parents @(.state cell#))]
+       (remove-parent-watcher r# w#))
+
+     ; Add watchers to new parents.
+     (let [new-w# (map (fn [p#] (add-parent-watcher p# update#)) ~parents)
+           new-p# (apply hash-map (interleave ~parents new-w#))]
+       (doall new-w#)
+       (dosync
+         (alter (.state cell#) assoc :parents new-p#))
+       (doall new-p#))
+
+     (update#)
+     cell#))
+
+(defmacro cell
+  ([parents bindings expr]
+    `(alter-cell (net.ksojat.neman.cells.Cell. {}) ~parents ~bindings ~expr))
+  ([init-val]
+    `(net.ksojat.neman.cells.Cell. {:value ~init-val})))
+
+;(defn add-trigger [cell trigger-fn]
+;  (dosync
+;    (alter (.state cell) update-in [:triggers] conj trigger-fn))
+;  trigger-fn)
+
+(defn add-trigger [cell trigger-fn]
+  (dosync
+    (alter (.state cell) update-in [:triggers] conj trigger-fn))
+  trigger-fn)
+
+;(defn remove-trigger [cell trigger-fn]
+;  
+
+;; TODO: add special :this parent, so cells can be accumulators
+
+(comment
+  (def a (ref 1))
+  (def b (ref 2))
+
+  (def x (cell [a b] [v1 v2] (+ v1 v2)))
+  (println @a) (println @b) (println @x)
+  ; 1
+  ; 2
+  ; 3
+
+  (dosync (ref-set a 100))
+  (println @a) (println @x)
+  ; 100
+  ; 102
+
+  (alter-cell x [b] [v] (inc b))
+  (println @x)
+  ; 3
+
+  ;
+  ; Depending on object property
+  ;
+  (def tw (javax.swing.JTextField.))
+  (def fw (javax.swing.JFrame.))
+  (doto fw
+    (.add tw) .pack .show)
+
+  ; Cell is updated when text property of JTextField widget is changed.
+  (def c1 (cell [[tw :text]] [t] (str "Text is: " t)))
+  (add-trigger c1
+    (fn [old-v new-v]
+      (println old-v)
+      (println new-v)))
+
+  ; circular dependancies.
+  (def a (Cell. {:value 5}))
+  (def b (cell [a] [v] (dec v)))
+  (add-trigger a
+    (fn [old-v new-v]
+      (println (str "Cell a changed from: " old-v " to " new-v))))
+  (add-trigger b
+    (fn [old-v new-v]
+      (println (str "Cell b changed from: " old-v " to " new-v))))
+  (alter-cell a [b] [v] (if (< v 0) 0 v))
+)

neman/core/src/net/ksojat/neman/core.clj

+;; Copyright (c) 2008 Krešimir Šojat. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns net.ksojat.neman.core
+  (:import (clojure.lang RT Reflector)
+           (java.util UUID)))
+
+(defn str-join [s & strings]
+  (str (interpose s strings)))
+
+(defn resource-url [res]
+  (when res (.getResource (RT/baseLoader) res)))
+
+;(defn resource-url [& res]
+;  (when-let [res (apply str-join "/" res)]
+;    (.getResource (RT/baseLoader) res)))
+
+(defn resource-as-stream [res]
+  (when res (.getResourceAsStream (RT/baseLoader) res)))
+
+;(defn resource-as-stream [& res]
+;  (when-let [res (apply str-join "/" res)]
+;    (.getResource (RT/baseLoader) res)))
+
+;(defn resource-as-file [res]
+;  (when-let [res (apply str-join "/" res)]
+;    (when-let [res (.ge
+
+;(defn resource-as-file [& res]
+;  (when-let [res (apply resource-url res)]
+;    (.getFile res)))
+
+(defn resource-as-file [res]
+  (when-let [res (resource-url res)] (.getFile res)))
+
+(defn uuid
+  ([]         (UUID/randomUUID))
+  ([uuid-str] (UUID/fromString uuid-str)))
+
+(defn throw-illegal-argument [& args]
+  (throw (IllegalArgumentException. (apply str args))))
+
+(defn throw-exception [& args]
+  (throw (Exception. (apply str args))))
+
+(defn not-nil? [v]
+  (not= v nil))
+
+(defn system-property
+  ([name]       (System/getProperty name))
+  ([name value] (System/setProperty name value)))
+
+(defn static-field [cls field]
+  (Reflector/getStaticField cls field))
+
+(defn kw-enum
+  ([cls field]
+    (if (keyword? field)
+      (static-field cls (.. (name field) toUpperCase (replace "-" "_")))
+      field))
+
+  ([cls prefix field]
+    (if (keyword? field)
+      (static-field cls (.. (str prefix "_" (name field)) toUpperCase (replace "-" "_")))
+      field)))
+
+(defn into-array-of [type s]
+  (let [c (count s), a (make-array type c)]
+    (doseq [i (range c)] (aset a i (nth s i)))
+    a))
+
+;; 'flatten' written by Rich Hickey,
+;; see http://groups.google.com/group/clojure/msg/385098fabfcaad9b
+(defn flatten
+  "Takes any nested combination of sequential things (lists, vectors,
+  etc.) and returns their contents as a single, flat sequence.
+  (flatten nil) returns nil."
+  [x]
+  (filter (complement sequential?)
+          (rest (tree-seq sequential? seq x))))
+
+(defn- make-args [x]
+  (if x (to-array x) RT/EMPTY_ARRAY))
+
+(defn- arglist [x]
+  (if (seq? x) x (list x)))
+
+(defmulti
+  ctor (fn [x] (if (vector? x) (first x) x)))
+
+(defmethod ctor :default [x]
+  (if (vector? x)
+    (let [[o & args] x]
+      (Reflector/invokeConstructor o (make-args args)))
+    x))
+
+; Default builder contructor binding.
+(def *ctor* #'ctor)
+
+(defmulti
+  #^{:doc "Class method 'monkey patching' system used by => macro."}
+  patch (fn [object method & args] [(class object) method]))
+
+(defmethod patch :default [object method & args]
+  (Reflector/invokeInstanceMethod object (name method) (make-args args)))
+
+(defmulti default-method (fn [x t] [(class x) t]))
+(defmethod default-method :default [& _] nil)
+
+(defn last-char [s]
+  (first (reverse s)))
+
+(defn drop-last-char [s]
+  (apply str (drop-last s)))
+
+(defn str-ends-with [s c]
+  (= (last-char s) c))
+
+(defn setter-symbol [x]
+  (symbol (str "set" (name x))))
+
+(defn- mquote [x]
+  (list 'quote x))
+
+(defmacro => [x & members]
+  (let [gx (gensym)
+        x `(*ctor* ~x)
+        map-dm (gensym)
+        vec-dm (gensym)
+        str-dm (gensym)]
+    `(let [~gx ~x
+           ~map-dm (default-method ~gx :map)
+           ~vec-dm (default-method ~gx :vector)
+           ~str-dm (default-method ~gx :string)]
+      ~@(loop [mx members, p nil]
+          (if mx
+            (let [m (first mx)]
+              (cond
+                (keyword? m)
+                  (recur
+                    (rrest mx)
+                    (cons
+                      (concat
+                        (list 'patch gx (mquote (setter-symbol m)))
+                        (if (vector? (second mx))
+                          (second mx)
+                          (list (second mx))))
+                      p))
+                (map? m)
+                  (recur (rest mx) (cons (list 'patch gx map-dm m) p))
+                (string? m)
+                  (recur (rest mx) (cons (list 'patch gx str-dm m) p))
+                (vector? m)
+                  (let [calls (map
+                                #(concat
+                                  (list 'patch gx vec-dm)
+                                  (if (vector? %) % (list %)))
+                                m)]
+                    (recur (rest mx) (concat (reverse calls) p)))
+                :else
+                  (if (str-ends-with (name (first m)) \+)
+                    (let [mn (symbol (drop-last-char (name (first m))))
+                          calls (map
+                                  #(concat
+                                    (list 'patch gx (mquote (first m))) %)
+                                  (rest m))]
+                      (recur (rest mx) (concat (reverse calls) p)))
+                    (recur
+                      (rest mx)
+                      (cons
+                        (concat
+                          (list 'patch gx (mquote (first m))) (rest m))
+                        p)))))
+            (reverse p)))
+      ~gx)))
+
+(defmacro let-builder-ids
+  ([x]
+    `(let-builder-vars {:id :Id :result :toplevel} ~x))
+
+  ([{id :id result :result} x]
+    `(do ~x)))

neman/json/src/net/ksojat/neman/json.clj

+;; Copyright (c) 2008 Krešimir Šojat. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+;;
+;; Simple wrapper for jackson (http://jackson.codehaus.org/)
+;; library.
+
+(ns net.ksojat.neman.json
+  (:refer-clojure :exclude [read read-string])
+  (:use net.ksojat.neman.core)
+  (:import
+    (org.codehaus.jackson JsonFactory JsonToken)
+    (java.io FileReader FileWriter BufferedWriter StringReader StringWriter)))
+
+;; Helpers
+
+(defn boolean? [n]
+  (instance? Boolean n))
+
+(defn file-reader [pathname]
+  (new FileReader pathname))
+
+(defn file-writer
+  ([pathname]        (FileWriter. pathname))
+  ([pathname append] (FileWriter. pathname append)))
+
+(def *factory* (JsonFactory.))
+
+;;
+;; Reader functions
+;;
+
+(defn reader[source]
+  (.createJsonParser *factory* source))
+
+(defn- current-token [reader]
+  (.getCurrentToken reader))
+
+(defn- next-token [reader]
+  (.nextToken reader))
+
+(defn- get-keyword [reader]
+  (keyword (.getText reader)))
+
+; Forward declaration
+(def read-nested)
+
+(defn- read-array [reader]
+  (next-token reader)
+  (loop [array []]
+    (if (= JsonToken/END_ARRAY (current-token reader))
+        array
+        (recur (conj array (read-nested reader))))))
+
+(defn- read-attr [reader object]
+  (assoc object
+         (get-keyword reader)
+         (do
+           (next-token  reader)
+           (read-nested reader))))
+
+(defn- read-object [reader]
+  (next-token reader)
+  (loop [object {}]
+    (if (= JsonToken/END_OBJECT (current-token reader))
+        object
+        (recur (read-attr reader object)))))
+
+(defn- read-nested [reader]
+  (let [token  (current-token reader)
+        token= #(= token %)
+        value
+          (cond
+            (token= JsonToken/VALUE_NULL)         nil
+            (token= JsonToken/VALUE_FALSE)        false
+            (token= JsonToken/VALUE_TRUE)         true
+            (token= JsonToken/VALUE_NUMBER_FLOAT) (.getDoubleValue reader)
+            (token= JsonToken/VALUE_NUMBER_INT)   (.getIntValue    reader)
+            (token= JsonToken/VALUE_STRING)       (.getText        reader)
+            (token= JsonToken/START_OBJECT)       (read-object reader)
+            (token= JsonToken/START_ARRAY)        (read-array  reader))]
+    (next-token reader)
+    value))
+
+(defn read [reader]
+  (let [node  (next-token reader)
+        node= #(= node %)]
+    (cond
+      (node= JsonToken/START_OBJECT) (read-object reader)
+      (node= JsonToken/START_ARRAY)  (read-array  reader))))
+
+(defn read-stream [s]
+  (let [jr (reader s), res (read jr)]
+    (.close jr) res))
+
+; TODO: Uzmi da koristi read-stream
+(defn read-file [pathname]
+  (let [file-reader (FileReader. pathname)
+        json-reader (reader file-reader)
+        result      (read json-reader)]
+    (.close json-reader)
+    result))
+
+(defn read-string [s]
+  (read-stream (StringReader. s)))
+
+;;
+;; Writer functions
+;;
+
+(defn writer
+  ([target]
+    (doto (.createJsonGenerator *factory* target)
+      (.useDefaultPrettyPrinter)))
+
+  ([target enc]
+    (doto (.createJsonGenerator *factory* target enc)
+      (.useDefaultPrettyPrinter))))
+
+; Forward declaration.
+(def write-nested)
+
+(defn- write-object [writer object]
+  (.writeStartObject writer)
+  (doseq [key (keys object)]
+    (.writeFieldName writer (name key))
+    (write-nested writer (object key)))
+  (.writeEndObject writer))
+
+(defn- write-array [writer vec]
+  (.writeStartArray writer)
+  (doseq [v vec] (write-nested writer v))
+  (.writeEndArray writer))
+
+(defn- write-nested [writer x]
+  (cond
+    (nil?     x) (.writeNull    writer)
+    (string?  x) (.writeString  writer x)
+    (boolean? x) (.writeBoolean writer x)
+    (number?  x) (.writeNumber  writer x)
+    (map?     x) (write-object  writer x)
+    (vector?  x) (write-array   writer x)))
+
+(defn write [writer & body]
+  (let [[x & xs] body]
+    (cond
+      (map?    x) (write-object writer x)
+      (vector? x) (write-array  writer x))
+    (when (seq xs) (recur writer xs))))
+
+(defn write-stream [s data]
+  (let [jw (writer s)]
+    (write jw data)
+    (.flush jw)))
+
+(defn write-file [pathname data]
+  (write-stream (file-writer pathname) data))
+
+(defn append-file [pathname data]
+  (write-stream (file-writer pathname true) data))
+
+(defn write-string [data]
+  (let [sw (StringWriter.)]
+    (write-stream (BufferedWriter. sw) data)
+    (.toString sw)))
+
+

neman/swing/src/net/ksojat/neman/swing.clj

+;; Copyright (c) 2008 Krešimir Šojat. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns net.ksojat.neman.swing
+  (:import
+    (clojure.lang Reflector RT))
+  (:use net.ksojat.neman.core))
+
+(defn swing-invoke [f]
+  (javax.swing.SwingUtilities/invokeLater f))
+
+(defmacro layout-data [expr]
+  ~expr)
+
+(defmacro swing [expr]
+  `(layout-data (let-builder-ids ~expr)))
+
+;;
+;; Event listeners.
+;;
+
+(defmulti on (fn [widget action callback] action))
+
+(defmethod on :action-performed [widget action callback]
+  (.addActionListener widget
+    (proxy [java.awt.event.ActionListener] []
+      (actionPerformed [#^java.awt.event.ActionEvent e]
+        (callback e)))))
+
+;;
+;; Builder integration.
+;;
+
+(defmethod default-method [javax.swing.JFrame    :vector] [& _] 'add)
+(defmethod default-method [javax.swing.JMenuBar  :vector] [& _] 'add)
+(defmethod default-method [javax.swing.JMenu     :vector] [& _] 'add)
+(defmethod default-method [javax.swing.JMenuItem :vector] [& _] 'add)
+(defmethod default-method [javax.swing.JToolBar  :vector] [& _] 'add)
+
+;(default-method
+;  [javax.swing.JFrame    :vector 'add]
+;  [javax.swing.JMenuBar  :vector 'add]
+;  [javax.swing.JMenuItem :vector 'add]
+;  [javax.swing.JToolBar  :vector 'add])
+
+(defmethod patch [javax.swing.JRadioButtonMenuItem 'setGroup] [o _ g]
+  (.add g o))
+
+(defn extract-mnemonic [s]
+  (let [m     (re-matcher #"&(\w)" s)
+        [_ c] (re-find m)]
+    (if c
+      [(.start m) (.replaceFirst m c) (first c)]
+      [-1 s nil])))
+
+(defn set-abutton [x label-text]
+  (let [[_ raw-text accelerator] (or
+                                   (re-find #"^(.*)(?:\s+)(?:\[(.*)\])$" label-text)
+                                   [nil label-text nil])
+        [index text mnemonic] (extract-mnemonic raw-text)]
+    (.setText x text)
+    (when accelerator
+      (.setAccelerator x (javax.swing.KeyStroke/getKeyStroke accelerator)))
+    (when mnemonic
+      (doto x
+        (.setMnemonic mnemonic)
+        (.setDisplayedMnemonicIndex index)))
+    x))
+
+(defmethod ctor javax.swing.AbstractButton [c s]
+  (let [o (Reflector/invokeConstructor c RT/EMPTY_ARRAY)]
+    (set-abutton o s)))
+
+;;
+;; Event listeners.
+;;
+
+(defmulti on (fn [object method handler-fn] [(class object) method]))
+
+;; Listeneres for java.awt.Component
+(import '(java.awt Component))
+
+(import '(java.awt.event ComponentAdapter ComponentEvent))
+
+(defmethod on [Component :resize] [object _ handler-fn]
+  (let [listener (proxy [ComponentAdapter] []
+                   (componentResized [#^ComponentEvent e] (handler-fn e)))]
+    (.addComponentListener object listener)
+    listener))
+
+(defmethod on [Component :move] [object _ handler-fn]
+  (let [listener (proxy [ComponentAdapter] []
+                   (componentMoved [#^ComponentEvent e] (handler-fn e)))]
+    (.addComponentListener object listener)
+    listener))
+
+(defmethod on [Component :show] [object _ handler-fn]
+  (let [listener (proxy [ComponentAdapter] []
+                   (componentShown [#^CompoentEvent e] (handler-fn e)))]
+    (.addComponentListener object listener)
+    (listener)))
+
+(defmethod on [Component :hide] [object _ handler-fn]
+  (let [listener (proxy [ComponentAdapter] []
+                   (componentHidden [#^ComponentEvent e] (handler-fn e)))]
+    (.addComponentListener object listener)
+    listener))
+
+(import '(java.awt.event FocusAdapter FocusEvent))
+
+(defmethod on [Component :focus-gained] [object _ handler-fn]
+  (let [listener (proxy [FocusAdapter] []
+                   (focusGained [#^FocusEvent e] (handler-fn e)))]
+    (.addFocusListener object listener)
+    listener))
+
+(defmethod on [Component :focus-lost] [object _ handler-fn]
+  (let [listener (proxy [FocusAdapter] []
+                   (focusLost [#^FocusEvent e] (handler-fn e)))]
+    (.addFocusListener object listener)
+    listener))
+
+(import '(java.awt.event HierarchyBoundsAdapter HierarchyListener HierarchyEvent))
+
+(defmethod on [Component :hierarchy-changed] [object _ handler-fn]
+  (let [listener (proxy [HierarchyListener] []
+                   (hierarchyChanged [#^HierarchyEvent e] (handler-fn e)))]
+    (.addHierarchyListener object listener)
+    listener))
+
+(defmethod on [Component :ancestor-moved] [object _ handler-fn]
+  (let [listener (proxy [HierarchyBoundsAdapter] []
+                   (ancestorMoved [#^HierarchyEvent e] (handler-fn e)))]
+    (.addHierarchyBoundsListener object listener)
+    listener))
+
+(defmethod on [Component :ancestor-resized] [object _ handler-fn]
+  (let [listener (proxy [HierarchyBoundsAdapter] []
+                   (ancestorResized [#^HierarchyEvent e] (handler-fn e)))]
+    (.addHierarchyBoundsListener object listener)
+    listener))
+
+; TODO: InputMethodListener
+
+(import '(java.awt.event KeyAdapter KeyEvent))
+
+(defmethod on [Component :key-pressed] [object _ handler-fn]
+  (let [listener (proxy [KeyAdapter] []
+                   (keyPressed [#^KeyEvent e] (handler-fn e)))]
+    (.addKeyListener object listener)
+    listener))
+
+(defmethod on [Component :key-released] [object _ handler-fn]
+  (let [listener (proxy [KeyAdapter] []
+                   (keyReleased [#^KeyEvent e] (handler-fn e)))]
+    (.addKeyListener object listener)
+    listener))
+
+(defmethod on [Component :key-typed] [object _ handler-fn]
+  (let [listener (proxy [KeyAdapter] []
+                   (keyTyped [#^KeyEvent e] (handler-fn e)))]
+    (.addKeyListener object listener)
+    listener))
+
+(import '(java.awt.event MouseAdapter MouseMotionAdapter MouseWheelListener MouseEvent))
+
+(defmethod on [Component :mouse-clicked] [object _ handler-fn]
+  (let [listener (proxy [MouseAdapter] []
+                   (mouseClicked [#^MouseEvent e] (handler-fn)))]
+    (.addMouseListener object listener)
+    listener))
+
+(defmethod on [Component :mouse-entered] [object _ handler-fn]
+  (let [listener (proxy [MouseAdapter] []
+                   (mouseEntered [#^MouseEvent e] (handler-fn e)))]
+    (.addMouseListener object listener)
+    listener))
+
+(defmethod on [Component :mouse-pressed] [object _ handler-fn]
+  (let [listener (proxy [MouseAdapter] []
+                   (mousePressed [#^MouseEvent e] (handler-fn e)))]
+    (.addMouseListener object listener)
+    listener))
+
+(defmethod on [Component :mouse-released] [object _ handler-fn]
+  (let [listener (proxy [MouseAdapter] []
+                   (mouseReleased [#^MouseEvent e] (handler-fn e)))]
+    (.addMouseListener object listener)
+    listener))
+
+(defmethod on [Component :mouse-dragged] [object _ handler-fn]
+  (let [listener (proxy [MouseMotionAdapter] []
+                   (mouseDragged [#^MouseEvent e] (handler-fn e)))]
+    (.addMouseMotionListener object listener)
+    listener))
+
+(defmethod on [Component :mouse-moved] [object _ handler-fn]
+  (let [listener (proxy [MouseMotionAdapter] []
+                   (mouseMoved [#^MouseEvent e] (handler-fn e)))]
+    (.addMouseMotionListener object listener)
+    listener))
+
+(defmethod on [Component :wheel-moved] [object _ handler-fn]
+  (let [listener (proxy [MouseWheelListener] []
+                   (mouseWheelMoved [#^MouseEvent e] (handler-fn e)))]
+    (.addMouseWheelListener object listener)
+    listener))
+
+;; Listeners for java.awt.ItemSelectable
+(import '(java.awt ItemSelectable))
+
+(import '(java.awt.event ItemListener ItemEvent))
+
+(defmethod on [ItemSelectable :item-changed] [object _ handler-fn]
+  (let [listener (proxy [ItemListener] []
+                   (itemStateChanged [#^ItemEvent e] (handler-fn e)))]
+    (.addItemListener object listener)
+    listener))
+
+
+;; Listeners for java.awt.Container
+(import '(java.awt Container))
+
+(import '(java.awt.event ContainerAdapter ContainerEvent))
+
+(defmethod on [Container :component-added] [object _ handler-fn]
+  (let [listener (proxy [ContainerAdapter] []
+                   (componentAdded [#^ComponentEvent e] (handler-fn e)))]
+    (.addComponentListener object listener)
+    listener))
+
+(defmethod on [Container :component-removed] [object _ handler-fn]
+  (let [listener (proxy [ContainerAdapter] []
+                   (componentRemoved [#^ComponentEvenet e] (handler-fn e)))]
+    (.addComponentListener object listener)
+    listener))
+
+;; Listeners for javax.swing.JComponent
+(import '(javax.swing JComponent))
+
+(import '(javax.swing.event AncestorListener AncestorEvent))
+
+(defmethod on [JComponent :ancestor-added] [object _ handler-fn]
+  (let [listener (proxy [AncestorListener] []
+                   (ancestorAdded   [#^AncestorEvent e] (handler-fn e))
+                   (ancestorMoved   [#^AncestorEvent e])
+                   (ancestorRemoved [#^AncestorEvent e]))]
+    (.addAncestorListener object listener)
+    listener))
+
+(defmethod on [JComponent :ancestor-moved] [object _ handler-fn]
+  (let [listener (proxy [AncestorListener] []
+                   (ancestorAdded   [#^AncestorEvent e])
+                   (ancestorMoved   [#^AncestorEvent e] (handler-fn e))
+                   (ancestorRemoved [#^AncestorEvent e]))]
+    (.addAncestorListener object listener)
+    listener))
+
+(defmethod on [JComponent :ancestor-removed] [object _ handler-fn]
+  (let [listener (proxy [AncestorListener] []
+                   (ancestorAdded   [#^AncestorEvent e])
+                   (ancestorMoved   [#^AncestorEvent e])
+                   (ancestorRemoved [#^AncestorEvent e] (handler-fn e)))]
+    (.addAncestorListener object listener)
+    listener))
+
+;; Listeners for javax.swing.AbstractButton
+(import '(javax.swing AbstractButton))
+
+(import '(java.awt.event ActionListener ActionEvent))
+
+(defmethod on [AbstractButton :action] [object _ handler-fn]
+  (let [listener (proxy [ActionListener] []
+                   (actionPerformed [#^ActionEvent e] (handler-fn e)))]
+    (.addActionListener object listener)
+    listener))
+
+(import '(javax.swing.event ChangeListener ChangeEvent))
+
+(defmethod on [AbstractButton :state-changed] [object _ handler-fn]
+  (let [listener (proxy [ChangeListener] []
+                   (stateChanged [#^ChangeEvent e] (handler-fn e)))]
+    (.addChangeListener object listener)
+    listener))
+
+;; Listeners for javax.swing.JMenuItem
+(import '(javax.swing JMenuItem))
+
+(import '(javax.swing.event MenuDragMouseListener MenuDragMouseEvent))
+
+(defmethod on [JMenuItem :mouse-dragged] [object _ handler-fn]
+  (let [listener (proxy [MenuDragMouseListener] []
+                   (menuDragMouseDragged  [#^MenuDragMouseEvent e] (handler-fn e))
+                   (menuDragMouseEntered  [#^MenuDragMouseEvent e])
+                   (menuDragMouseExited   [#^MenuDragMouseEvent e])
+                   (menuDragMouseReleased [#^MenuDragMouseEvent e]))]
+    (.addMenuDragMouseListener object listener)
+    listener))
+
+(defmethod on [JMenuItem :mouse-drag-entered] [object _ handler-fn]
+  (let [listener (proxy [MenuDragMouseListener] []
+                   (menuDragMouseDragged  [#^MenuDragMouseEvent e])
+                   (menuDragMouseEntered  [#^MenuDragMouseEvent e] (handler-fn e))
+                   (menuDragMouseExited   [#^MenuDragMouseEvent e])
+                   (menuDragMouseReleased [#^MenuDragMouseEvent e]))]
+    (.addMenuDragMouseListener object listener)
+    listener))
+
+(defmethod on [JMenuItem :mouse-drag-exited] [object _ handler-fn]
+  (let [listener (proxy [MenuDragMouseListener] []
+                   (menuDragMouseDragged  [#^MenuDragMouseEvent e])
+                   (menuDragMouseEntered  [#^MenuDragMouseEvent e])
+                   (menuDragMouseExited   [#^MenuDragMouseEvent e] (handler-fn e))
+                   (menuDragMouseReleased [#^MenuDragMouseEvent e]))]
+    (.addMenuDragMouseListener object listener)
+    listener))
+
+(defmethod on [JMenuItem :mouse-drag-released] [object _ handler-fn]
+  (let [listener (proxy [MenuDragMouseListener] []
+                   (menuDragMouseDragged  [#^MenuDragMouseEvent e])
+                   (menuDragMouseEntered  [#^MenuDragMouseEvent e])
+                   (menuDragMouseExited   [#^MenuDragMouseEvent e])
+                   (menuDragMouseReleased [#^MenuDragMouseEvent e] (handler-fn e)))]
+    (.addMenuDragMouseListener object listener)
+    listener))
+
+(import '(javax.swing.event MenuKeyListener MenuKeyEvent))
+
+(defmethod on [JMenuItem :menu-key-pressed] [object _ handler-fn]
+  (let [listener (proxy [MenuKeyListener] []
+                   (menuKeyPressed  [#^MenuKeyEvent e] (handler-fn e))
+                   (menuKeyReleased [#^MenuKeyEvent e])
+                   (menuKeyTyped    [#^MenuKeyEvent e]))]
+    (.addMenuKeyListener object listener)
+    listener))
+
+(defmethod on [JMenuItem :menu-key-released] [object _ handler-fn]
+  (let [listener (proxy [MenuKeyListener] []
+                   (menuKeyPressed  [#^MenuKeyEvent e])
+                   (menuKeyReleased [#^MenuKeyEvent e] (handler-fn e))
+                   (menuKeyTyped    [#^MenuKeyEvent e]))]
+    (.addMenuKeyListener object listener)
+    listener))
+
+(defmethod on [JMenuItem :menu-key-typed] [object _ handler-fn]
+  (let [listener (proxy [MenuKeyListener] []
+                   (menuKeyPressed  [#^MenuKeyEvent e])
+                   (menuKeyReleased [#^MenuKeyEvent e])
+                   (menuKeyTyped    [#^MenuKeyEvent e] (handler-fn e)))]
+    (.addMenuKeyListener object listener)
+    listener))
+
+;; Listeners for javax.swing.JMenu
+(import '(javax.swing JMenu))
+
+(import '(javax.swing.event MenuListener MenuEvent))
+
+(defmethod on [JMenu :menu-canceled] [object _ handler-fn]
+  (let [listener (proxy [MenuListener] []
+                   (menuCanceled   [#^MenuEvent e] (handler-fn e))
+                   (menuDeselected [#^MenuEvent e])
+                   (menuSelected   [#^MenuEvent e]))]
+    (.addMenuListener object listener)
+    listener))
+
+(defmethod on [JMenu :menu-deselected] [object _ handler-fn]
+  (let [listener (proxy [MenuListener] []
+                   (menuCanceled   [#^MenuEvent e])
+                   (menuDeselected [#^MenuEvent e] (handler-fn e))
+                   (menuSelected   [#^MenuEvent e]))]
+    (.addMenuListener object listener)
+    listener))
+
+(defmethod on [JMenu :menu-selected] [object _ handler-fn]
+  (let [listener (proxy [MenuListener] []
+                   (menuCanceled   [#^MenuEvent e])
+                   (menuDeselected [#^MenuEvent e])
+                   (menuSelected   [#^MenuEvent e] (handler-fn e)))]
+    (.addMenuListener object listener)
+    listener))

neman/utils/src/net/ksojat/neman/cli.clj

+;; Copyright (c) 2008 Krešimir Šojat. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns net.ksojat.neman.cli
+  (:use net.ksojat.neman.core)
+  (:import (org.apache.commons.cli Options GnuParser HelpFormatter)))
+
+; Default method in builder macro.
+(defmethod default-method [Options :vector] [& _] 'addOption)
+
+(defn parse-gnu [options args]
+  (.parse (GnuParser.) options (into-array args)))
+
+(defn has-option? [cmd name]
+  (.hasOption cmd name))
+
+(defn get-option [cmd name]
+  (.getOptionValue cmd name))
+
+(defn print-help [name options]
+  (.printHelp (HelpFormatter.) name options))
+
+(defn print-help-and-exit [name options]
+  (print-help name options)
+  (System/exit 0))
+
+

neman/utils/src/net/ksojat/neman/textile.clj

+;; Copyright (c) 2009 Krešimir Šojat. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns net.ksojat.neman.textile
+  (:import
+    (java.io BufferedReader FileReader StringReader)
+    (org.jdom Namespace)
+    (org.jdom.input SAXBuilder)
+    (net.java.textilej.parser MarkupParser)
+    (net.java.textilej.parser.builder HtmlDocumentBuilder)
+    (net.java.textilej.parser.markup.textile TextileDialect))
+  (:use
+    (net.ksojat.neman
+      core
+      [xml :only [xmlns xpath select-single-node]])))
+
+(def #^{:private true} xhtml-ns (xmlns "h" "http://www.w3.org/1999/xhtml"))
+
+;(defn html-builder
+;  ([]
+;    (html-builder *out*))
+;  ([writer]
+;    (=> (HtmlDocumentBuilder. writer) :XhtmlStrict false, :EmitAsDocument true)))
+
+(defn html-builder
+  ([]
+    (html-builder *out*))
+  ([writer]
+    (doto (HtmlDocumentBuilder. writer) (.setXhtmlStrict false) (.setEmitAsDocument true))))
+
+(defn textile-parser
+  ([]
+    (textile-parser (html-builder)))
+  ([builder]
+    (doto (MarkupParser. (TextileDialect.)) (.setBuilder builder))))
+
+(defn parse-textile-file [file]
+  (with-out-str
+    (.parse (textile-parser) (BufferedReader. (FileReader. file)))))
+
+(defn textile-dom [source-str]
+  (.build (SAXBuilder.) (StringReader. source-str)))
+
+(defn body [dom]
+  (let [path (xpath "/h:html/h:body" xhtml-ns)]
+    (when-let [b (select-single-node path dom)]
+      (seq (.cloneContent b)))))
+
+(defn title [dom]
+  (let [path (xpath "/h:html/h:body/h:h1[1]/text()" xhtml-ns)]
+    (when-let [t (select-single-node path dom)]
+      (.getValue t))))
+
+(defn first-paragraph [dom]
+  (let [path (xpath "/h:html/h:body/h:p[1]" xhtml-ns)]
+    (when-let [p (select-single-node path dom)]
+      (.clone p))))

neman/web/src/net/ksojat/neman/css.clj

+;; Copyright (c) 2008 Krešimir Šojat. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns net.ksojat.neman.css
+  (:use net.ksojat.neman.core))
+
+(defmulti property (fn [name arg] name))
+
+(defmethod property :default [name arg]
+  [name arg])
+
+(defmethod property :border-bottom-colors [_ arg]
+  [:-moz-border-bottom-colors arg
+   :border-bottom-colors      arg])
+
+(defmethod property :border-top-colors [_ arg]
+  [:-moz-border-top-colors arg
+   :border-top-colors      arg])
+
+(defmethod property :border-left-colors [_ arg]
+  [:-moz-border-left-colors arg
+   :border-left-colors      arg])
+
+(defmethod property :border-right-colors [_ arg]
+  [:-moz-border-right-colors arg
+   :border-right-colors      arg])
+
+(defmethod property :border-colors [_ arg]
+  [:-moz-border-bottom-colors arg
+   :-moz-border-top-colors    arg
+   :-moz-border-left-colors   arg
+   :-moz-border-right-colors  arg
+   :border-colors             arg])
+
+(defmethod property :border-image [_ arg]
+  [:-moz-border-image    arg
+   :-webkit-border-image arg
+   :border-image         arg])
+
+(defmethod property :border-radius-topleft [_ arg]
+  [:-moz-border-radius-topleft    arg
+   :-webkit-border-radius-topleft arg
+   :border-radius-topleft         arg])
+
+(defmethod property :border-radius-topright [_ arg]
+  [:-moz-border-radius-topright    arg
+   :-webkit-border-radius-topright arg
+   :border-radius-topright         arg])
+
+(defmethod property :border-radius-bottomleft [_ arg]
+  [:-moz-border-radius-bottomleft    arg
+   :-webkit-border-radius-bottomleft arg
+   :border-radius-bottomleft         arg])
+
+(defmethod property :border-radius-bottomright [_ arg]
+  [:-moz-border-radius-bottomright    arg
+   :-webkit-border-radius-bottomright arg
+   :border-radius-bottomright         arg])
+
+(defmethod property :border-radius [_ arg]
+  [:-moz-border-radius    arg
+   :-webkit-border-radius arg
+   :border-radius         arg])
+
+(defmethod property :box-shadow [_ arg]
+  [:-moz-box-shadow    arg
+   :-webkit-box-shadow arg
+   :box-shadow         arg])
+
+(defmethod property :background-origin [_ arg]
+  [:-moz-background-origin    arg
+   :-webkit-background-origin arg
+   :background-origin         arg])
+
+(defmethod property :background-clip [_ arg]
+  [:-moz-background-clip    arg
+   :-webkit-background-clip arg
+   :background-clip         arg])
+
+(defn value-str [v]
+  (cond
+    (keyword? v) (name v)
+    :else        (str v)))
+
+(defn property-str* [[k v]]
+  (str \tab (name k) ": " (value-str v) ";\n"))
+
+(defn property-str [[k v]]
+  (apply str (map property-str* (partition 2 (property k v)))))
+
+(defn rule-str [[selector & props]]
+  (let [props (partition 2 (flatten props))]
+    (str selector " {\n" (apply str (map property-str props)) "}\n")))
+
+(defn to-css [css-spec]
+  (apply str (map rule-str css-spec)))
+
+;;
+;; CSS Framework
+;;
+
+(def reset
+  [[(str "html, body, div, span, object, iframe, h1, h2, h3, h4, h5, h6, p, "
+         "blockquote, pre, a, abbr, acronym, address, code, del, dfn, em, img, "
+         "q, dl, dt, dd, ol, ul, li, fieldset, form, label, legend, table, "
+         "caption, tbody, tfoot, thead, tr, th, td")
+    :margin  "0"
+    :padding "0"
+    :border  "0"
+    :font-weight :inherit
+    :font-style  :inherit
+    :font-size   "100%"
+    :font-family :inherit
+    :vertical-align :baseline]
+
+   ["body"
+    :line-height "1.5"]
+
+   ["table"
+    :border-collapse :separate
+     :border-spacing  "0"]
+
+   ["caption, th, td"
+    :text-align  :left
+    :font-weight :normal]
+
+   ["table, td, th"
+    :vertical-align :middle]
+
+   ["blockquote:before, blockquote:after, q:before, q:after"
+    :content ""]
+
+   ["a img"
+    :border :none]])
+
+(def main
+  [:width      "70em"
+   :margin     "0 auto"
+   :text-align :left
+   :display    :block])
+
+(def clear
+  [".clear"
+   :clear :both])
+
+(def fluid
+  [[".fluid"
+    :width :auto, :float :none]
+   ["div .fluid"
+    :padding "0em 0em 0em 0.1em"]])
+
+(def hp
+  [[".hp"
+    :width "100%", :float :left]])
+
+;(def base
+;  (concat
+;    reset
+;    [[".main"
+;      [:width      "70em"
+;       :margin     "0 auto"
+;       :text-align :left]]
+;     [".clear"
+;      [:clear :both]]
+;     [".
+
+(defn display-left [n]
+  [:float   :left
+   :display :inline
+   :width   (str n "em")])
+
+(defn display-right [n]
+  [:float   :right
+   :display :inline
+   :width   (str n "em")])
+
+(defn from-left [n]
+  [:margin-left (str n "em")])
+
+(defn from-right [n]
+  [:margin-right (str n "em")])
+
+(defn from-top [n]
+  [:margin-top (str n "em")])
+
+(comment
+  (to-css
+    [["h1"
+      :font-size   "2em"
+       :font-weight :bold
+       :font-family "Verdana"]
+     ["h2"
+      :font-size "1.8em"
+       :color     "#383334"]]))

neman/web/src/net/ksojat/neman/jetty.clj

+;; Copyright (c) 2008 Krešimir Šojat. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns net.ksojat.neman.jetty
+  (:use net.ksojat.neman.core)
+  (:import
+    (javax.servlet.http HttpServletRequest HttpServletResponse)
+    (org.mortbay.jetty
+      Handler MimeTypes HttpConnection Request Response)
+    (org.mortbay.jetty.handler
+      AbstractHandler HandlerList HandlerCollection RewriteHandler)))
+
+;;
+;; Builder integration.
+;;
+
+(defmethod default-method [MimeTypes :vector] [& _] 'addMimeMappings)
+(defmethod default-method [RewriteHandler :vector] [& _] 'addRewriteRule)
+
+(defmethod patch [Handler 'addHandlerList] [o _ v]
+  (.addHandler o
+    (doto (HandlerList.) (.setHandlers (into-array-of Handler v)))))
+
+(defmethod patch [Handler 'addHandlerCollection] [o _ v]
+  (.addHandler o
+    (doto (HandlerCollection.) (.setHandlers (into-array-of Handler v)))))
+
+;;
+;; Helpers.
+;;
+
+(defn status [status-kw]
+  (kw-enum HttpServletResponse "SC" status-kw))
+
+(defn current-connection []
+  (HttpConnection/getCurrentConnection))
+
+(defn current-request []
+  (.getRequest (current-connection)))
+
+(defn get-request [r]
+  (if (instance? Request r) (cast Request r) (current-request)))
+
+(defn current-response []
+  (.getResponse (current-connection)))
+
+(defn get-response [r]
+  (if (instance? Response r) (cast Response r) (current-response)))
+
+(defn handler [f]
+  (proxy [AbstractHandler] []
+    (handle [target #^HttpServletRequest request #^HttpServletResponse response dispatch]
+      (let [request (get-request request), response (get-response response)]
+        (f target request response dispatch)))))

neman/web/src/net/ksojat/neman/web.clj

+;; Copyright (c) 2008 Krešimir Šojat. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns net.ksojat.neman.web
+  (:import
+    (clojure.lang IPersistentMap Keyword)
+    (javax.servlet.http Cookie))
+  (:refer-clojure :exclude [partial])
+  (:require [net.ksojat.neman.jetty :as jetty])
+  (:use
+    clojure.set
+    (net.ksojat.neman
+      core
+      [cells :only [cell]])))
+
+(declare
+  *request* *response*)
+
+;;
+;; URL path convertors.
+;;
+
+(defmulti convertor (fn [name] name))
+
+(defmethod convertor :default [name]
+  (throw-exception "Unknown convertor for tyoe: " name))
+
+(defmethod convertor :kw [_]
+  {:regex    "([^/]+)"
+   :from-url keyword
+   :to-url   name})
+
+(defmethod convertor :path [_]
+  {:regex    "(.+)"
+   :from-url (fn [v] (seq (.split v "/")))
+   :to-url   (fn [v] (apply str (interpose "/" v)))})
+
+(defmethod convertor :int [_]
+  {:regex    "([0-9]+)"
+   :from-url #(Integer/parseInt %)
+   :to-url   #(Integer/toString %)})
+
+(defmethod convertor :str [_]
+  {:regex    "([^/]+)"
+   :from-url (fn [v] v)
+   :to-url   (fn [v] v)})
+
+(defmethod convertor :uuid [_]
+  {:regex    "([0-9A-Fa-f]{8}-[0-9A-Fa-f]{4}-[0-9A-Fa-f]{4}-[0-9A-Fa-f]{4}-[0-9A-Fa-f]{12})"
+   :from-url uuid
+   :to-url   str})
+
+(defmethod convertor :date [_]
+  {:regex    "([0-9]{8})"
+   :from-url (fn [v] v)
+   :to-url   (fn [v] v)})
+
+(defmethod convertor :date-map [_]
+  {:regex    "([0-9]{8})"
+   :from-url (fn [v]
+               (let [[_ year month day] (re-matches #"([0-9]{4})([0-9]{2})([0-9]{2})" v)]
+                 {:year year :month month :day day}))
+   :to-url   (fn [{:keys [year month day]}] (str year month day))})
+
+(defn convertor-regex [type]
+  (:regex (convertor type)))
+
+(defn from-url [type value]
+  (((convertor type) :from-url) value))
+
+(defn to-url [type value]
+  (((convertor type) :to-url) value))
+
+;;
+;; Request guards.
+;;
+
+(defmulti guard (fn [type request & args] type))
+
+(defmethod guard :any [& _] true)
+
+(defmethod guard :method [_ request allowed]
+  (allowed (keyword (.. request getMethod toLowerCase))))
+
+(defmethod guard :post [_ request]
+  (guard :method request #{:post}))
+
+(defmethod guard :put [_ request]
+  (guard :method request #{:put}))
+
+(defmethod guard :get [_ request]
+  (guard :method request #{:get}))
+
+(defmethod guard :head [_ request]
+  (guard :method request #{:head}))
+
+(defmethod guard :delete [_ request]
+  (guard :method request #{:delete}))
+
+(defmethod guard :header [_ request header-map]
+  (every? true?
+    (map
+      (fn [[k v]]
+        (let [h (.getHeader request k)]
+          (cond
+            (ifn?   v) (v h)
+            (true?  v) (not= nil h)
+            (false? v) (= nil h)
+            :else      (= v h))))
+      header-map)))
+
+(defmethod guard :xhr [_ request]
+  (guard :header request {"X-Requested-With" "XMLHttpRequest"}))
+
+;(defmethod guard :authenticated [_ request]
+;  (.getRemoteUser request))
+
+(defmacro match [& clauses]
+  (let [make-guard (fn [test]
+                     (let [[f & r] (if (vector? test) test (vector test))]
+                       `(guard ~f *request* ~@r)))
+        clauses (mapcat
+                  (fn [[test expr]]
+                    [(if (seq? test)
+                       `(and ~@(map (fn [t] (make-guard t)) test)) (make-guard test))
+                     expr])
+                  (partition 2 clauses))]
+    `(cond ~@clauses)))
+
+;;
+;; Views.
+;;
+
+(defn new-arg [name type value]
+  {:name name :type type :value value})
+
+(defn value? [arg]
+  (= (:type arg) :value))
+
+(defn convertor? [arg]
+  (= (:type arg) :convertor))
+
+(defn distinct-arguments?
+  "Check are view argument names unique."
+  [arg-seq]
+  (or (not (seq? arg-seq)) (apply distinct? (map :name arg-seq))))
+
+(defmacro view* [bindings & body]
+  (let [expand   (fn
+                   ([s]     [s (new-arg s :convertor :str)])
+                   ([s c]   [s (new-arg s :convertor c)])
+                   ([d s c] [d (new-arg s :convertor c)]))
+        bindings (map #(apply expand (if (vector? %) % (list %))) bindings)
+        fargs (map first  bindings)
+        vargs (map second bindings)]
+    (if (distinct-arguments? vargs)
+      `(with-meta
+         {:args '~(vec vargs), :fn (fn ~(vec fargs) ~@body)}
+         {::view true})
+      (throw-illegal-argument "View arguments must have unique names."))))
+
+(defmacro view [bindings & body]
+  (let [[f & r] body]
+    (if (and (= f '->) (seq r))
+      `(view* ~bindings (match ~@r))
+      `(view* ~bindings ~@body))))
+
+(defmacro defview [name bindings & body]
+  `(def ~name (view ~bindings ~@body)))
+
+(defn view? [x]
+  (true? (::view (meta x))))
+
+(defn argument-names [view]
+  (map :name (filter convertor? (view :args))))
+
+(defn argument-types [view]
+  (into {}
+    (map (fn [a] [(:name a) (:value a)]) (filter convertor? (view :args)))))
+
+(defn argument-regex [view]
+  (into {}
+    (map (fn [[name type]] [name (convertor-regex type)]) (argument-types view))))
+
+(defn call-view [view arguments]
+  (let [[n1 n2] [(set (argument-names view)) (set (keys arguments))]
+        [d1 d2] [(difference n1 n2) (difference n2 n1)]]
+    (cond
+      (not= #{} d1) (throw-illegal-argument "Missing argument(s): " d1)
+      (not= #{} d2) (throw-illegal-argument "Unknown argument(s): " d2)
+      :else
+        (apply (view :fn)
+          (map
+            (fn [a]
+              (if (value? a)
+                (:value a) (from-url (:value a) (arguments (:name a)))))
+            (view :args))))))
+
+(defn has-argument? [view name]
+  (some #(= name %) (argument-names view)))
+
+(defn update-arguments [view new-arg]
+  (if (false? (has-argument? view (:name new-arg)))
+    (throw-illegal-argument "Unknown argument: " (:name new-arg)))
+  (assoc view :args
+    (map
+      (fn [old-arg]
+        (if (= (:name new-arg) (:name old-arg)) new-arg old-arg))
+      (view :args))))
+
+(defn partial [view new-args]
+  (let [update (apply comp
+                 (map
+                   (fn [[k v]] #(update-arguments % (new-arg k :value v)))
+                  new-args))]
+    (update view)))
+
+;;
+;; Paths.
+;;
+
+(defn get-view-at [paths view-path]
+  (let [x (get-in paths view-path)] (if (view? x) x)))
+
+;;
+;; Rules.
+;;
+
+(def rule-pattern #"(?:([^<]*)(?:<([^>]*)>))|([^<^>]*)")
+
+(defn rule-part-seq [route]
+  (butlast (re-seq rule-pattern route)))
+
+(defn valid-rule-part? [rule]
+  (not= ["" nil nil ""] rule))
+
+(defn parse-rule [rule]
+  (let [ps (rule-part-seq rule)] (if (every? valid-rule-part? ps) ps)))
+
+(defn rule-parts [rule]
+  (map (fn [[_ path1 arg path2]] [(or path1 path2) arg]) (parse-rule rule)))
+
+(defn valid-rule? [rule-parts]
+  (not= nil rule-parts))
+
+(defn rule-names [rule]
+  (filter not-nil?
+    (map (fn [[_ name]] name) (rule-parts rule))))
+
+(defn rule-regex [rule arg-regex]
+  (loop [parts (rule-parts rule), out []]
+    (if (seq parts)
+      (let [[[path arg] & ps] parts]
+        (recur ps (conj out path (arg-regex (if arg (symbol arg))))))
+      (re-pattern (apply str out)))))
+
+;(defn rule-regex [rule arg-regex]
+;  (loop [parts (rule-parts rule), out []]
+;    (if-let [[[path arg] & ps] parts]
+;      (recur ps (conj out path (arg-regex (symbol arg))))
+;      (re-pattern (apply str out)))))
+
+;(defn rule-regex [rule arg-regex]
+;  (loop [[[path arg] & ps] (rule-parts rule), out []]
+;    (if (seq ps)
+;      (recur ps (conj out path (arg-regex (symbol arg))))
+;      (re-pattern (apply str out)))))
+
+(defn rule-matcher [rule arg-regex]
+  (let [regex (rule-regex rule arg-regex)
+        names (map symbol (rule-names rule))]
+    (fn [url-path]
+      (when-let [[_ & args] (re-matches regex url-path)]
+        (apply hash-map (interleave names args))))))
+
+;;
+;; Routes.
+;;
+
+(defn route [rule path view]
+  [(rule-matcher rule (argument-regex view)) path view])
+
+(defn create-routes [paths rules]
+  (map
+    (fn [[path rule]]
+      (let [view (get-view-at paths path)]
+        (if view
+          (route rule path view)
+          (throw-exception "Unknown view at: " path))))
+    rules))
+
+(defn create-default-routes
+  "Create default routes from path names."; TODO: Write more docs here
+  ([paths]
+    (create-default-routes paths {}))
+
+  ([paths exceptions]
+    nil)); TODO: Add code for this
+
+
+;;
+;; Jetty integration.
+;;
+
+(def status
+  #(jetty/status %))
+
+(defmulti update-response (fn [response x] (class x)))
+
+(defmethod update-response String [response x]
+  (.. response getWriter (print x)))
+
+(defmethod update-response IPersistentMap [response x]
+  (doseq [k (keys x)] (.setHeader response k (x k))))
+
+; TODO: Inject status in Response, replace this and the one in mapper
+(defmethod update-response Keyword [response x]
+  (.setStatus response (status x)))
+
+(defmethod update-response Cookie [response x]
+  (.addCookie response x))
+
+(defn iterate-butlast [coll]
+  (take (inc (count coll)) (iterate butlast coll)))
+
+(declare
+  *paths* *rules* *routes* *current-path*)
+
+(defn url-for-path
+  ([path]
+    (url-for-path path {}))
+
+  ([path args]
+    (when-let [rule (*rules* (vec path))]
+      (let [parts (rule-parts rule)
+            types (argument-types (get-view-at *paths* path))
+            args  (into {} (map (fn [[n v]] [(name n) (to-url (types n) v)]) args))]
+        (apply str
+          (mapcat (fn [[p a]] [p (args a)]) parts))))))
+
+(defn url-for
+  ([path]
+    (url-for path {}))
+
+  ([path args]
+    (let [path (if (vector? path) path (vector path))
+          current (butlast *current-path*)
+          bases   (iterate-butlast current)
+          paths   (map #(concat % path) bases)]
+      (first (filter #(not= % nil) (map #(url-for-path % args) paths))))))
+
+(defn internal-redirect-to
+  ([path]
+    (internal-redirect-to path {}))
+
+  ([path args]
+    nil))
+
+(def redirect-to)
+
+(defn handle-url [url-path [[matcher path view] & rs]]
+  (if-let [args (matcher url-path)]
+    (binding [*current-path* path]
+      (when-let [res (call-view view args)]
+        (.setHandled *request* true)
+        (.setStatus  *response* (status :ok))
+        (if (vector? res)
+          (doseq [r res] (update-response *response* r))
+          (update-response *response* res))))
+    (when (seq rs) (recur url-path rs))))
+
+;; TODO: Move to core
+(defn tree-paths [branch? tree]
+  (let [paths (fn paths [parent children]
+                (mapcat
+                  (fn [[k v]]
+                    (let [p (conj parent k)]
+                      (if (branch? v) (paths p v) [p v])))
+                  children))]
+    (paths [] tree)))
+
+;; TODO: Remove this
+(defn numerics-path? [path]
+  (some number? path))
+
+(defn auto-rules [paths rule-ex]
+  (let [paths           (filter
+                          (fn [[p _]] (not (numerics-path? p)))
+                          (partition 2 (tree-paths (complement view?) paths)))
+        [rel-ex abs-ex] (split-with (fn [[k _]] (keyword? k)) rule-ex)
+        rel-ex (into {} rel-ex)
+        abs-ex (sort-by first #(> (count %1) (count %2)) abs-ex)]
+    (into {}
+      (map
+        (fn [[path view]]
+          [path
+           (apply str "/"
+             (interpose "/"
+               (concat
+                 (filter #(not (empty? %)) (map #(get rel-ex % (name %)) path))
+                 (map #(str "<" % ">") (argument-names view)))))])
+        paths))))
+
+;; TODO: Add this
+(defn paths-vfn [new-state]
+  ; 1. Niti jedan view nesmije imati argumente koji imaju :internal flag na sebi
+  nil)
+
+(defn paths [x]
+  (ref x paths-vfn))
+
+;; TODO: Add this
+(defn rules-vfn [new-state]
+  nil)
+
+(defn rules
+  ([specs]
+    (ref specs rules-vfn))
+  ([paths ex]
+    (cell [paths] [v] (auto-rules v ex))))
+
+(defn mapper [paths rules]
+  (let [routes (cell [paths rules] [p r] (create-routes p r))]
+    (jetty/handler
+      (fn [target request response dispatch]
+        (binding [*request*  request
+                  *response* response
+                  *paths*    @paths
+                  *rules*    @rules
+                  *routes*   @routes]
+          (handle-url target @routes))))))
+

neman/xml/src/net/ksojat/neman/xml.clj

+;; Copyright (c) 2008 Krešimir Šojat. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns net.ksojat.neman.xml
+  (:use net.ksojat.neman.core)
+  (:import
+    (org.jdom Document DocType Namespace Element Text)
+    (org.jdom.xpath XPath)
+    (org.jdom.output XMLOutputter)))
+
+(defmethod default-method [Document :string] [& _] 'setDocType)
+(defmethod default-method [Element :vector] [& _] 'addContent)
+(defmethod default-method [Element :string] [& _] 'addContent)
+(defmethod default-method [Element :map] [& _] 'setAttributes)
+
+(defmethod patch [Document 'setDocType] [o _ a]
+  (.setDocType a (if (string? a) (DocType. a) a)))
+
+(defmethod patch [Element 'setAttributes] [o _ a]
+  (if (map? a)
+    (doseq [[k v] a]
+      (if v (.setAttribute o (name k) (str v))))
+    (.setAttributes o (str a))))
+
+(defn element? [x]
+  (instance? Element x))
+
+(defmethod patch [Element 'addContent] [o _ a]
+;  (.println System/out o)
+;  (.println System/out a)
+;  (.println System/out (class a))
+;  (.flush (System/out))
+  (cond
+    (instance? java.util.List a) (=> o (addContent (seq a)))
+    (seq? a) (doseq [x a] (.addContent o x))
+;    (seq? a)     (doseq [x a]
+;                   (.addContent o (if (element? x) x (str x))))
+    (element? a) (.addContent o a)
+    :else        (.addContent o (str a))))
+
+(def tag-re #"([^.#]+)(?:(?:\.)([^#]*))?(?:(?:#)([^.]*))?")
+
+(defn xml-keyword-ctor [x]
+  (let [[_ tag classes id] (re-matches tag-re (name x))]
+    (=> (Element. tag)
+      {:class (when classes (.replace classes "." " "))
+       :id    id})))
+
+(defn xml-ctor [x]
+  ; Fix for strage behaviour with JDOM 1.1 when adding node with no content.
+  (.addContent
+    (if (keyword? x) (xml-keyword-ctor x) x) ""))
+
+(defmacro xml-node [node]
+  `(binding [*ctor* #'xml-ctor] ~node))
+
+(defmacro xml-nodes [& nodes]
+  `(binding [*ctor* #'xml-ctor] (list ~@nodes)))
+
+;(defmacro xml-nodes [& nodes]
+;  `(binding [*ctor* #'xml-ctor] (flatten ~nodes)))
+
+(defmacro xml
+  ([root-node]
+    (let [doc (gensym)]
+      `(binding [*ctor* #'xml-ctor]
+         (let [~doc (org.jdom.Document.)]
+          (.setRootElement ~doc ~root-node)))))
+
+  ([doc-type root-node]
+    `(.setDocType (xml root-node) ~doc-type)))
+
+(defmacro render-xml [root-node]
+  `(.output (org.jdom.output.XMLOutputter.) (xml ~root-node) *out*))
+
+;;
+;; Templates.
+;;
+
+(declare context child)
+
+(defn context-bindings [bindings]
+  (let [as-kw  #(keyword (name %))
+        expand (fn ([a1]       [a1 `(get context ~(as-kw a1))])
+                   ([a1 a2]    (if (symbol? a1)
+                                 [a1 `(get context ~(as-kw a1) ~a2)]
+                                 [a1 `(get context ~(as-kw a2))]))
+                   ([a1 a2 a3] [a1 `(get context ~(as-kw a2) ~a3)]))]
+    (vec (mapcat
+           (fn [v]
+            (if (vector? v) (apply expand v) (apply expand v '())))
+            bindings))))
+
+(defmacro template* [& body]
+  `(fn [context# children#]
+     (binding [context context#, child children#]
+       (xml ~@body))))
+
+(defmacro template [& [f & r :as body]]
+  (if (vector? f)
+    `(template* (let ~(context-bindings f) ~@r)) `(template* ~@body)))
+
+(defmacro template-from* [base & children]
+  (let [local-children (into {}
+                         (map (fn [[f & r]] [f `(xml-nodes ~@r)]) children))]
+    `(fn [context# children#]
+       (binding [context context#, child children#]
+         (~base context# (merge children# ~local-children))))))
+
+(defn child-block [[name & [f & r :as body] :as block]]
+  (if (vector? f)
+    `(~name (let ~(context-bindings f) ~@r)) `(~@block)))
+
+(defmacro template-from [base & [f & r :as body]]
+  (let [base (if (keyword? base) `(context ~base) base)]
+    (if (vector? f)
+      (let [c (context-bindings f)]
+        `(template-from* ~base ~@(map (fn [[n & ns]] `(~n (let ~c ~@ns))) (map child-block r))))
+      `(template-from* ~base ~@(map child-block body)))))
+
+(defn expand [template context]
+  (template context {}))
+
+(defn render
+  ([template]
+    (render template {}))
+
+  ([template context]
+    (.output (XMLOutputter.) (expand template context) *out*)))
+
+(defn render-str [& render-args]
+  (with-out-str (apply render render-args)))
+
+;;
+;; XPath
+;;
+
+(defn xmlns
+  ([uri]        (Namespace/getNamespace uri))
+  ([prefix uri] (Namespace/getNamespace prefix uri)))
+
+(defn xpath
+  ([expr]
+    (XPath/newInstance expr))
+
+  ([expr & namespaces]
+    (let [path (xpath expr)]
+      (doseq [n namespaces] (.addNamespace path n))
+      path)))
+
+(defn select-nodes [xpath doc]
+  (seq (.selectNodes xpath doc)))
+
+(defn select-single-node [xpath doc]
+  (.selectSingleNode xpath doc))

src/net/ksojat/neman/cells.clj

-;; Copyright (c) 2009 Krešimir Šojat. All rights reserved.  The use and
-;; distribution terms for this software are covered by the Common
-;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
-;; which can be found in the file CPL.TXT at the root of this
-;; distribution.  By using this software in any fashion, you are
-;; agreeing to be bound by the terms of this license.  You must not
-;; remove this notice, or any other, from this software.
-
-(ns net.ksojat.neman.cells
-  (:import (clojure.lang IRef)))
-
-;;
-;; Cell class
-;;
-
-(gen-class
-  :name        net.ksojat.neman.cells.Cell
-  :implements  [clojure.lang.IRef]
-  :state        state
-  :init         Cell-init
-  :constructors {[clojure.lang.IPersistentMap] []})
-
-(defn -Cell-init [init]
-  [[] (ref (merge {:value nil :parents {} :triggers []} init))])
-
-(defn -get [this]
-  (get @(.state this) :value))
-
-(defn -setValidator [this validator-fn]
-  (.. this state (setValidator validator-fn)))
-
-(defn -getValidator [this]
-  (.. this state getValidator))
-
-(defn -addWatch [this watcher action send-off]
-  (.. this state (addWatch watcher action send-off)))
-
-(defn -removeWatch [this watcher]
-  (.. this state (removeWatch watcher)))
-
-(defn -notifyWatches [this]
-  (.. this state notifyWatches))
-
-;;
-;; Property Listeners
-;;
-
-(defmulti add-listener
-  (fn [object property callback] [(class object) property]))
-
-(defmulti remove-listener
-  (fn [object listener] [(class object) (class listener)]))
-
-(import '(javax.swing JTextField)
-        '(java.awt.event ActionListener ActionEvent))
-
-(defmethod add-listener [JTextField :text] [object _ callback]
-  (let [listener (proxy [ActionListener] []
-                   (actionPerformed [#^ActionEvent e]
-                     (callback)))]
-    (.addActionListener object listener)
-    listener))
-
-(defmethod remove-listener [JTextField ActionListener] [object listener]
-  (.removeActionListener object listener))
-
-;;
-;;
-;;
-
-(defn add-parent-watcher [parent update-fn]
-  (if (vector? parent)
-    (let [[object property] parent]
-      (add-listener object property update-fn))
-    (let [watcher (agent nil)]
-      (add-watcher parent :send watcher (fn [& _] (update-fn)))
-      watcher)))
-
-(defn remove-parent-watcher [parent watcher]
-  (if (instance? IRef parent)
-    (remove-watcher  parent watcher)
-    (remove-listener parent watcher)))
-
-(defn parent-value [parent]
-  (if (vector? parent)
-    (let [[object property] parent]
-      (property (bean object)))
-    (deref parent)))
-
-(defmacro alter-cell [cell parents bindings expr]
-  `(let [cell# ~cell
-         f# (fn []
-              (let
-                ~(vec (interleave bindings (map #(do `(parent-value ~%)) parents)))
-                ~expr))
-         update# (fn []
-                   (let [ov# (deref cell#), nv# (f#)]
-                     (when (not= ov# nv#)
-                       (dosync (alter (.state cell#) assoc :value nv#))
-                       (doseq [t# (:triggers @(.state cell#))] (t# ov# nv#)))))]
-     ; Remove watchers from old parents
-     (doseq [[r# w#] (:parents @(.state cell#))]
-       (remove-parent-watcher r# w#))
-
-     ; Add watchers to new parents.
-     (let [new-w# (map (fn [p#] (add-parent-watcher p# update#)) ~parents)
-           new-p# (apply hash-map (interleave ~parents new-w#))]
-       (doall new-w#)
-       (dosync
-         (alter (.state cell#) assoc :parents new-p#))
-       (doall new-p#))
-
-     (update#)
-     cell#))
-
-(defmacro cell
-  ([parents bindings expr]
-    `(alter-cell (net.ksojat.neman.cells.Cell. {}) ~parents ~bindings ~expr))
-  ([init-val]
-    `(net.ksojat.neman.cells.Cell. {:value ~init-val})))
-
-;(defn add-trigger [cell trigger-fn]
-;  (dosync
-;    (alter (.state cell) update-in [:triggers] conj trigger-fn))
-;  trigger-fn)
-
-(defn add-trigger [cell trigger-fn]
-  (dosync
-    (alter (.state cell) update-in [:triggers] conj trigger-fn))
-  trigger-fn)
-
-;(defn remove-trigger [cell trigger-fn]
-;  
-
-;; TODO: add special :this parent, so cells can be accumulators
-
-(comment
-  (def a (ref 1))
-  (def b (ref 2))
-
-  (def x (cell [a b] [v1 v2] (+ v1 v2)))
-  (println @a) (println @b) (println @x)
-  ; 1
-  ; 2
-  ; 3
-
-  (dosync (ref-set a 100))
-  (println @a) (println @x)
-  ; 100
-  ; 102
-
-  (alter-cell x [b] [v] (inc b))
-  (println @x)
-  ; 3
-
-  ;
-  ; Depending on object property
-  ;
-  (def tw (javax.swing.JTextField.))
-  (def fw (javax.swing.JFrame.))
-  (doto fw
-    (.add tw) .pack .show)
-
-  ; Cell is updated when text property of JTextField widget is changed.
-  (def c1 (cell [[tw :text]] [t] (str "Text is: " t)))
-  (add-trigger c1
-    (fn [old-v new-v]
-      (println old-v)
-      (println new-v)))
-
-  ; circular dependancies.
-  (def a (Cell. {:value 5}))
-  (def b (cell [a] [v] (dec v)))
-  (add-trigger a
-    (fn [old-v new-v]
-      (println (str "Cell a changed from: " old-v " to " new-v))))
-  (add-trigger b
-    (fn [old-v new-v]
-      (println (str "Cell b changed from: " old-v " to " new-v))))
-  (alter-cell a [b] [v] (if (< v 0) 0 v))
-)