heads_up.cljs

(ns figwheel.tools.heads-up
  (:require
   [clojure.string :as string]
   [goog.string]
   [goog.dom.dataset :as data]
   [goog.object :as gobj]
   [goog.dom :as dom]
   [cljs.pprint :as pp])
  (:import [goog Promise]))

(declare clear cljs-logo-svg)

;; cheap hiccup
(defn node [t attrs & children]
     (let [e (.createElement js/document (name t))]
       (doseq [k (keys attrs)] (.setAttribute e (name k) (get attrs k)))
       (doseq [ch children] (.appendChild e ch)) ;; children
       e))

(defmulti heads-up-event-dispatch (fn [dataset] (.-figwheelEvent dataset)))
(defmethod heads-up-event-dispatch :default [_]  {})

;; TODO change this so that clients of this library can register
;; to catch this event
(defmethod heads-up-event-dispatch "file-selected" [dataset]
  #_(socket/send! {:figwheel-event "file-selected"
                   :file-name (.-fileName dataset)
                   :file-line (.-fileLine dataset)
                   :file-column (.-fileColumn dataset)}))

(defmethod heads-up-event-dispatch "close-heads-up" [dataset] (clear))

(defn ancestor-nodes [el]
  (iterate (fn [e] (.-parentNode e)) el))

(defn get-dataset [el]
  (first (keep (fn [x] (when (.. x -dataset -figwheelEvent) (.. x -dataset)))
               (take 4 (ancestor-nodes el)))))

(defn heads-up-onclick-handler [event]
  (let [dataset (get-dataset (.. event -target))]
    (.preventDefault event)
    (when dataset
      (heads-up-event-dispatch dataset))))

(defn ensure-container []
  (let [cont-id "figwheel-heads-up-container"
        content-id "figwheel-heads-up-content-area"]
    (if-not (.querySelector js/document (str "#" cont-id))
      (let [el (node :div { :id cont-id
                           :style
                           (str "-webkit-transition: all 0.2s ease-in-out;"
                                "-moz-transition: all 0.2s ease-in-out;"
                                "-o-transition: all 0.2s ease-in-out;"
                                "transition: all 0.2s ease-in-out;"
                                "font-size: 13px;"
                                "border-top: 1px solid #f5f5f5;"
                                "box-shadow: 0px 0px 1px #aaaaaa;"
                                "line-height: 18px;"
                                "color: #333;"
                                "font-family: monospace;"
                                "padding: 0px 10px 0px 70px;"
                                "position: fixed;"
                                "bottom: 0px;"
                                "left: 0px;"
                                "height: 0px;"
                                "opacity: 0.0;"
                                "box-sizing: border-box;"
                                "z-index: 10000;"
                                "text-align: left;"
                                ) })]
        (set! (.-onclick el) heads-up-onclick-handler)
        (set! (.-innerHTML el) cljs-logo-svg)
        (.appendChild el (node :div {:id content-id}))
        (-> (.-body js/document)
            (.appendChild el))))
    { :container-el    (.getElementById js/document cont-id)
      :content-area-el (.getElementById js/document content-id) }
      ))

(defn set-style! [{:keys [container-el]} st-map]
  (mapv
   (fn [[k v]]
     (gobj/set (.-style container-el) (name k) v))
   st-map))

(defn set-content! [{:keys [content-area-el] :as c} dom-str]
  (set! (.-innerHTML content-area-el) dom-str))

(defn get-content [{:keys [content-area-el]}]
  (.-innerHTML content-area-el))

(defn close-link []
  (str "<a style=\""
      "float: right;"
      "font-size: 18px;"
      "text-decoration: none;"
      "text-align: right;"
      "width: 30px;"
      "height: 30px;"
      "color: rgba(84,84,84, 0.5);"
      "\" href=\"#\"  data-figwheel-event=\"close-heads-up\">"
      "x"
      "</a>"))

(defn display-heads-up [style msg]
  (Promise.
   (fn [resolve reject]
     (let [c (ensure-container)]
       (set-style! c (merge {
                             :paddingTop "10px"
                             :paddingBottom "10px"
                             :width "100%"
                             :minHeight "68px"
                             :opacity "1.0" }
                            style))
       (set-content! c msg)
       (js/setTimeout (fn []
                        (set-style! c {:height "auto"})
                        (resolve true))
                      300)))))

(defn heading
  ([s] (heading s ""))
  ([s sub-head]
   (str "<div style=\""
        "font-size: 26px;"
        "line-height: 26px;"
        "margin-bottom: 2px;"
        "padding-top: 1px;"
        "\">"
        s
        " <span style=\""
        "display: inline-block;"
        "font-size: 13px;"
        "\">"
        sub-head
        "</span></div>")))

