Experiment with syntax generation in macro

demo/reagentdemo/news/clockpost.cljs

@@ -2,7 +2,8 @@
   (:require [reagent.core :as r :refer [atom]]
             [reagent.interop :refer-macros [.' .!]]
             [reagent.debug :refer-macros [dbg]]
-            [reagentdemo.syntax :refer-macros [get-source]]
+            [reagentdemo.syntax :as s :include-macros true
+             :refer-macros [get-source]]
             [sitetools :as tools :refer [link]]
             [reagentdemo.common :as common :refer [demo-component]]
             [reagentdemo.news.binaryclock :as binaryclock]))
@@ -10,13 +11,8 @@
 (def url "news/binary-clock.html")
 (def title "A binary clock")
 
-(def funmap (-> "reagentdemo/news/binaryclock.cljs"
-                get-source common/fun-map))
-(def src-for (partial common/src-for funmap))
-
-(defn fn-src [& parts]
-  [demo-component {:src (src-for (vec parts))
-                   :no-heading true}])
+(defn fn-src [src]
+  [demo-component {:src src :no-heading true}])
 
 (defn main [{:keys [summary]}]
   (let [lexclock {:href "http://www.lexicallyscoped.com/2014/01/23/clojurescript-react-om-binary-clock.html"}
@@ -47,38 +43,45 @@
                :class 'news-read-mode} "Read more"]
         [:div.demo-text
 
-         [fn-src :nsr]
+         [fn-src (s/syntaxed "(ns example
+  (:require [reagent.core :as r :refer [atom]]))")]
 
          [:p "We start with the basics: The clock is built out of
          cells, with a light colour if the bit the cell corresponds to
          is set."]
 
-         [fn-src :cell]
+         [fn-src (s/src-of [:cell]
+                          "reagentdemo/news/binaryclock.cljs")]
 
          [:p "Cells are combined into columns of four bits, with a
          decimal digit at the bottom."]
 
-         [fn-src :column]
+         [fn-src (s/src-of [:column]
+                          "reagentdemo/news/binaryclock.cljs")]
 
          [:p "Columns are in turn combined into pairs:"]
 
-         [fn-src :column-pair]
+         [fn-src (s/src-of [:column-pair]
+                          "reagentdemo/news/binaryclock.cljs")]
 
          [:p "We'll also need the legend on the left side:"]
 
-         [fn-src :legend]
+         [fn-src (s/src-of [:legend]
+                          "reagentdemo/news/binaryclock.cljs")]
 
          [:p "We combine these element into a component that shows the
          legend, hours, minutes and seconds; and optionally 1/100
          seconds. It also responds to clicks."]
 
-         [fn-src :clock]
+         [fn-src (s/src-of [:clock]
+                          "reagentdemo/news/binaryclock.cljs")]
 
          [:p "We also need to keep track of the time, and of the
          detail shown, in a Reagent atom. And a function to update the
          time."]
 
-         [fn-src :clock-state :update-time]
+         [fn-src (s/src-of [:clock-state :update-time]
+                          "reagentdemo/news/binaryclock.cljs")]
 
          [:p "And finally we use the " [:code "clock"] " component.
          The current time is scheduled to be updated, after a suitable
@@ -86,7 +89,8 @@
          [:code "reagent.core/next-tick"] " is just a front for "
          [:code "requestAnimationFrame"] "):"]
 
-         [fn-src :main]
+         [fn-src (s/src-of [:main]
+                          "reagentdemo/news/binaryclock.cljs")]
 
          [:p "The entire source is also available " [:a
          clocksrc "here"] "."]

demo/reagentdemo/syntax.clj

@@ -10,3 +10,130 @@
                 (string/replace #"[.]" "/")
                 (str ".cljs")))]
     (-> s io/resource slurp)))
+
+;;;;; Colorization
+
+(def builtins #{"def" "defn" "ns" "atom" "let" "if" "when"
+               "cond" "merge" "assoc" "swap!" "reset!" "for"
+               "range" "nil?" "int" "or" "->" "->>" "%" "fn" "if-not"
+               "empty?" "case" "str" "pos?" "zero?" "map" "remove"
+               "empty" "into" "assoc-in" "dissoc" "get-in" "when-not"
+               "filter" "vals" "count" "complement" "identity" "dotimes"
+               "update-in" "sorted-map" "inc" "dec" "false" "true" "not"
+               "=" "partial" "first" "second" "rest" "list" "conj"
+               "drop" "when-let" "if-let" "add-watch" "mod" "quot"
+               "bit-test" "vector"})
+
+(def me "reagentdemo.syntax")
+
+(def styles {:comment  (symbol me "comment-span")
+             :str-litt (symbol me "string-span")
+             :keyw     (symbol me "keyword-span")
+             :builtin  (symbol me "builtin-span")
+             :def      (symbol me "def-span")})
+
+(def paren-styles [(symbol me "paren-span-1")
+                   (symbol me "paren-span-2")
+                   (symbol me "paren-span-3")])
+
+(defn tokenize [src]
+  (let [ws " \\t\\n"
+        open "\\[({"
+        close ")\\]}"
+        sep (str ws open close)
+        comment-p ";.*"
+        str-p "\"[^\"]*\""
+        open-p (str "[" open "]")
+        close-p (str "[" close "]")
+        iden-p (str "[^" sep "]+")
+        meta-p (str "\\^" iden-p)
+        any-p (str "[" ws "]+" "|\\^[^" sep "]+|.")
+        patt (re-pattern (str "("
+                              (string/join ")|(" [comment-p str-p open-p
+                                                  close-p meta-p iden-p any-p])
+                              ")"))
+        keyw-re #"^:"]
+    (for [[s comment str-litt open close met iden any] (re-seq patt src)]
+      (cond
+       comment [:comment s]
+       str-litt [:str-litt s]
+       open [:open s]
+       close [:close s]
+       met [:other s]
+       iden (cond
+             (re-find keyw-re s) [:keyw s]
+             (builtins s) [:builtin s]
+             :else [:iden s])
+       any [:other s]))))
+
+(defn syntaxify [src]
+  (let [def-re #"^def|^ns\b"
+        ncol (count paren-styles)
+        paren-style (fn [level]
+                      (nth paren-styles (mod level ncol)))]
+    (loop [tokens (tokenize (str src " "))
+           prev nil
+           level 0
+           res []]
+      (let [[kind val] (first tokens)
+            level' (case kind
+                     :open (inc level)
+                     :close (dec level)
+                     level)
+            style (case kind
+                    :iden  (when (and prev (re-find def-re prev))
+                             (:def styles))
+                    :open  (paren-style level)
+                    :close (paren-style level')
+                    (styles kind))
+            remain (rest tokens)]
+        (if-not (empty? remain)
+          (recur remain
+                 (if (= kind :other) prev val)
+                 level'
+                 (conj res (if (nil? style)
+                             val
+                             (list style val))))
+          (apply vector :pre res))))))
+
+;;;; Source splitting
+
+(defn src-parts [src]
+  (string/split src #"\n(?=[(])"))
+
+(defn src-defs [parts]
+  (let [ws #"[^ \t]+"]
+    (into {} (for [x parts]
+               [(->> x (re-seq ws) second keyword) x]))))
+
+(defn fun-map [src]
+  (-> src src-parts src-defs))
+
+(defn src-for-names [srcmap names]
+  (string/join "\n" (map srcmap names)))
+
+;;; Macros
+
+(defmacro syntaxed [src]
+  (assert (string? src))
+  (syntaxify src))
+
+(defmacro src-of
+  ([funs]
+   `(src-of ~funs nil))
+  ([funs resource]
+   (assert (or (nil? funs)
+               (vector? funs)))
+   (assert (or (nil? resource)
+               (string? resource)))
+   (let [f (if (nil? resource)
+             (-> (name cljs.analyzer/*cljs-ns*)
+                 (string/replace #"[.]" "/")
+                 (str ".cljs"))
+             resource)
+         src (-> f io/resource slurp)
+         fm (fun-map src)
+         sel (if (nil? funs)
+               src
+               (-> src fun-map (src-for-names funs)))]
+     (syntaxify sel))))

demo/reagentdemo/syntax.cljs

@@ -1,6 +1,32 @@
 (ns reagentdemo.syntax
   (:require [clojure.string :as string]))
 
+(def comment-style {:style {:color "gray"
+                            :font-style "italic"}})
+(def string-style {:style {:color "green"}})
+(def keyword-style {:style {:color "blue"}})
+(def builtin-style {:style {:font-weight "bold"
+                            :color "#687868"}})
+(def def-style {:style {:color "#55c"
+                        :font-weight "bold"}})
+
+(def paren-style-1 {:style {:color "#272"}})
+(def paren-style-2 {:style {:color "#940"}})
+(def paren-style-3 {:style {:color "#44a"}})
+
+(defn comment-span [v] [:span comment-style v])
+(defn string-span [v] [:span string-style v])
+(defn keyword-span [v] [:span string-style v])
+(defn builtin-span [v] [:span builtin-style v])
+(defn def-span [v] [:span def-style v])
+
+(defn paren-span-1 [v] [:span paren-style-1 v])
+(defn paren-span-2 [v] [:span paren-style-2 v])
+(defn paren-span-3 [v] [:span paren-style-3 v])
+
+
+;;; Old stuff
+
 (def builtins #{"def" "defn" "ns" "atom" "let" "if" "when"
                "cond" "merge" "assoc" "swap!" "reset!" "for"
                "range" "nil?" "int" "or" "->" "->>" "%" "fn" "if-not"
@@ -60,7 +86,7 @@
         ncol (count paren-styles)
         paren-style (fn [level]
                       (nth paren-styles (mod level ncol)))]
-    (loop [tokens (tokenize src)
+    (loop [tokens (tokenize (str src " "))
            prev nil
            level 0
            res []]

demo/sitetools.cljs

@@ -108,7 +108,7 @@
         (.setToken h p))
       h)))
 
-(def history nil)
+(defonce history nil)
 
 (defn token-base []
   (if (use-html5-history)
@@ -259,9 +259,10 @@
                  (js->clj js/pageConfig :keywordize-keys true))
           page-name (:page-name conf)]
       (swap! config merge conf)
-      (when page-name
-        (set-start-page page-name))
-      (setup-history page-name)
-      (set! (.-title js/document) (get-title))
+      (when (nil? history)
+        (when page-name
+          (set-start-page page-name))
+        (setup-history page-name)
+        (set! (.-title js/document) (get-title)))
       (reagent/render-component (body)
                                 (.' js/document :body)))))