Make loom Clojure[Script] portable

.gitignore

@@ -5,3 +5,5 @@ classes
 /bin
 /target
 /.lein-*
+.nrepl-port
+out

.travis.yml

@@ -1,7 +1,7 @@
 language: clojure
 lein: lein2
-script: lein2 test :all
+script: lein2 test-all
 jdk:
   - openjdk7
-  - openjdk6
   - oraclejdk7
+  - oraclejdk8

project.clj

@@ -1,17 +1,45 @@
 (defproject aysylu/loom "0.6.1-SNAPSHOT"
+  :min-lein-version "2.0.0"
   :description "Graph library for Clojure"
   :license {:name "Eclipse Public License"
             :url "http://www.eclipse.org/legal/epl-v10.html"}
   :dependencies [[org.clojure/clojure "1.7.0"]
                  [org.clojure/data.priority-map "0.0.5"]
-                 [tailrecursion/cljs-priority-map "1.1.0"]]
+                 [tailrecursion/cljs-priority-map "1.2.0"]]
   :url "https://github.com/aysylu/loom"
   :test-selectors {:default (fn [m] (not (:test-check-slow m)))
                    :all (constantly true)
                    :test-check-slow :test-check-slow}
-  :profiles {:dev
-             {:dependencies [[org.clojure/test.check "0.5.7"]]}}
-  :aliases {"release" ["do" "clean," "with-profile" "default" "deploy" "clojars"]}
+
+  :profiles {:dev [:cljs
+                   {:dependencies [[org.clojure/test.check "0.9.0"]]
+                    :plugins [[com.jakemccrary/lein-test-refresh "0.15.0"]]
+                    :repl-options {:init (set! *print-length* 50)}}]
+
+             :cljs {:dependencies [[org.clojure/clojurescript "1.9.89"]]
+                    :plugins [[lein-cljsbuild "1.1.3" :exclusions [org.clojure/clojure]]
+                              [lein-doo "0.1.7"]]
+                    :doo {:build "node-dev"}
+                    :cljsbuild {:builds
+                                {"node-dev"
+                                 {:source-paths ["src", "test"]
+                                  :compiler {:output-to "target/loom.js"
+                                             :optimizations :none
+                                             :pretty-print true
+                                             :target :nodejs
+                                             :main loom.test.runner}}
+                                 "node-test"
+                                 {:id "min"
+                                  :source-paths ["src", "test"]
+                                  :compiler {:output-to "target/loom.js"
+                                             :optimizations :advanced
+                                             :pretty-print false
+                                             :target :nodejs
+                                             :main loom.test.runner}}}}}}
+
+  :aliases {"test-all" ["do" "clean," "test" ":all," "cljs-test"]
+            "cljs-test" ["doo" "node" "node-test" "once"]
+            "release" ["do" "clean," "with-profile" "default" "deploy" "clojars"]}
 
   :plugins  [[codox "0.8.12"]]
   :codox  {:src-dir-uri "https://github.com/aysylu/loom/blob/master/"

src/loom/alg.cljc

@@ -430,7 +430,7 @@ can use these functions."
   (letfn [(color-component [coloring start]
             (loop [coloring (assoc coloring start 1)
                    queue (conj #?(:clj clojure.lang.PersistentQueue/EMPTY
-                                  :cljs cljs.core.PersistentQueue/EMPTY) start)]
+                                  :cljs cljs.core/PersistentQueue.EMPTY) start)]
               (if (empty? queue)
                 coloring
                 (let [v (peek queue)
@@ -530,9 +530,10 @@ can use these functions."
         [flow-map flow-value] (case method
                                 :edmonds-karp (flow/edmonds-karp n i c s t)
                                 (throw
-                                 (java.lang.RuntimeException.
+                                 (ex-info
                                   (str "Method not found.  Choose from: "
-                                       method-set))))]
+                                       method-set)
+                                  {:method-set method-set})))]
     [flow-map flow-value]))
 
 
