├── .travis.yml
├── src
    └── enliven
    │   ├── text
    │       ├── model.clj
    │       └── emit
    │       │   └── static.clj
    │   ├── core
    │       ├── grounder.clj
    │       ├── actions.clj
    │       ├── locs.clj
    │       ├── selectors.clj
    │       ├── transformations.clj
    │       ├── plans.clj
    │       └── lenses.clj
    │   ├── text.clj
    │   ├── html
    │       ├── jsoup.clj
    │       ├── model.clj
    │       └── emit
    │       │   └── static.clj
    │   ├── commons
    │       └── emit
    │       │   └── static.clj
    │   └── html.clj
├── project.clj
├── test
    └── enliven
    │   ├── core
    │       └── paths_test.clj
    │   └── html_test.clj
└── README.md


/.travis.yml:
--------------------------------------------------------------------------------
1 | language: clojure
2 | lein: lein2
3 | script: lein2 do test
4 | jdk:
5 |   - openjdk6
6 |   - openjdk7
7 |   - oraclejdk7


--------------------------------------------------------------------------------
/src/enliven/text/model.clj:
--------------------------------------------------------------------------------
 1 | (ns enliven.text.model
 2 |   (:refer-clojure :exclude [chars])
 3 |   (:require [enliven.core.lenses :as lens]))
 4 | 
 5 | (lens/deflens chars [s cs]
 6 |   :fetch (vec s)
 7 |   :putback (apply str cs))
 8 | 
 9 | (lens/deftransitions
10 |   {::chars {`chars ::chars
11 |             `lens/slice ::chars
12 |             Number ::char}})
13 | 


--------------------------------------------------------------------------------
/project.clj:
--------------------------------------------------------------------------------
 1 | (defproject enliven "0.1.0-SNAPSHOT"
 2 |   :description "FIXME: write description"
 3 |   :url "http://example.com/FIXME"
 4 |   :license {:name "Eclipse Public License"
 5 |             :url "http://www.eclipse.org/legal/epl-v10.html"}
 6 |   :repositories [["phloc.com" "http://repo.phloc.com/maven2"]]
 7 |   :dependencies [[org.clojure/clojure "1.5.1"]
 8 |                  [com.phloc/phloc-css "3.7.0"]
 9 |                  [org.jsoup/jsoup "1.7.2"]])
10 | 


--------------------------------------------------------------------------------
/src/enliven/core/grounder.clj:
--------------------------------------------------------------------------------
 1 | (ns enliven.core.grounder
 2 |   (:require [enliven.core.actions :as action]
 3 |     [enliven.core.locs :as loc]
 4 |     [enliven.core.lenses :as lens]))
 5 | 
 6 | ;; a transformation is a function from loc to seq of [loc action]
 7 | ;; rules (as returned by ground-loc) are seq of [path action]
 8 | (defn ground-loc [transformation loc]
 9 |   (let [path (lens/canonical (loc/path loc))]
10 |     (for [[sloc action] (transformation loc)]
11 |      [(lens/relativize (lens/canonical (loc/path sloc)) path)
12 |       (action/update action :arg lens/canonical)])))
13 | 
14 | (defn ground
15 |   "Returns a seq of [canonical-path action]."
16 |   [transformation node]
17 |   (ground-loc transformation (loc/loc node)))
18 | 


--------------------------------------------------------------------------------
/src/enliven/text/emit/static.clj:
--------------------------------------------------------------------------------
 1 | (ns enliven.text.emit.static
 2 |   (:require [enliven.text.model :as text]
 3 |     [enliven.core.actions :as action]
 4 |     [enliven.core.plans :as plan]
 5 |     [enliven.commons.emit.static :as static]))
 6 | 
 7 | (defmethod static/prerenderer-fn ::text/char [node-type]
 8 |   (fn [text plan enc emit acc]
 9 |     (if (char? text)
10 |       (if (nil? plan)
11 |         (emit acc (enc (str text)))
12 |         (static/prerender-unknown plan ::text/char (comp enc str) emit acc))
13 |       (static/prerender ::text/chars text plan enc emit acc))))
14 | 
15 | (defmethod static/prerenderer-fn ::text/chars [node-type]
16 |   (fn [text plan enc emit acc]
17 |     (static/prerender-nodes text plan ::text/char enc emit acc)))
18 | 


--------------------------------------------------------------------------------
/src/enliven/core/actions.clj:
--------------------------------------------------------------------------------
 1 | (ns enliven.core.actions
 2 |   (:refer-clojure :exclude [replace]))
 3 | 
 4 | ;; An action is made of an op, a scope-idx, an arg and
 5 | 
 6 | (defn replace [path] {:op ::replace :scope-idx 0 :arg path})
 7 | (defn dup [path sub]  {:op ::dup :scope-idx 0 :arg path :subs [[list sub]]})
 8 | 
 9 | (defmulti update (fn [action key f & args] key))
