(ns simple-check.generators
  (:import java.util.Random)
  (:require [clj-tuple])
  (:refer-clojure :exclude [int vector list map keyword
                            char boolean byte bytes]))

;; Helpers
;; ---------------------------------------------------------------------------

(defn random
  ([] (Random.))
  ([seed] (Random. seed)))

(defn call-gen
  [[tag generator-fn] rand-seed size]
  (generator-fn rand-seed size))

(defn make-size-range-seq
  [max-size]
  (cycle (range 0 max-size)))

(defn sample-seq
  ([generator] (sample-seq generator 100))
  ([generator max-size]
   (let [r (random)
         size-seq (make-size-range-seq max-size)]
     (clojure.core/map (partial call-gen generator r) size-seq))))

(defn sample
  "Return a sequence of `num-samples` (default 10)
  realized values from `generator`."
  ([generator]
   (sample generator 10))
  ([generator num-samples]
   (take num-samples (sample-seq generator))))

;; Shrink protocol, Functor and Monad implementations
;; ---------------------------------------------------------------------------

(defprotocol Shrink
  "The Shrink protocol exists for dispatching the shrink function
  based on type."
  (shrink [this]
          "Return a (possibly empty) sequence of smaller values.
          Care must be given to not create any loops if shrink is called
          recursively on the sequence."))

(defn fmap
  "Create a new generator that calls `f` on the generated value before
  returning it."
  [f gen]
  [:gen (fn [rand-seed size]
          (f (call-gen gen rand-seed size)))])

(defn bind
  "Create a new generator that passes the result of `gen` into function
  `k`. `k` should return a new generator. This allows you to create new
  generators that depend on the value of other generators. For example,
  to create a generator which first generates a vector of integers, and
  then chooses a random element from that vector:

      (gen/bind (gen/such-that not-empty (gen/vector gen/int))
                ;; this function takes a realized vector,
                ;; and then returns a new generator which
                ;; chooses a random element from it
                gen/elements)

  This is equivalent to Haskell QuickCheck's implementation
  of bind (`>>=`) for the generator monad.
  "
  [gen k]
  [:gen (fn [rand-seed size]
          (let [value (call-gen gen rand-seed size)]
            (call-gen (k value) rand-seed size)))])

(defn return
  "Create a generator that always returns `val`"
  [val]
  [:gen (fn [rand-seed size] val)])

;; Combinators
;; ---------------------------------------------------------------------------

(defn choose
  "Create a generator that returns numbers in the range
  `min-range` to `max-range`."
  [min-range max-range]
  (let [diff (Math/abs (long (- max-range min-range)))]
    [:gen (fn [^Random rand-seed _size]
            (if (zero? diff)
              min-range
              (+ (.nextInt rand-seed (inc diff)) min-range)))]))

(defn one-of
  "Create a generator that randomly chooses a value from the list of
  provided generators.

  Examples:

      (one-of [gen/int gen/boolean (gen/vector gen/int)])

  "
  [generators]
  (bind (choose 0 (dec (count generators)))
        #(nth generators %)))

(defn- pick
  [[h & tail] n]
  (let [[chance gen] h]
    (if (<= n chance)
      gen
      (recur tail (- n chance)))))

(defn frequency
  "Create a generator that chooses a generator from `pairs` based on the
  provided likelihoods. The likelihood of a given generator being chosen is
  its likelihood divided by the sum of all likelihoods

  Examples:

      (gen/frequency [[5 gen/int] [3 (gen/vector gen/int)] [2 gen/boolean]])
  "
  [pairs]
  (let [total (apply + (clojure.core/map first pairs))]
    (bind (choose 1 total)
          (partial pick pairs))))

(defn elements
  "Create a generator that randomly chooses an element from `coll`.

  Examples:

      (gen/elements [:foo :bar :baz])
  "
  [coll]
  (fmap #(nth coll %)
        (choose 0 (dec (count coll)))))

(defn such-that
  "Create a generator that generates values from `gen` that satisfy predicate
  `f`. Care is needed to ensure there is a high chance `gen` will satisfy `f`,
  otherwise it will keep trying forever. Eventually we will add another
  generator combinator that only tries N times before giving up. In the Haskell
  version this is called `suchThatMaybe`.

  Examples:

      ;; generate non-empty vectors of integers
      (such-that not-empty (gen/vector gen/int))
  "
  [f gen]
  [:gen (fn [rand-seed size]
    (let [value (call-gen gen rand-seed size)]
      (if (f value)
        value
        (recur rand-seed (inc size)))))])

;; Generic generators and helpers
;; ---------------------------------------------------------------------------

(declare tuple)

(def pair
  "Create a generator that generates two-vectors that generate a value
  from `a` and `b`.

  Examples:

      (pair gen/int gen/int)
  "
  tuple)

(defn shrink-index
  [coll index]
  (clojure.core/map (partial assoc coll index) (shrink (nth coll index))))

(defn shrink-seq
  [coll]
  (if (empty? coll)
    coll
    (let [head (first coll)
          tail (rest coll)]
      (concat [tail]
              (for [x (shrink-seq tail)] (cons head x))
              (for [y (shrink head)] (cons y tail))))))

(defn halfs
  [n]
  (take-while (partial not= 0) (iterate #(quot % 2) n)))

;; Boolean
;; ---------------------------------------------------------------------------

(def boolean (elements [true false]))

(defn shrink-boolean
  [b]
  (if b [false] []))

(extend java.lang.Boolean
  Shrink
  {:shrink shrink-boolean})

;; Number
;; ---------------------------------------------------------------------------

(defn int-gen
  ([rand-seed size]
   (call-gen (choose (- size) size)
      rand-seed size)))

(def int
  "Generates a positive or negative integer bounded by the generator's
  `size` parameter."
  [:gen int-gen])

(def pos-int
  "Generate positive integers bounded by the generator's `size` parameter."
  (fmap #(Math/abs (long %)) int))
(def neg-int
  "Generate negative integers bounded by the generator's `size` parameter."
  (fmap (partial * -1) pos-int))

(def s-pos-int
  "Generate strictly positive integers bounded by the generator's `size`
   parameter."
  (fmap inc pos-int))
(def s-neg-int
  "Generate strictly negative integers bounded by the generator's `size`
   parameter."
  (fmap (partial * -1) s-pos-int))

(defn shrink-int
  [integer]
  (clojure.core/map (partial - integer) (halfs integer)))

(extend java.lang.Number
  Shrink
  ;; TODO:
  ;; this shrink goes into an infinite loop with floats
  {:shrink shrink-int})

;; Tuple
;; ---------------------------------------------------------------------------

(defn tuple
  "Create a generator that returns a vector, whose elements are chosen
  from the generators in the same position.

  Examples:

      (def t (tuple gen/int gen/boolean))
      (sample t)
      ;; => ([1 true] [2 true] [2 false] [1 false] [0 true] [-2 false] [-6 false]
      ;; =>  [3 true] [-4 false] [9 true]))
  "
  [& generators]
  [:gen (fn [rand-seed size]
    (apply clj-tuple/tuple (clojure.core/map #(call-gen % rand-seed size) generators)))])

(defn shrink-tuple
  [value]
  (clojure.core/map (partial apply clj-tuple/tuple)
    (mapcat (partial shrink-index (vec value)) (range (count value)))))

(extend clj_tuple.Tuple1 Shrink {:shrink shrink-tuple})
(extend clj_tuple.Tuple2 Shrink {:shrink shrink-tuple})
(extend clj_tuple.Tuple3 Shrink {:shrink shrink-tuple})
(extend clj_tuple.Tuple4 Shrink {:shrink shrink-tuple})
(extend clj_tuple.Tuple5 Shrink {:shrink shrink-tuple})
(extend clj_tuple.Tuple6 Shrink {:shrink shrink-tuple})

;; Vector
;; ---------------------------------------------------------------------------

(defn vector
  "Create a generator whose elements are chosen from `gen`. The count of the
  vector will be bounded by the `size` generator parameter."
  ([gen]
   [:gen (fn [rand-seed size]
     (let [num-elements (Math/abs (long (call-gen int rand-seed size)))]
       (vec (repeatedly num-elements #(call-gen gen rand-seed size)))))])
  ([gen num-elements]
   [:gen (fn [rand-seed size]
     (vec (repeatedly num-elements #(call-gen gen rand-seed size))))])
  ([gen min-elements max-elements]
   [:gen (fn [rand-seed size]
     (let [max-translated (- max-elements min-elements)
           num-translated (long (call-gen pos-int rand-seed max-translated))
           num-elements (+ min-elements num-translated)]
       (vec (repeatedly num-elements #(call-gen gen rand-seed size)))))]))

(extend clojure.lang.IPersistentVector
  Shrink
  ;; TODO:
  ;; this shrink goes into an infinite loop with floats
  {:shrink (comp (partial clojure.core/map vec) shrink-seq)})

;; List
;; ---------------------------------------------------------------------------

(defn list
  "Like `vector`, but generators lists."
  [gen]
  [:gen (fn [rand-seed size]
    (let [num-elements (Math/abs (long (call-gen int rand-seed size)))]
      (into '() (repeatedly num-elements #(call-gen gen rand-seed size)))))])

(defn shrink-list
  [l]
  (clojure.core/map list* (shrink-seq l)))

(extend clojure.lang.PersistentList
  Shrink
  ;; TODO:
  ;; this shrink goes into an infinite loop with floats
  {:shrink shrink-list})

(extend (type '())
  Shrink
  {:shrink (constantly [])})

;; Bytes
;; ---------------------------------------------------------------------------

(def byte (fmap clojure.core/byte (choose 0 127)))

(def bytes (fmap clojure.core/byte-array (vector byte)))

(defn shrink-byte
  [b]
  (let [i (clojure.core/int b)]
    (clojure.core/map clojure.core/byte (shrink i))))

(defn shrink-bytes
  [bs]
  (let [vbs (vec bs)]
    (clojure.core/map clojure.core/byte-array (shrink vbs))))

(extend java.lang.Byte
  Shrink
  {:shrink shrink-byte})

(extend (Class/forName "[B")
  Shrink
  {:shrink shrink-bytes})

;; Map
;; ---------------------------------------------------------------------------

(defn map
  "Create a generator that generates maps, with keys chosen from
  `ken-gen` and values chosen from `val-gen`."
  [key-gen val-gen]
  [:gen (fn [rand-seed size]
    (let [map-size (call-gen (choose 0 size) rand-seed size)
          p (pair key-gen val-gen)]
      (into {} (repeatedly map-size #(call-gen p rand-seed size)))))])

(defn shrink-map
  [value]
  [])
(extend clojure.lang.IPersistentMap
  Shrink
  {:shrink shrink-map})

;; Character
;; (generator and shrink strategy pretty much ripped from Haskell impl.)
;; ---------------------------------------------------------------------------

(def char
  "Generates character from 0-255."
  (fmap clojure.core/char (choose 0 255)))

(def char-ascii
  "Generate only ascii character."
  (fmap clojure.core/char (choose 32 126)))

(def char-alpha-numeric
  "Generate alpha-numeric characters."
  (fmap clojure.core/char
        (one-of [(choose 48 57)
                 (choose 65 90)
                 (choose 97 122)])))

(defn- stamp
  [^Character c]
  [(not (Character/isLowerCase c))
   (not (Character/isUpperCase c))
   (not (Character/isDigit c))
   (not= \space c)
   c])

(defn- <-stamp
  [a b]
  (neg? (compare (stamp a) (stamp b))))

(defn shrink-char
  [c]
  (filter
    #(<-stamp % c)
    (concat [\a \b \c]
            (for [^Character x [c] :while #(Character/isUpperCase ^Character %)]
              (Character/toLowerCase x))
            [\A \B \C
             \1 \2 \3
             ;; TODO: should newline be here? It will make ascii chars
             ;; shrink incorrectly. But it's also useful for finding bugs...
             ;; \newline
             \space])))

(extend java.lang.Character
  Shrink
  {:shrink shrink-char})

;; String
;; ---------------------------------------------------------------------------

;; TODO: make strings use the full utf-8 range

(defn string-gen
  [rand-seed size]
  (clojure.string/join (repeatedly (call-gen (choose 0 size) rand-seed size)
                                   #(call-gen char rand-seed size))))

(def string
  "Generate strings."
  [:gen string-gen])

(defn string-ascii-gen
  [rand-seed size]
  (clojure.string/join (repeatedly (call-gen (choose 0 size) rand-seed size)
                                   #(call-gen char-ascii rand-seed size))))

(def string-ascii
  "Generate ascii strings."
  [:gen string-ascii-gen])

(defn string-alpha-numeric-gen
  [rand-seed size]
  (clojure.string/join (repeatedly (call-gen (choose 0 size) rand-seed size)
                                   #(call-gen char-alpha-numeric rand-seed size))))

(def string-alpha-numeric
  "Generate alpha-numeric strings."
  [:gen string-alpha-numeric-gen])

(defn shrink-string
  [s]
  (clojure.core/map clojure.string/join (shrink-seq s)))

(extend java.lang.String
  Shrink
  {:shrink shrink-string})

;; Keyword
;; ---------------------------------------------------------------------------

(def keyword
  "Generate keywords."
  (->> string-alpha-numeric
       (such-that #(not= "" %))
       (fmap clojure.core/keyword)))

(defn shrink-keyword
  [k]
  (clojure.core/map clojure.core/keyword
                    (-> k str
                      rest
                      clojure.string/join
                      shrink-string)))

(extend clojure.lang.Keyword
  Shrink
  {:shrink shrink-keyword})

;; Ratios
;; ---------------------------------------------------------------------------

(def ratio
  (->> (tuple int (such-that (complement zero?) int))
       (fmap (fn [[a b]] (/ a b)))))

(defn shrink-ratio
  [ratio]
  (for [d (shrink (denominator ratio))
        :when (not (zero? d))
        n (shrink (numerator ratio))]
    (/ n d)))

(extend clojure.lang.Ratio
  Shrink
  {:shrink shrink-ratio})

(ns simple-check.generators
  (:import java.util.Random)
  (:require [clj-tuple])
  (:refer-clojure :exclude [int vector list map keyword
                            char boolean byte bytes]))

;; Helpers
;; ---------------------------------------------------------------------------

(defn random
  ([] (Random.))
  ([seed] (Random. seed)))

(defn call-gen
  [[tag generator-fn] rand-seed size]
  (generator-fn rand-seed size))

(defn make-size-range-seq
  [max-size]
  (cycle (range 0 max-size)))

(defn sample-seq
  ([generator] (sample-seq generator 100))
  ([generator max-size]
   (let [r (random)
         size-seq (make-size-range-seq max-size)]
     (clojure.core/map (partial call-gen generator r) size-seq))))

(defn sample
  "Return a sequence of `num-samples` (default 10)
  realized values from `generator`."
  ([generator]
   (sample generator 10))
  ([generator num-samples]
   (take num-samples (sample-seq generator))))

;; Shrink protocol, Functor and Monad implementations
;; ---------------------------------------------------------------------------

(defprotocol Shrink
  "The Shrink protocol exists for dispatching the shrink function
  based on type."
  (shrink [this]
          "Return a (possibly empty) sequence of smaller values.
          Care must be given to not create any loops if shrink is called
          recursively on the sequence."))

(defn fmap
  "Create a new generator that calls `f` on the generated value before
  returning it."
  [f gen]
  [:gen (fn [rand-seed size]
          (f (call-gen gen rand-seed size)))])

(defn bind
  "Create a new generator that passes the result of `gen` into function
  `k`. `k` should return a new generator. This allows you to create new
  generators that depend on the value of other generators. For example,
  to create a generator which first generates a vector of integers, and
  then chooses a random element from that vector:

      (gen/bind (gen/such-that not-empty (gen/vector gen/int))
                ;; this function takes a realized vector,
                ;; and then returns a new generator which
                ;; chooses a random element from it
                gen/elements)

  This is equivalent to Haskell QuickCheck's implementation
  of bind (`>>=`) for the generator monad.
  "
  [gen k]
  [:gen (fn [rand-seed size]
          (let [value (call-gen gen rand-seed size)]
            (call-gen (k value) rand-seed size)))])

(defn return
  "Create a generator that always returns `val`"
  [val]
  [:gen (fn [rand-seed size] val)])

;; Combinators
;; ---------------------------------------------------------------------------

(defn choose
  "Create a generator that returns numbers in the range
  `min-range` to `max-range`."
  [min-range max-range]
  (let [diff (Math/abs (long (- max-range min-range)))]
    [:gen (fn [^Random rand-seed _size]
            (if (zero? diff)
              min-range
              (+ (.nextInt rand-seed (inc diff)) min-range)))]))

(defn one-of
  "Create a generator that randomly chooses a value from the list of
  provided generators.

  Examples:

      (one-of [gen/int gen/boolean (gen/vector gen/int)])

  "
  [generators]
  (bind (choose 0 (dec (count generators)))
        #(nth generators %)))

(defn- pick
  [[h & tail] n]
  (let [[chance gen] h]
    (if (<= n chance)
      gen
      (recur tail (- n chance)))))

(defn frequency
  "Create a generator that chooses a generator from `pairs` based on the
  provided likelihoods. The likelihood of a given generator being chosen is
  its likelihood divided by the sum of all likelihoods

  Examples:

      (gen/frequency [[5 gen/int] [3 (gen/vector gen/int)] [2 gen/boolean]])
  "
  [pairs]
  (let [total (apply + (clojure.core/map first pairs))]
    (bind (choose 1 total)
          (partial pick pairs))))

(defn elements
  "Create a generator that randomly chooses an element from `coll`.

  Examples:

      (gen/elements [:foo :bar :baz])
  "
  [coll]
  (fmap #(nth coll %)
        (choose 0 (dec (count coll)))))

(defn such-that
  "Create a generator that generates values from `gen` that satisfy predicate
  `f`. Care is needed to ensure there is a high chance `gen` will satisfy `f`,
  otherwise it will keep trying forever. Eventually we will add another
  generator combinator that only tries N times before giving up. In the Haskell
  version this is called `suchThatMaybe`.

  Examples:

      ;; generate non-empty vectors of integers
      (such-that not-empty (gen/vector gen/int))
  "
  [f gen]
  [:gen (fn [rand-seed size]
    (let [value (call-gen gen rand-seed size)]
      (if (f value)
        value
        (recur rand-seed (inc size)))))])

;; Generic generators and helpers
;; ---------------------------------------------------------------------------

(declare tuple)

(def pair
  "Create a generator that generates two-vectors that generate a value
  from `a` and `b`.

  Examples:

      (pair gen/int gen/int)
  "
  tuple)

(defn shrink-index
  [coll index]
  (clojure.core/map (partial assoc coll index) (shrink (nth coll index))))

(defn shrink-seq
  [coll]
  (if (empty? coll)
    coll
    (let [head (first coll)
          tail (rest coll)]
      (concat [tail]
              (for [x (shrink-seq tail)] (cons head x))
              (for [y (shrink head)] (cons y tail))))))

(defn halfs
  [n]
  (take-while (partial not= 0) (iterate #(quot % 2) n)))

;; Boolean
;; ---------------------------------------------------------------------------

(def boolean (elements [true false]))

(defn shrink-boolean
  [b]
  (if b [false] []))

(extend java.lang.Boolean
  Shrink
  {:shrink shrink-boolean})

;; Number
;; ---------------------------------------------------------------------------

(defn int-gen
  ([rand-seed size]
   (call-gen (choose (- size) size)
      rand-seed size)))

(def int
  "Generates a positive or negative integer bounded by the generator's
  `size` parameter."
  [:gen int-gen])

(def pos-int
  "Generate positive integers bounded by the generator's `size` parameter."
  (fmap #(Math/abs (long %)) int))
(def neg-int
  "Generate negative integers bounded by the generator's `size` parameter."
  (fmap (partial * -1) pos-int))

(def s-pos-int
  "Generate strictly positive integers bounded by the generator's `size`
   parameter."
  (fmap inc pos-int))
(def s-neg-int
  "Generate strictly negative integers bounded by the generator's `size`
   parameter."
  (fmap (partial * -1) s-pos-int))

(defn shrink-int
  [integer]
  (clojure.core/map (partial - integer) (halfs integer)))

(extend java.lang.Number
  Shrink
  ;; TODO:
  ;; this shrink goes into an infinite loop with floats
  {:shrink shrink-int})

;; Tuple
;; ---------------------------------------------------------------------------

(defn tuple
  "Create a generator that returns a vector, whose elements are chosen
  from the generators in the same position.

  Examples:

      (def t (tuple gen/int gen/boolean))
      (sample t)
      ;; => ([1 true] [2 true] [2 false] [1 false] [0 true] [-2 false] [-6 false]
      ;; =>  [3 true] [-4 false] [9 true]))
  "
  [& generators]
  [:gen (fn [rand-seed size]
    (apply clj-tuple/tuple (clojure.core/map #(call-gen % rand-seed size) generators)))])

(defn shrink-tuple
  [value]
  (clojure.core/map (partial apply clj-tuple/tuple)
    (mapcat (partial shrink-index (vec value)) (range (count value)))))

(extend clj_tuple.Tuple1 Shrink {:shrink shrink-tuple})
(extend clj_tuple.Tuple2 Shrink {:shrink shrink-tuple})
(extend clj_tuple.Tuple3 Shrink {:shrink shrink-tuple})
(extend clj_tuple.Tuple4 Shrink {:shrink shrink-tuple})
(extend clj_tuple.Tuple5 Shrink {:shrink shrink-tuple})
(extend clj_tuple.Tuple6 Shrink {:shrink shrink-tuple})

;; Vector
;; ---------------------------------------------------------------------------

(defn vector
  "Create a generator whose elements are chosen from `gen`. The count of the
  vector will be bounded by the `size` generator parameter."
  ([gen]
   [:gen (fn [rand-seed size]
     (let [num-elements (Math/abs (long (call-gen int rand-seed size)))]
       (vec (repeatedly num-elements #(call-gen gen rand-seed size)))))])
  ([gen num-elements]
   [:gen (fn [rand-seed size]
     (vec (repeatedly num-elements #(call-gen gen rand-seed size))))])
  ([gen min-elements max-elements]
   [:gen (fn [rand-seed size]
     (let [max-translated (- max-elements min-elements)
           num-translated (long (call-gen pos-int rand-seed max-translated))
           num-elements (+ min-elements num-translated)]
       (vec (repeatedly num-elements #(call-gen gen rand-seed size)))))]))

(extend clojure.lang.IPersistentVector
  Shrink
  ;; TODO:
  ;; this shrink goes into an infinite loop with floats
  {:shrink (comp (partial clojure.core/map vec) shrink-seq)})

;; List
;; ---------------------------------------------------------------------------

(defn list
  "Like `vector`, but generators lists."
  [gen]
  [:gen (fn [rand-seed size]
    (let [num-elements (Math/abs (long (call-gen int rand-seed size)))]
      (into '() (repeatedly num-elements #(call-gen gen rand-seed size)))))])

(defn shrink-list
  [l]
  (clojure.core/map list* (shrink-seq l)))

(extend clojure.lang.PersistentList
  Shrink
  ;; TODO:
  ;; this shrink goes into an infinite loop with floats
  {:shrink shrink-list})

(extend (type '())
  Shrink
  {:shrink (constantly [])})

;; Bytes
;; ---------------------------------------------------------------------------

(def byte (fmap clojure.core/byte (choose -128 127)))

(def bytes (fmap clojure.core/byte-array (vector byte)))

(defn shrink-byte
  [b]
  (let [i (clojure.core/int b)]
    (clojure.core/map clojure.core/byte (shrink i))))

(defn shrink-bytes
  [bs]
  (let [vbs (vec bs)]
    (clojure.core/map clojure.core/byte-array (shrink vbs))))

(extend java.lang.Byte
  Shrink
  {:shrink shrink-byte})

(extend (Class/forName "[B")
  Shrink
  {:shrink shrink-bytes})

;; Map
;; ---------------------------------------------------------------------------

(defn map
  "Create a generator that generates maps, with keys chosen from
  `ken-gen` and values chosen from `val-gen`."
  [key-gen val-gen]
  [:gen (fn [rand-seed size]
    (let [map-size (call-gen (choose 0 size) rand-seed size)
          p (pair key-gen val-gen)]
      (into {} (repeatedly map-size #(call-gen p rand-seed size)))))])

(defn shrink-map
  [value]
  [])
(extend clojure.lang.IPersistentMap
  Shrink
  {:shrink shrink-map})

;; Character
;; (generator and shrink strategy pretty much ripped from Haskell impl.)
;; ---------------------------------------------------------------------------

(def char
  "Generates character from 0-255."
  (fmap clojure.core/char (choose 0 255)))

(def char-ascii
  "Generate only ascii character."
  (fmap clojure.core/char (choose 32 126)))

(def char-alpha-numeric
  "Generate alpha-numeric characters."
  (fmap clojure.core/char
        (one-of [(choose 48 57)
                 (choose 65 90)
                 (choose 97 122)])))

(defn- stamp
  [^Character c]
  [(not (Character/isLowerCase c))
   (not (Character/isUpperCase c))
   (not (Character/isDigit c))
   (not= \space c)
   c])

(defn- <-stamp
  [a b]
  (neg? (compare (stamp a) (stamp b))))

(defn shrink-char
  [c]
  (filter
    #(<-stamp % c)
    (concat [\a \b \c]
            (for [^Character x [c] :while #(Character/isUpperCase ^Character %)]
              (Character/toLowerCase x))
            [\A \B \C
             \1 \2 \3
             ;; TODO: should newline be here? It will make ascii chars
             ;; shrink incorrectly. But it's also useful for finding bugs...
             ;; \newline
             \space])))

(extend java.lang.Character
  Shrink
  {:shrink shrink-char})

;; String
;; ---------------------------------------------------------------------------

;; TODO: make strings use the full utf-8 range

(defn string-gen
  [rand-seed size]
  (clojure.string/join (repeatedly (call-gen (choose 0 size) rand-seed size)
                                   #(call-gen char rand-seed size))))

(def string
  "Generate strings."
  [:gen string-gen])

(defn string-ascii-gen
  [rand-seed size]
  (clojure.string/join (repeatedly (call-gen (choose 0 size) rand-seed size)
                                   #(call-gen char-ascii rand-seed size))))

(def string-ascii
  "Generate ascii strings."
  [:gen string-ascii-gen])

(defn string-alpha-numeric-gen
  [rand-seed size]
  (clojure.string/join (repeatedly (call-gen (choose 0 size) rand-seed size)
                                   #(call-gen char-alpha-numeric rand-seed size))))

(def string-alpha-numeric
  "Generate alpha-numeric strings."
  [:gen string-alpha-numeric-gen])

(defn shrink-string
  [s]
  (clojure.core/map clojure.string/join (shrink-seq s)))

(extend java.lang.String
  Shrink
  {:shrink shrink-string})

;; Keyword
;; ---------------------------------------------------------------------------

(def keyword
  "Generate keywords."
  (->> string-alpha-numeric
       (such-that #(not= "" %))
       (fmap clojure.core/keyword)))

(defn shrink-keyword
  [k]
  (clojure.core/map clojure.core/keyword
                    (-> k str
                      rest
                      clojure.string/join
                      shrink-string)))

(extend clojure.lang.Keyword
  Shrink
  {:shrink shrink-keyword})

;; Ratios
;; ---------------------------------------------------------------------------

(def ratio
  (->> (tuple int (such-that (complement zero?) int))
       (fmap (fn [[a b]] (/ a b)))))

(defn shrink-ratio
  [ratio]
  (for [d (shrink (denominator ratio))
        :when (not (zero? d))
        n (shrink (numerator ratio))]
    (/ n d)))

(extend clojure.lang.Ratio
  Shrink
  {:shrink shrink-ratio})

Use full byte range in gen/byte

Use full byte range in gen/byte


(ns qcast.server
  (:gen-class)
  (:require [compojure.core        :as compojure :refer [defroutes GET]]
            [compojure.handler     :as handler]
            [compojure.route       :as route]
            [qcast.cache           :as cache]
            [qcast.feed.ext.atom   :as atom]
            [qcast.feed.ext.itunes :as itunes]
            [qcast.feed.ext.simple-chapters :as psc]
            [qcast.feed.rss        :as rss]
            [qcast.util            :as util :refer [parse-int]]
            [org.httpkit.server    :as http]
            [taoensso.timbre       :as timbre :refer :all]))

;;; Internals

(defn- slides
  ([] (slides 1))
  ([n]
     (cons (str "Slide " n)
           (lazy-seq (slides (inc n))))))

(defn- prepare-item [p]
  (let [link (:link p)]
    [(rss/title (:title p))
     (rss/link link)
     (rss/description (:summary p))
     ;;(rss/author (string/join ", " (:authors p)))
     (rss/author "info@infoq.com (InfoQ)")
     (rss/pub-date (:publish-date p))
     (rss/guid link)
     (apply rss/enclosure (:video p))
     (apply rss/categories (:keywords p))
     ;;(itunes/author (string/join ", " (:authors p)))
     (itunes/author "info@infoq.com")
     (itunes/summary (:summary p))
     ;;(itunes/image (:poster p))
     (itunes/image (first (:slides p)))
     (itunes/duration (:length p))
     (apply psc/chapters (map vector (:times p) (slides) (:slides p)))]))

(defn- serve-feed [req]
  (let [base-url #(apply str "http://www.infoq.com" %&)
        entries (cache/latest 50)
        items (map (comp prepare-item :data) entries)
        title "QCast - InfoQ Presentation Podcast"
        channel [(rss/title title)
                 (rss/link (base-url))
                 (rss/description (str "Facilitating the spread of knowledge "
                                       "and innovation in enterprise software "
                                       "development"))
                 (rss/image (base-url "/styles/i/logo-big.jpg") title (base-url))
                 (rss/language "en-US")
                 (rss/generator "InfoQ-Feed-Generator/1.0")
                 (rss/last-build-date (get-in (first entries) [:data :publish-date]))
                 (atom/link "http://infoqcast.herokuapp.com/feed")
                 (itunes/author "InfoQ")
                 (itunes/owner "InfoQ" "info@infoq.com")
                 (itunes/summary (str "InfoQ.com is a practitioner-driven "
                                      "community news site focused on "
                                      "facilitating the spread of knowledge and "
                                      "innovation in enterprise software "
                                      "development."))
                 (itunes/categories "Education" "Technology")
                 (itunes/keywords "Java" ".NET" "dotnet" "Ruby" "SOA"
                                  "Service Oriented Architecture" "Agile"
                                  "enterprise" "software development"
                                  "development" "architecture" "programming")
                 (itunes/image (base-url "/styles/i/logo-big.jpg"))
                 (itunes/block false)
                 (itunes/explicit false)]
        extensions [:atom :itunes :simple-chapters]
        feed (rss/feed channel items extensions)]
    feed))

;;; Main

(defn- rss-response [body & [status]]
  {:status (or status 200)
   :headers {"Content-Type" "application/rss+xml"}
   :body body})

(defroutes app-routes
  (GET "/feed" [] (comp rss-response serve-feed))
  (route/files "/")
  (route/not-found "Not found"))

(defn -main []
  (info "Starting web server")
  (let [port (parse-int (or (System/getenv "PORT") "8080"))]
    (http/run-server (handler/site app-routes) {:port port})))

(ns qcast.server
  (:gen-class)
  (:require [compojure.core        :as compojure :refer [defroutes GET]]
            [compojure.handler     :as handler]
            [compojure.route       :as route]
            [qcast.cache           :as cache]
            [qcast.feed.ext.atom   :as atom]
            [qcast.feed.ext.itunes :as itunes]
            [qcast.feed.ext.simple-chapters :as psc]
            [qcast.feed.rss        :as rss]
            [qcast.util            :as util :refer [parse-int]]
            [org.httpkit.server    :as http]
            [taoensso.timbre       :as timbre :refer :all]))

;;; Internals

(defn- slides
  ([] (slides 1))
  ([n]
     (cons (str "Slide " n)
           (lazy-seq (slides (inc n))))))

(defn- prepare-item [p]
  (let [link (:link p)]
    [(rss/title (:title p))
     (rss/link link)
     (rss/description (:summary p))
     ;;(rss/author (string/join ", " (:authors p)))
     (rss/author "info@infoq.com (InfoQ)")
     (rss/pub-date (:publish-date p))
     (rss/guid link)
     (apply rss/enclosure (:video p))
     (apply rss/categories (:keywords p))
     ;;(itunes/author (string/join ", " (:authors p)))
     (itunes/author "info@infoq.com")
     (itunes/summary (:summary p))
     ;;(itunes/image (:poster p))
     (itunes/image (first (:slides p)))
     (itunes/duration (:length p))
     (apply psc/chapters (map vector (:times p) (slides) (:slides p)))]))

(defn- serve-feed [req]
  (let [base-url #(apply str "http://www.infoq.com" %&)
        entries (cache/latest 50)
        items (map (comp prepare-item :data) entries)
  (let [entries (map :data (cache/latest 50))
        items (map #(feed-item media %) entries)
        change-date (:publish-date (first entries))
        base-url "http://www.infoq.com"
        title "QCast - InfoQ Presentation Podcast"
        channel [(rss/title title)
                 (rss/link base-url)
                 (rss/description (str "Facilitating the spread of knowledge "
                                       "and innovation in enterprise software "
                                       "development"))
                 (rss/image (str base-url "/styles/i/logo-big.jpg") title base-url)
                 (rss/language "en-US")
                 (rss/generator "InfoQ-Feed-Generator/1.0")
                 (rss/last-build-date change-date)
                 (atom/link "http://infoqcast.herokuapp.com/feed")
                 (itunes/author "InfoQ")
                 (itunes/owner "InfoQ" "info@infoq.com")
                 (itunes/summary (str "InfoQ.com is a practitioner-driven "
                                      "community news site focused on "
                                      "facilitating the spread of knowledge and "
                                      "innovation in enterprise software "
                                      "development."))
                 (itunes/categories "Education" "Technology")
                 (itunes/keywords "Java" ".NET" "dotnet" "Ruby" "SOA"
                                  "Service Oriented Architecture" "Agile"
                                  "enterprise" "software development"
                                  "development" "architecture" "programming")
                 (itunes/image (str base-url "/styles/i/logo-big.jpg"))
                 (itunes/block false)
                 (itunes/explicit false)]
        extensions [:atom :itunes :simple-chapters]]
    (rss/feed channel items extensions)))

;;; Main

(defn- rss-response [body & [status]]
  {:status (or status 200)
   :headers {"Content-Type" "application/rss+xml"}
   :body body})

(defroutes app-routes
  (GET "/feed" [] (comp rss-response serve-feed))
  (route/files "/")
  (route/not-found "Not found"))

(defn -main []
  (info "Starting web server")
  (let [port (parse-int (or (System/getenv "PORT") "8080"))]
    (http/run-server (handler/site app-routes) {:port port})))

Clean up

Clean up


(ns re-frame.fx
  (:require
    [re-frame.router      :as router]
    [re-frame.db          :refer [app-db]]
    [re-frame.interceptor :refer [->interceptor]]
    [re-frame.interop     :refer [set-timeout!]]
    [re-frame.events      :as events]
    [re-frame.registrar   :refer [get-handler clear-handlers register-handler]]
    [re-frame.loggers     :refer [console]]
    [re-frame.trace :as trace :include-macros true]))

;; -- Registration ------------------------------------------------------------

(def kind :fx)
(assert (re-frame.registrar/kinds kind))

(defn reg-fx
  "Register the given effect `handler` for the given `id`.

  `id` is keyword, often namespaced.
  `handler` is a side-effecting function which takes a single argument and whose return
  value is ignored.

  Example Use
  -----------

  First, registration ... associate `:effect2` with a handler.

  (reg-fx
     :effect2
     (fn [value]
        ... do something side-effect-y))

  Then, later, if an event handler were to return this effects map ...

  {...
   :effect2  [1 2]}

   ... then the `handler` `fn` we registered previously, using `reg-fx`, will be
   called with an argument of `[1 2]`."
  [id handler]
  (register-handler kind id handler))

;; -- Interceptor -------------------------------------------------------------

(def do-fx
  "An interceptor whose `:after` actions the contents of `:effects`. As a result,
  this interceptor is Domino 3.

  This interceptor is silently added (by reg-event-db etc) to the front of
  interceptor chains for all events.

  For each key in `:effects` (a map), it calls the registered `effects handler`
  (see `reg-fx` for registration of effect handlers).

  So, if `:effects` was:
      {:dispatch  [:hello 42]
       :db        {...}
       :undo      \"set flag\"}

  it will call the registered effect handlers for each of the map's keys:
  `:dispatch`, `:undo` and `:db`. When calling each handler, provides the map
  value for that key - so in the example above the effect handler for :dispatch
  will be given one arg `[:hello 42]`.

  You cannot rely on the ordering in which effects are executed."
  (->interceptor
    :id :do-fx
    :after (fn do-fx-after
             [context]
             (trace/with-trace
               {:op-type :event/do-fx}
               (doseq [[effect-key effect-value] (:effects context)]
                 (if-let [effect-fn (get-handler kind effect-key false)]
                   (effect-fn effect-value)
                   (console :error "re-frame: no handler registered for effect:" effect-key ". Ignoring.")))))))

;; -- Builtin Effect Handlers  ------------------------------------------------

;; :dispatch-later
;;
;; `dispatch` one or more events after given delays. Expects a collection
;; of maps with two keys:  :`ms` and `:dispatch`
;;
;; usage:
;;
;;    {:dispatch-later [{:ms 200 :dispatch [:event-id "param"]}    ;;  in 200ms do this: (dispatch [:event-id "param"])
;;                      {:ms 100 :dispatch [:also :this :in :100ms]}]}
;;
;; Note: nil entries in the collection are ignored which means events can be added
;; conditionally:
;;    {:dispatch-later [ (when (> 3 5) {:ms 200 :dispatch [:conditioned-out]})
;;                       {:ms 100 :dispatch [:another-one]}]}
;;
(reg-fx
  :dispatch-later
  (fn [value]
    (doseq [{:keys [ms dispatch] :as effect} (filter nil? value)]
        (if (or (empty? dispatch) (not (number? ms)))
          (console :error "re-frame: ignoring bad :dispatch-later value:" effect)
          (set-timeout! #(router/dispatch dispatch) ms)))))

;; :dispatch
;;
;; `dispatch` one event. Excepts a single vector.
;;
;; usage:
;;   {:dispatch [:event-id "param"] }

(reg-fx
  :dispatch
  (fn [value]
    (if-not (vector? value)
      (console :error "re-frame: ignoring bad :dispatch value. Expected a vector, but got:" value)
      (router/dispatch value))))

;; :dispatch-n
;;
;; `dispatch` more than one event. Expects a list or vector of events. Something for which
;; sequential? returns true.
;;
;; usage:
;;   {:dispatch-n (list [:do :all] [:three :of] [:these])}
;;
;; Note: nil events are ignored which means events can be added
;; conditionally:
;;    {:dispatch-n (list (when (> 3 5) [:conditioned-out])
;;                       [:another-one])}
;;
(reg-fx
  :dispatch-n
  (fn [value]
    (if-not (sequential? value)
      (console :error "re-frame: ignoring bad :dispatch-n value. Expected a collection, got got:" value)
      (doseq [event (remove nil? value)] (router/dispatch event)))))

;; :deregister-event-handler
;;
;; removes a previously registered event handler. Expects either a single id (
;; typically a namespaced keyword), or a seq of ids.
;;
;; usage:
;;   {:deregister-event-handler :my-id)}
;; or:
;;   {:deregister-event-handler [:one-id :another-id]}
;;
(reg-fx
  :deregister-event-handler
  (fn [value]
    (let [clear-event (partial clear-handlers events/kind)]
      (if (sequential? value)
        (doseq [event value] (clear-event event))
        (clear-event value)))))

;; :db
;;
;; reset! app-db with a new value. `value` is expected to be a map.
;;
;; usage:
;;   {:db  {:key1 value1 key2 value2}}
;;
(reg-fx
  :db
  (fn [value]
    (if-not (identical? @app-db value)
      (reset! app-db value))))

(ns re-frame.fx
  (:require
    [re-frame.router      :as router]
    [re-frame.db          :refer [app-db]]
    [re-frame.interceptor :refer [->interceptor]]
    [re-frame.interop     :refer [set-timeout!]]
    [re-frame.events      :as events]
    [re-frame.registrar   :refer [get-handler clear-handlers register-handler]]
    [re-frame.loggers     :refer [console]]
    [re-frame.trace :as trace :include-macros true]))

;; -- Registration ------------------------------------------------------------

(def kind :fx)
(assert (re-frame.registrar/kinds kind))

(defn reg-fx
  "Register the given effect `handler` for the given `id`.

  `id` is keyword, often namespaced.
  `handler` is a side-effecting function which takes a single argument and whose return
  value is ignored.

  Example Use
  -----------

  First, registration ... associate `:effect2` with a handler.

  (reg-fx
     :effect2
     (fn [value]
        ... do something side-effect-y))

  Then, later, if an event handler were to return this effects map ...

  {...
   :effect2  [1 2]}

   ... then the `handler` `fn` we registered previously, using `reg-fx`, will be
   called with an argument of `[1 2]`."
  [id handler]
  (register-handler kind id handler))

;; -- Interceptor -------------------------------------------------------------

(def do-fx
  "An interceptor whose `:after` actions the contents of `:effects`. As a result,
  this interceptor is Domino 3.

  This interceptor is silently added (by reg-event-db etc) to the front of
  interceptor chains for all events.

  For each key in `:effects` (a map), it calls the registered `effects handler`
  (see `reg-fx` for registration of effect handlers).

  So, if `:effects` was:
      {:dispatch  [:hello 42]
       :db        {...}
       :undo      \"set flag\"}

  it will call the registered effect handlers for each of the map's keys:
  `:dispatch`, `:undo` and `:db`. When calling each handler, provides the map
  value for that key - so in the example above the effect handler for :dispatch
  will be given one arg `[:hello 42]`.

  You cannot rely on the ordering in which effects are executed."
  (->interceptor
    :id :do-fx
    :after (fn do-fx-after
             [context]
             (trace/with-trace
               {:op-type :event/do-fx}
               (doseq [[effect-key effect-value] (:effects context)]
                 (if-let [effect-fn (get-handler kind effect-key false)]
                   (effect-fn effect-value)
                   (console :error "re-frame: no handler registered for effect:" effect-key ". Ignoring.")))))))

;; -- Builtin Effect Handlers  ------------------------------------------------

;; :dispatch-later
;;
;; `dispatch` one or more events after given delays. Expects a collection
;; of maps with two keys:  :`ms` and `:dispatch`
;;
;; usage:
;;
;;    {:dispatch-later [{:ms 200 :dispatch [:event-id "param"]}    ;;  in 200ms do this: (dispatch [:event-id "param"])
;;                      {:ms 100 :dispatch [:also :this :in :100ms]}]}
;;
;; Note: nil entries in the collection are ignored which means events can be added
;; conditionally:
;;    {:dispatch-later [ (when (> 3 5) {:ms 200 :dispatch [:conditioned-out]})
;;                       {:ms 100 :dispatch [:another-one]}]}
;;
(reg-fx
  :dispatch-later
  (fn [value]
    (doseq [{:keys [ms dispatch] :as effect} (remove nil? value)]
        (if (or (empty? dispatch) (not (number? ms)))
          (console :error "re-frame: ignoring bad :dispatch-later value:" effect)
          (set-timeout! #(router/dispatch dispatch) ms)))))

;; :dispatch
;;
;; `dispatch` one event. Excepts a single vector.
;;
;; usage:
;;   {:dispatch [:event-id "param"] }

(reg-fx
  :dispatch
  (fn [value]
    (if-not (vector? value)
      (console :error "re-frame: ignoring bad :dispatch value. Expected a vector, but got:" value)
      (router/dispatch value))))

;; :dispatch-n
;;
;; `dispatch` more than one event. Expects a list or vector of events. Something for which
;; sequential? returns true.
;;
;; usage:
;;   {:dispatch-n (list [:do :all] [:three :of] [:these])}
;;
;; Note: nil events are ignored which means events can be added
;; conditionally:
;;    {:dispatch-n (list (when (> 3 5) [:conditioned-out])
;;                       [:another-one])}
;;
(reg-fx
  :dispatch-n
  (fn [value]
    (if-not (sequential? value)
      (console :error "re-frame: ignoring bad :dispatch-n value. Expected a collection, got got:" value)
      (doseq [event (remove nil? value)] (router/dispatch event)))))

;; :deregister-event-handler
;;
;; removes a previously registered event handler. Expects either a single id (
;; typically a namespaced keyword), or a seq of ids.
;;
;; usage:
;;   {:deregister-event-handler :my-id)}
;; or:
;;   {:deregister-event-handler [:one-id :another-id]}
;;
(reg-fx
  :deregister-event-handler
  (fn [value]
    (let [clear-event (partial clear-handlers events/kind)]
      (if (sequential? value)
        (doseq [event value] (clear-event event))
        (clear-event value)))))

;; :db
;;
;; reset! app-db with a new value. `value` is expected to be a map.
;;
;; usage:
;;   {:db  {:key1 value1 key2 value2}}
;;
(reg-fx
  :db
  (fn [value]
    (if-not (identical? @app-db value)
      (reset! app-db value))))

Fix the bug I recently introduced

Fix the bug I recently introduced


(ns braid.core.client.ui.views.pills
  (:require
    [braid.core.client.helpers :as helpers]
    [braid.core.client.helpers :refer [id->color]]
    [braid.core.client.routes :as routes]
    [re-frame.core :refer [dispatch subscribe]]
    [reagent.core :as r]))

(defn subscribe-button-view
  [tag-id]
  (let [user-subscribed-to-tag? (subscribe [:user-subscribed-to-tag? tag-id])]
    (if @user-subscribed-to-tag?
      [:a.button {:on-click
                  (fn [_]
                    (dispatch [:unsubscribe-from-tag tag-id]))}
       "Unsubscribe"]
      [:a.button {:on-click
                  (fn [_]
                    (dispatch [:subscribe-to-tag {:tag-id tag-id}]))}
       "Subscribe"])))

(defn tag-pill
  [tag-id]
  (let [tag (subscribe [:tag tag-id])
        user-subscribed-to-tag? (subscribe [:user-subscribed-to-tag? tag-id])
        color (id->color tag-id)]
    [:span.pill {:class (if @user-subscribed-to-tag? "on" "off")
                 :tabIndex -1
                 :style {:background-color color
                         :color color
                         :border-color color}}
     [:div.name "#" (@tag :name)]]))

(defn search-button-view [query]
  (let [open-group-id (subscribe [:open-group-id])]
    [:a.search
     {:href (routes/search-page-path {:group-id @open-group-id
                                      :query query})}
     "Search"]))

(defn tag-card-view
  [tag-id]
  (let [tag (subscribe [:tag tag-id])
        user-subscribed-to-tag? (subscribe [:user-subscribed-to-tag? tag-id])]
    [:div.card
     [:div.header {:style {:background-color (id->color tag-id)}}
      [tag-pill tag-id]
      [:div.subscribers.count
       {:title (str (@tag :subscribers-count) " Subscribers")}
       (@tag :subscribers-count)]
      [:div.threads.count
       {:title (str (@tag :threads-count) " Conversations")}
       (@tag :threads-count)]]
     [:div.info
      [:div.description
       (or (@tag :description) "If I had a description, it would be here.")]]
     [:div.actions
      [search-button-view (str "#" (@tag :name))]
      [subscribe-button-view tag-id]]]))

(defn tag-pill-view
  [tag-id]
  [:div.tag
   [tag-pill tag-id]
   [tag-card-view tag-id]])

(defn user-pill
  [user-id]
  (let [user (subscribe [:user user-id])]
    (let [color (id->color user-id)]
      [:span.pill {:class (str (case (@user :status) :online "on" "off"))
                   :tabIndex -1
                   :style {:background-color color
                           :color color
                           :border-color color}}
       [:span.name (str "@" (@user :nickname))]])))

(defn user-card-view
  [user-id]
  (let [user (subscribe [:user user-id])
        open-group-id (subscribe [:open-group-id])
        admin? (subscribe [:user-is-group-admin? user-id] [open-group-id])
        viewer-admin? (subscribe [:current-user-is-group-admin?] [open-group-id])]
    [:div.card

     [:div.header {:style {:background-color (id->color user-id)}}
      [user-pill user-id]
      [:div.status
       (@user :status)
       #_[:div "time since last online"]]
      [:div.badges
       (when @admin?
         [:div.admin {:title "admin"}])]
      [:img.avatar {:src (@user :avatar)}]]

     [:div.info
      [:div.local-time (helpers/format-date (js/Date.))]
      #_[:div.since "member since"]
      [:div.description
       "If I had a profile, it would be here"]]

     [:div.actions
      #_[:a.pm "PM"]
      #_[:a.mute "Mute"]

      [search-button-view (str "@" (@user :nickname))]

      (when (and @viewer-admin? (not= user-id @(subscribe [:user-id])))
        [:button.ban
         {:on-click
          (fn [_]
            (dispatch [:remove-from-group
                       {:group-id @open-group-id
                        :user-id user-id}]))}
         "Kick"])

      (when (and @viewer-admin? (not @admin?))
        [:button.make-admin
         {:on-click
          (fn [_]
            (dispatch [:make-admin
                       {:group-id @open-group-id
                        :user-id user-id}]))}
         "Make Admin"])]]))

(defn user-pill-view
  [user-id]
  [:div.user
   [user-pill user-id]
   [user-card-view user-id]])

(ns braid.core.client.ui.views.pills
  (:require
    [braid.core.client.helpers :as helpers]
    [braid.core.client.helpers :refer [id->color]]
    [braid.core.client.routes :as routes]
    [re-frame.core :refer [dispatch subscribe]]
    [reagent.core :as r]))

(defn subscribe-button-view
  [tag-id]
  (let [user-subscribed-to-tag? (subscribe [:user-subscribed-to-tag? tag-id])]
    (if @user-subscribed-to-tag?
      [:a.button {:on-click
                  (fn [_]
                    (dispatch [:unsubscribe-from-tag tag-id]))}
       "Unsubscribe"]
      [:a.button {:on-click
                  (fn [_]
                    (dispatch [:subscribe-to-tag {:tag-id tag-id}]))}
       "Subscribe"])))

(defn tag-pill
  [tag-id]
  (let [tag (subscribe [:tag tag-id])
        user-subscribed-to-tag? (subscribe [:user-subscribed-to-tag? tag-id])
        color (id->color tag-id)]
    [:span.pill {:class (if @user-subscribed-to-tag? "on" "off")
                 :tabIndex -1
                 :style {:background-color color
                         :color color
                         :border-color color}}
     [:div.name "#" (@tag :name)]]))

(defn search-button-view [query]
  (let [open-group-id (subscribe [:open-group-id])]
    [:a.search
     {:href (routes/search-page-path {:group-id @open-group-id
                                      :query query})}
     "Search"]))

(defn tag-card-view
  [tag-id]
  (let [tag (subscribe [:tag tag-id])
        user-subscribed-to-tag? (subscribe [:user-subscribed-to-tag? tag-id])]
    [:div.card
     [:div.header {:style {:background-color (id->color tag-id)}}
      [tag-pill tag-id]
      [:div.subscribers.count
       {:title (str (@tag :subscribers-count) " Subscribers")}
       (@tag :subscribers-count)]
      [:div.threads.count
       {:title (str (@tag :threads-count) " Conversations")}
       (@tag :threads-count)]]
     [:div.info
      [:div.description
       (@tag :description)]]
     [:div.actions
      [search-button-view (str "#" (@tag :name))]
      [subscribe-button-view tag-id]]]))

(defn tag-pill-view
  [tag-id]
  [:div.tag
   [tag-pill tag-id]
   [tag-card-view tag-id]])

(defn user-pill
  [user-id]
  (let [user (subscribe [:user user-id])]
    (let [color (id->color user-id)]
      [:span.pill {:class (str (case (@user :status) :online "on" "off"))
                   :tabIndex -1
                   :style {:background-color color
                           :color color
                           :border-color color}}
       [:span.name (str "@" (@user :nickname))]])))

(defn user-card-view
  [user-id]
  (let [user (subscribe [:user user-id])
        open-group-id (subscribe [:open-group-id])
        admin? (subscribe [:user-is-group-admin? user-id] [open-group-id])
        viewer-admin? (subscribe [:current-user-is-group-admin?] [open-group-id])]
    [:div.card

     [:div.header {:style {:background-color (id->color user-id)}}
      [user-pill user-id]
      [:div.status
       (@user :status)
       #_[:div "time since last online"]]
      [:div.badges
       (when @admin?
         [:div.admin {:title "admin"}])]
      [:img.avatar {:src (@user :avatar)}]]

     [:div.info
      [:div.local-time (helpers/format-date (js/Date.))]
      #_[:div.since "member since"]
      [:div.description
       #_"If I had a profile, it would be here"]]

     [:div.actions
      #_[:a.pm "PM"]
      #_[:a.mute "Mute"]

      [search-button-view (str "@" (@user :nickname))]

      (when (and @viewer-admin? (not= user-id @(subscribe [:user-id])))
        [:button.ban
         {:on-click
          (fn [_]
            (dispatch [:remove-from-group
                       {:group-id @open-group-id
                        :user-id user-id}]))}
         "Kick"])

      (when (and @viewer-admin? (not @admin?))
        [:button.make-admin
         {:on-click
          (fn [_]
            (dispatch [:make-admin
                       {:group-id @open-group-id
                        :user-id user-id}]))}
         "Make Admin"])]]))

(defn user-pill-view
  [user-id]
  [:div.user
   [user-pill user-id]
   [user-card-view user-id]])

Remove placeholder messages in user and tag hover-cards


{:user {
        :plugins [[cider/cider-nrepl "0.11.0-SNAPSHOT"]
                  [jonase/eastwood "0.2.3"]
                  [lein-kibit "0.1.2"]
                  [lein-typed "0.3.5"]
                  ]
        :dependencies [[org.clojure/clojure "1.8.0"]
                       [com.datomic/datomic-free "0.9.5350"]
                       [me.raynes/fs "1.4.6"]
                       ;; Consider using typed? [org.clojure/core.typed "0.3.22"]
                       ]
        }}

{:user {
        :plugins [[cider/cider-nrepl "0.11.0"]
                  [jonase/eastwood "0.2.3"]
                  [lein-kibit "0.1.2"]
                  [lein-typed "0.3.5"]
                  ]
        :dependencies [[org.clojure/clojure "1.8.0"]
                       [datomic-schema-grapher "0.0.1"]
                       [com.datomic/datomic-pro "0.9.5350"]
                       [me.raynes/fs "1.4.6"]
                       [clj-stacktrace "0.2.8"]
                       ;; Consider using typed? [org.clojure/core.typed "0.3.22"]
                       ]
        }}

Add clj-stacktrace to global lein deps.

Add clj-stacktrace to global lein deps.


(ns planck.core
  (:require-macros [cljs.env.macros :refer [with-compiler-env]])
  (:require [cljs.js :as cljs]
            [cljs.tagged-literals :as tags]
            [cljs.tools.reader :as r]
            [cljs.analyzer :as ana]
            [cljs.repl :as repl]
            [cljs.stacktrace :as st]
            [cljs.source-map :as sm]
            [tailrecursion.cljson :refer [cljson->clj]]
            [planck.io]))

(defonce st (cljs/empty-state))

(defonce current-ns (atom 'cljs.user))

(defonce app-env (atom nil))

(defn map-keys [f m]
  (reduce-kv (fn [r k v] (assoc r (f k) v)) {} m))

(defn ^:export init-app-env [app-env]
  (reset! planck.core/app-env (map-keys keyword (cljs.core/js->clj app-env))))

(defn repl-read-string [line]
  (r/read-string {:read-cond :allow :features #{:cljs}} line))

(defn ^:export is-readable? [line]
  (binding [r/*data-readers* tags/*cljs-data-readers*]
    (try
      (repl-read-string line)
      true
      (catch :default _
        false))))

(defn ns-form? [form]
  (and (seq? form) (= 'ns (first form))))

(def repl-specials '#{in-ns require require-macros doc})

(defn repl-special? [form]
  (and (seq? form) (repl-specials (first form))))

(def repl-special-doc-map
  '{in-ns          {:arglists ([name])
                    :doc      "Sets *cljs-ns* to the namespace named by the symbol, creating it if needed."}
    require        {:arglists ([& args])
                    :doc      "Loads libs, skipping any that are already loaded."}
    require-macros {:arglists ([& args])
                    :doc      "Similar to the require REPL special function but\n  only for macros."}
    doc            {:arglists ([name])
                    :doc      "Prints documentation for a var or special form given its name"}})

(defn- repl-special-doc [name-symbol]
  (assoc (repl-special-doc-map name-symbol)
    :name name-symbol
    :repl-special-function true))

(defn resolve
  "Given an analysis environment resolve a var. Analogous to
   clojure.core/resolve"
  [env sym]
  {:pre [(map? env) (symbol? sym)]}
  (try
    (ana/resolve-var env sym
      (ana/confirm-var-exists-throw))
    (catch :default _
      (ana/resolve-macro-var env sym))))

(defn ^:export get-current-ns []
  (str @current-ns))

(defn completion-candidates-for-ns [ns-sym allow-private?]
  (map (comp str key)
    (filter (if allow-private?
              identity
              #(not (:private (:meta (val %)))))
      (apply merge
        ((juxt :defs :macros)
          (get (:cljs.analyzer/namespaces @planck.core/st) ns-sym))))))

(defn is-completion? [buffer-match-suffix candidate]
  (re-find (js/RegExp. (str "^" buffer-match-suffix)) candidate))

(defn ^:export get-completions [buffer]
  (let [namespace-candidates (map str
                               (keys (:cljs.analyzer/namespaces @planck.core/st)))
        all-candidates (into
                         (into
                           (into
                             (into #{} namespace-candidates)
                             (completion-candidates-for-ns 'cljs.core false))
                           (completion-candidates-for-ns @current-ns true))
                         (map str repl-specials))]
    (let [buffer-match-suffix (re-find #"[a-zA-Z]*$" buffer)
          buffer-prefix (subs buffer 0 (- (count buffer) (count buffer-match-suffix)))]
      (clj->js (if (= "" buffer-match-suffix)
                 []
                 (map #(str buffer-prefix %)
                   (sort
                     (filter (partial is-completion? buffer-match-suffix)
                       all-candidates))))))))

(defn extension->lang [extension]
  (if (= ".js" extension)
    :js
    :clj))

(defn load-and-callback! [path extension cb]
  (when-let [source (js/PLANCK_LOAD (str path extension))]
    (cb {:lang   (extension->lang extension)
         :source source})
    :loaded))

(defn load [{:keys [name macros path] :as full} cb]
  #_(prn full)
  (loop [extensions (if macros
                      [".clj" ".cljc"]
                      [".cljs" ".cljc" ".js"])]
    (if extensions
      (when-not (load-and-callback! path (first extensions) cb)
        (recur (next extensions)))
      (cb nil))))

(defn require [macros-ns? sym reload]
  (cljs.js/require
    {:*compiler*     st
     :*data-readers* tags/*cljs-data-readers*
     :*load-fn*      load
     :*eval-fn*      cljs/js-eval}
    sym
    reload
    {:macros-ns  macros-ns?
     :verbose    (:verbose @app-env)
     :source-map true}
    (fn [res]
      #_(println "require result:" res))))

(defn require-destructure [macros-ns? args]
  (let [[[_ sym] reload] args]
    (require macros-ns? sym reload)))

(defn ^:export run-main [main-ns args]
  (let [main-args (js->clj args)]
    (require false (symbol main-ns) nil)
    (cljs/eval-str st
      (str "(var -main)")
      nil
      {:ns         (symbol main-ns)
       :load       load
       :eval       cljs/js-eval
       :source-map true
       :context    :expr}
      (fn [{:keys [ns value error] :as ret}]
        (apply value args)))
    nil))

(defn load-core-source-maps! []
  (when-not (get (:source-maps @planck.core/st) 'planck.core)
    (swap! st update-in [:source-maps] merge {'planck.core
                                              (sm/decode
                                                (cljson->clj
                                                  (js/PLANCK_LOAD "planck/core.js.map")))
                                              'cljs.core
                                              (sm/decode
                                                (cljson->clj
                                                  (js/PLANCK_LOAD "cljs/core.js.map")))})))

(defn print-error [error]
  (let [cause (or (.-cause error) error)]
    (println (.-message cause))
    (load-core-source-maps!)
    (let [canonical-stacktrace (st/parse-stacktrace
                                 {}
                                 (.-stack cause)
                                 {:ua-product :safari}
                                 {:output-dir "file://(/goog/..)?"})]
      (println
        (st/mapped-stacktrace-str
          canonical-stacktrace
          (or (:source-maps @planck.core/st) {})
          nil)))))

(defn ^:export read-eval-print
  [source expression? print-nil-expression?]
  (binding [ana/*cljs-ns* @current-ns
            *ns* (create-ns @current-ns)
            r/*data-readers* tags/*cljs-data-readers*]
    (let [expression-form (and expression? (repl-read-string source))]
      (if (repl-special? expression-form)
        (let [env (assoc (ana/empty-env) :context :expr
                                         :ns {:name @current-ns})]
          (case (first expression-form)
            in-ns (reset! current-ns (second (second expression-form)))
            require (require-destructure false (rest expression-form))
            require-macros (require-destructure true (rest expression-form))
            doc (if (repl-specials (second expression-form))
                  (repl/print-doc (repl-special-doc (second expression-form)))
                  (repl/print-doc
                    (let [sym (second expression-form)
                          var (with-compiler-env st
                                (resolve env sym))]
                      (:meta var)))))
          (prn nil))
        (try
          (cljs/eval-str
            st
            source
            (if expression? source "File")
            (merge
              {:ns         @current-ns
               :load       load
               :eval       cljs/js-eval
               :source-map false
               :verbose    (:verbose @app-env)}
              (when expression?
                {:context       :expr
                 :def-emits-var true}))
            (fn [{:keys [ns value error] :as ret}]
              (if expression?
                (if-not error
                  (do
                    (when (or print-nil-expression?
                            (not (nil? value)))
                      (prn value))
                    (when-not
                      (or ('#{*1 *2 *3 *e} expression-form)
                        (ns-form? expression-form))
                      (set! *3 *2)
                      (set! *2 *1)
                      (set! *1 value))
                    (reset! current-ns ns)
                    nil)
                  (do
                    (set! *e error))))
              (when error
                (print-error error))))
          (catch :default e
            (print-error e)))))))

(ns planck.core
  (:require-macros [cljs.env.macros :refer [with-compiler-env]])
  (:require [cljs.js :as cljs]
            [cljs.tagged-literals :as tags]
            [cljs.tools.reader :as r]
            [cljs.analyzer :as ana]
            [cljs.repl :as repl]
            [cljs.stacktrace :as st]
            [cljs.source-map :as sm]
            [tailrecursion.cljson :refer [cljson->clj]]
            [planck.io]))

(defonce st (cljs/empty-state))

(defonce current-ns (atom 'cljs.user))

(defonce app-env (atom nil))

(defn map-keys [f m]
  (reduce-kv (fn [r k v] (assoc r (f k) v)) {} m))

(defn ^:export init-app-env [app-env]
  (reset! planck.core/app-env (map-keys keyword (cljs.core/js->clj app-env))))

(defn repl-read-string [line]
  (r/read-string {:read-cond :allow :features #{:cljs}} line))

(defn ^:export is-readable? [line]
  (binding [r/*data-readers* tags/*cljs-data-readers*]
    (try
      (repl-read-string line)
      true
      (catch :default _
        false))))

(defn ns-form? [form]
  (and (seq? form) (= 'ns (first form))))

(def repl-specials '#{in-ns require require-macros doc})

(defn repl-special? [form]
  (and (seq? form) (repl-specials (first form))))

(def repl-special-doc-map
  '{in-ns          {:arglists ([name])
                    :doc      "Sets *cljs-ns* to the namespace named by the symbol, creating it if needed."}
    require        {:arglists ([& args])
                    :doc      "Loads libs, skipping any that are already loaded."}
    require-macros {:arglists ([& args])
                    :doc      "Similar to the require REPL special function but\n  only for macros."}
    doc            {:arglists ([name])
                    :doc      "Prints documentation for a var or special form given its name"}})

(defn- repl-special-doc [name-symbol]
  (assoc (repl-special-doc-map name-symbol)
    :name name-symbol
    :repl-special-function true))

(defn resolve
  "Given an analysis environment resolve a var. Analogous to
   clojure.core/resolve"
  [env sym]
  {:pre [(map? env) (symbol? sym)]}
  (try
    (ana/resolve-var env sym
      (ana/confirm-var-exists-throw))
    (catch :default _
      (ana/resolve-macro-var env sym))))

(defn ^:export get-current-ns []
  (str @current-ns))

(defn completion-candidates-for-ns [ns-sym allow-private?]
  (map (comp str key)
    (filter (if allow-private?
              identity
              #(not (:private (:meta (val %)))))
      (apply merge
        ((juxt :defs :macros)
          (get (:cljs.analyzer/namespaces @planck.core/st) ns-sym))))))

(defn is-completion? [buffer-match-suffix candidate]
  (re-find (js/RegExp. (str "^" buffer-match-suffix)) candidate))

(defn ^:export get-completions [buffer]
  (let [namespace-candidates (map str
                               (keys (:cljs.analyzer/namespaces @planck.core/st)))
        all-candidates (set (concat namespace-candidates
                                    (completion-candidates-for-ns 'cljs.core false)
                                    (completion-candidates-for-ns @current-ns true)
                                    (map str repl-specials)))]
    (let [buffer-match-suffix (re-find #"[a-zA-Z]*$" buffer)
          buffer-prefix (subs buffer 0 (- (count buffer) (count buffer-match-suffix)))]
      (clj->js (if (= "" buffer-match-suffix)
                 []
                 (map #(str buffer-prefix %)
                   (sort
                     (filter (partial is-completion? buffer-match-suffix)
                       all-candidates))))))))

(defn extension->lang [extension]
  (if (= ".js" extension)
    :js
    :clj))

(defn load-and-callback! [path extension cb]
  (when-let [source (js/PLANCK_LOAD (str path extension))]
    (cb {:lang   (extension->lang extension)
         :source source})
    :loaded))

(defn load [{:keys [name macros path] :as full} cb]
  #_(prn full)
  (loop [extensions (if macros
                      [".clj" ".cljc"]
                      [".cljs" ".cljc" ".js"])]
    (if extensions
      (when-not (load-and-callback! path (first extensions) cb)
        (recur (next extensions)))
      (cb nil))))

(defn require [macros-ns? sym reload]
  (cljs.js/require
    {:*compiler*     st
     :*data-readers* tags/*cljs-data-readers*
     :*load-fn*      load
     :*eval-fn*      cljs/js-eval}
    sym
    reload
    {:macros-ns  macros-ns?
     :verbose    (:verbose @app-env)
     :source-map true}
    (fn [res]
      #_(println "require result:" res))))

(defn require-destructure [macros-ns? args]
  (let [[[_ sym] reload] args]
    (require macros-ns? sym reload)))

(defn ^:export run-main [main-ns args]
  (let [main-args (js->clj args)]
    (require false (symbol main-ns) nil)
    (cljs/eval-str st
      (str "(var -main)")
      nil
      {:ns         (symbol main-ns)
       :load       load
       :eval       cljs/js-eval
       :source-map true
       :context    :expr}
      (fn [{:keys [ns value error] :as ret}]
        (apply value args)))
    nil))

(defn load-core-source-maps! []
  (when-not (get (:source-maps @planck.core/st) 'planck.core)
    (swap! st update-in [:source-maps] merge {'planck.core
                                              (sm/decode
                                                (cljson->clj
                                                  (js/PLANCK_LOAD "planck/core.js.map")))
                                              'cljs.core
                                              (sm/decode
                                                (cljson->clj
                                                  (js/PLANCK_LOAD "cljs/core.js.map")))})))

(defn print-error [error]
  (let [cause (or (.-cause error) error)]
    (println (.-message cause))
    (load-core-source-maps!)
    (let [canonical-stacktrace (st/parse-stacktrace
                                 {}
                                 (.-stack cause)
                                 {:ua-product :safari}
                                 {:output-dir "file://(/goog/..)?"})]
      (println
        (st/mapped-stacktrace-str
          canonical-stacktrace
          (or (:source-maps @planck.core/st) {})
          nil)))))

(defn ^:export read-eval-print
  [source expression? print-nil-expression?]
  (binding [ana/*cljs-ns* @current-ns
            *ns* (create-ns @current-ns)
            r/*data-readers* tags/*cljs-data-readers*]
    (let [expression-form (and expression? (repl-read-string source))]
      (if (repl-special? expression-form)
        (let [env (assoc (ana/empty-env) :context :expr
                                         :ns {:name @current-ns})]
          (case (first expression-form)
            in-ns (reset! current-ns (second (second expression-form)))
            require (require-destructure false (rest expression-form))
            require-macros (require-destructure true (rest expression-form))
            doc (if (repl-specials (second expression-form))
                  (repl/print-doc (repl-special-doc (second expression-form)))
                  (repl/print-doc
                    (let [sym (second expression-form)
                          var (with-compiler-env st
                                (resolve env sym))]
                      (:meta var)))))
          (prn nil))
        (try
          (cljs/eval-str
            st
            source
            (if expression? source "File")
            (merge
              {:ns         @current-ns
               :load       load
               :eval       cljs/js-eval
               :source-map false
               :verbose    (:verbose @app-env)}
              (when expression?
                {:context       :expr
                 :def-emits-var true}))
            (fn [{:keys [ns value error] :as ret}]
              (if expression?
                (if-not error
                  (do
                    (when (or print-nil-expression?
                            (not (nil? value)))
                      (prn value))
                    (when-not
                      (or ('#{*1 *2 *3 *e} expression-form)
                        (ns-form? expression-form))
                      (set! *3 *2)
                      (set! *2 *1)
                      (set! *1 value))
                    (reset! current-ns ns)
                    nil)
                  (do
                    (set! *e error))))
              (when error
                (print-error error))))
          (catch :default e
            (print-error e)))))))

Simplify nested `into`s

Simplify nested `into`s


(ns cglossa.search-inputs.cwb.shared
  (:require [clojure.string :as str]
            [cljs-http.client :as http]))

(defn- search! [queries corpus]
  (let [queries*    @queries
        first-query (:query (first queries*))]
    (when (and first-query
               (not= first-query "\"\""))
      (let [q             (if (= (:lang corpus) "zh")
                            ;; For Chinese: If the tone number is missing, add a pattern
                            ;; that matches all tones
                            (for [query queries*]
                              (update query :query
                                      str/replace #"\bphon=\"([^0-9\"]+)\"" "phon=\"$1[1-4]?\""))
                            ;; For other languages, leave the queries unmodified
                            queries*)
            search-engine (:search-engine corpus "cwb")]
        (http/post "/search"
                   {:json-params {:corpus-id (:rid @corpus)
                                  :queries q}})))))

(defn on-key-down [event wrapped-query corpus]
  (when (= "Enter" (.-key event))
    (.preventDefault event)
    (search! wrapped-query corpus)))

(defn remove-row-btn [show? wrapped-query]
  [:button.btn.btn-danger.btn-xs {:type     "button"
                                  :title    "Remove row"
                                  :on-click #(reset! wrapped-query nil)
                                  :style    {:margin-right 5
                                             :padding-top  3
                                             :visibility   (if show?
                                                             "visible"
                                                             "hidden")}}
   [:span.glyphicon.glyphicon-remove]])

(defn- on-headword-search-changed [event wrapped-query]
  (swap! wrapped-query assoc :headword-search (.-target.checked event)))

(defn headword-search-checkbox [wrapped-query margin-left]
  [:label {:style {:margin-left margin-left}}
   [:input {:type      "checkbox"
            :value     "1"
            :checked   (:headword-search @wrapped-query)
            :on-change #(on-headword-search-changed % wrapped-query)
            :id        "headword_search"
            :name      "headword_search"} " Headword search"]])

(ns cglossa.search-inputs.cwb.shared
  (:require-macros [cljs.core.async.macros :refer [go]])
  (:require [clojure.string :as str]
            [cljs-http.client :as http]
            [cljs.core.async :refer [<!]]))

(defn- search! [queries corpus]
  (let [queries*    @queries
        first-query (:query (first queries*))]
    (when (and first-query
               (not= first-query "\"\""))
      (let [q             (if (= (:lang corpus) "zh")
                            ;; For Chinese: If the tone number is missing, add a pattern
                            ;; that matches all tones
                            (for [query queries*]
                              (update query :query
                                      str/replace #"\bphon=\"([^0-9\"]+)\"" "phon=\"$1[1-4]?\""))
                            ;; For other languages, leave the queries unmodified
                            queries*)
            search-engine (:search-engine corpus "cwb")]
        (go (let [{:keys [status success] :as response}
                  (<! (http/post "/search"
                                 {:json-params {:corpus-id (:rid @corpus)
                                                :queries   q}}))]
              (if success
                (let [results (get-in response [:body :results])]
                  (.log js/console (str results)))
                (.log js/console status))))))))

(defn on-key-down [event wrapped-query corpus]
  (when (= "Enter" (.-key event))
    (.preventDefault event)
    (search! wrapped-query corpus)))

(defn remove-row-btn [show? wrapped-query]
  [:button.btn.btn-danger.btn-xs {:type     "button"
                                  :title    "Remove row"
                                  :on-click #(reset! wrapped-query nil)
                                  :style    {:margin-right 5
                                             :padding-top  3
                                             :visibility   (if show?
                                                             "visible"
                                                             "hidden")}}
   [:span.glyphicon.glyphicon-remove]])

(defn- on-headword-search-changed [event wrapped-query]
  (swap! wrapped-query assoc :headword-search (.-target.checked event)))

(defn headword-search-checkbox [wrapped-query margin-left]
  [:label {:style {:margin-left margin-left}}
   [:input {:type      "checkbox"
            :value     "1"
            :checked   (:headword-search @wrapped-query)
            :on-change #(on-headword-search-changed % wrapped-query)
            :id        "headword_search"
            :name      "headword_search"} " Headword search"]])

Read results from channel returned by http/post


(ns onyx.windowing.window-extensions
  (:require [onyx.windowing.units :refer [to-standard-units coerce-key] :as units]
            [onyx.windowing.window-id :as wid]
            [onyx.static.default-vals :as d]))

(defn window-id-impl-extents [units min-value w-range w-slide window-time]
  (let [min-value (or min-value 0)]
    (wid/wids min-value w-range w-slide window-time)))

(defprotocol IWindow

  (extent-operations [this all-extents segment time-index]
    "Given a segment time and all extents, return the vector of operations that should be performed on the windows.
     Operations take the form [action arg1 arg2].
     Support actions are:
     [:merge-extents extent1 extent2 merged-extent]
     [:alter-extents old-extent new-extent]
     [:update extent]")

  (time-index [this segment]
    "Given a segment, return the coerced window time for the window key.")

  (bounds [this window-id]
    "Returns a vector of two elements. The first is the lower bound that this window
     id accepts, and the second is the upper."))

(defrecord FixedWindow
  [id task type init window-key min-value range w-range units slide timeout-gap doc window]
  IWindow

  (extent-operations [this extents _ time-index]
    (map (fn [extent]
           [:update extent])
         (window-id-impl-extents units min-value w-range w-range time-index)))

  (time-index [this segment]
    (units/coerce-key (get segment window-key) units))

  (bounds [this window-id]
    (let [win-min (or min-value (get d/default-vals :onyx.windowing/min-value))]
      [(wid/extent-lower win-min w-range w-range window-id)
       (wid/extent-upper win-min w-range window-id)])))

(defrecord SlidingWindow
  [id task type init window-key min-value range slide units w-range w-slide timeout-gap doc window]
  IWindow

  (extent-operations [this _ _ time-index]
    (map (fn [extent]
           [:update extent])
         (window-id-impl-extents units min-value w-range w-slide time-index)))

  (time-index [this segment]
    (units/coerce-key (get segment window-key) units))

  (bounds [this window-id]
    (let [win-min (or min-value (get d/default-vals :onyx.windowing/min-value))]
      [(wid/extent-lower win-min w-range w-slide window-id)
       (wid/extent-upper win-min w-slide window-id)])))

(defrecord GlobalWindow
  [id task type init window-key min-value range slide timeout-gap doc window]
  IWindow

  (extent-operations [this _ _ time-index]
    ;; Always return the same window ID, the actual number
    ;; doesn't matter - as long as its constant.
    [[:update 1]])

  (time-index [this segment] 0)

  (bounds [this window-id]
    ;; Everything is in bounds.
    #?(:clj  [Double/NEGATIVE_INFINITY Double/POSITIVE_INFINITY])
    #?(:cljs [(.-NEGATIVE_INFINITY js/Number) (.-POSITIVE_INFINITY js/Number)])))

(defn bounding-extents
  "Find the extents with the closest lower bounds."
  [extents session-time]
  (loop [extent (first extents)
         vs (rest extents)
         closest-below [#?(:clj Long/MAX_VALUE
                           :cljs (.-POSITIVE_INFINITY js/Number))
                        nil]
         closest-above [#?(:clj Long/MAX_VALUE
                           :cljs (.-POSITIVE_INFINITY js/Number))
                        nil]]
    (if (nil? extent)
      [(second closest-below)
       (second closest-above)]
      (let [[session-lower-bound] extent
            lower-distance (- session-time session-lower-bound)
            new-closest-below (if (and (<= session-lower-bound session-time)
                                       (< lower-distance (first closest-below)))
                                [lower-distance extent]
                                closest-below)
            upper-distance (- session-lower-bound session-time)
            new-closest-above (if (and (>= session-lower-bound session-time)
                                       (< upper-distance (first closest-above)))
                                [upper-distance extent]
                                closest-above)]
        (recur (first vs)
               (rest vs)
               new-closest-below
               new-closest-above)))))

(defrecord SessionWindow
  [id task type init window-key min-value range slide gap timeout-gap units doc window]
  IWindow
  (extent-operations [this all-extents _ time-index]
    (let [[below-extent above-extent] (bounding-extents @all-extents time-index)
          [below-lower below-upper] below-extent
          [above-lower above-upper] above-extent
          below-contains? (and below-upper (>= below-upper (- time-index gap)))
          above-contains? (and above-lower (>= (+ time-index gap) above-lower))]
      (cond ;; matches point exactly
            (and below-extent above-extent (= below-extent above-extent))
            [[:update below-extent]]

            (and below-contains? above-contains?)
            [[:merge-extents
              [below-lower below-upper]
              [above-lower above-upper]
              [below-lower above-upper]]
             [:update [below-lower above-upper]]]

            (and below-contains? (> time-index below-upper))
            [[:alter-extents
              [below-lower below-upper]
              [below-lower time-index]]
             [:update [below-lower time-index]]]

            below-contains?
            [[:update [below-lower (max below-upper time-index)]]]

            (and above-contains? (< time-index above-lower))
            [[:alter-extents
              [above-lower above-upper]
              [time-index above-upper]]
             [:update [time-index above-upper]]]

            above-contains?
            [[:update [above-lower (max time-index above-upper)]]]

            ;; no windows matched
            :else
            [[:update [time-index time-index]]])))

  (time-index [this segment]
    (units/coerce-key (get segment window-key) units))

  (bounds [this window-id]
    window-id))

(defmulti extent-serializer
  "Given a window, return the type of extent serializer"
  (fn [window]
    (:window/type window)))

(defmethod extent-serializer :fixed
  [window]
  :long)

(defmethod extent-serializer :sliding
  [window]
  :long)

(defmethod extent-serializer :global
  [window]
  :nil)

(defmethod extent-serializer :session
  [window]
  :long-long)

(defmulti windowing-builder
  "Given a window, return the concrete type to perform
   operations against."
  (fn [window]
    (:window/type window)))

(defmethod windowing-builder :fixed
  [window]
  (fn [{:keys [range] :as m}]
    (-> m
        (assoc :units (units/standard-units-for (last range)))
        (assoc :w-range (apply units/to-standard-units range))
        (map->FixedWindow))))

(defmethod windowing-builder :sliding
  [window]
  (fn [{:keys [range slide] :as m}]
    (-> m
        (assoc :units (units/standard-units-for (last range)))
        (assoc :w-range (apply units/to-standard-units range))
        (assoc :w-slide (apply to-standard-units (or slide range)))
        (map->SlidingWindow))))

(defmethod windowing-builder :global
  [window] map->GlobalWindow)

(defmethod windowing-builder :session
  [window]
  (fn [{:keys [timeout-gap] :as m}]
    (-> m
        (assoc :units (units/standard-units-for (last timeout-gap)))
        (assoc :gap (apply units/to-standard-units timeout-gap))
        map->SessionWindow)))

(ns onyx.windowing.window-extensions
  (:require [onyx.windowing.units :refer [to-standard-units coerce-key] :as units]
            [onyx.windowing.window-id :as wid]
            [onyx.static.default-vals :as d]))

(defn window-id-impl-extents [units min-value w-range w-slide window-time]
  (let [min-value (or min-value 0)]
    (wid/wids min-value w-range w-slide window-time)))

(defprotocol IWindow

  (extent-operations [this all-extents segment time-index]
    "Given a segment time and all extents, return the vector of operations that should be performed on the windows.
     Operations take the form [action arg1 arg2].
     Support actions are:
     [:merge-extents extent1 extent2 merged-extent]
     [:alter-extents old-extent new-extent]
     [:update extent]")

  (time-index [this segment]
    "Given a segment, return the coerced window time for the window key.")

  (bounds [this window-id]
    "Returns a vector of two elements. The first is the lower bound that this window
     id accepts, and the second is the upper."))

(defrecord FixedWindow
  [id task type init window-key min-value range w-range units slide timeout-gap doc window]
  IWindow

  (extent-operations [this extents _ time-index]
    (map (fn [extent]
           [:update extent])
         (window-id-impl-extents units min-value w-range w-range time-index)))

  (time-index [this segment]
    (units/coerce-key (get segment window-key) units))

  (bounds [this window-id]
    (let [win-min (or min-value (get d/default-vals :onyx.windowing/min-value))]
      [(wid/extent-lower win-min w-range w-range window-id)
       (wid/extent-upper win-min w-range window-id)])))

(defrecord SlidingWindow
  [id task type init window-key min-value range slide units w-range w-slide timeout-gap doc window]
  IWindow

  (extent-operations [this _ _ time-index]
    (map (fn [extent]
           [:update extent])
         (window-id-impl-extents units min-value w-range w-slide time-index)))

  (time-index [this segment]
    (units/coerce-key (get segment window-key) units))

  (bounds [this window-id]
    (let [win-min (or min-value (get d/default-vals :onyx.windowing/min-value))]
      [(wid/extent-lower win-min w-range w-slide window-id)
       (wid/extent-upper win-min w-slide window-id)])))

(defrecord GlobalWindow
  [id task type init window-key min-value range slide timeout-gap doc window]
  IWindow

  (extent-operations [this _ _ time-index]
    ;; Always return the same window ID, the actual number
    ;; doesn't matter - as long as its constant.
    [[:update 1]])

  (time-index [this segment]
    (if window-key
      (get segment window-key)
      0))

  (bounds [this window-id]
    ;; Everything is in bounds.
    #?(:clj  [Double/NEGATIVE_INFINITY Double/POSITIVE_INFINITY])
    #?(:cljs [(.-NEGATIVE_INFINITY js/Number) (.-POSITIVE_INFINITY js/Number)])))

(defn bounding-extents
  "Find the extents with the closest lower bounds."
  [extents session-time]
  (loop [extent (first extents)
         vs (rest extents)
         closest-below [#?(:clj Long/MAX_VALUE
                           :cljs (.-POSITIVE_INFINITY js/Number))
                        nil]
         closest-above [#?(:clj Long/MAX_VALUE
                           :cljs (.-POSITIVE_INFINITY js/Number))
                        nil]]
    (if (nil? extent)
      [(second closest-below)
       (second closest-above)]
      (let [[session-lower-bound] extent
            lower-distance (- session-time session-lower-bound)
            new-closest-below (if (and (<= session-lower-bound session-time)
                                       (< lower-distance (first closest-below)))
                                [lower-distance extent]
                                closest-below)
            upper-distance (- session-lower-bound session-time)
            new-closest-above (if (and (>= session-lower-bound session-time)
                                       (< upper-distance (first closest-above)))
                                [upper-distance extent]
                                closest-above)]
        (recur (first vs)
               (rest vs)
               new-closest-below
               new-closest-above)))))

(defrecord SessionWindow
  [id task type init window-key min-value range slide gap timeout-gap units doc window]
  IWindow
  (extent-operations [this all-extents _ time-index]
    (let [[below-extent above-extent] (bounding-extents @all-extents time-index)
          [below-lower below-upper] below-extent
          [above-lower above-upper] above-extent
          below-contains? (and below-upper (>= below-upper (- time-index gap)))
          above-contains? (and above-lower (>= (+ time-index gap) above-lower))]
      (cond ;; matches point exactly
            (and below-extent above-extent (= below-extent above-extent))
            [[:update below-extent]]

            (and below-contains? above-contains?)
            [[:merge-extents
              [below-lower below-upper]
              [above-lower above-upper]
              [below-lower above-upper]]
             [:update [below-lower above-upper]]]

            (and below-contains? (> time-index below-upper))
            [[:alter-extents
              [below-lower below-upper]
              [below-lower time-index]]
             [:update [below-lower time-index]]]

            below-contains?
            [[:update [below-lower (max below-upper time-index)]]]

            (and above-contains? (< time-index above-lower))
            [[:alter-extents
              [above-lower above-upper]
              [time-index above-upper]]
             [:update [time-index above-upper]]]

            above-contains?
            [[:update [above-lower (max time-index above-upper)]]]

            ;; no windows matched
            :else
            [[:update [time-index time-index]]])))

  (time-index [this segment]
    (units/coerce-key (get segment window-key) units))

  (bounds [this window-id]
    window-id))

(defmulti extent-serializer
  "Given a window, return the type of extent serializer"
  (fn [window]
    (:window/type window)))

(defmethod extent-serializer :fixed
  [window]
  :long)

(defmethod extent-serializer :sliding
  [window]
  :long)

(defmethod extent-serializer :global
  [window]
  :nil)

(defmethod extent-serializer :session
  [window]
  :long-long)

(defmulti windowing-builder
  "Given a window, return the concrete type to perform
   operations against."
  (fn [window]
    (:window/type window)))

(defmethod windowing-builder :fixed
  [window]
  (fn [{:keys [range] :as m}]
    (-> m
        (assoc :units (units/standard-units-for (last range)))
        (assoc :w-range (apply units/to-standard-units range))
        (map->FixedWindow))))

(defmethod windowing-builder :sliding
  [window]
  (fn [{:keys [range slide] :as m}]
    (-> m
        (assoc :units (units/standard-units-for (last range)))
        (assoc :w-range (apply units/to-standard-units range))
        (assoc :w-slide (apply to-standard-units (or slide range)))
        (map->SlidingWindow))))

(defmethod windowing-builder :global
  [window]
  (println "BUILD" window)
  map->GlobalWindow)

(defmethod windowing-builder :session
  [window]
  (fn [{:keys [timeout-gap] :as m}]
    (-> m
        (assoc :units (units/standard-units-for (last timeout-gap)))
        (assoc :gap (apply units/to-standard-units timeout-gap))
        map->SessionWindow)))

Allow non-zero global time index when window-key is supplied.


(ns swarmpit.component.registry.info
  (:require [material.component :as comp]
            [material.icon :as icon]
            [swarmpit.url :refer [dispatch!]]
            [swarmpit.component.handler :as handler]
            [swarmpit.component.message :as message]
            [swarmpit.routes :as routes]
            [rum.core :as rum]))

(enable-console-print!)

(defn- delete-registry-handler
  [registry-id]
  (handler/delete
    (routes/path-for-backend :registry-delete {:id registry-id})
    (fn [_]
      (dispatch!
        (routes/path-for-frontend :registry-list))
      (message/info
        (str "Registry " registry-id " has been removed.")))
    (fn [response]
      (message/error
        (str "Registry removing failed. Reason: " (:error response))))))

(rum/defc form < rum/static [item]
  [:div
   [:div.form-panel
    [:div.form-panel-left
     (comp/panel-info icon/registries
                      (:name item))]
    [:div.form-panel-right
     (comp/mui
       (comp/raised-button
         {:onTouchTap #(delete-registry-handler (:_id item))
          :label      "Delete"}))]]
   [:div.form-view
    [:div.form-view-group
     (comp/form-item "ID" (:_id item))
     (comp/form-item "NAME" (:name item))
     (comp/form-item "URL" (:url item))
     (comp/form-item "AUTHENTICATION" (if (:withAuth item)
                                        "yes"
                                        "no"))
     (if (:withAuth item)
       [:div
        (comp/form-item "USERNAME" (:username item))
        (comp/form-item "PASSWORD" (:password item))])]]])

(ns swarmpit.component.registry.info
  (:require [material.component :as comp]
            [material.icon :as icon]
            [swarmpit.url :refer [dispatch!]]
            [swarmpit.component.handler :as handler]
            [swarmpit.component.message :as message]
            [swarmpit.routes :as routes]
            [rum.core :as rum]))

(enable-console-print!)

(defn- delete-registry-handler
  [registry-id]
  (handler/delete
    (routes/path-for-backend :registry-delete {:id registry-id})
    (fn [_]
      (dispatch!
        (routes/path-for-frontend :registry-list))
      (message/info
        (str "Registry " registry-id " has been removed.")))
    (fn [response]
      (message/error
        (str "Registry removing failed. Reason: " (:error response))))))

(rum/defc form < rum/static [item]
  [:div
   [:div.form-panel
    [:div.form-panel-left
     (comp/panel-info icon/registries
                      (:name item))]
    [:div.form-panel-right
     (comp/mui
       (comp/raised-button
         {:onTouchTap #(delete-registry-handler (:_id item))
          :label      "Delete"}))]]
   [:div.form-view
    [:div.form-view-group
     (comp/form-item "ID" (:_id item))
     (comp/form-item "NAME" (:name item))
     (comp/form-item "URL" (:url item))
     (comp/form-item "AUTHENTICATION" (if (:withAuth item)
                                        "yes"
                                        "no"))
     (if (:withAuth item)
       [:div
        (comp/form-item "USERNAME" (:username item))])]]])

remove password field from registry view form


(defproject advent2016 "0.1.0-SNAPSHOT"
  :description "FIXME: write description"
  :url "http://example.com/FIXME"
  :license {:name "Eclipse Public License"
            :url "http://www.eclipse.org/legal/epl-v10.html"}
  :dependencies [[org.clojure/clojure "1.8.0"]
                 [digest "1.4.5"]
                 [org.clojure/math.combinatorics "0.1.3"]
                 [com.taoensso/tufte "1.1.0"]
                 [aysylu/loom "0.6.0"]]
  :main ^:skip-aot advent2016.core
  :target-path "target/%s"
  :profiles {:uberjar {:aot :all}})

(defproject advent2016 "0.1.0-SNAPSHOT"
  :description "FIXME: write description"
  :url "http://example.com/FIXME"
  :license {:name "Eclipse Public License"
            :url "http://www.eclipse.org/legal/epl-v10.html"}
  :dependencies [[org.clojure/clojure "1.8.0"]
                 [digest "1.4.5"]
                 [org.clojure/math.combinatorics "0.1.3"]
                 [com.taoensso/tufte "1.1.0"]
                 [aysylu/loom "0.6.0"]
                 [org.flatland/useful "0.11.5"]]
  :main ^:skip-aot advent2016.core
  :target-path "target/%s"
  :profiles {:uberjar {:aot :all}})

Update project deps.

Update project deps.