(defn file-selector-div [file-name line-number column-number msg]
  (str "<div style=\"cursor: pointer;\" data-figwheel-event=\"file-selected\" data-file-name=\""
       file-name "\" data-file-line=\"" line-number "\" data-file-column=\"" column-number
       "\">" msg "</div>"))

(defn format-line [msg {:keys [file line column]}]
  (let [msg (goog.string/htmlEscape msg)]
    (if (or file line)
      (file-selector-div file line column msg)
      (str "<div>" msg "</div>"))))

(defn escape [x]
  (goog.string/htmlEscape x))

(defn pad-line-number [n line-number]
  (let [len (count ((fnil str "") line-number))]
    (-> (if (< len n)
          (apply str (repeat (- n len) " "))
          "")
        (str line-number))))

(defn inline-error-line [style line-number line]
  (str "<span style='" style "'>" "<span style='color: #757575;'>" line-number "  </span>" (escape line) "</span>"))

(defn format-inline-error-line [[typ line-number line]]
  (condp = typ
    :code-line     (inline-error-line "color: #999;" line-number line)
    :error-in-code (inline-error-line "color: #ccc; font-weight: bold;" line-number line)
    :error-message (inline-error-line "color: #D07D7D;" line-number line)
    (inline-error-line "color: #666;" line-number line)))

(defn pad-line-numbers [inline-error]
  (let [max-line-number-length (count (str (reduce max (map second inline-error))))]
    (map #(update-in % [1]
                     (partial pad-line-number max-line-number-length)) inline-error)))

(defn format-inline-error [inline-error]
  (when (not-empty inline-error)
    (let [lines (map format-inline-error-line (pad-line-numbers inline-error))]
      (str "<pre style='whitespace:pre; overflow-x: scroll; display:block; font-family:monospace; font-size:0.8em; border-radius: 3px;"
           " line-height: 1.1em; padding: 10px; background-color: rgb(24,26,38); margin-right: 5px'>"
           (string/join "\n" lines)
           "</pre>"))))

(def flatten-exception #(take-while some? (iterate :cause %)))

(defn exception->display-data [{:keys [tag message line column type file data error-inline] :as exception}]
  (let [last-message (cond
                       (and file line)
                       (str "Please see line " line " of file " file )
                       file (str "Please see " file)
                       :else nil)
        data-for-display (when-not (#{"cljs/analysis-error" "tools.reader/eof-reader-exception" "tools.reader/reader-exception"}
                                    tag)
                           data)]
    {:head (condp = tag
             "clj/compiler-exception"            "Couldn't load Clojure file"
             "cljs/missing-required-ns"          "Could not Find Namespace"
             "cljs/analysis-error"               "Could not Analyze"
             "tools.reader/eof-reader-exception" "Could not Read"
             "tools.reader/reader-exception"     "Could not Read"
             "cljs/general-compile-failure"      "Could not Compile"
             "Compile Exception")
     :sub-head file
     :messages (concat
                (map
                 #(str "<div>" % "</div>")
                 (filter
                  (complement string/blank?)
                  [(cond-> ""
                     type (str (escape type))
                     (and type message) (str ": ")
                     message (str "<span style=\"font-weight:bold;\">" (escape message) "</span>"))
                   (when data-for-display
                     (str "<pre style=\"white-space: pre-wrap\">"
                          (goog.string/trimRight (with-out-str (pp/pprint data-for-display)))
                          "</pre>"))
                   (when (pos? (count error-inline))
                     (format-inline-error error-inline))]))
                (when last-message [(str "<div style=\"color: #AD4F4F; padding-top: 3px;\">" (escape last-message) "</div>")]))
     :file file
     :line line
     :column column}))

#_(defn auto-notify-source-file-line [{:keys [file line column]}]
  #_(socket/send! {:figwheel-event "file-selected"
                   :file-name (str file)
                   :file-line (str line)
                   :file-column (str column)}))

(defn display-exception [exception-data]
  (let [{:keys [head
                sub-head
                messages
                last-message
                file
                line
                column]}
        (-> exception-data
            exception->display-data)
        msg (apply str messages)]
    (display-heads-up {:backgroundColor "rgba(255, 161, 161, 0.95)"}
                      (str (close-link)
                           (heading head sub-head)
                           (file-selector-div file line column msg)))))

(defn warning-data->display-data [{:keys [file line column message error-inline] :as warning-data}]
  (let [last-message (cond
                       (and file line)
                       (str "Please see line " line " of file " file )
                       file (str "Please see " file)
                       :else nil)]
    {:head "Compile Warning"
     :sub-head file
     :messages (concat
                (map
                 #(str "<div>" % "</div>")
                 [(when message
                    (str "<span style=\"font-weight:bold;\">" (escape message) "</span>"))
                  (when (pos? (count error-inline))
                    (format-inline-error error-inline))])
                (when last-message
                  [(str "<div style=\"color: #AD4F4F; padding-top: 3px; margin-bottom: 10px;\">" (escape last-message) "</div>")]))
     :file file
     :line line
     :column column}))