@@ -606,7 +607,7 @@ can use these functions."
   ([g src target heur q explored]
      (cond
       ;; queue empty, target not reachable
-      (empty? q) (throw (Exception. "Target not reachable from source"))
+      (empty? q) (throw (ex-info "Target not reachable from source" {}))
       ;; target found, build path and return
       (= (first (peek q)) target) (let [u (first (peek q))
                                         parent ((second (peek q)) 1)

src/loom/alg_generic.cljc

@@ -1,8 +1,11 @@
 (ns ^{:doc "Graph algorithms for use on any type of graph"
       :author "Justin Kramer"}
   loom.alg-generic
-  (:refer-clojure :exclude [ancestors])
-  (:import [java.util Arrays]))
+  (:refer-clojure :exclude [ancestors]))
+
+#?(:clj (do (set! *warn-on-reflection* true)
+            ;(set! *unchecked-math* :warn-on-boxed)
+            ))
 
 ;;;
 ;;; Utility functions
@@ -199,7 +202,9 @@
                                   (filter #(nbr-pred % node (inc depth))))]
                     (step (into (pop queue) (for [nbr nbrs] [nbr (inc depth)]))
                           (reduce #(assoc %1 %2 node) preds nbrs)))))))]
-      (step (conj clojure.lang.PersistentQueue/EMPTY [start 0])
+      (step (conj #?(:clj clojure.lang.PersistentQueue/EMPTY
+                     :cljs cljs.core/PersistentQueue.EMPTY)
+                  [start 0])
             (if (map? seen)
               (assoc seen start nil)
               (into {start nil} (for [s seen] [s nil])))))))
@@ -231,42 +236,46 @@
     (recur m2 m1)
     (filter (partial contains? m2) (keys m1))))
 
