compiler: tag support

hyperfiddle · May 24, 2024 · c086e7c · c086e7c
1 parent 99a57b2
commit c086e7c
Show file tree

Hide file tree

Showing 3 changed files with 33 additions and 3 deletions.
diff --git a/src/hyperfiddle/electric/impl/lang_de2.clj b/src/hyperfiddle/electric/impl/lang_de2.clj
@@ -628,6 +628,9 @@
         (::call) (let [e (->id)] (recur (second form) e env
                                    (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call, ::uid (->uid)})
                                      (?add-source-map e form))))
+        (::tag) (let [e (->id)] (recur (second form) e env
+                                  (-> (ts/add ts {:db/id e, ::parent pe, ::type ::call, ::uid (->uid), ::call-type ::tag})
+                                    (?add-source-map e form))))
         (::pure) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::pure})
                                                               (?add-source-map e form))))
         (::join) (let [e (->id)] (recur (second form) e env (-> (ts/add ts {:db/id e, ::parent pe, ::type ::join})
@@ -722,6 +725,8 @@
 
 (defn ->thunk [xs] `(fn* [] (~@xs)))
 
+(defn tag-call? [ts e] (= ::tag (::call-type (ts/->node ts e))))
+
 (defn emit [ts e ctor-e env nm]
   ((fn rec [e]
      (let [nd (get (:eav ts) e)]
@@ -751,7 +756,9 @@
                                               ::closed-ref (::closed-ref nd))
                                          first (ts/->node ts) ::free-idx)))))
                     (ts/find ts ::ctor-free (e->uid ts e))))
-         ::call (list `r/join (list `r/call 'frame (::call-idx (ts/->node ts e))))
+         ::call (if (tag-call? ts e)
+                  (list `r/pure (list `r/tag 'frame (::call-idx nd)))
+                  (list `r/join (list `r/call 'frame (::call-idx nd))))
          ::frame 'frame
          ::lookup (list* `r/lookup 'frame (::sym nd) (when-some [c (?get-child-e ts e)] (list (rec c))))
          ::mklocal (recur (get-ret-e ts (get-child-e ts e)))
@@ -803,7 +810,7 @@
   (let [ret-e (get-ret-e ts (get-child-e ts ctor-e))
         ctor-uid (::uid (ts/->node ts ctor-e))
         nodes-e (get-ordered-nodes-e ts ctor-uid)
-        calls-e (get-ordered-calls-e ts ctor-uid)]
+        calls-e (into [] (remove #(tag-call? ts %)) (get-ordered-calls-e ts ctor-uid))]
     `(r/cdef ~(count (ts/find ts ::ctor-free ctor-uid))
        ~(mapv #(get-site ts (->> (ts/->node ts %) ::ctor-ref (->localv-e ts) (get-ret-e ts)))
           nodes-e)

diff --git a/src/hyperfiddle/electric/impl/runtime_de.cljc b/src/hyperfiddle/electric/impl/runtime_de.cljc
@@ -1017,3 +1017,5 @@ Returns a peer definition from given definitions and main key.
         (recur ret (dissoc left k))
         (recur (assoc ret k f) (merge (dissoc left k) (f :get :deps))))
       ret)))
+
+(def tag)
diff --git a/test/hyperfiddle/electric/impl/compiler_test.cljc b/test/hyperfiddle/electric/impl/compiler_test.cljc
@@ -2,7 +2,7 @@
   (:require [hyperfiddle.electric-de :as e]
             [hyperfiddle.incseq :as i]
             #?(:clj [contrib.triple-store :as ts])
-            #?(:clj [hyperfiddle.electric.impl.lang-de2 :as lang])
+            [hyperfiddle.electric.impl.lang-de2 :as lang]
             [hyperfiddle.electric.impl.runtime-de :as r]
             [hyperfiddle.electric-local-def-de :as l]
             #?(:clj [hyperfiddle.electric.impl.compiler-test-clj :refer [cannot-be-unsited]]
@@ -532,6 +532,27 @@
     `[(r/cdef 0 [] [] :server
         (fn [~'frame] (r/pure (vector 11))))]))
 
+(tests "::lang/tag"
+  (match (l/test-compile ::Main [(::lang/tag)
+                                 (::lang/tag)
+                                 (::lang/call (::lang/ctor 1))
+                                 (::lang/tag)
+                                 (::lang/call (::lang/ctor 2))])
+    `[(r/cdef 0 [] [nil nil] nil
+        (fn [~'frame]
+          (r/define-call ~'frame 2 (r/pure (r/ctor ::Main 1)))
+          (r/define-call ~'frame 4 (r/pure (r/ctor ::Main 2)))
+          (r/ap (r/pure vector)
+            (r/pure (r/tag ~'frame 0))
+            (r/pure (r/tag ~'frame 1))
+            (r/join (r/call ~'frame 2))
+            (r/pure (r/tag ~'frame 3))
+            (r/join (r/call ~'frame 4)))))
+      (r/cdef 0 [] [] nil
+        (fn [~'frame] (r/pure 1)))
+      (r/cdef 0 [] [] nil
+        (fn [~'frame] (r/pure 2)))]))
+
 (comment
 
   (let [ts (l/code->ts {} (prn :hello))