From 3de45662231dd2a1c5a4135e45b239909f128841 Mon Sep 17 00:00:00 2001 From: Bruce Hauman Date: Wed, 17 Oct 2018 07:16:38 -0400 Subject: [PATCH] fix let block scoping Signed-off-by: Julien Eluard --- .gitignore | 3 +- src/pluto/reader/blocks.cljc | 90 ++++++++-- src/pluto/reader/destructuring.cljc | 17 ++ test/pluto/reader/block_test.cljc | 247 +++++++++++++++++++++++++--- test/pluto/reader_test.cljc | 9 +- 5 files changed, 332 insertions(+), 34 deletions(-) diff --git a/.gitignore b/.gitignore index 1ad61bb..fc871dd 100644 --- a/.gitignore +++ b/.gitignore @@ -14,4 +14,5 @@ resources/public/js/ website/build/ website/static/js/ website/static/extensions/ -\.\#* \ No newline at end of file +\.\#* +.nrepl-port diff --git a/src/pluto/reader/blocks.cljc b/src/pluto/reader/blocks.cljc index b296ead..03cec0b 100644 --- a/src/pluto/reader/blocks.cljc +++ b/src/pluto/reader/blocks.cljc @@ -24,14 +24,23 @@ ;; TODO handle errors (:data (destructuring/destructure k v)))) +(defn substitute-query-values [m v] + (if (vector? v) + (walk/prewalk #(or (get m %) %) v) + v)) + (defn assoc-binding [m k v] - (let [resolved-value (resolve-binding-value v) + (let [resolved-value (resolve-binding-value + (substitute-query-values m v)) o (resolve-binding-key k resolved-value)] (if (symbol? o) (assoc m o resolved-value) (merge m o)))) +(defn interpolate [values s] + (reduce-kv #(string/replace %1 (str "${" (str %2) "}") (str %3)) s values)) + (defn replace-atom [values o] (cond (contains? values o) (get values o) (symbol? o) nil @@ -39,10 +48,31 @@ (and (fn? o) (= :event (meta o))) #(o % values) ;; Intercept events and inject the env. TODO remove this hack :else o)) -(defn let-block [{:keys [env]} children] - ;; TODO nested let block should accumulate the env - (let [values (reduce-kv assoc-binding {} env)] - (walk/prewalk #(replace-atom values %) children))) +(defn walkup-upto-leaf [f lp? lf tree] + (if (lp? tree) + (lf tree) + (let [res (f tree) + f2 (partial walkup-upto-leaf f lp? lf)] + (cond (list? res) (apply list (map f2 res)) + (map-entry? res) (vec (map f2 res)) + (seq? res) (doall (map f2 res)) + (coll? res) (into (empty res) (map f2 res)) + :else res)))) + +(declare let-block bindings->env) + +(defn let-block [{:keys [prev-env ctx ext bindings env]} children] + ;; env here is always a destructured set of properties + (let [env' (merge env prev-env) + {:keys [data errors]} (bindings->env env' ctx ext bindings) + ;; this can be moved to into bindings->env now + + values (reduce-kv assoc-binding env' data)] + (walkup-upto-leaf #(replace-atom values %) + #(and (vector? %) (= let-block (first %))) + (fn [[_ props children]] + [let-block (assoc props :prev-env values) children]) + children))) (defn properties? [o] (= 'properties o)) @@ -55,7 +85,7 @@ (defn valid-bindings? [k v] (and (or (symbol? k) (map? k)) - (or (symbol? v) (static-value? v) (query? v) (query? v)))) + (or (symbol? v) (static-value? v) (query? v)))) (defn- resolve-symbol [m s] (if (and (symbol? s) (not= 'properties s)) @@ -90,18 +120,52 @@ (defn- valid-bindings-form? [bindings] (even? (count bindings))) -(defn bindings->env [ctx ext bindings] +;; errors are a problem here we shouldn't be returning data errors anymore +(defn bindings->env [prev-env ctx ext bindings] + (doall + (reduce (fn [accum [k v]] + (resolve-env ctx ext accum k + (resolve-symbol (:data accum) v))) + {:data prev-env} + (partition 2 bindings)))) + +;; we also need a set of available symbols bound at this point +(defn validate-bindings [bindings] (if (valid-bindings-form? bindings) - (reduce-kv #(resolve-env ctx ext %1 %2 (resolve-symbol (:data %1) %3)) {} (apply hash-map bindings)) - {:errors [(errors/error ::errors/invalid-bindings-format bindings)]})) + (not-empty + (let [binding-pairs (partition 2 bindings)] + (concat + (->> binding-pairs + (filter #(not (apply valid-bindings? %))) + (mapv #(errors/error ::errors/invalid-bindings %))) + (->> binding-pairs + (map first) + (filter (some-fn sequential? map?)) + (mapcat destructuring/validate-destructure-bindings)) + ))) + [(errors/error ::errors/invalid-bindings-format bindings)])) + +;; shouldn't need to do this really should inject props +;; into the initial map from the top +(defn prop-env-from-bindings [bindings] + (some->> bindings + (partition 2) + (filter #(= (second %) 'properties)) + first + reverse + (apply hash-map))) (defmethod parse 'let [ctx ext [_ bindings & body]] - (let [{:keys [data errors] :as m} (bindings->env ctx ext bindings)] + (if-let [errors (validate-bindings bindings)] + {:errors errors} ;; TODO fail if some symbol are not defined in the env (if (= 1 (count body)) - (merge {:data [let-block {:env data} (last body)]} - (when errors - {:errors errors})) + (let [prop-env (prop-env-from-bindings bindings)] + {:data [let-block (cond-> {:ctx ctx + :ext ext + :bindings bindings} + prop-env (assoc :env prop-env)) + (last body)]}) {:errors [(errors/error ::errors/invalid-let-body {:value body})]}))) (defn when-block [{:keys [test]} body] diff --git a/src/pluto/reader/destructuring.cljc b/src/pluto/reader/destructuring.cljc index 8b3312c..7927546 100644 --- a/src/pluto/reader/destructuring.cljc +++ b/src/pluto/reader/destructuring.cljc @@ -53,6 +53,23 @@ (reduce-kv #(merge-assoc-bindings s %1 %2 %3) {} bindings) {:errors [(errors/error ::errors/invalid-destructuring-format {:type :assoc :data bindings})]})) +;; recursively validate destructure bindings form +(defn validate-destructure-bindings [bindings] + (not-empty + (cond + (map? bindings) + (if (valid-assoc-format? bindings) + (mapcat + validate-destructure-bindings + (filter (some-fn sequential? map?) (keys bindings))) + [(errors/error ::errors/invalid-destructuring-format {:type :assoc :data bindings})]) + (sequential? bindings) + (if (every? valid-bindings-form? bindings) + (mapcat + validate-destructure-bindings + (filter (some-fn sequential? map?) bindings)) + [(errors/error ::errors/invalid-destructuring-format {:type :assoc :data bindings})])))) + (defn destructure "Given a pattern and an associated data structure, return a map of either: * :data, a map of extracted symbol / value pairs diff --git a/test/pluto/reader/block_test.cljc b/test/pluto/reader/block_test.cljc index 3b87547..4d78890 100644 --- a/test/pluto/reader/block_test.cljc +++ b/test/pluto/reader/block_test.cljc @@ -1,39 +1,54 @@ (ns pluto.reader.block-test (:require [clojure.test :refer [is deftest testing]] + [pluto.reader :as reader] [pluto.reader.errors :as errors] - [pluto.reader.blocks :as blocks])) + [pluto.reader.blocks :as blocks] + [re-frame.core :as re-frame])) (deftest bindings->env - (is (= {:data '{a 1}} (blocks/bindings->env {} {} '[a 1]))) - (is (= {:errors [(errors/error ::errors/invalid-bindings-format '[a 1 2])]} - (blocks/bindings->env {} {} '[a 1 2]))) - (is (= {:errors [(errors/error ::errors/invalid-bindings '[1 2])]} - (blocks/bindings->env {} {} '[1 2]))) - (is (= {:data '{x 1}} (blocks/bindings->env {} {} '[{x :x} {:x 1}])))) + (is (= {:data '{a 1}} (blocks/bindings->env {} {} {} '[a 1]))) + (is (= (blocks/validate-bindings '[a 1 2]) + [(errors/error ::errors/invalid-bindings-format '[a 1 2])])) + (is (= (blocks/validate-bindings [1 2]) + [(errors/error ::errors/invalid-bindings [1 2])])) + (is (= {:data '{x 1}} (blocks/bindings->env {} {} {} '[{x :x} {:x 1}])))) (deftest let-block (testing "parse" - (is (= {:data [blocks/let-block {:env {'s "Hello"}} 's]} + (is (= {:data [blocks/let-block '{:ctx {}, :ext {}, :bindings [s "Hello"]} 's]} (blocks/parse {} {} '(let [s "Hello"] s)))) (is (empty? (:errors (blocks/parse {:capacities {:queries {'aa {:value :a}}}} {} '(let [{a :a} [aa]] a))))) - (is (= {:data [blocks/let-block {:env '{a {:b 1} b 1}} 'b]} + (is (= {:data [blocks/let-block + '{:ctx {}, :ext {}, :bindings [{a :a} {:a {:b 1}} {b :b} a]} + 'b]} (blocks/parse {} {} '(let [{a :a} {:a {:b 1}} {b :b} a] b)))) (is (empty? - (:errors (blocks/parse {:capacities {:queries {'aa {:value :a :arguments {:x :string}}}}} {} '(let [x 1 {a :a} [aa {:x x}]] a))))) - - (is (= {:data [blocks/let-block {:env {'s "Hello"}} ['test {} 's]]} + (:errors (blocks/parse {:capacities + {:queries {'aa {:value :a :arguments {:x :string}}}}} + {} + '(let [x 1 {a :a} [aa {:x x}]] a))))) + (is (= {:data [blocks/let-block '{:ctx {}, :ext {}, :bindings [s "Hello"]} + ['test {} 's]]} (blocks/parse {} {} (list 'let ['s "Hello"] ['test {} 's])))) - (is (= {:data [blocks/let-block {:env nil} - ['test {} 's]] - :errors [(errors/error ::errors/invalid-bindings-format ['s "Hello" 1])]} - (blocks/parse {} {} (list 'let ['s "Hello" 1] ['test {} 's])))) - (is (= {:data [blocks/let-block {:env {'a 1}} ['test {} 'a]]} - (blocks/parse {} {} (list 'let ['{a :a} {:a 1}] ['test {} 'a])))))) + (is (= (blocks/validate-bindings '[s "Hello" 1]) + [(errors/error ::errors/invalid-bindings-format ['s "Hello" 1])])) + + ) + + + (is (= {:errors [(errors/error ::errors/invalid-bindings-format ['s "Hello" 1])]} + (blocks/parse {} {} (list 'let ['s "Hello" 1] ['test {} 's])))) + + (is (= {:data [blocks/let-block '{:ctx {}, :ext {}, :bindings [{a :a} {:a 1}]} + '[test {} a]]} + (blocks/parse {} {} '(let [{a :a} {:a 1}] [test {} a])))) + +) (deftest let-block-resolution - (is (= [identity {} 1] (blocks/let-block {:env {'a 1}} [identity {} 'a]))) + (is (= [identity {} 1] (blocks/let-block {:bindings '[a 1] } [identity {} 'a]))) #_ (is (= ['test {} 1] (blocks/let-block {:env '{{a :a} [:aa]}} '[test {} a])))) @@ -51,3 +66,197 @@ :pluto.reader.errors/invalid-when-block)) (is (= (first-error-type (blocks/parse {} {} '(when asdf))) :pluto.reader.errors/invalid-when-block))) + + +;; The following is all set up so that we can fake "render" the blocks +;; in the resulting view tree + +;; this will allow us to verify basic binding replacement behaviors of let blocks + +(defn view-component [& args] [:view args]) +(defn text-component [& args] [:text args]) +(defn button-component [& args] [:button args]) + +(re-frame/reg-sub ::identity-query + (fn [db [_ {:keys [x]}]] x)) + +(re-frame/reg-sub ::identity-map + (fn [db [_ {:keys [x]}]] {:asdf x})) + +(def let-test-capacities + {:components {'view {:properties {} + :value view-component} + 'button {:properties {:on-click :event} + :value button-component} + 'text {:properties {} + :value text-component}} + :queries '{identity-query {:value ::identity-query :arguments {:x :string}} + identity-map {:value ::identity-map :arguments {:x :string}}} + :events {'alert + {:value :alert}} + :hooks {:main + {:properties {:view :view}}}}) + +(defn exec [parsed] + (cond-> parsed + (not (:errors parsed)) + (assoc + :execed + ((get-in parsed [:data :hooks :main :demo :parsed :view]) + {:name "test-name-prop"})))) + +(defn test-parse [extention] + (-> (reader/parse {:capacities let-test-capacities} extention) + exec)) + +(defn simple-render-tree-blocks [[x & xs]] + (cond + (and (fn? x) (#{pluto.reader.blocks/if-block + pluto.reader.blocks/when-block + pluto.reader.blocks/let-block} x)) + (let [new-tree (apply x xs)] + (if (sequential? new-tree) + (simple-render-tree-blocks new-tree) + new-tree)) + :else + (apply + vector + x + (map #(if (sequential? %) + (simple-render-tree-blocks %) + %) + xs)))) + +(defn blocks-render [block-syn] + (let [{:keys [execed errors] :as res} + (test-parse (-> '{meta + {:name "Test Ext", + :description "A test extension", + :documentation "Nothing."}, + hooks/main.demo {:view [main]}} + (assoc 'views/main block-syn)))] + ;; for dev time + #?(:clj + (when-not (nil? errors) + (clojure.pprint/pprint errors) + (assert (nil? errors)))) + (when (and execed (sequential? execed)) + (simple-render-tree-blocks execed)))) + +;; end of rendering util to support tesing block rendering + +(deftest if-when-block-rendering + ;; need to set up a query to have a false value? + (is (= [view-component "true"] + (blocks-render '(let [a "asdf"] + (if a + [view "true"] + [view "false"]))))) + + (is (= [view-component "false"] + (blocks-render '(let [a [identity-query {:x false}]] + (if a + [view "true"] + [view "false"]))))) + (is (= [view-component "true"] + (blocks-render '(let [a "asdf"] + (when a [view "true"]))))) + + (is (= [view-component nil] + (blocks-render '(let [a [identity-query {:x false}]] + [view (when a [view "true"])])))) + ) + +(deftest basic-let-block-replacement [] + (is (= [view-component "hello"] + (blocks-render '(let [a "hello"] + [view a])))) + (is (= [view-component "hello" "jenny" + [text-component "jenny" "hello"] + [text-component "hello" "darlene"]] + (blocks-render '(let [a "hello" + b "jenny" + c "darlene"] + [view a b + [text b a] + [text a c]])))) + (is (= [view-component "john"] + (blocks-render '(let [a "john" + b a] + [view b])))) + (is (= [view-component "john"] + (blocks-render '(let [a "john" + b a] + [view b])))) + (is (= [view-component "john"] + (blocks-render '(let [a "john"] + (let [b a] + [view b]))))) + (is (= [view-component "john"] + (blocks-render '(let [a "john" + dd a] + (let [b a + c b] + [view b])))))) + +(deftest let-blocks-with-properties + (is (= [view-component "test-name-prop"] + (blocks-render '(let [{name :name} properties] + [view name])))) + + (is (= [view-component "test-name-prop"] + (blocks-render '(let [{name :name} properties + b name] + [view b])))) + + (is (= [view-component "jolly"] + (blocks-render '(let [{name :name} properties + b name] + (let [name "jolly"] + [view name]))))) + + ;; doesn't work and should work + ;; this is caused by the way that properties are bound + ;; seperately + #_(is (= [view-component "test-name-prop"] + (blocks-render '(let [name "jolly" + {name :name} properties] + [view name])) + )) + + ) + +(deftest let-blocks-with-queries + (is (= [view-component "a temp"] + (blocks-render '(let [temp [identity-query {:x "a temp"}]] + [view temp])))) + + (is (= [view-component "a temp" "a temp"] + (blocks-render '(let [a "a temp" + temp [identity-query {:x a}]] + [view a temp])))) + + (is (= [view-component "a temp" "charmed"] + (blocks-render '(let [a "a temp" + {asdf :asdf} [identity-map {:x "charmed"}]] + [view a asdf])))) + + + ;; this should work as well but ... + #_(is (= [view-component "a temp" "a temp"] + (blocks-render '(let [a "a temp" + temp [identity-query {:x a}] + ouch temp] + [view temp ouch])) + + )) + + (is (= [view-component "a temp" "a temp"] + (blocks-render '(let [a "a temp" + temp [identity-query {:x a}]] + (let [ouch temp] + [view temp ouch]))))) + + + ) + diff --git a/test/pluto/reader_test.cljc b/test/pluto/reader_test.cljc index 02e5111..6e7d1c2 100644 --- a/test/pluto/reader_test.cljc +++ b/test/pluto/reader_test.cljc @@ -61,7 +61,14 @@ ((get-in m [:data :hooks :main :a :parsed :view]) {})) (deftest parse-blocks - (is (= [blocks/let-block {:env {'s "Hello"}} '[text {} s]] + (is (= [blocks/let-block + '{:bindings [s "Hello"], + :ctx {:capacities {:components {text :text, view :view}, + :hooks {:main {:properties {:view :view}}}}}, + :ext {meta {:description "", :documentation "", :name ""}, + hooks/main.a {:view [views/main]}, + views/main (let [s "Hello"] [text {} s])}} + '[text {} s]] (view (reader/parse default-capacities (extension {'views/main (list 'let ['s "Hello"] ['text {} 's]) 'hooks/main.a {:view ['views/main]}})))))