-(defn bf-path-bi
-  "Using a bidirectional breadth-first search, finds a path from start
+#?(:cljs
+   (defn bf-path-bi [outgoing predecessors start end]
+     (throw (js/Error. "Unsupported operation `bf-path-bi`")))
+   :clj
+   (defn bf-path-bi
+     "Using a bidirectional breadth-first search, finds a path from start
   to end with the fewest hops (i.e. irrespective of edge weights),
   outgoing and predecessors being functions which return adjacent
   nodes. Can be much faster than a unidirectional search on certain
   types of graphs"
-  [outgoing predecessors start end]
-  (let [done? (atom false)
-        preds1 (atom {}) ;from start to end
-        preds2 (atom {}) ;from end to start
-        search (fn [nbrs n preds]
-                 (dorun
-                  (take-while
-                   (fn [_] (not @done?))
-                   (bf-traverse
-                    nbrs n :f (fn [_ pm _] (reset! preds pm))))))
-        search1 (future (search outgoing start preds1))
-        search2 (future (search predecessors end preds2))
-        ;; TODO: watchers?
-        find-intersects #(shared-keys @preds1 @preds2)]
-    (loop [intersects (find-intersects)]
-      (if (or (seq intersects) (future-done? search1) (future-done? search2))
-        (do
-          (reset! done? true)
-          (cond
-           (seq intersects)
-           (let [intersect (apply min-key
-                                  #(+ (count (trace-path @preds1 %))
-                                      (count (trace-path @preds2 %)))
-                                  intersects)]
-             (concat
-              (reverse (trace-path @preds1 intersect))
-              (rest (trace-path @preds2 intersect))))
-           (@preds1 end) (reverse (trace-path @preds1 end))
-           (@preds2 start) (trace-path @preds2 start)))
-        (recur (find-intersects))))))
+     [outgoing predecessors start end]
+     (let [done? (atom false)
+           preds1 (atom {})             ;from start to end
+           preds2 (atom {})             ;from end to start
+           search (fn [nbrs n preds]
+                    (dorun
+                     (take-while
+                      (fn [_] (not @done?))
+                      (bf-traverse
+                       nbrs n :f (fn [_ pm _] (reset! preds pm))))))
+           search1 (future (search outgoing start preds1))
+           search2 (future (search predecessors end preds2))
+           ;; TODO: watchers?
+           find-intersects #(shared-keys @preds1 @preds2)]
+       (loop [intersects (find-intersects)]
+         (if (or (seq intersects) (future-done? search1) (future-done? search2))
+           (do
+             (reset! done? true)
+             (cond
+               (seq intersects)
+               (let [intersect (apply min-key
+                                      #(+ (count (trace-path @preds1 %))
+                                          (count (trace-path @preds2 %)))
+                                      intersects)]
+                 (concat
+                  (reverse (trace-path @preds1 intersect))
+                  (rest (trace-path @preds2 intersect))))
+               (@preds1 end) (reverse (trace-path @preds1 end))
+               (@preds2 start) (trace-path @preds2 start)))
+           (recur (find-intersects)))))))
 
 (defn- reverse-edges [successor-fn nodes coll]
   (for [node nodes
@@ -457,9 +466,9 @@
 
 ;;; Ancestry node-bitmap helper vars/fns
 
-(def ^Long bits-per-long (long (Long/SIZE)))
+(def bits-per-long (long #?(:clj 64 :cljs 32)))
 
-(defn ^Long bm-longs
+(defn bm-longs
   "Returns the number of longs required to store bits count bits in a bitmap."
   [bits]
   (long (Math/ceil (/ bits bits-per-long))))
@@ -469,11 +478,15 @@
   ^longs []
   (long-array 1))
 
+(defn- bm-copy ^longs [bm size]
+  #?(:clj (java.util.Arrays/copyOf ^longs bm ^Long size)
+     :cljs (.slice bm 0 size)))
+
 (defn bm-set
   "Set boolean state of bit in 'bitmap at 'idx to true."
   ^longs [^longs bitmap idx]
   (let [size (max (count bitmap) (bm-longs (inc idx)))
-        new-bitmap (Arrays/copyOf bitmap ^Long size)
+        new-bitmap (bm-copy bitmap size) 
         chunk (quot idx bits-per-long)
         offset (mod idx bits-per-long)
         mask (bit-set 0 offset)
@@ -499,7 +512,7 @@
   (if (empty? bitmaps)
     (bm-new)
     (let [size (apply max (map count bitmaps))
-          new-bitmap (Arrays/copyOf ^longs (first bitmaps) ^Long size)]
+          new-bitmap (bm-copy (first bitmaps) size)]
       (doseq [bitmap (rest bitmaps)
               [idx value] (map-indexed list bitmap)
               :let [masked-value (bit-or value (aget new-bitmap idx))]]

src/loom/attr.cljc

@@ -4,18 +4,17 @@ thickness, etc)."
       :author "Justin Kramer"}
   loom.attr
   (:require [loom.graph :refer [directed? nodes edges src dest has-node?]
-             :as graph])
-  (:import [loom.graph BasicEditableGraph BasicEditableDigraph
-            BasicEditableWeightedGraph BasicEditableWeightedDigraph
-            FlyGraph FlyDigraph WeightedFlyGraph WeightedFlyDigraph]))
+             :as graph]
+            #?@(:clj [[loom.cljs :refer (def-protocol-impls)]]))
+  #?@(:cljs [(:require-macros [loom.cljs :refer [def-protocol-impls extend]])]))
 
 (defprotocol AttrGraph
   (add-attr [g node-or-edge k v] [g n1 n2 k v] "Add an attribute to node or edge")
   (remove-attr [g node-or-edge k] [g n1 n2 k] "Remove an attribute from a node or edge")
   (attr [g node-or-edge k] [g n1 n2 k] "Return the attribute on a node or edge")
   (attrs [g node-or-edge] [g n1 n2] "Return all attributes on a node or edge"))
 
-(def default-attr-graph-impl
+(def-protocol-impls default-attr-graph-impl
   {:add-attr (fn
                ([g node-or-edge k v]
                  (if (has-node? g node-or-edge)
@@ -49,35 +48,35 @@ thickness, etc)."
                (let [attributes (get-in g [:attrs n1 ::edge-attrs n2])]
                  (when (seq attributes) attributes))))})
 
-(extend BasicEditableGraph
+(extend loom.graph.BasicEditableGraph
   AttrGraph
   default-attr-graph-impl)
 
-(extend BasicEditableDigraph
+(extend loom.graph.BasicEditableDigraph
   AttrGraph
   default-attr-graph-impl)
 
-(extend BasicEditableWeightedGraph
+(extend loom.graph.BasicEditableWeightedGraph
   AttrGraph
   default-attr-graph-impl)
 
-(extend BasicEditableWeightedDigraph
+(extend loom.graph.BasicEditableWeightedDigraph
   AttrGraph
   default-attr-graph-impl)
 
-(extend FlyGraph
+(extend loom.graph.FlyGraph
   AttrGraph
   default-attr-graph-impl)
 
-(extend FlyDigraph
+(extend loom.graph.FlyDigraph
   AttrGraph
   default-attr-graph-impl)
 
-(extend WeightedFlyGraph
+(extend loom.graph.WeightedFlyGraph
   AttrGraph
   default-attr-graph-impl)
 
-(extend WeightedFlyDigraph
+(extend loom.graph.WeightedFlyDigraph
   AttrGraph
   default-attr-graph-impl)
 
@@ -144,3 +143,4 @@ thickness, etc)."
          (hilite n2)
          (hilite n1 n2)))
    g (partition 2 1 path)))
+

src/loom/cljs.clj

@@ -0,0 +1,87 @@
+(ns loom.cljs
+  (:refer-clojure :exclude (extend)))
+
+;; What's going on here?
+;; 
+;; Loom uses `extend` extensively to provide protocol implementations for its
+;; various graph types. ClojureScript does not offer `extend` (only
+;; `extend-type` and `extend-protocol` are available). I did not want to
+;; refactor all the graph type definitions to use `extend-type` (either to
+;; duplicate all the protocol method impls, or delegate to the shared protocol
+;; fns that could be provided to `extend` in Clojure). Further, the protocol
+;; method impl maps in `loom.graph` are public, so I didn't want to change them
+;; from the perspective of a Clojure consumer (which might base other graph
+;; impls on those "base" maps).
+;; 
+;; This namespace is my hack/solution. Protocol method impl maps are now defined
+;; using `def-protocol-impls`, which behaves just as `def` in Clojure. But in
+;; ClojureScript, `def-protocol-impls` stores the provided map. An
+;; "implementation" of `extend` for ClojureScript is also provided here, which
+;; looks up those previously-defined maps, and uses their contents as the basis
+;; for an equivalent `extend-type` form.
+;; 
+;; There are various aspects of this that are wince-inducing, including the
+;; questionable-but-working resolution of `extend` map symbols, and the ad-hoc
+;; pattern matching and "application" on the ClojureScript side of certain
+;; functions that _loom_ uses to manipulate `extend` protocol method impl maps
+;; (`get-in`, `merge`). While such things are completely fine in Clojure, if
+;; later changes to loom manipulate those maps using other functions, the code
+;; below will need to be changed to accommodate them.
+;; 
+;; For all sorts of reasons, this is _not_ a general-purpose `extend`
+;; replacement, and so ClojureScript consumers of Loom will not be able to
+;; e.g. reliably reuse base protocol method impl maps as one can in Clojure.
+;; 
+;; - Chas
+
+(def ^:private protocol-impls (atom {}))
+
+(defn- resolve-symbol [ns sym]
+  (-> ns :name str (symbol (str sym))))
+
+(defmacro def-protocol-impls [name impl-map]
+  (if-let [ns (:ns &env)]
+    (let [impl-map (reduce
+                    (fn [impls [method impl]]
+                      (case (first impl)
+                        fn (assoc impls method impl)
+                        get-in (let [[_ other-impl-map-name path] impl
+                                      other-impl-map (@protocol-impls
+                                                      (resolve-symbol ns other-impl-map-name))]
+                                  (assoc impls method (get-in other-impl-map path)))))
+                    {}
+                    impl-map)]
+      (swap! protocol-impls assoc (resolve-symbol ns name) impl-map)
+      nil)
+    `(def ~name ~impl-map)))
+
+(defn- resolve-impl-map [env imap]
+  (cond
+    (map? imap) imap
+
+    (and (seq? imap) (= 'merge (first imap)))
+    (apply merge (map #(resolve-impl-map env %) (rest imap)))
+
+    (symbol? imap)
+    (@protocol-impls
+     (if (namespace imap)
+       imap
+       (resolve-symbol (:ns env) imap)))
+    :default
+    (throw (ex-info "Unsupported `extend` impl map"
+                    {:impl-map imap}))))
+
+(defmacro extend [type & protocols+impls]
+  `(extend-type ~type
+         ~@(reduce
+             (fn [impls [protocol imap]]
+               (let [impl-map (resolve-impl-map &env imap)]
+                 (-> (conj impls protocol)
+                     (into (map (fn [[method [_ & arities]]]
+                                  (cons (symbol (name method))
+                                        arities))
+                                impl-map)))))
+             []
+             (partition 2 protocols+impls))))
+
+