highlight evaluated form

mk · mhuebert · nextjournal-ci · commit 4821704d771b · 2020-12-23T08:02:30.000Z
* highlight after eval (partial impl)
* derive eval-region from selection + modifier state
* Make eval form/at-cursor accessible through command palette
* Keymap
* Fix demo after eval-region refactoring
* Adjust key mapping based on user agent platform
* Fix title
* docs
* fix bug when no form is at cursor, make cursor and top-level searches more precise

Co-authored-by: Matthew Huebert &lt;mhuebert@gmail.com&gt;
Co-authored-by: Matthew Huebert &lt;mhuebert@gmail.com&gt;
Co-authored-by: Matthew Huebert &lt;mhuebert@gmail.com&gt;
Co-authored-by: Matthew Huebert &lt;mhuebert@gmail.com&gt;
diff --git a/public/index.html b/public/index.html
@@ -2,7 +2,7 @@
 <html>
   <head>
     <meta charset="utf8">
-    <title>lezer-clojure</title>
+    <title>Clojure/Script mode for CodeMirror 6</title>
     <link href="https://cdn.nextjournal.com/data/QmW53nJSRrRao5FZ9sZ2pwQ4Gd4mK4nZcvhrATVdiabPkc?filename=tailwind-a4c8a6fe636b6d528505c30cb68526a024f446a7.css&content-type=text/css" rel="stylesheet">
     <link href="https://cdn.nextjournal.com/data/QmSaHZCU6U2DeNohfW2PuXDHkayw7w21uvUWL5oEqVWKwH?filename=viewer-1c61aac61ffa4da89b828d538c5e4eff188e7b56.css&content-type=text/css" rel="stylesheet">
     <link href="https://cdn.nextjournal.com/data/QmZZpjcdZDa8WT27QpcepDfqwuGik6Y3Ueyxaxs1Gqpk9w?filename=nextjournal-c81d440c5a7312046bbc5a2c3f2c5567d9ea9131.css&content-type=text/css" rel="stylesheet">
@@ -15,7 +15,7 @@
     <div class="landing-page">
       <div class="hero pb-4">
         <div>
-          <h1>Clojure/Script mode for <a href="https://codemirror.net/6/">codemirror.next</a></h1>
+          <h1>Clojure/Script mode for <a href="https://codemirror.net/6/">CodeMirror 6</a></h1>
           <p>
             Enable a decent Clojure/Script editor experience in the browser.
             Implemented as a <a href="https://lezer.codemirror.net">lezer</a> grammar.
@@ -29,6 +29,7 @@ <h1>Clojure/Script mode for <a href="https://codemirror.net/6/">codemirror.next<
               🤹‍♀️ Try in Nextjournal
             </a>
           </div>
+
         </div>
       </div>
     </div>
diff --git a/src/demo/codemirror_next/clojure/demo.cljs b/src/demo/codemirror_next/clojure/demo.cljs
@@ -43,8 +43,7 @@
                   :$cursor {:visibility "hidden"}
                   "$$focused $cursor" {:visibility "visible"}})))
 