(defn display-system-warning [header msg]
  (display-heads-up {:backgroundColor "rgba(255, 220, 110, 0.95)" }
                    (str (close-link) (heading header)
                         "<div>" msg "</div>"
                         #_(format-line msg {}))))

(defn display-warning [warning-data]
  (let [{:keys [head
                sub-head
                messages
                last-message
                file
                line
                column]}
        (-> warning-data
            warning-data->display-data)
        msg (apply str messages)]
    (display-heads-up {:backgroundColor "rgba(255, 220, 110, 0.95)" }
                      (str (close-link)
                           (heading head sub-head)
                           (file-selector-div file line column msg)))))

(defn format-warning-message [{:keys [message file line column] :as warning-data}]
  (cond-> message
    line (str " at line " line)
    (and line column) (str ", column " column)
    file (str " in file " file)) )

(defn append-warning-message [{:keys [message file line column] :as warning-data}]
  (when message
    (let [{:keys [content-area-el]} (ensure-container)
          el (dom/createElement "div")
          child-count (.-length (dom/getChildren content-area-el))]
      (if (< child-count 6)
        (do
          (set! (.-innerHTML el)
                (format-line (format-warning-message warning-data)
                             warning-data))
          (dom/append content-area-el el))
        (when-let [last-child (dom/getLastElementChild content-area-el)]
          (if-let [message-count (data/get last-child "figwheel_count")]
            (let [message-count (inc (js/parseInt message-count))]
              (data/set last-child "figwheel_count" message-count)
              (set! (.-innerHTML last-child)
                    (str message-count " more warnings have not been displayed ...")))
            (dom/append
             content-area-el
             (dom/createDom "div" #js {:data-figwheel_count 1
                                       :style "margin-top: 3px; font-weight: bold"}
                            "1 more warning that has not been displayed ..."))))))))

(defn timeout* [time-ms]
  (Promise.
   (fn [resolve _]
     (js/setTimeout #(resolve true) time-ms))))

(defn clear []
  (let [c (ensure-container)]
    (-> (Promise.
         (fn [r _]
           (set-style! c { :opacity "0.0" })
           (r true)))
        (.then (fn [_] (timeout* 300)))
        (.then (fn [_]
                 (set-style! c { :width "auto"
                                :height "0px"
                                :minHeight "0px"
                                :padding "0px 10px 0px 70px"
                                :borderRadius "0px"
                                :backgroundColor "transparent" })))
        (.then (fn [_] (timeout* 200)))
        (.then (fn [_] (set-content! c ""))))))

(defn display-loaded-start []
  (display-heads-up {:backgroundColor "rgba(211,234,172,1.0)"
                     :width "68px"
                     :height "68px"
                     :paddingLeft "0px"
                     :paddingRight "0px"
                     :borderRadius "35px" } ""))

(defn flash-loaded []
  (-> (display-loaded-start)
      (.then (fn [_] (timeout* 400)))
      (.then (fn [_] (clear)))))

(def cljs-logo-svg
  "<?xml version='1.0' encoding='utf-8'?>
<!DOCTYPE svg PUBLIC '-//W3C//DTD SVG 1.1//EN' 'http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd'>
<svg width='49px' height='49px' style='position:absolute; top:9px; left: 10px;' version='1.1'
  xmlns='http://www.w3.org/2000/svg' xmlns:xlink='http://www.w3.org/1999/xlink' x='0px' y='0px'
  viewBox='0 0 428 428' enable-background='new 0 0 428 428' xml:space='preserve'>
<circle fill='#fff' cx='213' cy='214' r='213' />
<g>
<path fill='#96CA4B' d='M122,266.6c-12.7,0-22.3-3.7-28.9-11.1c-6.6-7.4-9.9-18-9.9-31.8c0-14.1,3.4-24.9,10.3-32.5
  s16.8-11.4,29.9-11.4c8.8,0,16.8,1.6,23.8,4.9l-5.4,14.3c-7.5-2.9-13.7-4.4-18.6-4.4c-14.5,0-21.7,9.6-21.7,28.8
  c0,9.4,1.8,16.4,5.4,21.2c3.6,4.7,8.9,7.1,15.9,7.1c7.9,0,15.4-2,22.5-5.9v15.5c-3.2,1.9-6.6,3.2-10.2,4
  C131.5,266.2,127.1,266.6,122,266.6z'/>
<path fill='#96CA4B' d='M194.4,265.1h-17.8V147.3h17.8V265.1z'/>
<path fill='#5F7FBF' d='M222.9,302.3c-5.3,0-9.8-0.6-13.3-1.9v-14.1c3.4,0.9,6.9,1.4,10.5,1.4c7.6,0,11.4-4.3,11.4-12.9v-93.5h17.8
  v94.7c0,8.6-2.3,15.2-6.8,19.6C237.9,300.1,231.4,302.3,222.9,302.3z M230.4,159.2c0-3.2,0.9-5.6,2.6-7.3c1.7-1.7,4.2-2.6,7.5-2.6
  c3.1,0,5.6,0.9,7.3,2.6c1.7,1.7,2.6,4.2,2.6,7.3c0,3-0.9,5.4-2.6,7.2c-1.7,1.7-4.2,2.6-7.3,2.6c-3.2,0-5.7-0.9-7.5-2.6
  C231.2,164.6,230.4,162.2,230.4,159.2z'/>
<path fill='#5F7FBF' d='M342.5,241.3c0,8.2-3,14.4-8.9,18.8c-6,4.4-14.5,6.5-25.6,6.5c-11.2,0-20.1-1.7-26.9-5.1v-15.4
  c9.8,4.5,19,6.8,27.5,6.8c10.9,0,16.4-3.3,16.4-9.9c0-2.1-0.6-3.9-1.8-5.3c-1.2-1.4-3.2-2.9-6-4.4c-2.8-1.5-6.6-3.2-11.6-5.1
  c-9.6-3.7-16.2-7.5-19.6-11.2c-3.4-3.7-5.1-8.6-5.1-14.5c0-7.2,2.9-12.7,8.7-16.7c5.8-4,13.6-5.9,23.6-5.9c9.8,0,19.1,2,27.9,6
  l-5.8,13.4c-9-3.7-16.6-5.6-22.8-5.6c-9.4,0-14.1,2.7-14.1,8c0,2.6,1.2,4.8,3.7,6.7c2.4,1.8,7.8,4.3,16,7.5
  c6.9,2.7,11.9,5.1,15.1,7.3c3.1,2.2,5.4,4.8,7,7.7C341.7,233.7,342.5,237.2,342.5,241.3z'/>
</g>
<path fill='#96CA4B' stroke='#96CA4B' stroke-width='6' stroke-miterlimit='10' d='M197,392.7c-91.2-8.1-163-85-163-178.3
  S105.8,44.3,197,36.2V16.1c-102.3,8.2-183,94-183,198.4s80.7,190.2,183,198.4V392.7z'/>
<path fill='#5F7FBF' stroke='#5F7FBF' stroke-width='6' stroke-miterlimit='10' d='M229,16.1v20.1c91.2,8.1,163,85,163,178.3
  s-71.8,170.2-163,178.3v20.1c102.3-8.2,183-94,183-198.4S331.3,24.3,229,16.1z'/>
</svg>")

;; ---- bad compile helper ui ----

(defn close-bad-compile-screen []
  (when-let [el (js/document.getElementById "figwheelFailScreen")]
    (dom/removeNode el)))

(defn bad-compile-screen []
  (let [body (-> (dom/getElementsByTagNameAndClass "body")
                 (aget 0))]
    (close-bad-compile-screen)
    #_(dom/removeChildren body)
    (dom/append body
              (dom/createDom
               "div"
               #js {:id "figwheelFailScreen"
                    :style (str "background-color: rgba(24, 26, 38, 0.95);"
                                "position: absolute;"
                                "z-index: 9000;"
                                "width: 100vw;"
                                "height: 100vh;"
                                "top: 0px; left: 0px;"
                                "font-family: monospace")}
               (dom/createDom
                "div"
                #js {:class "message"
                     :style (str
                                 "color: #FFF5DB;"
                                 "width: 100vw;"
                                 "margin: auto;"
                                 "margin-top: 10px;"
                                 "text-align: center; "
                                 "padding: 2px 0px;"
                                 "font-size: 13px;"
                                 "position: relative")}
                (dom/createDom
                 "a"
                 #js {:onclick (fn [e]
                                 (.preventDefault e)
                                 (close-bad-compile-screen))
                      :href "javascript:"
                      :style "position: absolute; right: 10px; top: 10px; color: #666"}
                 "X")
                (dom/createDom "h2" #js {:style "color: #FFF5DB"}
                             "Figwheel Says: Your code didn't compile.")
                (dom/createDom "div" #js {:style "font-size: 12px"}
                             (dom/createDom "p" #js { :style "color: #D07D7D;"}
                                          "Keep trying. This page will auto-refresh when your code compiles successfully.")
                             ))))))