(ns glimmer-jvui.tests
  "Every check here runs headless: no window, no SDL, no font, no display.

   jvui takes its measurer as a function, so the whole stack — glimmer's
   reconciler, this backend's walk, jvui's layout and event routing — can be
   driven with a stub that says eight pixels a character. `jolt test`."
  (:require [glimmer.ratom :as ra]
            [glimmer.backend :as b]
            [jvui.widgets :as w]
            [glimmer.core :as gui]
            [glimmer-jvui.core :as jv]
            [jvui.core :as c]))

(def ^:private failures (atom 0))

(defn- check! [ok? msg]
  (when-not ok?
    (swap! failures inc)
    (println "  FAIL:" msg)))

(defn- ctx []
  (c/context {:size [400 300]
              :measure (fn [s _] [(* 8.0 (count s)) 16.0])
              :line-height (fn [_] 16.0)}))

(defn- walk [n] (cons n (mapcat walk (:children @n))))
(defn- tagged [root tag] (first (filter #(= tag (:tag @%)) (walk root))))
(defn- labels [root]
  (map #(str (:label (:props @%)))
       (filter #(= :label (:tag @%)) (walk root))))

(defn- centre
  "The middle of the rectangle jvui gave this node on the last walk."
  [n]
  (let [[x y w h] (:rect @n)] [(+ x (/ w 2.0)) (+ y (/ h 2.0))]))

(defn- click-at [x y]
  [{:kind :motion :x x :y y}
   {:kind :mouse-down :x x :y y :button 1 :clicks 1}
   {:kind :mouse-up :x x :y y :button 1}])

;; --- the reconciler reaches the backend --------------------------------------

(def ^:private clicks (ra/atom 0))
(def ^:private on? (ra/atom false))

(defn- app []
  [:card {}
   [:title {:label "Counter"}]
   [:label {:label (str "Count: " (ra/deref clicks))}]
   [:button {:label "+1" :kind :primary :on-click #(ra/swap! clicks inc)}]
   [:checkbox {:label "loud" :checked (ra/deref on?)
               :on-change #(ra/reset! on? %)}]])

(defn- check-tree! []
  (let [root (jv/root-node)]
    (gui/mount root :page [app])
    (check! (some? (tagged root :card)) "the reconciler built a card")
    (check! (some? (tagged root :button)) "and a button")
    (check! (some #{"Count: 0"} (labels root))
            "and a label that read the ratom")))

(defn- check-walk-places-widgets! []
  (let [root (jv/root-node) cx (ctx)]
    (gui/mount root :page [app])
    (jv/render-once root cx)
    (let [placed (vals (:data @cx))
          card (first (filter #(and (:rect %) (> (first (:min-size % [0 0])) 100))
                              placed))]
      (check! (some? card) "the walk placed a container with a rectangle")
      (check! (every? (fn [[_ _ w h]] (and (>= w 0) (>= h 0)))
                      (keep :rect placed))
              "and no rectangle came out negative"))))

;; --- a click goes all the way round ------------------------------------------

(defn- check-click-fires-the-handler! []
  (let [root (jv/root-node) cx (ctx)]
    (ra/reset! clicks 0)
    (gui/mount root :page [app])
    (jv/render-once root cx)
    (jv/render-once root cx)
    (let [before (ra/deref clicks)
          [bx by] (centre (tagged root :button))]
      (jv/render-once root cx (click-at bx by))
      (check! (= (inc before) (ra/deref clicks))
              (str "the click reached :on-click (" before " -> "
                   (ra/deref clicks) ")"))
      (jv/render-once root cx)
      (check! (some #{(str "Count: " (ra/deref clicks))} (labels root))
              "and the reactive re-render reached the tree"))))

(defn- check-press-alone-is-not-a-click! []
  (let [root (jv/root-node) cx (ctx)]
    (ra/reset! clicks 0)
    (gui/mount root :page [app])
    (jv/render-once root cx)
    (jv/render-once root cx)
    (let [[bx by] (centre (tagged root :button))]
      (jv/render-once root cx [{:kind :motion :x bx :y by}
                               {:kind :mouse-down :x bx :y by :button 1 :clicks 1}]))
    (check! (zero? (ra/deref clicks)) "a press alone must not fire the handler")
    (jv/render-once root cx [{:kind :motion :x 390 :y 290}
                             {:kind :mouse-up :x 390 :y 290 :button 1}])
    (check! (zero? (ra/deref clicks)) "and releasing off it must not either")))

;; --- identity follows the node, not its index --------------------------------

(defn- check-reorder-keeps-identity! []
  ;; The reason every node carries a serial as its jvui key. Render a list,
  ;; reorder it, and the ids the walk hands out must travel with the nodes.
  (let [root (jv/root-node) cx (ctx)
        items (ra/atom [:a :b :c])
        list-app (fn []
                   (into [:vbox {}]
                         (for [k (ra/deref items)]
                           ^{:key k} [:button {:label (name k)}])))
        ids (fn [] (into {} (map (fn [n] [(:label (:props @n)) (:key @n)])
                                 (filter #(= :button (:tag @%)) (walk root)))))]
    (gui/mount root :page [list-app])
    (jv/render-once root cx)
    (let [before (ids)]
      (ra/reset! items [:c :a :b])
      (jv/render-once root cx)
      (let [after (ids)]
        (check! (= 3 (count after)) "the list still has three buttons")
        (check! (= (get before "a") (get after "a"))
                "a keyed node keeps its jvui key across a reorder")
        (check! (= (get before "c") (get after "c"))
                "including the one that moved to the front")))))

;; --- the vocabulary ----------------------------------------------------------

(defn- check-unknown-tag-is-a-container! []
  (let [root (jv/root-node) cx (ctx)]
    (gui/mount root :page [(fn [] [:flerb {} [:label {:label "inside"}]])])
    (jv/render-once root cx)
    (check! (some #{"inside"} (labels root))
            "an unknown tag shows its contents rather than raising")))

(defn- check-entry-round-trips! []
  (let [root (jv/root-node) cx (ctx)
        text (ra/atom "")]
    (gui/mount root :page
               [(fn [] [:entry {:value (ra/deref text)
                                :on-change #(ra/reset! text %)}])])
    (jv/render-once root cx)
    (let [[ex ey] (centre (tagged root :entry))]
      (jv/render-once root cx (click-at ex ey)))       ; take focus
    (jv/render-once root cx [{:kind :text :text "hi"}])
    (check! (= "hi" (ra/deref text))
            (str "typed text reached :on-change: " (pr-str (ra/deref text))))))

(defn- check-paste-reaches-the-client! []
  ;; Both halves of a paste, through the reconciler. Text lands in :on-change
  ;; like typing; a clipboard with no text on it reaches :on-paste-empty, a
  ;; THUNK, which is frq's `s/paste-image!` — the way a picture is pasted.
  (let [root (jv/root-node) cx (ctx)
        text (ra/atom "")
        asked (ra/atom 0)
        clip (atom "pasted")]
    (swap! cx assoc :clipboard (fn [] @clip))
    (gui/mount root :page
               [(fn [] [:entry {:value (ra/deref text)
                                :on-change #(ra/reset! text %)
                                :on-paste-empty #(ra/swap! asked inc)}])])
    (jv/render-once root cx)
    (let [[ex ey] (centre (tagged root :entry))]
      (jv/render-once root cx (click-at ex ey)))
    (jv/render-once root cx [{:kind :key-down :key :v :ctrl? true}])
    (check! (= "pasted" (ra/deref text))
            (str "pasted text reached :on-change: " (pr-str (ra/deref text))))
    (check! (zero? (ra/deref asked)) "and a paste of text is not a request")
    (reset! clip nil)
    (jv/render-once root cx [{:kind :key-down :key :v :ctrl? true}])
    (check! (= 1 (ra/deref asked))
            "a paste with no text on the clipboard reached :on-paste-empty")
    (check! (= "pasted" (ra/deref text)) "and changed nothing")))

(defn- check-enter-sends! []
  ;; Enter is the one key a field must not swallow. frq sends its message
  ;; on it, so a compose box that accepted text and never reported Enter
  ;; would take a message and have no way to say it was finished — typing
  ;; works, sending does not, and nothing looks broken.
  (let [root (jv/root-node) cx (ctx)
        text (ra/atom "hello")
        sent (ra/atom nil)]
    (gui/mount root :page
               [(fn [] [:entry {:value (ra/deref text)
                                :on-change #(ra/reset! text %)
                                ;; A THUNK, which is what frq's handlers
                                ;; are: s/send-draft! takes no arguments
                                ;; and the text is already the caller's
                                ;; from :on-change.
                                :on-activate #(ra/reset! sent (ra/deref text))}])])
    (jv/render-once root cx)
    (let [[ex ey] (centre (tagged root :entry))]
      (jv/render-once root cx (click-at ex ey)))       ; take focus
    (jv/render-once root cx [{:kind :key-down :key :return}])
    (check! (= "hello" (ra/deref sent))
            (str "Enter reached :on-activate: " (pr-str (ra/deref sent))))))

(defn- label-node [root text]
  (first (filter #(and (= :label (:tag @%)) (= text (str (:label (:props @%)))))
                 (walk root))))

(defn- check-rows-do-not-stretch! []
  ;; Every box shrink-wrapping its children is how frq's chat column came
  ;; out a couple of hundred points wide in a five-hundred-point window,
  ;; with every message wrapped to match and the scrollbar stranded in the
  ;; middle of the screen. A container fills its parent's cross axis.
  ;;
  ;; And a ROW's children must NOT: :cross rather than :horizontal is what
  ;; keeps a line of buttons from stretching to fill the window.
  (let [root (jv/root-node) cx (ctx)]     ; a 400-wide context
    (gui/mount root :page
               [(fn [] [:vbox {:key :outer}
                        [:vbox {:key :inner} [:label {:label "hi"}]]
                        [:hbox {:key :row} [:button {:label "a"}]
                                           [:button {:label "b"}]]])])
    (dotimes [_ 3] (jv/render-once root cx))
    ;; Only tags that register for events carry a rect here, so the
    ;; filling half is checked by pixel in props-check — a card paints a
    ;; background and a screenshot can measure it. What CAN be asserted
    ;; from the tree is the half that would regress silently.
    (let [buttons (filter #(and (= :button (:tag @%)) (:rect @%)) (walk root))]
      (check! (every? #(< (nth (:rect @%) 2) 120.0) buttons)
              (str "and buttons in a row do not stretch: "
                   (pr-str (map #(nth (:rect @%) 2) buttons)))))))

(defn- check-scroll-sticks! []
  ;; A chat that does not follow new messages is the difference between a
  ;; window you read and one you drag.
  ;;
  ;; Asserted on GEOMETRY and not on which labels exist: every line is in
  ;; the tree whether or not it is on screen, so `labels` cannot tell a
  ;; stuck list from a pinned one. What tells them apart is where the last
  ;; line was PUT — inside the viewport, or far below it.
  (let [root (jv/root-node) cx (ctx)
        n (ra/atom 3)]
    (gui/mount root :page
               [(fn [] [:scroll {:height 60 :scroll-key "chat" :stick-to-bottom true}
                        (into [:vbox {}]
                              (for [i (range (ra/deref n))]
                                [:label {:key i :label (str "line " i)}]))])])
    (dotimes [_ 3] (jv/render-once root cx))
    (ra/reset! n 40)
    (dotimes [_ 3] (jv/render-once root cx))
    ;; Forty lines of sixteen in a sixty-tall viewport leaves a long way
    ;; to scroll. A stuck list is at the far end of it; a pinned one is
    ;; still at zero.
    (let [off (w/scroll-offset "chat")]
      (check! (and off (> off 100.0))
              (str "a stuck list followed its content: offset=" off))
      ;; And it must STOP following once the reader has moved, or they can
      ;; never read anything but the newest line.
      ;; The mouse has to be OVER the list: a wheel is delivered to
      ;; whatever is under the pointer, and the pointer only moves on a
      ;; motion event.
      (jv/render-once root cx [{:kind :motion :x 20 :y 30}])
      (dotimes [_ 4]
        (jv/render-once root cx [{:kind :motion :x 20 :y 30}
                                 {:kind :wheel :x 20 :y 30 :dy 3}]))
      (let [off2 (w/scroll-offset "chat")]
        (check! (and off2 (< off2 off))
                (str "and let go when the reader scrolled up: " off " -> " off2))))))

(defn- check-scroll-here! []
  ;; frq's reply chip sets :scroll-here on the message it answers. The list
  ;; is stuck to its end, so the row it points at is far above the viewport
  ;; until something moves it.
  (let [root (jv/root-node) cx (ctx)
        target (ra/atom nil)]
    (gui/mount root :page
               [(fn [] [:scroll {:height 60 :scroll-key "jump" :stick-to-bottom true}
                        (into [:vbox {}]
                              (for [i (range 40)]
                                [:vbox {:key i :scroll-here (= i (ra/deref target))}
                                 [:label {:label (str "line " i)}]]))])])
    (dotimes [_ 3] (jv/render-once root cx))
    (let [stuck (w/scroll-offset "jump")]
      (ra/reset! target 4)
      (dotimes [_ 3] (jv/render-once root cx))
      ;; Labels keep no rectangle, so the offset says where the list went:
      ;; line 4 starts under a hundred points down, and centring a line in a
      ;; sixty-tall viewport puts the offset below that — nowhere near the
      ;; end, where forty lines leave it.
      (let [off (w/scroll-offset "jump")]
        (check! (and stuck (> stuck 400.0))
                (str "the list starts at its end: offset=" stuck))
        (check! (and off (< off 100.0))
                (str "a :scroll-here row is brought on screen: offset=" off))))))

(defn- check-checkbox-round-trips! []
  (let [root (jv/root-node) cx (ctx)]
    (ra/reset! on? false)
    (gui/mount root :page [app])
    (jv/render-once root cx)
    (jv/render-once root cx)
    (let [[bx by] (centre (tagged root :checkbox))]
      (jv/render-once root cx (click-at bx by)))
    (check! (true? (ra/deref on?))
            (str "the checkbox reached :on-change: " (ra/deref on?)))))

;; --- runner ------------------------------------------------------------------

(def ^:private rows (ra/atom 1))

(defn- growing []
  [:vbox {}
   [:card {}
    (for [i (range (ra/deref rows))]
      ^{:key i} [:label {:label (str "line " i)}])]
   [:button {:label "under"}]])

(defn- check-a-patch-settles-before-it-paints! []
  ;; What the eye actually catches. A container is as big as what its children
  ;; asked for LAST frame, so the first walk after the reconciler patches the
  ;; tree knows the new children and the old sizes: the card already holds four
  ;; lines and the button under it still sits where one line put it. That frame
  ;; is painted, and the frame after it is right — a flash of the old layout
  ;; under the new contents, on every change the client makes.
  ;;
  ;; The fix is for the backend to say that it patched something, so jvui
  ;; spends that walk settling instead of painting. Checked here rather than in
  ;; jvui's own tests because it takes a reconciler to reproduce: the patch has
  ;; to arrive BETWEEN two frames, which is the one thing a widget called
  ;; directly cannot do.
  ;;
  ;; `loop-running?` is what makes glimmer defer a re-render onto the frame
  ;; loop rather than run it inline, which is the arrangement a window is in
  ;; and the only one where any of this happens.
  (let [root (jv/root-node) cx (ctx)]
    (ra/reset! rows 1)
    (gui/mount root :page [growing])
    (dotimes [_ 3] (jv/render-once root cx))
    (reset! b/loop-running? true)
    (try
      (let [under #(second (:rect @(tagged root :button)))
            was (under)]
        (ra/reset! rows 4)
        (jv/render-once root cx)
        (let [painted (under)]
          (jv/render-once root cx)
          (check! (not= painted was)
                  "the frame after a patch has moved what the patch moved")
          (check! (= painted (under))
                  (str "and it is already where it comes to rest: painted at "
                       painted ", settles at " (under)))))
      (finally (reset! b/loop-running? false)))))

(def ^:private checks
  [["the reconciler builds a tree"  check-tree!]
   ["the walk places widgets"       check-walk-places-widgets!]
   ["a click fires the handler"     check-click-fires-the-handler!]
   ["a press alone does not"        check-press-alone-is-not-a-click!]
   ["a reorder keeps identity"      check-reorder-keeps-identity!]
   ["an unknown tag is a container" check-unknown-tag-is-a-container!]
   ["a row does not stretch"       check-rows-do-not-stretch!]
   ["a list sticks to the end"     check-scroll-sticks!]
   ["a row asks to be seen"        check-scroll-here!]
   ["Enter sends"                  check-enter-sends!]
   ["an entry round-trips"          check-entry-round-trips!]
   ["a paste reaches the client"    check-paste-reaches-the-client!]
   ["a checkbox round-trips"        check-checkbox-round-trips!]
   ["a patch settles before it paints" check-a-patch-settles-before-it-paints!]])

(defn -main [& _]
  (doseq [[name f] checks]
    (println "-" name)
    (f))
  (if (zero? @failures)
    (println "\nall" (count checks) "checks passed")
    (do (println "\n" @failures "failed") (System/exit 1))))