10 | 
11 | (defmethod update :default [action key f & args]
12 |   (assoc action key (mapv #(apply f % args) (get action key))))
13 | 
14 | #_(defmethod update :subs [action key f & args]
15 |    (assoc action :subs (mapv (fn [[p sub]] [p (apply f sub args)]) (:subs action))))
16 | 
17 | (defmethod update :arg [action key f & args]
18 |   (if-let [path (:arg action)]
19 |     (assoc action :arg (apply f path args))
20 |     action))
21 | 


--------------------------------------------------------------------------------
/src/enliven/core/locs.clj:
--------------------------------------------------------------------------------
 1 | (ns enliven.core.locs
 2 |   (:require [enliven.core.lenses :as lens]))
 3 | 
 4 | (defrecord ^:private Loc [value seg ploc])
 5 | 
 6 | (defn loc [x]
 7 |   (->Loc x nil nil))
 8 | 
 9 | (defn down [loc seg]
10 |   (->Loc (lens/fetch (:value loc) seg) seg loc))
11 | 
12 | (defn up [loc]
13 |   (:ploc loc))
14 | 
15 | (defn node [loc]
16 |   (:value loc))
17 | 
18 | (defn segment [loc]
19 |   (:seg loc))
20 | 
21 | (defn path [loc]
22 |   (loop [path () loc loc]
23 |     (if-let [ploc (up loc)]
24 |       (recur (conj path (:seg loc)) ploc)
25 |       path)))
26 | 
27 | (defn root [loc]
28 |   (if-let [ploc (up loc)]
29 |     (recur ploc)
30 |     (:value loc)))
31 | 
32 | (defn canonicalize-path [loc']
33 |   (reduce down (-> loc' root loc) (lens/canonical (path loc'))))
34 | 
35 | (defn spliceable
36 |   "Returns the immediate splicing location, if none returns nil."
37 |   [loc]
38 |   (let [seg (segment loc)]
39 |     (cond
40 |       (number? seg)
41 |       (-> loc up (down (lens/slice seg (inc seg))))
42 |       (lens/slice? seg) loc)))
43 | 


--------------------------------------------------------------------------------
/src/enliven/text.clj:
--------------------------------------------------------------------------------
 1 | (ns enliven.text
 2 |   (:refer-clojure :exclude [replace])
 3 |   (:require [enliven.text.model :as text]
 4 |     [enliven.core.lenses :as lens]
 5 |     [enliven.core.locs :as loc]
 6 |     [enliven.core.actions :as action]
 7 |     [enliven.core.transformations :as transform]))
 8 | 
 9 | (defn sel [selector]
10 |   (if (instance? java.util.regex.Pattern selector)
11 |     (fn [loc]
12 |       (let [s (loc/node loc)]
13 |         (when (string? s)
14 |           (let [loc (loc/down loc chars)
15 |                 m (re-matcher selector s)]
16 |             (loop [locs []]
17 |               (if (.find m)
18 |                 (recur (conj locs (loc/down loc (lens/slice (.start m) (.end m)))))
19 |                 locs))))))
20 |     selector))
21 | 
22 | (defn replace [selector path]
23 |   (transform/replace (sel selector) path))
24 | 
25 | #_(defn static-template [text & transformations]
26 |    (let [plan (plan/plan (grounder/ground (apply at transformations) text))
27 |          emitted (common/tight-fn-emit! (static/prerender node plan common/tight-fn-emit! (common/tight-fn-emit!)))]
28 |      (fn
29 |        ([data] (common/render emitted data))
30 |        ([data emit acc] (common/render emitted data emit acc)))))
31 | 


--------------------------------------------------------------------------------
/test/enliven/core/paths_test.clj:
--------------------------------------------------------------------------------
 1 | (ns enliven.core.paths-test
 2 |   (:use clojure.test)
 3 |   (:require
 4 |     [enliven.html.model :as html]
 5 |     [enliven.text.model :as text]
 6 |     [enliven.core.lenses :as lens]))
 7 | 
 8 | (deftest canonicalization
 9 |   (testing "Hoisting segments"
10 |     (is (= (lens/canonical :foo) :foo))
11 |     (is (= (lens/canonical [:foo]) :foo)))
12 |   (testing "empty path is the identity"
13 |     (is (= (lens/canonical []) lens/identity)))
14 |   (testing "Merge nested slices"
15 |     (is (= (lens/canonical [(lens/slice 1 3) (lens/slice 1 2)])
16 |           (lens/slice 2 3))))
17 |   (testing "Reparent indexed segment as a 0-index in a singleton slice."
18 |     (is (= (lens/decompose (lens/canonical [12]))
19 |           [(lens/slice 12 13) 0]))
20 |     (is (= (lens/decompose (lens/canonical [(lens/slice 2 20) 12]))
21 |              [(lens/slice 14 15) 0])))
22 |   (testing "Simplify constant paths"
23 |     (is (= (lens/canonical [:foo (lens/const 42)])
24 |           (lens/const 42)))
25 |     (is (= (lens/canonical [:foo (lens/const 42) (lens/const 63)])
26 |           (lens/const 63)))
27 |     (is (= (lens/canonical [:foo (lens/const {:pi 3.14}) :pi])
28 |           (lens/const 3.14)))
29 |     (is (= (lens/canonical [:foo (lens/const {:pi 3.14}) :pi (lens/const 42)])
30 |           (lens/const 42)))))
31 | 
32 | (deftest abstract-fetch
33 |   (are [from path to] (= (lens/fetch-type from path) to)
34 |     ::html/node [:content (lens/slice 1 2) 0 :attrs :class html/classes "important"] ::lens/boolsy
35 |     ::html/node [:content (lens/slice 1 2) 0 :attrs :style text/chars] ::text/chars))
36 | 


--------------------------------------------------------------------------------
/src/enliven/core/selectors.clj:
--------------------------------------------------------------------------------
 1 | (ns enliven.core.selectors
 2 |   (:require [enliven.core.locs :as locs]
 3 |     [enliven.core.lenses :as lens]))
 4 | 
 5 | ;; A selector is a function from one loc to a coll of locs; loc -> locs
 6 | (defn locs [root sel]
 7 |   (sel (locs/loc root)))
 8 | 
 9 | (defn paths [root sel]
10 |   (map locs/path (locs root sel)))
11 | 
12 | (defn nodes [root sel]
13 |   (map locs/node (locs root sel)))
14 | 
15 | (defn chain
16 |   "Composes several selectors, from left to right."
17 |   ([] list)
18 |   ([sel] sel)
19 |   ([sela selb]
20 |     (fn [loc]
21 |       (for [loc (sela loc), loc (selb loc)]
22 |         loc)))
23 |   ([sela selb & sels]
24 |     (reduce chain (chain sela selb) sels)))
25 | 
26 | (defn union
27 |   "Returns the union selector of the specified selectors."
28 |   [& sels]
29 |   (fn [loc]
30 |     (distinct (mapcat #(% loc) sels))))
31 | 
32 | (defn rights
33 |   "A selector that returns all the rights siblings of a node
34 |   (ordered from closest to farthest)."
35 |   [loc]
36 |   (let [loc (locs/canonicalize-path loc)]
37 |     (when-let [loc (and (zero? (locs/segment loc)) (locs/up loc))]
38 |       (let [[idx] (lens/bounds (locs/segment loc))
39 |             loc (locs/up loc)
40 |             n (-> loc locs/node count)]
41 |         (map #(locs/down loc %) (range (inc idx) n))))))
42 | 
43 | (defn loc-pred
44 |   "Returns a filtering selector which keeps only locs for which pred is true."
45 |   [pred]
46 |   (fn [loc]
47 |     (when (pred loc) (list loc))))
48 | 
49 | (defn node-pred [pred]
50 |   (loc-pred (comp pred locs/node)))
51 | 
52 | (defn by-path [path]
53 |   (fn [loc]
54 |     (list (reduce locs/down loc path))))
55 | 


--------------------------------------------------------------------------------
/src/enliven/html/jsoup.clj:
--------------------------------------------------------------------------------
 1 | ;   Copyright (c) Christophe Grand, 2009. All rights reserved.
 2 | ;   Copyright (c) Baishampayan Ghose, 2013. All rights reserved.
 3 | 
 4 | ;   The use and distribution terms for this software are covered by the
 5 | ;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
 6 | ;   which can be found in the file epl-v10.html at the root of this
 7 | ;   distribution.
 8 | ;   By using this software in any fashion, you are agreeing to be bound by
 9 | ;   the terms of this license.
10 | ;   You must not remove this notice, or any other, from this software.
11 | 
12 | (ns enliven.html.jsoup
13 |   "JSoup based parser backend."
14 |   (:import [org.jsoup Jsoup]
15 |            [org.jsoup.nodes Attribute Attributes Comment DataNode Document
16 |             DocumentType Element Node TextNode XmlDeclaration]
17 |            [org.jsoup.parser Parser Tag]))
18 | 
19 | (def ^:private ->key (comp keyword #(-> % .toString .toLowerCase)))
20 | 
21 | (defprotocol IEnlive
22 |   (->nodes [d] "Convert object into Enlive node(s)."))
23 | 
24 | (extend-protocol IEnlive
25 |   Attribute
26 |   (->nodes [a] [(->key (.getKey a)) (.getValue a)])
27 | 
28 |   Attributes
29 |   (->nodes [as] (not-empty (into {} (map ->nodes as))))
30 | 
31 |   Comment
32 |   (->nodes [c] {:type :comment :data (.getData c)})
33 | 
34 |   DataNode
35 |   (->nodes [dn] (str dn))
36 | 
37 |   Document
38 |   (->nodes [d] (not-empty (map ->nodes (.childNodes d))))
39 | 
40 |   DocumentType
41 |   (->nodes [dtd] {:type :dtd :data ((juxt :name :publicid :systemid) (->nodes (.attributes dtd)))})
42 | 
43 |   Element
44 |   (->nodes [e] {:tag (->key (.tagName e))
45 |                 :attrs (->nodes (.attributes e))
46 |                 :content (vec (map ->nodes (.childNodes e)))})
47 | 
48 |   TextNode
49 |   (->nodes [tn] (.getWholeText tn))
50 | 
51 |   nil
52 |   (->nodes [_] nil))
53 | 
54 | (defn parser
55 |   "Parse a HTML document stream into Enlive nodes using JSoup."
56 |   [stream]
57 |   (with-open [^java.io.Closeable stream stream]
58 |     (->nodes (Jsoup/parse stream "UTF-8" ""))))
59 | 
60 | (defn parse [^String s]
61 |   (first (->nodes (org.jsoup.Jsoup/parse s))))
62 | 


--------------------------------------------------------------------------------
/src/enliven/core/transformations.clj:
--------------------------------------------------------------------------------
 1 | (ns enliven.core.transformations
 2 |   (:refer-clojure :exclude [replace])
 3 |   (:require [enliven.core.actions :as action]
 4 |     [enliven.core.grounder :as grounder]
 5 |     [enliven.core.selectors :as sel]
 6 |     [enliven.core.locs :as loc]
 7 |     [enliven.core.lenses :as lens]))
 8 | 
 9 | (defn composite [transformations]
10 |   (fn [loc] (mapcat #(% loc) transformations)))
11 | 
12 | (defn mash [& transformations]
13 |   (composite transformations))
14 | 
15 | (defn at*
16 |   ([selector+transformations] (at* selector+transformations identity))
17 |   ([selector+transformations sel]
18 |     (if (next selector+transformations)
19 |       (composite
20 |         (for [[selector t] (partition 2 selector+transformations)
21 |               :let [selector (sel selector)]]
22 |           (fn [loc] (mapcat t (selector loc)))))
23 |       (first selector+transformations))))
24 | 
25 | (defn at [& selector+transformations]
26 |   (at* selector+transformations))
27 | 
28 | (defn replace
29 |   ([path]
30 |     (let [action (action/replace path)]
31 |       (fn [loc]
32 |         [[(or (loc/spliceable loc) loc) action]])))
33 |   ([selector path]
34 |     (at selector  (replace path))))
35 | 
36 | (defn dup [data-path sub]
37 |   (let [action (action/dup data-path sub)]
38 |     (fn [loc]
39 |       (let [sloc (loc/spliceable loc)
40 |             _ (when-not sloc
41 |                 (throw (ex-info "Unexpected location for a dup"
42 |                                   {:loc loc :action action})))
43 |             path (lens/canonical (loc/path sloc))]
44 |         [[sloc (action/update action :subs
45 |                  (fn [[subsel sub]]
46 |                    (let [subloc (first (subsel loc))]
47 |                      [(lens/relativize (lens/canonical (loc/path subloc)) path)
48 |                       (grounder/ground-loc sub subloc)])))]]))))
49 | 
50 | #_(defn if' [path then-sub else-sub]
51 |    (let [action (action/if' path then-sub else-sub)]
52 |      (fn [loc]
53 |        (let [sloc (or (loc/spliceable loc) loc)
54 |              nloc (-> sloc loc/node loc/loc)
55 |              nloc (if (= loc sloc)
56 |                     nloc
57 |                     (loc/down nloc 0))]
58 |          [[sloc (action/update action :subs grounder/ground-loc nloc)]]))))
59 | 


--------------------------------------------------------------------------------
/src/enliven/html/model.clj:
--------------------------------------------------------------------------------
 1 | (ns enliven.html.model
 2 |   (:require
 3 |     [clojure.string :as str]
 4 |     [enliven.text.model :as text]
 5 |     [enliven.core.lenses :as lens]))
 6 | 
 7 | ;; html-specific segments
 8 | (lens/deflens classes [class-attr classes]
 9 |   :fetch
10 |     (zipmap (re-seq #"\S+" (or class-attr "")) (repeat true))
11 |   :putback
12 |     (some->> classes (keep (fn [[k v]] (when v k))) seq (str/join " ")))
13 | 
14 | 
15 | (defn read-css-attributes
16 |   "parses an style attribute string into a sequence of key value pairs"
17 |   [attr-str]
18 |   (let [el (com.phloc.css.reader.CSSReaderDeclarationList/readFromString
19 |             (or attr-str "") com.phloc.css.ECSSVersion/CSS30)]
20 |     (if el
21 |       (for [idx (range (.getDeclarationCount el))]
22 |         [(-> (.getDeclarationAtIndex el idx)
23 |              (.getProperty))
24 |          (-> (.getDeclarationAtIndex el idx)
25 |              (.getExpression)
26 |              (.getAsCSSString (com.phloc.css.writer.CSSWriterSettings.
27 |                                com.phloc.css.ECSSVersion/CSS30)
28 |                               0))])
29 |       '())))
30 | 
31 | (lens/deflens styles
32 |   "allows you to operate on seqence of key value pairs vs the
33 |    style attribute string directly"
34 |   [style-attr styles]
35 |   :fetch
36 |     (read-css-attributes style-attr)
37 |   :putback
38 |     (reduce (fn [s [k v]] (str s k ":" v ";")) "" styles))
39 | 
40 | 
41 | 
42 | (lens/deftransitions
43 |   {::node {:content {:type ::nodes
44 |                      :js/fetcher (fn [node seg]
45 |                                    `(.-childNodes ~node))}
46 |            :attrs {:type ::attrs
47 |                    :js/fetcher (fn [node seg]
48 |                                  `(.-attributes ~node))}
49 |            :tag ::tag
50 |            `text/chars ::text/chars}
51 |    ::nodes {`lens/slice {:type ::nodes
52 |                         :js/fetcher (fn [node seg]
53 |                                       `(nodes-slice ~node ~(:from seg) ~(:to seg)))}
54 |             Number {:type ::node
55 |                     :js/fetcher (fn [node seg]
56 |                                   `(aget ~node ~seg))}
57 |             #_#_:js/replace (fn [node data] ; not the right place
58 |                               `(set! (.-nodeValue ~node) (as-nodes ~data)))}
59 |    ::attrs {clojure.lang.Keyword {:type ::attr-value
60 |                                   :js/fetcher (fn [node seg]
61 |                                                 `(aget ~node ~(name seg)))}}
62 |    ::attr-value {`classes ::classes
63 |                  `text/chars ::text/chars
64 |                  `styles ::style-decls
65 |                  #_#_:js/replace (fn [node data] ; not the right place
66 |                                    `(set! (.-nodeValue ~node) ~data))}
67 |    ::style-decls {`lens/append-on-assoc ::style-maps}
68 |    ::classes {String ::lens/boolsy}})
69 | 
70 | 


--------------------------------------------------------------------------------
/src/enliven/html/emit/static.clj:
--------------------------------------------------------------------------------
 1 | (ns enliven.html.emit.static
 2 |   (:require [enliven.html.model :as html]
 3 |     [enliven.text.model :as text]
 4 |     [enliven.core.lenses :as lens]
 5 |     [enliven.commons.emit.static :as static]
 6 |     [enliven.core.plans :as plan]
 7 |     [enliven.core.actions :as action]))
 8 | 
 9 | (defn known-segs-only? [plan known-segs]
10 |   (every? known-segs (keys plan)))
11 | 
12 | (defn escape-text-node [text-node]
13 |   (-> text-node str (.replace "&" "&amp;") (.replace "<" "&lt;")))
14 | 
15 | (defn escape-attr-value
16 |   "Escape string for use in an attribute. Avoid escaping ampersands as much as possible.
17 |    (see HTML5 parsing algorithm)"
18 |   [^String attr-value]
19 |   (-> (re-matcher #"&([a-zA-Z0-9]+(?![=a-zA-Z0-9])|#)" attr-value)
20 |     (.replaceAll "&amp;$1")
21 |     (.replace "'" "&quot;")))
22 | 
23 | (defn prerender-text-node [node plan enc emit acc]
24 |   (let [enc (comp enc escape-text-node)]
25 |     (if plan
26 |       (if-let [char-plan (some-> plan :misc (get text/chars))]
27 |         (static/prerender ::text/chars
28 |           (lens/fetch node text/chars)
29 |           char-plan
30 |           enc emit acc)
31 |         (static/prerender-unknown node plan ::html/node enc emit acc))
32 |       (emit acc (enc node)))))
33 | 
34 | (defmethod static/prerenderer-fn ::html/tag [node-type]
35 |   (fn [tag plan enc emit acc]
36 |     (if plan
37 |       (static/prerender-unknown tag plan node-type enc emit acc)
38 |       (emit acc (enc (name tag))))))
39 | 
40 | (defmacro ^:private inline-emit
41 |   "Threads the emit fn and its accumulator through each items of coll.
42 |   When the item is unquoted, emit and acc are apssed as the last two arguments."
43 |   [enc emit acc & coll]
44 |   (let [encsym (gensym 'enc)
45 |         emitsym (gensym 'emit)]
46 |     `(let [~encsym ~enc
47 |            ~emitsym ~emit]
48 |        ~(reduce (fn [acc x]
49 |                   (if (and (seq? x) (= `clojure.core/unquote (first x)))
50 |                     (let [expr (second x)]
51 |                       (concat (if (seq? expr) expr (list expr)) [encsym emitsym acc]))
52 |                     (list emitsym acc (list encsym x))))
53 |           acc coll))))
54 | 
55 | (defn- render-attrs [attrs enc emit acc]
56 |   (reduce-kv (fn [acc attr v]
57 |                (cond
58 |                  (true? v) (emit acc (enc (name attr)))
59 |                  v (inline-emit enc emit acc " " (name attr)
60 |                      "='" (escape-attr-value v) "'")
61 |                  :else acc))
62 |     acc attrs))
63 | 
64 | (defmethod static/prerenderer-fn ::html/attrs [node-type]
65 |   (fn [attrs plan enc emit acc]
66 |     (cond
67 |       (nil? plan) (render-attrs attrs enc emit acc)
68 |       (or (:action plan) (not-every? keyword? (keys (:misc plan))))
69 |         (static/prerender-unknown attrs plan node-type enc emit acc)
70 |       :else
71 |       (let [untoucheds (reduce dissoc attrs (keys (:misc plan)))
72 |             toucheds (reduce dissoc attrs (keys untoucheds))]
73 |         (inline-emit enc emit acc
74 |           ~(render-attrs untoucheds)
75 |           ~(static/prerender-unknown toucheds plan node-type))))))
76 | 
77 | (defn prerender-element [node plan enc emit acc]
78 |   (if (and (not (:action plan)) (known-segs-only? (:misc plan) #{:tag :attrs :content}))
79 |     (let [plan-by-seg (:misc plan)
80 |           prerender (fn [seg enc emit acc]
81 |                       (static/prerender (lens/fetch-type ::html/node seg) (lens/fetch node seg) (get plan-by-seg seg)
82 |                         enc emit acc))]
83 |       (inline-emit enc emit acc
84 |         "<" ~(prerender :tag) ~(prerender :attrs) ">" ~(prerender :content) "</" ~(prerender :tag) ">"))
85 |     (static/prerender-unknown node plan ::html/node enc emit acc)))
86 | 
87 | (defmethod static/prerenderer-fn ::html/node [node-type]
88 |   (fn [node plan enc emit acc]
89 |     (cond
90 |       (string? node) (prerender-text-node node plan enc emit acc)
91 |       (:tag node) (prerender-element node plan enc emit acc)
92 |       (or (nil? node) (sequential? node)) (static/prerender ::html/nodes node plan enc emit acc)
93 |       :else (throw (ex-info "Unexpected node" {:node node})))))
94 | 
95 | (defmethod static/prerenderer-fn ::html/nodes [node-type]
96 |   (fn [nodes plan enc emit acc]
97 |     (static/prerender-nodes nodes plan ::html/node enc emit acc)))
98 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # Enliven [![Build Status](https://travis-ci.org/cgrand/enliven.png?branch=master)](https://travis-ci.org/cgrand/enliven)
  2 | 
  3 | Enliven: a (not yet) continuous templating system.
  4 | 
  5 | *WARNING* very wet paint
  6 | 
  7 | ## Enliven is the successor to Enlive
  8 | 
  9 | Even dictionaries say so:
 10 | 
 11 | > Enlive: To Enliven (Obs.)
 12 | 
 13 | Enliven also stands for Enlive N(ext).
 14 | 
 15 | ### Not tied to HTML
 16 | 
 17 | Currently Enliven can template plain text (`enliven.text`) and html (`enliven.html`).
 18 | The HTML "domain" is even composite since it uses the text "domain" to template text nodes.
 19 | 
 20 | ### Simpler selectors
 21 | 
 22 | Selectors are now functions from loc to locs. Most domains should expose a `sel` function to coerce
 23 | a domain specific selector (eg a CSS-selector in string or a regex) to a selector fn.
 24 | 
 25 | ### Parallel execution of transformations
 26 | 
 27 | All transformations occur at once for maximum declarativeness (and it enables good performance). It follows that two transformations can't work on the same node
 28 | or on a node and one of its ancestors.
 29 | 
 30 | This constraint is heavily mitigated by infinite-resolution selectors and transformation-refined selectors.
 31 | 
 32 | ### Infinite-resolution selectors
 33 | 
 34 | Selectors don't stop at nodes as specified in the DOM. Any node can be subdivided at will!
 35 | 
 36 | For example classes in a `class` attribute can be targeted independently. Each character of a text node can be transformed independently.
 37 | You can append/content/prepend on an element without conflicts!
 38 | 
 39 | However this happens under the hood, see: 
 40 | 
 41 | ```clj
 42 | (at 
 43 |   "div" (class "important" :important)
 44 |   "div" (class "footnote" :foot-note))
 45 | ```
 46 | 
 47 | Those two transformations won't conflict because they refine their selector.
 48 | 
 49 | ### Point-free
 50 | 
 51 | Templates take a single argument which is the data model to render.
 52 | 
 53 | Transformations don't take as arguments the actual values but keys or paths into the model.
 54 | 
 55 | ```clj
 56 | => ((static-template
 57 |      (enliven.html.jsoup/parse "<div>")
 58 |      "div" (content :sentence))
 59 |      {:sentence "Hello world"})
 60 | "<html><head></head><body><div>Hello world</div></body></html>"
 61 | ```
 62 | 
 63 | Some transformations like `dup` introduces a new scope so that sub-transformation can only see
 64 | the current item.
 65 | 
 66 | ```clj
 67 | => ((static-template
 68 |      (enliven.html.jsoup/parse "<ul><li>")
 69 |      "li" (dup :todos 
 70 |             (content []))) ; [] is the empty path, so points to the whole value
 71 |      {:todos ["Laundry" "Walk the dog"]})
 72 | "<html><head></head><body><ul><li>Laundry</li><li>Walk the dog</li></ul></body></html>"
 73 | ```
 74 | 
 75 | ### It's fast
 76 | 
 77 | Generating a 5x5 table. (pr-str just dumps the 5*5 vector):
 78 | * pr-str (24.5µs), 
 79 | * enliven (24.8µs), 
 80 | * hiccup (44.8µs), 
 81 | * enlive (130µs), 
 82 | * laser (1280µs).
 83 | 
 84 | https://gist.github.com/cgrand/8471718
 85 | 
 86 | ## Dev details
 87 | 
 88 | ### Processing model
 89 | 
 90 | 1. Nodes are selected
 91 | 2. For each selected node, associated transformations are grounded -- this is where the nodes are refined to avoid conflicts. The result is a set of rules.
 92 | 3. A hierarchical plan is created from the rules.
 93 | 4. The plan can either be executed as is or "compiled".
 94 | 
 95 | ### Paths and segments
 96 | 
 97 | Rules (as produced by the grounding phase) are pairs of a path and an action.
 98 | 
 99 | As a first approximation, you can imagine that they are going to be used in conjunction with `assoc-in` to updates parts of the structure.
100 | 
101 | If you have one rule on `[:a :b]` and another one `[:a :c]`, they can be executed in any order (they may even be performed concurrently as long as you coordinate on the longest common prefix).
102 | 
103 | However rules on `[:a :b]` and `[:a :b :c]` can't be freely reordered and as such are forbidden.
104 | 
105 | To alleviate this constraint, segments are a bit more expressive than simple keys in associative data structures.
106 | 
107 | Segments are used in conjunction with `fetch` and `putback` which are akin to `get` and `assoc`.
108 | 
109 | Numbers, strings and keywords are segments and Enliven knows that if they are different they don't impede.
110 | 
111 | Slices (ranges) are also segments and non-overlapping ranges don't impede. (Slices and numbers should not be mixed and that's the main purpose of path canonicalization).
112 | 
113 | Other segments are opaque and thus will conflict with any other segment. A good practice is to use non-opaque segments as much as possible.
114 | 
115 | For example the `html/classes` segment can't be used on an HTML element: otherwise it would clash with any other transformation on the element. 
116 | So the `html/classes` segment is meant to be used after `[:attrs :class]` thus giving to the planner the information that `html/classes` *owns* only the `class` attribute.
117 | 
118 | Furthermore the `html/classes` segment returns a map so individual classes can be addressed individually. For example `[:attrs :class html/classes "class1"]` and `[:attrs :class html/classes "class2"]` don't clash.
119 | 
120 | A custom segment thus creates a sort of contention point but by having it to return an associative structure it becomes a coordination point.
121 | 
122 | ### Locs
123 | 
124 | Locs are a kind of zippers for associative structures. They support only two moves: `up` and `down` (which takes a segment as additional argument).
125 | 
126 | ## License
127 | 
128 | Copyright © 2014 Christophe Grand
129 | 
130 | Distributed under the Eclipse Public License, the same as Clojure.
131 | 


--------------------------------------------------------------------------------
/test/enliven/html_test.clj:
--------------------------------------------------------------------------------
  1 | (ns enliven.html-test
  2 |   (:use clojure.test)
  3 |   (:refer-clojure :exclude [class])
  4 |   (:require
  5 |    [enliven.html :as h :refer [static-template content class
  6 |                                append prepend style]]
  7 |    [enliven.html.jsoup :as jsoup]
  8 |    [enliven.core.locs :as loc]
  9 |    [enliven.core.lenses :as lens]))
 10 | 
 11 | 
 12 | (deftest selector-tests
 13 |   (are [sel e] (not-empty ((h/css sel) (loc/loc e)))
 14 |     "div" {:tag :div}
 15 |     "[id]" {:tag :div :attrs {:id "foo"}}
 16 |     "[id=foo]" {:tag :div :attrs {:id "foo"}}
 17 |     "[class~=foo]" {:tag :div :attrs {:class "foo bar baz"}}
 18 |     "[class~=bar]" {:tag :div :attrs {:class "foo bar baz"}}
 19 |     "[class~=baz]" {:tag :div :attrs {:class "foo bar baz"}}
 20 |     "[lang|=fr]" {:tag :div :attrs {:lang "fr"}}
 21 |     "[lang|=fr]" {:tag :div :attrs {:lang "fr-be"}}
 22 |     "[class^=fo]" {:tag :div :attrs {:class "foo bar baz"}}
 23 |     "[class*=ba]" {:tag :div :attrs {:class "foo bar baz"}}
 24 |     "[class$=az]" {:tag :div :attrs {:class "foo bar baz"}}
 25 |     "div#id.foo" {:tag :div :attrs {:class "foo bar baz" :id "id"}}
 26 |     "div #id.foo" {:tag :div :content [{:tag :span :attrs {:class "foo bar baz" :id "id"}}]})
 27 |   (are [sel e] (empty? ((h/css sel) (loc/loc e)))
 28 |     "span" {:tag :div}
 29 |     "[id]" {:tag :div :attrs {:class "foo"}}
 30 |     "[id=bar]" {:tag :div :attrs {:id "foo"}}
 31 |     "[class~=fizz]" {:tag :div :attrs {:class "foo bar baz"}}
 32 |     "[lang|=fr]" {:tag :div :attrs {:lang "de"}}
 33 |     "[lang|=fr]" {:tag :div :attrs {:lang "be-fr"}}
 34 |     "[class^=oo]" {:tag :div :attrs {:class "foo bar baz"}}
 35 |     "[class*=boom]" {:tag :div :attrs {:class "foo bar baz"}}
 36 |     "[class$=ba]" {:tag :div :attrs {:class "foo bar baz"}}
 37 |     "span#id.foo" {:tag :div :attrs {:class "foo bar baz" :id "id"}}))
 38 | 
 39 | (def node (jsoup/parse "<div>"))
 40 | (def node2 (jsoup/parse "<div><span>t</span></div>"))
 41 | (def node3 (jsoup/parse "<ul><li><span class=a></span><span class=b></span>"))
 42 | (def node4 (jsoup/parse "<div style='background-color:green;color:blue;'>"))
 43 | 
 44 | (defn page-wrap [node-str]
 45 |   (str "<html><head></head><body>" node-str "</body></html>"))
 46 | 
 47 | (deftest transform-tests
 48 |   (testing "content tranform"
 49 |     (let [trans (static-template node :div (content :content))]
 50 |       (is (= (page-wrap "<div>test</div>")
 51 |              (trans {:content "test"})))))
 52 |   (testing "class tranform"
 53 |     (let [trans (static-template node :div (class :test :success))]
 54 |       (is (= (page-wrap "<div class='test'></div>")
 55 |              (trans {:success true})))))
 56 |   (testing "style tranform - insert style"
 57 |     (let [trans (static-template node :div (style :color :color))]
 58 |       (is (= (page-wrap "<div style='color:red;'></div>")
 59 |              (trans {:color "red"})))))
 60 |   (testing "style tranform - update style"
 61 |     (let [trans (static-template node4 :div (style :background-color
 62 |                                                    :color))]
 63 |       (is (= (page-wrap "<div style='color:blue;background-color:red;'></div>")
 64 |              (trans {:color "red"})))))
 65 |   (testing "append tranform"
 66 |     (let [trans (static-template node2 :div (append :success))]
 67 |       (is (= (page-wrap "<div><span>t</span>test</div>")
 68 |              (trans {:success "test"})))))
 69 |   (testing "prepend tranform"
 70 |     (let [trans (static-template node2 :div (prepend :success))]
 71 |       (is (= (page-wrap "<div>test<span>t</span></div>")
 72 |              (trans {:success "test"})))))
 73 |   (testing "dup tranform"
 74 |     (let [trans (static-template node :div (h/dup :items (content [])))]
 75 |       (is (= (page-wrap "<div>0</div><div>1</div><div>2</div>")
 76 |             (trans {:items (map str (range 3))}))))))
 77 | 
 78 | (deftest const-analysis-tests
 79 |   (let [t (static-template node3
 80 |             :li (h/dup (lens/const ["Hallo" ["Bonjour"]])
 81 |                   :span.a (content []))
 82 |             :span.b (content :msg))]
 83 |     (is (= (page-wrap "<ul><li><span class='a'>Hallo</span><span class='b'>x</span></li><li><span class='a'>Bonjour</span><span class='b'>x</span></li></ul>")
 84 |           (t {:msg "x"})))
 85 |     (is (= ["x"] (distinct
 86 |                     (keep (fn [[x y]] (when-not (identical? x y) x))
 87 |                       (map vector (t {:msg "x"} conj []) (t {:msg "y"} conj []))))))))
 88 | 
 89 | (deftest idempotency-tests
 90 |   (let [t (static-template node3
 91 |             :li (h/dup []
 92 |                   :span.a (content []))
 93 |             :li (h/dup []
 94 |                   :span.a (content [])))]
 95 |     (is (= (page-wrap "<ul><li><span class='a'>1</span><span class='b'></span></li><li><span class='a'>2</span><span class='b'></span></li></ul>")
 96 |           (t (map str (range 1 3))))))
 97 |   (let [t (static-template node3
 98 |             :li (h/dup []
 99 |                   :span (content []))
100 |             :li (h/dup []
101 |                   :span.a (content [])))]
102 |     (is (= (page-wrap "<ul><li><span class='a'>1</span><span class='b'>1</span></li><li><span class='a'>2</span><span class='b'>2</span></li></ul>")
103 |           (t (map str (range 1 3))))))
104 |   (let [t (static-template node3
105 |             :li (h/dup []
106 |                   :span.b (content []))
107 |             :li (h/dup []
108 |                   :span.a (content [])))]
109 |     (is (= (page-wrap "<ul><li><span class='a'>1</span><span class='b'>1</span></li><li><span class='a'>2</span><span class='b'>2</span></li></ul>")
110 |           (t (map str (range 1 3)))))))
111 | 
112 | (deftest escaping-test
113 |   (let [t (static-template node3
114 |             :span.a (content (lens/const "<&\"'"))
115 |             :span.a (h/attr :class (lens/const "<&\"'"))
116 |             :span.b (content [])
117 |             :span.b (h/attr :class []))]
118 |     (is (= (page-wrap
119 |              (let [s "<span class='<&\"&quot;'>&lt;&amp;\"'</span>"]
120 |                (str "<ul><li>" s s "</li></ul>")))
121 |           (t "<&\"'")))))
122 | 


--------------------------------------------------------------------------------
/src/enliven/commons/emit/static.clj:
--------------------------------------------------------------------------------
  1 | (ns enliven.commons.emit.static
  2 |   (:require [enliven.core.actions :as action]
  3 |     [enliven.core.plans :as plan]
  4 |     [enliven.core.lenses :as lens]))
  5 | 
  6 | (defn tight-emit!
  7 |   ([] [])
  8 |   ([acc]
  9 |     (let [p (peek acc)]
 10 |       (if (instance? StringBuilder p)
 11 |         (-> acc pop (conj (str p)))
 12 |         acc)))
 13 |   ([acc x]
 14 |     (let [p (peek acc)]
 15 |       (cond
 16 |         (fn? x) (conj (if (instance? StringBuilder p)
 17 |                         (-> acc pop (conj (str p)))
 18 |                         acc)
 19 |                   x)
 20 |         (instance? StringBuilder p) (do (.append ^StringBuilder p x) acc)
 21 |         :else (conj acc (StringBuilder. (str x)))))))
 22 | 
 23 | (defn tight-fn-emit!
 24 |   ([] [(fn [emit' acc stack] acc) nil])
 25 |   ([[f ^StringBuilder sb]]
 26 |     (if sb
 27 |       (let [s (str sb)]
 28 |         (fn [emit' acc stack]
 29 |           (emit' (f emit' acc stack) s)))
 30 |       f))
 31 |   ([[f ^StringBuilder sb] x]
 32 |     (cond
 33 |       (fn? x) [(if sb
 34 |                 (let [s (str sb)]
 35 |                   (fn [emit' acc stack]
 36 |                     (x emit' (emit' (f emit' acc stack) s) stack)))
 37 |                 (fn [emit' acc stack]
 38 |                   (x emit' (f emit' acc stack) stack)))
 39 |                nil]
 40 |       sb [f (.append sb x)]
 41 |       :else [f (StringBuilder. (str x))])))
 42 | 
 43 | #_(defn tight-eval-fn-emit!
 44 |    ([] [(map gensym '[emit' acc stack]) [] {} nil])
 45 |    ([[[emit'-sym acc-sym stack-sym] forms meta-args ^StringBuilder sb]]
 46 |      (let [forms (if sb
 47 |                    (conj forms (list emit'-sym acc-sym (str sb)))
 48 |                    forms)
 49 |            meta-f (eval `(fn [~@(keys meta-args)]
 50 |                            (fn [~emit'-sym ~acc-sym ~stack-sym]
 51 |                              (as-> ~acc-sym ~acc-sym ~@forms))))]
 52 |        (apply meta-f (vals meta-args))))
 53 |    ([[[emit'-sym acc-sym stack-sym :as syms] forms meta-args ^StringBuilder sb] x]
 54 |      (cond
 55 |        (fn? x) (let [f-sym (gensym 'f)]
 56 |                  [syms
 57 |                   (as-> forms forms
 58 |                     (if sb
 59 |                       (conj forms (list emit'-sym acc-sym (str sb)))
 60 |                       forms)
 61 |                     (conj forms (list f-sym emit'-sym acc-sym stack-sym)))
 62 |                   (assoc meta-args f-sym x)
 63 |                   nil])
 64 |        sb [syms forms meta-args (.append sb x)]
 65 |        :else [syms forms meta-args (StringBuilder. (str x))])))
 66 | 
 67 | (defn bytes-fn-emit!
 68 |   ([] [(fn [emit' acc stack] acc) nil])
 69 |   ([[f ^java.io.ByteArrayOutputStream out]]
 70 |     (if out
 71 |       (let [b (.toByteArray out)]
 72 |         (fn [emit' acc stack]
 73 |           (emit' (f emit' acc stack) b)))
 74 |       f))
 75 |   ([[f ^java.io.ByteArrayOutputStream out] x]
 76 |     (cond
 77 |       (fn? x) [(if out
 78 |                 (let [b (.toByteArray out)]
 79 |                   (fn [emit' acc stack]
 80 |                     (x emit' (emit' (f emit' acc stack) b) stack)))
 81 |                 (fn [emit' acc stack]
 82 |                   (x emit' (f emit' acc stack) stack)))
 83 |                nil]
 84 |       out [f (let [b (.getBytes ^String x "UTF-8")] (doto out (.write b 0 (alength b))))]
 85 |       :else [f (let [b (.getBytes ^String x "UTF-8")
 86 |                      n (alength b)]
 87 |                  (doto (java.io.ByteArrayOutputStream. n) (.write b 0 n)))])))
 88 | 
 89 | (defn render*
 90 |   "Similar to render but takes a stack of scopes instead of just the model."
 91 |   [emitted stack f acc]
 92 |   (cond
 93 |     (fn? emitted) (emitted f acc stack)
 94 |     (vector? emitted) (reduce #(render* %2 stack f %1) acc emitted)
 95 |     :else (f acc emitted)))
 96 | 
 97 | (defn render
 98 |   "Renders a compiled (emitted) template. Either as a string or using a reduce-like interface."
 99 |   ([emitted data]
100 |     (str (render emitted data (fn [^StringBuilder sb s] (.append sb s))
101 |           (StringBuilder.))))
102 |   ([emitted data f acc]
103 |     (render* emitted (list data) f acc)))
104 | 
105 | (defmulti perform (fn [action stack render emit' acc] (:op action)))
106 | 
107 | (defmethod perform ::action/replace [{n :scope-idx f :arg} stack render emit' acc]
108 |   (render (-> stack (nth n) f) emit' acc))
109 | 
110 | #_(defmethod perform ::action/if [{n :scope-idx f :arg [then else] :subs} stack render emit' acc]
111 |    (if (-> stack (nth n) f)
112 |      (render* then stack emit' acc)
113 |      (render* else stack emit' acc)))
114 | 
115 | (defmethod perform ::action/dup [{n :scope-idx f :arg [sub] :subs} stack render emit' acc]
116 |   (reduce (fn [acc item]
117 |             (render* sub (conj stack item) emit' acc))
118 |     acc (-> stack (nth n) f)))
119 | 
120 | (defmulti prerenderer-fn identity)
121 | 
122 | (defn prerender [node-type node plan enc emit acc]
123 |   ((prerenderer-fn node-type) node plan enc emit acc))
124 | 
125 | (defn prerender-action [node action node-type enc emit acc]
126 |   (let [prerenderer (prerenderer-fn node-type)
127 |         action (-> action
128 |                  (action/update :subs
129 |                    (fn [[skip-lens subplan]]
130 |                      (emit (prerenderer (lens/fetch node skip-lens) subplan enc emit (emit)))))
131 |                  (action/update :arg lens/fetcher))]
132 |     (emit acc (fn [emit' acc stack]
133 |                 (perform action stack
134 |                   (fn [node emit' acc]
135 |                     (prerenderer node nil enc emit' acc)) emit' acc)))))
136 | 
137 | (defn prerender-unknown
138 |   "When the plan involves unknown segments, fall back to the naive execution model."
139 |   [node plan node-type enc emit acc]
140 |   (if-let [action (:action plan)]
141 |     (prerender-action node action node-type enc emit acc)
142 |     (emit acc (let [prerenderer (prerenderer-fn node-type)]
143 |                 (fn [emit' acc stack]
144 |                   (prerenderer (plan/execute node plan stack) nil enc emit' acc))))))
145 | 
146 | (defn prerender-nodes
147 |   [nodes plan node-type enc emit acc]
148 |   (let [prerenderer (prerenderer-fn node-type)
149 |         emit-consts (fn [acc nodes]
150 |                       (reduce (fn [acc node]
151 |                                 (prerenderer node nil enc emit acc))
152 |                         acc nodes))]
153 |     (cond
154 |       (nil? plan) (emit-consts acc nodes)
155 |       (:action plan) (prerender-unknown nodes plan node-type enc emit acc)
156 |       ; there should be a check that we only have known segments
157 |       :else (let [[acc prev-to]
158 |                   (reduce
159 |                     (fn [[acc prev-to] [x subplan]]
160 |                       (let [[from to] (lens/bounds x nodes)
161 |                             subnode (lens/fetch nodes x)]
162 |                         [(as-> (emit-consts acc (subvec nodes prev-to from)) acc
163 |                            (prerenderer subnode subplan enc emit acc))
164 |                          to]))
165 |                     [acc 0] (concat (:number plan) (:range plan)))]
166 |               (emit-consts acc (subvec nodes prev-to))))))
167 | 


--------------------------------------------------------------------------------
/src/enliven/html.clj:
--------------------------------------------------------------------------------
  1 | (ns enliven.html
  2 |   (:refer-clojure :exclude [class descendants])
  3 |   (:require [enliven.core.actions :as action]
  4 |     [enliven.html.model :as html]
  5 |     [enliven.core.lenses :as lens]
  6 |     [enliven.core.locs :as loc]
  7 |     [enliven.core.selectors :as sel]
  8 |     [enliven.core.grounder :as grounder]
  9 |     [enliven.core.transformations :as transform]
 10 |     [enliven.core.plans :as plan]
 11 |     enliven.html.emit.static
 12 |     [enliven.commons.emit.static :as static]
 13 |     [clojure.string :as str]))
 14 | 
 15 | (defn children [loc]
 16 |   (when (:tag (loc/node loc))
 17 |     (let [loc (loc/down loc :content)]
 18 |       (for [i (range (count (loc/node loc)))]
 19 |         (loc/down loc i)))))
 20 | 
 21 | (defn text-node [loc]
 22 |   (when (string? (loc/node loc)) (list loc)))
 23 | 
 24 | (defn element [loc]
 25 |   (let [node (loc/node loc)]
 26 |     (when (and (map? node) (:tag node))
 27 |       (list loc))))
 28 | 
 29 | (defn descendants [loc]
 30 |   (mapcat #(cons % (descendants %)) (children loc)))
 31 | 
 32 | (defn descendants-and-self [loc]
 33 |   (cons loc (descendants loc)))
 34 | 
 35 | (defn indirect-adjacent-combinator
 36 |   "http://www.w3.org/TR/2001/CR-css3-selectors-20011113/#adjacent-i-combinators"
 37 |   [loc]
 38 |   (sel/chain (sel/rights loc) element))
 39 | 
 40 | (defn direct-adjacent-combinator
 41 |   "http://www.w3.org/TR/2001/CR-css3-selectors-20011113/#adjacent-d-combinators"
 42 |   [loc]
 43 |   (some-> loc indirect-adjacent-combinator first list))
 44 | 
 45 | (defn loose-chain
 46 |   ([] list)
 47 |   ([& sels] (reduce sel/chain (interpose descendants sels))))
 48 | 
 49 | (defprotocol ^:private ToSelector
 50 |   (as-sel [x]))
 51 | 
 52 | (def ^:private css-combinators
 53 |   {com.phloc.css.decl.ECSSSelectorCombinator/BLANK descendants
 54 |    com.phloc.css.decl.ECSSSelectorCombinator/TILDE indirect-adjacent-combinator
 55 |    com.phloc.css.decl.ECSSSelectorCombinator/PLUS direct-adjacent-combinator
 56 |    com.phloc.css.decl.ECSSSelectorCombinator/GREATER list})
 57 | 
 58 | (defn- css-sel [^com.phloc.css.decl.CSSSelector sel]
 59 |   (reduce sel/chain
 60 |     list (map #(or (css-combinators %) (as-sel %)) (.getAllMembers sel))))
 61 | 
 62 | (defn- css-members-sel [members]
 63 |   (->> members (map css-sel) (apply sel/union)))
 64 | 
 65 | (defn css [^String s]
 66 |   (-> s
 67 |     (str " {}")
 68 |     (com.phloc.css.reader.CSSReader/readFromString
 69 |       "utf-8"
 70 |       com.phloc.css.ECSSVersion/CSS30)
 71 |     .getAllStyleRules
 72 |     ^com.phloc.css.decl.CSSStyleRule first
 73 |     .getAllSelectors
 74 |     css-members-sel))
 75 | 
 76 | (defn sel
 77 |   ([spec]
 78 |     (sel spec :root))
 79 |   ([spec relationship]
 80 |     (if (sequential? spec)
 81 |       (first (reduce
 82 |                (fn [[r relationship] step]
 83 |                  (if (= :> step)
 84 |                    [r (case relationship
 85 |                         (:strict-root :root) :strict-root
 86 |                         :children)]
 87 |                    [(sel/chain r (sel step relationship)) :descendants]))
 88 |               [list relationship] spec))
 89 |       (sel/chain
 90 |         (case relationship
 91 |           :strict-root list
 92 |           :root descendants-and-self
 93 |           :children children
 94 |           :descendants descendants)
 95 |         (cond
 96 |           (string? spec) (css spec)
 97 |           (keyword? spec) (css (name spec))
 98 |           :else spec)))))
 99 | 
100 | (defn tag-selector [tag]
101 |   (sel/node-pred #(some->> % :tag (= tag))))
102 | 
103 | (defn- space-separated-values [s]
104 |   (re-seq #"\S+" s))
105 | 
106 | (defn class-selector [class]
107 |   (sel/node-pred #(some->> % :attrs :class space-separated-values (some #{class}))))
108 | 
109 | (defn id-selector [id]
110 |   (sel/node-pred #(some-> % :attrs :id str/trim (= id))))
111 | 
112 | (extend-protocol ToSelector
113 |   com.phloc.css.decl.CSSSelectorSimpleMember
114 |   (as-sel [sel]
115 |     (let [s (.getValue sel)]
116 |       (case (first s)
117 |         \# (id-selector (subs s 1))
118 |         \. (class-selector (subs s 1))
119 |         \: (throw (ex-info "unsupported pseudo-class" {:pseudo-class s}))
120 |         (tag-selector (keyword s)))))
121 |   com.phloc.css.decl.CSSSelectorAttribute
122 |   (as-sel [sel]
123 |     (let [attr (keyword (.getAttrName sel))
124 |           value (.getAttrValue sel)
125 |           op (.getOperator sel)
126 |           attr-pred
127 |           (condp = op
128 |             nil identity
129 |             com.phloc.css.decl.ECSSAttributeOperator/EQUALS
130 |             #(= % value)
131 |           com.phloc.css.decl.ECSSAttributeOperator/INCLUDES
132 |           #(some->> % space-separated-values (some #{value}))
133 |           com.phloc.css.decl.ECSSAttributeOperator/DASHMATCH
134 |           (let [value- (str value "-")]
135 |             (fn [^String v] (or (= v value) (.startsWith v value-))))
136 |           com.phloc.css.decl.ECSSAttributeOperator/BEGINMATCH
137 |           #(.startsWith ^String % value)
138 |           com.phloc.css.decl.ECSSAttributeOperator/CONTAINSMATCH
139 |           #(>= (.indexOf ^String % value) 0)
140 |           com.phloc.css.decl.ECSSAttributeOperator/ENDMATCH
141 |           #(.endsWith ^String % value)
142 |           (throw (ex-info "Unexpected attribute operator" {:op op})))]
143 |       (sel/node-pred
144 |         #(some-> % :attrs attr attr-pred))))
145 |   #_#_com.phloc.css.decl.CSSSelectorMemberNot
146 |   (as-sel [sel]
147 |     (let [nested-selector (-> sel .getNestedMembers css-members-sel)]
148 |       (fn [loc]))))
149 | 
150 | (defn at [& selector+transformations]
151 |   (transform/at* selector+transformations sel))
152 | 
153 | ;; html-specific transformations
154 | (defn class
155 |   "Set a class (on the selected elements) when the value at the corresponding path in the model is true."
156 |   {:arglists '([class path & class+paths])}
157 |   [& class+paths]
158 |   (transform/composite
159 |     (for [[class path] (partition 2 class+paths)]
160 |       (transform/replace
161 |         (sel/chain element (sel/by-path [:attrs :class html/classes (name class)]))
162 |         path))))
163 | 
164 | (defn style
165 |   "set style attributes (on the selected elements) to the value at the corriesponding path in the model. This transform will append modified styles to the end of style string. If you have multiple pairs being changes it does not guarantee order of appended pairs."
166 |   {:arglists '([style path & syle+paths])}
167 |   [& style+paths]
168 |   (transform/composite
169 |     (for [[style path] (partition 2 style+paths)]
170 |       (transform/replace
171 |         (sel/chain element (sel/by-path [:attrs :style html/styles lens/append-on-assoc (name style)]))
172 |         path))))
173 | 
174 | (defn attr
175 |   "Set an attribute (on the selected elements) to the value at the corresponding path in the model."
176 |   {:arglists '([attr path & attr+paths])}
177 |   [& attr+paths]
178 |   (transform/composite
179 |     (for [[attr path] (partition 2 attr+paths)]
180 |       (transform/replace
181 |         (sel/chain element (sel/by-path [:attrs (keyword attr)]))
182 |         path))))
183 | 
184 | (defn content
185 |   "Set the content (of the selected elements) the value at the path in the model."
186 |   [path]
187 |   (transform/replace
188 |     (sel/chain element (sel/by-path [:content (lens/slice 0 java.lang.Long/MAX_VALUE)]))
189 |     path))
190 | 
191 | (defn prepend [path]
192 |   (transform/replace
193 |     (sel/chain element (sel/by-path [:content (lens/slice 0 0)]))
194 |     path))
195 | 
196 | (defn append [path]
197 |   (transform/replace
198 |     (sel/chain element (sel/by-path [:content (lens/slice java.lang.Long/MAX_VALUE java.lang.Long/MAX_VALUE)]))
199 |     path))
200 | 
201 | (defn dup
202 |   "Dup[licate] the selected nodes for each item in the collection at the path in the model.
203 |   Each copy is then transformed using the specified transformations.
204 |   For these transformatons the model is restricted to the item."
205 |   [path & transformations]
206 |   (transform/dup path (apply at transformations)))
207 | 
208 | #_(defn if [selector test then else]
209 |    [[selector [::action/if 0 [test] then else]]])
210 | 
211 | (def discard (dup (lens/const nil)))
212 | 
213 | (defn static-template [node & transformations]
214 |   (let [plan (plan/plan (grounder/ground (apply at transformations) node))
215 |         [node plan] (plan/const-execute node plan (list ::plan/dynamic))
216 |         plan (plan/tidy plan)
217 |         emit! static/tight-fn-emit!
218 |         emitted (emit! (static/prerender ::html/node node plan identity emit! (emit!)))]
219 |     (fn
220 |       ([data] (static/render emitted data))
221 |       ([data emit acc] (static/render emitted data emit acc)))))
222 | 
223 | #_(defn static-bytes-template [node & transformations]
224 |    (let [plan (plan/plan (grounder/ground (apply at transformations) node))
225 |          [node plan] (plan/const-execute node plan (list ::plan/dynamic))
226 |          plan (plan/tidy plan)
227 |          emit static/bytes-fn-emit!
228 |          emitted (emit (static/prerender ::html/node node plan emit (emit)))]
229 |      (fn
230 |        ([data] (.toByteArray
231 |                  ^java.io.ByteArrayOutputStream (static/render emitted data
232 |                                                   (fn [^java.io.ByteArrayOutputStream out ^bytes x]
233 |                                                     (doto out (.write x 0 (alength x))))
234 |                                                   (java.io.ByteArrayOutputStream.))))
235 |        ([data emit acc] (static/render emitted data emit acc)))))
236 | 


--------------------------------------------------------------------------------
/src/enliven/core/plans.clj:
--------------------------------------------------------------------------------
  1 | (ns enliven.core.plans
  2 |   (:require
  3 |     [enliven.core.lenses :as lens]
  4 |     [enliven.core.actions :as action]))
  5 | 
  6 | ;; a plan is a hierarchical representation of a set of rules
  7 | 
  8 | (def empty-plan {:range (sorted-map)
  9 |                  :number (sorted-map)
 10 |                  :misc {}})
 11 | 
 12 | (defn map-vals [m f]
 13 |   (reduce-kv (fn [m k v] (assoc m k (f v))) m m))
 14 | 
 15 | (defn- map-actions [plan f]
 16 |   (if-let [action (:action plan)]
 17 |     (assoc plan :action (f action))
 18 |     (map-vals plan
 19 |       (fn [plans-by-seg]
 20 |         (map-vals plans-by-seg #(map-actions % f))))))
 21 | 
 22 | (declare plan-in)
 23 | 
 24 | (defn plan [rules]
 25 |   (map-actions
 26 |     (->> rules
 27 |       (sort-by (comp count first))
 28 |       (reduce (fn [plan [lens action]]
 29 |                 (plan-in plan (lens/decompose lens) action)) empty-plan))
 30 |     (fn [action] (action/update action :subs (lens/af plan 1) #_(fn [[skip-lens sub]] [skip-lens (plan sub)])))))
 31 | 
 32 | (defn- nest [action]
 33 |   (letfn [(nest-rules [rules]
 34 |             (set (for [[path action] rules]
 35 |                    [path (nest action)])))]
 36 |     (-> action (assoc :scope-idx (inc (:scope-idx action)))
 37 |       (action/update :subs (lens/af nest-rules 1)
 38 |         #_(fn [[skip-lens sub]] [skip-lens (nest-rules sub)])))))
 39 | 
 40 | (defn- mash [action path sub-action]
 41 |   (cond
 42 |     (seq (lens/decompose path))
 43 |     (let [path (lens/decompose path)
 44 |           sub-action (if (:arg action) (nest sub-action) sub-action)]
 45 |       (action/update action :subs
 46 |         (fn [[skip-lens sub]]
 47 |           (if-let [path (lens/relativize path skip-lens)]
 48 |             [skip-lens (conj sub [path sub-action])]
 49 |             [skip-lens sub]))))
 50 |     (= (action/update action :subs first) (action/update sub-action :subs first))
 51 |     (let [subs (into {} (:subs sub-action))]
 52 |       (action/update action :subs
 53 |         (fn [[skip-lens sub]]
 54 |           [skip-lens (into (set sub) (subs skip-lens))])))
 55 |     :else (throw (ex-info "Conflicting actions" {:actions [action sub-action]}))))
 56 | 
 57 | (defn unplan [plan]
 58 |   {:pre [(map? plan)]}
 59 |   (letfn [(unplan' [plan]
 60 |             (if-let [planned-action (:action plan)]
 61 |               (let [action (action/update planned-action :subs
 62 |                              (lens/af unplan 1)
 63 |                              #_(fn [[skip-lens plan]] [skip-lens (unplan plan)]))]
 64 |                 [[() action]])
 65 |               (for [plans-by-seg (vals plan)
 66 |                     [seg sub-plan] plans-by-seg
 67 |                     [path action] (unplan sub-plan)]
 68 |                 [(cons seg path) action])))]
 69 |     (for [[path action] (unplan' plan)]
 70 |       [path action])))
 71 | 
 72 | (defn tidy
 73 |   ([a-plan] (tidy a-plan lens/simplify))
 74 |   ([a-plan tidy-path]
 75 |     (letfn [(tidy-rules [rules]
 76 |               (map (fn [[path action]]
 77 |                      [(tidy-path path) (action/update action :subs (lens/af tidy-rules 1))]) rules))]
 78 |       (-> a-plan unplan tidy-rules plan))))
 79 | 
 80 | (defn- plan-in [wip-plan lenses action]
 81 |   {:pre [(or (nil? lenses) (sequential? lenses))
 82 |          (map? action)]}
 83 |   (let [wip-plan (or wip-plan empty-plan)]
 84 |     (if-let [other-action (:action wip-plan)]
 85 |       (assoc wip-plan
 86 |         :action (mash other-action lenses action))
 87 |       (if-let [[lens & lenses] (seq lenses)]
 88 |         (update-in wip-plan [(lens/lens-class lens) lens]
 89 |           plan-in lenses action)
 90 |         (assoc wip-plan :action action)))))
 91 | 
 92 | (defn perform-dispatch-fn [action scopes node] (:op action))
 93 | 
 94 | (defmulti perform
 95 |   "Performs the required action and returns the updated node."
 96 |   perform-dispatch-fn)
 97 | 
 98 | (defn execute [node plan scopes]
 99 |   (if-let [action (:action plan)]
100 |     (perform action scopes node)
101 |     (reduce (fn [node [seg plan]]
102 |               (lens/update node seg execute plan scopes))
103 |       node (concat (:misc plan) (rseq (:number plan)) (rseq (:range plan))))))
104 | 
105 | (defn- shift-seg [seg delta]
106 |   (cond
107 |     (lens/slice? seg)
108 |     (let [[from to] (lens/bounds seg)]
109 |       (lens/slice (+ from delta) (+ to delta)))
110 |     (number? seg)
111 |     (+ seg delta)
112 |     :else
113 |     seg))
114 | 
115 | (defn- spliceable [x]
116 |   (if (or (nil? x) (sequential? x))
117 |     x
118 |     (list x)))
119 | 
120 | (defn- has-plan? [plan]
121 |   (and plan (not= plan empty-plan)))
122 | 
123 | (defmulti const-perform
124 |   perform-dispatch-fn)
125 | 
126 | (defn const-execute [node plan scopes]
127 |   (if-let [action (:action plan)]
128 |     (const-perform action scopes node)
129 |     (cond
130 |       (seq (:range plan))
131 |       (let [[node _ plans-by-seg]
132 |             (reduce
133 |               (fn [[node' d plans-by-seg] [seg plan]]
134 |                 (let [seg (shift-seg seg d)
135 |                       sub-node (lens/fetch node' seg)
136 |                       [sub-node' plan'] (const-execute sub-node plan scopes)
137 |                       delta (- (count sub-node') (count sub-node))]
138 |                   [(lens/putback node' seg sub-node')
139 |                    (+ d delta)
140 |                    (assoc plans-by-seg seg plan')]))
141 |               [node 0 (sorted-map)] (rseq (:range plan)))]
142 |        [node (assoc empty-plan :range plans-by-seg)])
143 |       (seq (:misc plan))
144 |       (let [[node plans-by-seg]
145 |             (reduce
146 |               (fn [[node' plans-by-seg] [seg plan]]
147 |                 (let [sub-node (lens/fetch node' seg)
148 |                       [sub-node' plan'] (const-execute sub-node plan scopes)]
149 |                   [(lens/putback node' seg sub-node')
150 |                    (if (has-plan? plan')
151 |                      (assoc plans-by-seg seg plan')
152 |                      plans-by-seg)]))
153 |               [node (sorted-map)] (:misc plan))]
154 |        [node (assoc empty-plan :misc plans-by-seg)])
155 |       ; quick'n'dirty
156 |       (seq (:number plan))
157 |       (let [[node plans-by-seg]
158 |             (reduce
159 |               (fn [[node' plans-by-seg] [seg plan]]
160 |                 (let [sub-node (lens/fetch node' seg)
161 |                       [sub-node' plan'] (const-execute sub-node plan scopes)]
162 |                   [(lens/putback node' seg sub-node')
163 |                    (if (has-plan? plan')
164 |                      (assoc plans-by-seg seg plan')
165 |                      plans-by-seg)]))
166 |               [node (sorted-map)] (:number plan))]
167 |        [node (assoc empty-plan :number plans-by-seg)]))))
168 | 
169 | (defmacro ^:private if-const-let [[name scopes n lens] then else]
170 |   `(let [lens# ~lens]
171 |      (if (lens/const? lens#)
172 |       (let [~name (lens/fetch nil lens#)]
173 |         ~then)
174 |       (let [scope# (nth ~scopes ~n)]
175 |         (if (= ::dynamic scope#)
176 |           ~else
177 |           (let [~name (lens/fetch scope# lens#)]
178 |             ~then))))))
179 | 
180 | (defmethod const-perform ::action/replace [{n :scope-idx path :arg :as action} scopes node]
181 |   (if-const-let [v scopes n path]
182 |     [v empty-plan]
183 |     [node (assoc empty-plan :action action)]))
184 | 
185 | (defmethod perform ::action/replace [{n :scope-idx path :arg} scopes node]
186 |   (-> scopes (nth n) (lens/fetch path)))
187 | 
188 | (defmethod perform ::action/if [{n :scope-idx path :arg [then else] :subs} scopes node]
189 |   (if (-> scopes (nth n) (lens/fetch path))
190 |     (execute node then scopes)
191 |     (execute node else scopes)))
192 | 
193 | (defmethod perform ::action/dup [{n :scope-idx path :arg [[skip-lens sub]] :subs} scopes node]
194 |   (mapcat (fn [item]
195 |             (spliceable (execute node sub (conj scopes item))))
196 |     (-> scopes (nth n) (lens/fetch path))))
197 | 
198 | (defmulti ^:private propagate-drop-scope :op)
199 | 
200 | (defn- drop-scope
201 |   ([plan] (drop-scope plan 0))
202 |   ([plan n]
203 |     (map-actions plan (fn [{m :scope-idx :as action}]
204 |                         (propagate-drop-scope
205 |                           (if (> m n)
206 |                             (assoc action :scope-idx (dec m))
207 |                             action)
208 |                           n)))))
209 | 
210 | (defmethod propagate-drop-scope :default [action n]
211 |   (action/update action :subs drop-scope action n))
212 | 
213 | (defmethod propagate-drop-scope ::action/dup [action n]
214 |   (action/update action :subs drop-scope action (inc n)))
215 | 
216 | (defmethod const-perform ::action/dup [{n :scope-idx path :arg [[skip-lens sub]] :subs :as action} scopes node]
217 |   (if-const-let [coll scopes n path]
218 |     (let [node (lens/fetch node skip-lens)
219 |           [nodes plans-by-seg]
220 |           (reduce
221 |             (fn [[nodes plan-by-ranges] item]
222 |               (let [[node sub] (const-execute node sub (conj scopes item))
223 |                     sub (drop-scope sub)
224 |                     snodes (spliceable node)
225 |                     nodes' (into nodes snodes)]
226 |                 [nodes'
227 |                  (if (has-plan? sub)
228 |                    (assoc plan-by-ranges
229 |                      (lens/slice (count nodes) (count nodes'))
230 |                      (if (= snodes node)
231 |                        sub
232 |                        (assoc-in empty-plan [:number 0] sub)))
233 |                    plan-by-ranges)]))
234 |             [[] (sorted-map)] coll)]
235 |       [nodes (assoc empty-plan :range plans-by-seg)])
236 |     [node (assoc empty-plan
237 |             ; subs should embed their node so that const-execute could be propagated
238 |             :action action)]))
239 | 
240 | (defmethod const-perform ::action/if [{n :scope-idx path :arg [then else] :subs :as action} scopes node]
241 |   (if-const-let [test scopes n path]
242 |     (const-execute node (if test then else) scopes)
243 |     [node (assoc empty-plan
244 |             ; subs should embed their node so that const-execute could be propagated
245 |             :action action)]))
246 | 


--------------------------------------------------------------------------------
/src/enliven/core/lenses.clj:
--------------------------------------------------------------------------------
  1 | (ns enliven.core.lenses
  2 |   (:refer-clojure :exclude [comp identity]))
  3 | 
  4 | (ns-unmap *ns* 'Readable)
  5 | 
  6 | (defprotocol Readable
  7 |   (expr-form [x]))
  8 | 
  9 | (defprotocol Lens
 10 |   (-fetch [lens value])
 11 |   (-putback [lens value subvalue]))
 12 | 
 13 | (defprotocol LensEx
 14 |   (-fetcher [lens]))
 15 | 
 16 | (defprotocol CompoundLens
 17 |   (-decompose [lc]))
 18 | 
 19 | (defn lens? [l]
 20 |   (satisfies? Lens l))
 21 | 
 22 | (declare compound)
 23 | 
 24 | (def identity
 25 |   (reify
 26 |     Lens
 27 |     (-fetch [id x] x)
 28 |     (-putback [id x x'] x')
 29 |     Readable
 30 |     (expr-form [id] `identity)
 31 |     CompoundLens
 32 |     (-decompose [id] ())
 33 |     LensEx
 34 |     (-fetcher [id]
 35 |       clojure.core/identity)))
 36 | 
 37 | (defn lens [x]
 38 |   (cond
 39 |     (satisfies? Lens x) x
 40 |     (nil? x) identity ; not sure about this one, or even making nil the identity
 41 |     (sequential? x) (apply compound x)
 42 |     :else
 43 |     (throw (IllegalArgumentException. (str "Don't know how to create a lens from: " x)))))
 44 | 
 45 | (defn fetch [value l]
 46 |   (-fetch (lens l) value))
 47 | 
 48 | (defn putback [value l subvalue]
 49 |   (-putback (lens l) value subvalue))
 50 | 
 51 | (defn update [node l f & args]
 52 |   (let [l (lens l)]
 53 |     (-putback l node (apply f (-fetch l node) args))))
 54 | 
 55 | (defn fetcher [l]
 56 |   (-fetcher (lens l)))
 57 | 
 58 | (doseq [t [clojure.lang.Keyword clojure.lang.Symbol String]]
 59 |   (extend t
 60 |     Lens {:-fetch #(get %2 %1)
 61 |           :-putback #(assoc %2 %1 %3)}
 62 |     Readable {:expr-form clojure.core/identity}))
 63 | 
 64 | (extend java.util.regex.Pattern
 65 |   Lens
 66 |   {:-fetch (clojure.core/comp vec re-seq)
 67 |    :-putback (fn [p s replacements]
 68 |                (let [m (re-matcher p s)]
 69 |                  (loop [sb (StringBuilder.) i 0 [s' & ss] replacements]
 70 |                    (if (.find m)
 71 |                      (recur (-> sb (.append (subs s i (.start m))) (.append (str s')))
 72 |                        (.end m) ss)
 73 |                      (-> sb (.append (subs s i)) .toString)))))}
 74 |   Readable {:expr-form clojure.core/identity})
 75 | 
 76 | (extend-protocol LensEx
 77 |   Object
 78 |   (-fetcher [lens] #(-fetch lens %))
 79 |   String
 80 |   (-fetcher [lens] #(get % lens)))
 81 | 
 82 | (doseq [t [clojure.lang.Keyword clojure.lang.Symbol]]
 83 |   (extend t
 84 |     LensEx {:-fetcher clojure.core/identity}))
 85 | 
 86 | (defn decompose [l]
 87 |   (-decompose (lens l)))
 88 | 
 89 | (extend-protocol CompoundLens
 90 |   Object
 91 |   (-decompose [l]
 92 |     (if (lens? l)
 93 |       (do
 94 |         (extend (class l) CompoundLens {:-decompose list})
 95 |         (list l))
 96 |       (throw (IllegalArgumentException. (str "Don't know how to decompose " l))))
 97 |     (list l)))
 98 | 
 99 | (defrecord LensComposition [lenses]
100 |   Lens
101 |   (-fetch [lc x] (reduce fetch x lenses))
102 |   (-putback [lc value subvalue]
103 |     (letfn [(pb [lenses value]
104 |               (if-let [[lens & lenses] (seq lenses)]
105 |                 (-putback lens value
106 |                   (pb lenses (-fetch lens value)))
107 |                 subvalue))]
108 |       (pb lenses value)))
109 |   Readable
110 |   (expr-form [lc] (list* `compound lenses))
111 |   CompoundLens
112 |   (-decompose [lc] lenses)
113 |   LensEx
114 |   (-fetcher [id]
115 |     (apply clojure.core/comp (map fetcher lenses))))
116 | 
117 | (defn compound [& lenses]
118 |   (let [lenses (mapcat decompose lenses)]
119 |     (cond
120 |       (next lenses) (LensComposition. lenses)
121 |       (seq lenses) (first lenses)
122 |       :else identity)))
123 | 
124 | (defn- bound [mn n mx]
125 |   (-> n (max mn) (min mx)))
126 | 
127 | (defn spliceable? [x]
128 |   (or (nil? x) (sequential? x)))
129 | 
130 | (defrecord Slice [from to]
131 |   Lens
132 |   (-fetch [lens x]
133 |     (let [n (count x)]
134 |       (subvec x (bound 0 from n) (bound 0 to n))))
135 |   (-putback [lens x v]
136 |     (let [n (count x)]
137 |       (-> x
138 |         (subvec 0 (bound 0 from n))
139 |         (into (if (spliceable? v) v (list v)))
140 |         (into (subvec x (bound 0 to n) n)))))
141 |   Readable
142 |   (expr-form [lens] (list `slice from to))
143 |   LensEx
144 |   (-fetcher [lens]
145 |     (fn [x]
146 |       (let [n (count x)]
147 |         (subvec x (bound 0 from n) (bound 0 to n)))))
148 |   Comparable
149 |   (compareTo [a b]
150 |     (cond
151 |       (= a b) 0
152 |       (<= (:to a) (:from b)) -1
153 |       :else +1)))
154 | 
155 | (defn slice [from to] (Slice. from to))
156 | 
157 | (defn slice? [lens] (instance? Slice lens))
158 | 
159 | (extend Number
160 |   Lens {:-fetch #(nth %2 %1)
161 |         :-putback #(assoc %2 %1 %3)}
162 |   Readable {:expr-form clojure.core/identity}
163 |   LensEx {:-fetcher (fn [n] #(nth % n))})
164 | 
165 | (defn lens-class [lens]
166 |   (cond
167 |     (slice? lens) :range
168 |     (number? lens) :number
169 |     :else :misc))
170 | 
171 | (defn bounds
172 |   ([lens]
173 |     (case (lens-class lens)
174 |                       :range [(:from lens) (:to lens)]
175 |                       :number [lens (inc lens)]))
176 |   ([lens v]
177 |     (let [[from to] (bounds lens)
178 |           n (count v)]
179 |       [(bound 0 from n) (bound 0 to n)])))
180 | 
181 | (defrecord Constant [v]
182 |   Lens
183 |   (-fetch [lens _] v)
184 |   (-putback [lens x _] x)
185 |   Readable
186 |   (expr-form [lens] (list `const v))
187 |   LensEx
188 |   (-fetcher [lens]
189 |     (constantly v)))
190 | 
191 | (defn const [v] (Constant. v))
192 | 
193 | (defn const? [lens] (instance? Constant lens))
194 | 
195 | (defmacro deflens [name doc? initial-args & methods]
196 |   (let [[name initial-args methods] (if (string? doc?)
197 |                                       [(vary-meta name assoc :doc doc?) initial-args methods]
198 |                                       [name doc? (cons initial-args methods)])
199 |         [value-arg subvalue-arg & args] initial-args
200 |         fqname (symbol (clojure.core/name (ns-name *ns*))
201 |                  (clojure.core/name name))
202 |         singleton-lens (empty? args)
203 |         [args [_ & rest-arg]] (split-with #(not= (clojure.core/name %) "&") args)
204 |         plain-args (take (count args) (repeatedly gensym))
205 |         plain-rest-arg (when rest-arg (gensym))
206 |         fetchexpr-form (some (fn [[name expr]] (case name :fetch expr nil)) (partition 2 methods))
207 |         methods (for [[name expr] (partition 2 methods)]
208 |                   (case name
209 |                     :fetch `(-fetch [_# ~value-arg] ~expr)
210 |                     :putback `(-putback [_# ~value-arg ~subvalue-arg] ~expr)))
211 |         f `(fn [~@plain-args ~@(when plain-rest-arg `[& ~plain-rest-arg])]
212 |              (let [~@(interleave args plain-args)
213 |                    ~@(when plain-rest-arg [rest-arg plain-rest-arg])]
214 |                (reify
215 |                  Lens
216 |                  ~@methods
217 |                  Readable
218 |                  (expr-form [_#] ~(if singleton-lens
219 |                                 `'~fqname
220 |                                 `(list* '~fqname ~@plain-args ~plain-rest-arg)))
221 |                  LensEx
222 |                  (-fetcher [_#]
223 |                    (fn [~value-arg] ~fetchexpr-form))
224 |                  Object
225 |                  (equals [this# that#]
226 |                    (and (satisfies? Lens that#)
227 |                      (= (expr-form this#) (expr-form that#))))
228 |                  (hashCode [this#] (hash (expr-form this#)))
229 |                  (toString [this#] (pr-str (expr-form this#))))))]
230 |     `(def ~name ~(if singleton-lens (list f) f))))
231 | 
232 | (deflens append-on-assoc
233 |   "Presents a sequence of key-value pairs (an alist) as a map.
234 |    On putback, unmodified key-value pairs appear first and in their original
235 |    order, then followed by new or updated key-value pairs in unspecified order.
236 |    Example:
237 |    # (update [[:a 1] [:b 2] [:c 3]]
238 |        append-on-assoc assoc :a 5 :d 6)
239 |    # [[:b 2] [:c 3] [:d 6] [:a 5]]"
240 |   [pairs hash]
241 |   :fetch (into {} pairs)
242 |   :putback (loop [kvs [] okvs pairs m hash]
243 |              (if-let [[[k v :as kv] & okvs] okvs]
244 |                (if (= (get m k m) v)
245 |                  (recur (conj kvs kv) okvs (dissoc m k))
246 |                  (recur kvs okvs m))
247 |                (into kvs m))))
248 | 
249 | (def ^:private transitions {})
250 | 
251 | (defn deftransition [from lens-or-lens-type to]
252 |   (let [{to :type :as transition-info} (if (map? to) to {:type to})]
253 |     (when-not (and (namespace from) (namespace to))
254 |       (throw (ex-info "from and to must be namespaced" {:from from :to to})))
255 |     (alter-var-root #'transitions update-in [from lens-or-lens-type] merge transition-info)))
256 | 
257 | (defn deftransitions [transitions-map]
258 |   (doseq [[from to-map] transitions-map
259 |           [lens-type to] to-map]
260 |     (deftransition from lens-type to)))
261 | 
262 | (defn lens-types [lens]
263 |   (let [e (expr-form lens)
264 |         type (cond
265 |                (= e lens) (class lens)
266 |                (symbol? e) e
267 |                :else (first e))]
268 |     (cons lens (cons type (ancestors type)))))
269 | 
270 | (defn transition-info [value-type lens]
271 |   (when-let [to-map (get transitions value-type)]
272 |     (some #(get to-map %) (lens-types lens))))
273 | 
274 | (defn fetch-type [value-type lens]
275 |   (reduce (clojure.core/comp :type transition-info)
276 |     value-type (decompose lens)))
277 | 
278 | (defn simplify
279 |   "Simplify constant lenses and collapse compounded slice lenses."
280 |   [l]
281 |   (lens
282 |     (reduce
283 |       (fn [lenses l]
284 |         (let [prev-lens (peek lenses)]
285 |           (cond
286 |             (const? prev-lens) [(const (fetch (fetch nil prev-lens) l))]
287 |             (slice? prev-lens)
288 |             (let [[pfrom] (bounds prev-lens)]
289 |               (if (slice? l)
290 |                 (let [[from to] (bounds l)]
291 |                   ; TODO check for special bounds
292 |                   (-> lenses pop (conj (slice (+ pfrom from) (+ pfrom to)))))
293 |                 (conj lenses l)))
294 |             (const? l) [l]
295 |             :else (conj lenses l))))
296 |      [] (decompose l))))
297 | 
298 | (defn canonical
299 |   "Canonicalize a path: simplify and add a parent slice for each indexed access."
300 |   [l]
301 |   (lens
302 |     (reduce
303 |       (fn [lenses l]
304 |         (let [prev-lens (peek lenses)]
305 |           (cond
306 |             (not (number? l)) (conj lenses l)
307 |             (slice? prev-lens)
308 |             (let [[pfrom] (bounds prev-lens)]
309 |               (let [from (+ pfrom l)]
310 |                 ; TODO check for special bounds
311 |                 (-> lenses pop (conj (slice from (inc from)) 0))))
312 |             :else (conj lenses (slice l (inc l)) 0))))
313 |       [] (decompose (simplify l)))))
314 | 
315 | (defn minimal [l]
316 |   (lens
317 |     (reduce
318 |      (fn [lenses l]
319 |        (let [prev-lens (peek lenses)]
320 |          (if (and (number? l) (slice? prev-lens))
321 |            (let [[pfrom] (bounds prev-lens)]
322 |              ; TODO check for special bounds
323 |              (-> lenses pop (conj (+ pfrom l))))
324 |            (conj lenses l))))
325 |      [] (decompose (simplify l)))))
326 | 
327 | (defn relativize [l prefix-lens]
328 |   ; lenses should be canonical
329 |   (loop [lenses (decompose l) prefix-lenses (decompose prefix-lens)]
330 |     (if-let [[plens & more-prefix-lenses] (seq prefix-lenses)]
331 |       (when-let [[l & more-lenses] (seq lenses)]
332 |         (cond
333 |           (= l plens) (recur more-lenses more-prefix-lenses)
334 |           (and (slice? l) (slice? plens) (empty? more-prefix-lenses))
335 |           (let [[pfrom pto] (bounds plens)
336 |                 [from to] (bounds l)]
337 |             (when (and (<= pfrom from) (<= to pto))
338 |               (lens (into [(slice (- from pfrom) (- to pfrom))] more-lenses))))))
339 |       (lens lenses))))
340 | 
341 | (defn focus
342 |   "Takes a n-arg function and returns a 1-arg function. All arguments to the original
343 |    function are fetched from the single argument using the arg-lenses, the return
344 |    vaues is putback in the single argument using ret-lens."
345 |   [ret-lens f & arg-lenses]
346 |   (fn [x]
347 |     (putback x ret-lens
348 |       (apply f (map #(fetch x %) arg-lenses)))))
349 | 
350 | (defn af
351 |   "autofocus: like focus except the main-lens is both the ret-lens and
352 |    the first arg-lens."
353 |   [f main-lens & other-lenses]
354 |   (apply focus main-lens f main-lens other-lenses))
355 | 
356 | #_(defn lens-map [m]
357 |    (let [m (if (map? m) m (zipmap m m))]
358 |      (reify Lens
359 |        (-fetch [_ x]
360 |          (zipmap (keys m) (map #(fetch x %) (vals m))))
361 |        (-putback [_ x y]
362 |          (reduce-kv (fn [x k l]
363 |                       (putback x k (get y k)))
364 |            x m)
365 |          (zipmap (keys m) (map #(fetch x %) (vals m)))))))
366 | 


--------------------------------------------------------------------------------