-(defonce extensions #js[(.-lineWrapping EditorView)
-                        theme
+(defonce extensions #js[theme
                         (history)
                         highlight/defaultHighlightStyle
                         (view/drawSelection)
@@ -72,7 +71,7 @@
                                                                          :on-result (partial reset! last-result)})] source)
                                                     :parent el)))))]
     [:div
-     [:div {:class "mt-4 rounded-md border mb-0 text-sm monospace overflow-auto relative shadow-md bg-white"
+     [:div {:class "mt-4 rounded-md mb-0 text-sm monospace overflow-auto relative shadow-sm bg-white"
             :ref mount!}]
      [:div.mt-3.mv-4.pl-6 {:style {:white-space "pre-wrap" :font-family "monospace"}}
       (prn-str @last-result)]]
@@ -81,20 +80,51 @@
 
 (defn samples []
   (into [:<>]
-        (for [source ["(rand-nth (range 1000))"
-                      "(defn greeting [first-name] \n  (str \"Hello, \" first-name))"
-                      "(greeting \"fido\")"]]
+        (for [source ["(comment ;; try evaluating those with alt-enter
+  (fizz-buzz 1)
+  (fizz-buzz 3)
+  (fizz-buzz 5)
+  (fizz-buzz 15)
+  (fizz-buzz 17)
+  (fizz-buzz 42))
+
+(defn fizz-buzz [n]
+  (condp (fn [a b] (zero? (mod b a))) n
+    15 \"fizzbuzz\"
+    3  \"fizz\"
+    5  \"buzz\"
+    n))"]]
           [editor source])))
 
 (defn tag [tag & s]
   (let [[opts s] (if (map? (first s)) [(first s) (rest s)] [nil s])]
     (str "<" (name tag) (reduce-kv #(str %1 " " (name %2) "=" "'" %3 "'") "" opts) ">" (apply str s) "</" (name tag) ">")))
 
+(defn mac? []
+  (some? (re-find #"Mac" js/navigator.platform)))
+
+(defn key-mapping []
+  (cond-> {"ArrowUp" "↑"
+           "ArrowDown" "↓"
+           "ArrowRight" "→"
+           "ArrowLeft" "←"}
+    (mac?)
+    (merge {"Alt" "⌥"
+            "Shift" "⇧"
+            "Enter" "⏎"
+            "Ctrl" "⌃"})))
+
+(defn render-key [key]
+  (let [keys (into [] (map #(get ((memoize key-mapping)) % %) (str/split key #"-")))]
+    (tag :span
+         (str/join (tag :span "+") (map (partial tag :kdb {:class "bg-gray monospace m-1" :style "border-radius: 5px; padding: 1px 4px; border: 1px solid black;"}) keys)))))
+
 (defn ^:dev/after-load render []
   (rdom/render [samples] (js/document.getElementById "editor"))
   (j/assoc! (js/document.getElementById "docs")
             :innerHTML
             (tag :div
+                 (tag :h3 {:class "m-3" } "Keybindings")
                  (tag :table {:cellpadding 0 :class "w-full"}
                       (->> keymap/paredit-keymap*
                            (sort-by first)
@@ -103,14 +133,14 @@
                                           (tag :tr
                                                {:class "border-t even:bg-gray-100"}
                                                (tag :td {:class "px-3 py-1 align-top"} (tag :b (name command)))
-                                               (tag :td {:class "px-3 py-1 align-top monospace text-sm"} key)
+                                               (tag :td {:class "px-3 py-1 align-top text-sm"} (render-key key))
                                                (tag :td {:class "px-3 py-1 align-top"} doc))
                                           (when shift
                                             (tag :tr
                                                  {:class "border-t even:bg-gray-100"}
                                                  (tag :td {:class "px-3 py-1 align-top"} (tag :b (name shift)))
-                                                 (tag :td {:class "px-3 py-1 align-top monospace text-sm"}
-                                                      (str "Shift-" key))
+                                                 (tag :td {:class "px-3 py-1 align-top text-sm"}
+                                                      (render-key (str "Shift-" key)))
                                                  (tag :td {:class "px-3 py-1 align-top"} ""))))) ""))
                       "</table>"))))
 
diff --git a/src/demo/codemirror_next/clojure/demo/sci.cljs b/src/demo/codemirror_next/clojure/demo/sci.cljs
@@ -3,7 +3,7 @@
             [applied-science.js-interop :as j]
             [sci.core :as sci]
             [codemirror-next.clojure.node :as n]
-            [codemirror-next.clojure.extensions.temp-selection :as temp-selection]
+            [codemirror-next.clojure.extensions.eval-region :as eval-region]
             [codemirror-next.clojure.util :as u]))
 
 (defonce context (sci/init {}))
@@ -13,13 +13,19 @@
        (catch js/Error e
          (str e))))
 
-(j/defn eval-current-range [on-result ^:js {:as view :keys [state]}]
-  (some->> (temp-selection/current-string state)
+(j/defn eval-at-cursor [on-result ^:js {:keys [state]}]
+  (some->> (eval-region/cursor-node-string state)
            (eval-string)
            (on-result))
   true)
 
-(j/defn eval-cell [on-result ^:js {:as view :keys [state]}]
+(j/defn eval-top-level [on-result ^:js {:keys [state]}]
+  (some->> (eval-region/top-level-string state)
+           (eval-string)
+           (on-result))
+  true)
+
+(j/defn eval-cell [on-result ^:js {:keys [state]}]
   (-> (str "(do " (.-doc state) " )")
       (eval-string)
       (on-result))
@@ -32,5 +38,5 @@
     [{:key "Mod-Enter"
       :run (partial eval-cell on-result)}
      {:key (str modifier "-Enter")
-      :shift (partial eval-current-range on-result)
-      :run (partial eval-current-range on-result)}])))
+      :shift (partial eval-top-level on-result)
+      :run (partial eval-at-cursor on-result)}])))
diff --git a/src/main/codemirror_next/clojure.cljs b/src/main/codemirror_next/clojure.cljs
@@ -12,7 +12,7 @@
             [codemirror-next.clojure.extensions.match-brackets :as match-brackets]
             [codemirror-next.clojure.extensions.formatting :as format]
             [codemirror-next.clojure.extensions.selection-history :as sel-history]
-            [codemirror-next.clojure.extensions.temp-selection :as temp-selection]
+            [codemirror-next.clojure.extensions.eval-region :as eval-region]
             [codemirror-next.clojure.keymap :as keymap]
             [codemirror-next.clojure.node :as n]
             [codemirror-next.clojure.selections :as sel]
@@ -79,7 +79,7 @@
       (sel-history/extension)
       (format/ext-format-changed-lines)
       (.-lineWrapping EditorView)
-      (temp-selection/as-decoration {:modifier "Alt"})])
+      (eval-region/extension {:modifier "Alt"})])
 
 (comment
 
diff --git a/src/main/codemirror_next/clojure/extensions/eval_region.cljs b/src/main/codemirror_next/clojure/extensions/eval_region.cljs
@@ -0,0 +1,146 @@
+(ns codemirror-next.clojure.extensions.eval-region
+  (:require
+   ["@codemirror/next/state" :as state :refer [StateEffect StateField Facet precedence]]
+   ["@codemirror/next/view" :as view :refer [EditorView Decoration keymap]]
+   ["w3c-keyname" :refer [keyName]]
+   [applied-science.js-interop :as j]
+   [codemirror-next.clojure.util :as u]
+   [codemirror-next.clojure.node :as n]
+   [clojure.string :as str]))
+
+(defn uppermost-edge-here
+  "Returns node or its highest ancestor that starts or ends at the cursor position."
+  [pos node]
+  (or (->> (iterate n/up node)
+           (take-while (every-pred (complement n/top?)
+                                   #(or (= pos (n/end %) (n/end node))
+                                        (= pos (n/start %) (n/start node)))))
+           (last))
+      node))
+
+(defn primary-selection [state]
+  (-> (j/call-in state [:selection :asSingle])
+      (j/get-in [:ranges 0])))
+
+(defn node-at-cursor
+  ([state] (node-at-cursor state (j/get (primary-selection state) :from)))
+  ([^js state from]
+   (some->> (n/nearest-touching state from -1)
+            (#(when (and (or (n/terminal-type? (n/type %))
+                             (= (n/start %) from)
+                             (= (n/end %) from))
+                         (not (n/top? %))) %))
+            (uppermost-edge-here from)
+            (n/balanced-range state))))
+
+(defn top-level-node [state]
+  (->> (n/nearest-touching state (j/get (primary-selection state) :from) -1)
+       (iterate n/up)
+       (take-while (every-pred identity (complement n/top?)))
+       last))
+
+;; Modifier field
+(defonce modifier-effect (.define StateEffect))
+(defonce modifier-field
+         (.define StateField
+                  (j/lit {:create (constantly {})
+                          :update (fn [value ^js tr]
+                                    (or (some-> (first (filter #(.is ^js % modifier-effect) (.-effects tr)))
+                                                (j/get :value))
+                                        value))})))
+
+(defn get-modifier-field [^js state] (.field state modifier-field))
+
+(j/defn set-modifier-field! [^:js {:as view :keys [dispatch state]} value]
+  (dispatch #js{:effects (.of modifier-effect value)}))
+
+(j/defn mark [spec ^:js {:keys [from to]}]
+  (-> (.mark Decoration spec)
+      (.range from to)))
+
+(defn single-mark [spec range]
+  (.set Decoration #js[(mark spec range)]))
+
+(defonce mark-spec (j/lit {:attributes {:style "background-color: rgba(0, 243, 255, 0.14);"}}))
+(defonce mark-spec-highlight (j/lit {:attributes {:style "background-color: rgba(0, 243, 255, 0.35);"}}))
+
+(defn cursor-range [^js state]
+  (if (.. state -selection -primary -empty)
+    (node-at-cursor state)
+    (.. state -selection -primary)))
+
+(defonce region-field
+         (.define StateField
+                  (j/lit
+                   {:create  (constantly (.-none Decoration))
+                    :update  (j/fn [_value ^:js {:keys [state]}]
+                               (let [{:strs [Alt Shift Enter]} (get-modifier-field state)
+                                     spec (if Enter mark-spec-highlight mark-spec)]
+                                 (if-let [range (cond (and Alt Shift) (top-level-node state)
+                                                      Alt (or (u/guard (primary-selection state)
+                                                                       #(not (j/get % :empty)))
+                                                              (cursor-range state)))]
+                                   (single-mark spec range)
+                                   (.-none Decoration))))
+                    :provide [(.-decorations EditorView)]})))
+
+
+(defn get-region-field [^js state] (.field state region-field))
+
+(defn current-range [^js state]
+  (or (some-> (get-region-field state)
+              (j/call :iter)
+              (u/guard #(j/get % :value)))
+      (.. state -selection -primary)))
+
+(defn modifier-extension
+  "Maintains modifier-state-field, containing a map of {<modifier> true}, including Enter."
+  [modifier]
+  (let [handle-enter (j/fn handle-enter [^:js {:as view :keys [state]}]
+                       (set-modifier-field! view (assoc (get-modifier-field state) "Enter" true))
+                       nil)
+        handle-key-event (j/fn [^:js {:as event :keys [altKey shiftKey metaKey controlKey type]}
+                                ^:js {:as view :keys [state]}]
+                           (let [prev (get-modifier-field state)
+                                 next (cond-> {}
+                                              altKey (assoc "Alt" true)
+                                              shiftKey (assoc "Shift" true)
+                                              metaKey (assoc "Meta" true)
+                                              controlKey (assoc "Control" true)
+                                              (and (= "keydown" type)
+                                                   (= "Enter" (keyName event)))
+                                              (assoc "Enter" true))]
+                             (when (not= prev next)
+                               (set-modifier-field! view next))))
+        handle-backspace (j/fn [^:js {:as view :keys [state dispatch]}]
+                           (j/let [^:js {:keys [from to]} (current-range state)]
+                             (when (not= from to)
+                               (dispatch (j/lit {:changes {:from from :to to :insert ""}
+                                                 :annotations (u/user-event-annotation "delete")})))
+                             true))]
+    #js[modifier-field
+        (precedence (keymap
+                     (j/lit [{:key   (str modifier "-Enter")
+                              :shift handle-enter
+                              :run   handle-enter}
+                             {:key (str modifier "-Backspace")
+                              :run handle-backspace
+                              :shift handle-backspace}])) "override")
+        (.domEventHandlers view/EditorView
+                           #js{:keydown handle-key-event
+                               :keyup   handle-key-event})]))
+
+(defn extension [{:keys [modifier]
+                  :or   {modifier "Alt"}}]
+  #js[(modifier-extension modifier)
+      region-field])
+
+(defn cursor-node-string [^js state]
+  (u/guard (some->> (node-at-cursor state)
+                    (u/range-str state))
+           (complement str/blank?)))
+
+(defn top-level-string [^js state]
+  (u/guard (some->> (top-level-node state)
+                    (u/range-str state))
+           (complement str/blank?)))
diff --git a/src/main/codemirror_next/clojure/extensions/formatting.cljs b/src/main/codemirror_next/clojure/extensions/formatting.cljs
@@ -159,7 +159,7 @@
                 "pointerselection"
                 "cut"
                 "noformat"
-                "tempselection") nil
+                "evalregion") nil
                "format-selections" (format-selection (.-state tr))
                (let [state (.-state tr)
                      context (make-indent-context state)]
diff --git a/src/main/codemirror_next/clojure/extensions/temp_selection.cljs b/src/main/codemirror_next/clojure/extensions/temp_selection.cljs
diff --git a/src/main/codemirror_next/clojure/keymap.cljs b/src/main/codemirror_next/clojure/keymap.cljs
