noe/tl
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

transclusion fixes and other things by chat

Browse source
This commit is contained in:
Your Name 2026-07-06 23:48:01 -04:00
parent d2d803e38b
commit 4b29962677
7 changed files with 246 additions and 61 deletions
Download patch file Download diff file Expand all files Collapse all files

30
.dockerignore
View file

@ -1,16 +1,24 @@
.git
**/.venv
**/node_modules
**/.shadow-cljs
**/target
.venv
**/__pycache__
**/*.pyc
tl/node_modules
tl/.shadow-cljs
tl/target
tl/resources/public/js/compiled
**/__pycache__/
db.sqlite3
media/
staticfiles/
*.mp4
*.pdf
*.log
*.log.*
*.mbtree
*.mp4
*.mov
*.mkv
*.avi
*.pdf
thinking.org
.DS_Store
staticfiles
media
db.sqlite3

1
tl/package.json
View file

@ -5,6 +5,7 @@
"dev": "bash dev/dev.sh",
"media": "python3 dev/media_server.py",
"watch": "npx shadow-cljs watch app",
"test": "npx shadow-cljs compile test && node target/node-tests.js",
"release": "npx shadow-cljs release app",
"build-report": "npx shadow-cljs run shadow.cljs.build-report app target/build-report.html"
},

115
tl/src/tl/events.cljs
View file

@ -673,6 +673,23 @@
(rf/reg-event-db ::edit-draft (fn [db [_ gid]] (-> db (assoc-in [:scene :groups gid :draft] :edit)
(assoc-in [:view :pt] :new))))
;; Edit an annotation from a card. If its parent timeline is not the timeline
;; currently being viewed, enter that parent first so mark rows/handles edit in
;; their authored coordinate system. finish-edit pops this temporary parent.
(rf/reg-event-fx
::edit-annotation
(fn [{:keys [db]} [_ gid]]
(let [parent (get-in db [:scene :groups gid :parent])
ctx (peek (get-in db [:view :stack]))
push-parent? (and parent (not= parent ctx))
fx (if push-parent? (enter-ctx db #(conj % parent)) {:db db})]
(update fx :db #(cond-> (-> %
(assoc-in [:scene :groups gid :draft] :edit)
(assoc-in [:view :pt] :new)
(assoc-in [:view :edit-pop-parent] nil))
push-parent? (assoc-in [:view :edit-pop-parent] parent))))))
;; Edit the annotation you're currently inside: drop into its parent timeline so
;; its marks are editable there, remembering to pop back when done. Root has no
;; parent (and no marks) — edit it in place.
@ -687,13 +704,18 @@
(fn [{:keys [db]} _]
;; leaving the form (save OR cancel): tear down all authoring
;; transients so draw mode / pending points don't linger.
(let [db (-> db (assoc-in [:view :draw] nil)
(let [return-g (get-in db [:view :edit-return])
pop? (some? (get-in db [:view :edit-pop-parent]))
db (-> db (assoc-in [:view :draw] nil)
(assoc-in [:view :active-mark] nil)
(assoc-in [:view :pt] nil)
(assoc-in [:view :draft-stage] nil))]
(if-let [g (get-in db [:view :edit-return])]
(enter-ctx (assoc-in db [:view :edit-return] nil) #(conj % g))
{:db db}))))
(assoc-in [:view :draft-stage] nil)
(assoc-in [:view :edit-return] nil)
(assoc-in [:view :edit-pop-parent] nil))]
(cond
return-g (enter-ctx db #(conj % return-g))
pop? (enter-ctx db #(if (> (count %) 1) (pop %) %))
:else {:db db}))))
(rf/reg-event-db ::draft-focus (fn [db [_ pt]] (assoc-in db [:view :pt] pt)))
;; cancelling a draft is local only; saving a real annotation / deleting one
;; pushes a delta to the backend (which merges + attributes it).
@ -731,11 +753,10 @@
{:on-success [::scene-saved]
:on-failure [::save-error]}))))))
;; --- move an annotation into another context (drag-drop reparent) ---------
;; Changing :parent re-homes an annotation under a new context. Marks that no
;; longer resolve there just skip (scene/resolve drops them) and reappear if the
;; annotation is moved back — no data loss. Guard against cycles: never drop a
;; group into itself or one of its own descendants (that would make the :parent
;; chain loop forever, hanging path-to / resolve).
;; Drag/drop re-expresses the annotation's visible mark coverage in the target
;; context. The parent is just where the annotation is edited/listed; the marks
;; still decide what actually renders by resolving down to clips and intersecting
;; the target timeline.
(defn- descendant?
"Is `gid` equal to `anc` or somewhere below it in the :parent tree?"
[scene anc gid]
@ -744,24 +765,76 @@
(= g anc) true
:else (recur (get-in scene [:groups g :parent])))))
(rf/reg-event-db ::ann-drag-start (fn [db [_ gid]] (assoc-in db [:view :dragging-ann] gid)))
(rf/reg-event-db ::ann-drag-end (fn [db _] (assoc-in db [:view :dragging-ann] nil)))
(rf/reg-event-db
::ann-drag-start
(fn [db [_ gid source-parent]]
(-> db
(assoc-in [:view :dragging-ann] gid)
(assoc-in [:view :dragging-ann-source] source-parent))))
(rf/reg-event-db
::ann-drag-end
(fn [db _]
(-> db
(assoc-in [:view :dragging-ann] nil)
(assoc-in [:view :dragging-ann-source] nil))))
(defn- rehome-marks
[scene gid source-parent new-parent]
(let [target-segs (scene/content-segments scene new-parent)]
(reduce (fn [{:keys [marks proxies]} m]
(if (= source-parent (scene/mark-home scene m))
(let [bare (dissoc m :home-marks)
history (:home-marks m {})
history (assoc history source-parent bare)]
(if-let [saved (get history new-parent)]
{:marks (conj marks (assoc saved :home-marks (dissoc history new-parent)))
:proxies proxies}
(let [bars (scene/mark-bars scene gid (:id m) target-segs)]
(if (seq bars)
(let [pid (keyword (str "prox-" (random-uuid)))
proxy {:type :proxy :parent nil
:marks (mapv identity
(mapcat (fn [[lo hi]]
(scene/selection->marks scene new-parent lo hi))
bars))}
m* (assoc (merge m (scene/proxy-ref (:id m) pid))
:home-marks history)]
{:marks (conj marks m*) :proxies (assoc proxies pid proxy)})
{:marks (conj marks m) :proxies proxies}))))
{:marks (conj marks m) :proxies proxies}))
{:marks [] :proxies {}}
(get-in scene [:groups gid :marks]))))
(defn- has-home? [scene gid source-parent]
(some #(= source-parent (scene/mark-home scene %))
(get-in scene [:groups gid :marks])))
(rf/reg-event-fx
::reparent
(fn [{:keys [db]} [_ gid new-parent]]
(let [scene (:scene db)
g (get-in scene [:groups gid])]
g (get-in scene [:groups gid])
source-parent (or (get-in db [:view :dragging-ann-source])
(peek (get-in db [:view :stack])))]
(if (or (not= :annotation (:type g)) ; only annotations move
(:draft g) ; not while being drafted/edited
(= (:parent g) new-parent) ; no-op: already there
(descendant? scene gid new-parent)) ; target inside gid → cycle
{:db (assoc-in db [:view :dragging-ann] nil)}
(let [id (get-in db [:project :id])]
(cond-> {:db (-> db (assoc-in [:scene :groups gid :parent] new-parent)
(= source-parent new-parent)
(not (has-home? scene gid source-parent))
(descendant? scene gid new-parent)) ; target inside gid -> cycle
{:db (-> db
(assoc-in [:view :dragging-ann] nil)
(assoc-in [:view :dragging-ann-source] nil))}
(let [id (get-in db [:project :id])
{:keys [marks proxies]} (rehome-marks scene gid source-parent new-parent)
g* (assoc g :parent new-parent :marks marks)
patch (editable-group g*)]
(cond-> {:db (-> db (assoc-in [:scene :groups gid] g*)
(update-in [:scene :groups] merge proxies)
(assoc-in [:view :dragging-ann] nil)
(assoc-in [:view :dragging-ann-source] nil)
(assoc :save-error nil))}
id (assoc :http-xhrio (api/put-scene id {:changed {gid {:parent new-parent}}}
id (assoc :http-xhrio (api/put-scene id {:changed (merge {gid patch} proxies)}
{:on-success [::scene-saved]
:on-failure [::save-error]}))))))))
@ -933,7 +1006,9 @@
(fn [{:keys [db]} [_ draft-gid target-gid]]
(let [marks (get-in db [:scene :groups draft-gid :marks])
orig-t (get-in db [:scene :groups target-gid])
target (update orig-t :marks (fnil into []) marks)
target (-> orig-t
(update :marks (fnil into []) marks)
(dissoc :home))
patch (group-patch orig-t target) ; just the :marks change
proxies (into {} (keep (fn [m] (let [pid (get-in m [:start :ref])
pg (get-in db [:scene :groups pid])]

12
tl/src/tl/scene.cljs
View file

@ -420,8 +420,9 @@
annotation has no resolvable marks (a fresh draft, a fully broken one), so it
still shows somewhere."
[scene gid]
(let [homes (into #{} (keep #(mark-home scene %)) (:marks (grp scene gid)))]
(if (seq homes) homes #{(:parent (grp scene gid))})))
(let [g (grp scene gid)
homes (into #{} (keep #(mark-home scene %)) (:marks g))]
(if (seq homes) homes #{(:parent g)})))
(defn child-of?
"Is annotation `gid` a direct child of timeline `ctx` — a mark of its authored
@ -519,7 +520,12 @@
(get-in m [:end :ref]) (update-in [:end :ref] keyword)
(:track m) (update :track keyword)
(:notes m) (update :notes #(mapv keyword %)) ; bound script-note gids
(:drawings m) (update :drawings #(mapv keyword %)))) ; bound drawing gids
(:drawings m) (update :drawings #(mapv keyword %)) ; bound drawing gids
(:home-marks m) (update :home-marks
(fn [homes]
(into {} (map (fn [[home mark]]
[(keyword home) (restore-mark mark)]))
homes)))))
(defn- restore-region
"A script-note region loses keyword-ness through JSON: re-keyword :id and :kind."

23
tl/src/tl/subs.cljs
View file

@ -113,6 +113,22 @@
(defn- in-bars? [bars ph]
(some (fn [[lo hi]] (and (<= lo ph) (< ph hi))) bars))
(defn annotations-by-parent
"Group annotation cards by every reference parent they belong to."
[anns]
(reduce (fn [m a]
(reduce #(update %1 %2 (fnil conj []) a) m (:parents a)))
{}
anns))
(defn visible-child-annotations
"Nested cards under `parent-id` are controlled by that parent's reveal state.
A transcluded child may be visible because another parent was revealed, but it
should not render under this parent until this parent's panel is open."
[by-parent revealed parent-id seen]
(when (contains? (or revealed #{}) parent-id)
(seq (remove #(contains? seen (:id %)) (get by-parent parent-id)))))
;; child annotations of the current context, with their bars in local coords
(rf/reg-sub
::all-annotations
@ -144,7 +160,12 @@
(let [bars (scene/lane-bars scene gid segs)] ; one bar per mark; distinct marks never fuse
(when (shown? gid #{})
(let [reason (scene/broken-reason scene gid)
oor (boolean (scene/clip-loss? scene gid))
;; clip-loss compares against the structural :parent.
;; A transcluded annotation is intentionally authored in
;; multiple reference parents, so judging all marks
;; against only :parent creates a false warning.
oor (boolean (and (= (parents gid) #{(:parent g)})
(scene/clip-loss? scene gid)))
hidden (get-in g [:meta :hidden])
note-ids (->> (concat (:notes g) (mapcat :notes (:marks g)))
distinct

33
tl/src/tl/views.cljs
View file

@ -1205,7 +1205,7 @@
;; Drag-drop wiring shared by both card variants: an annotation is a drag source
;; (carries its gid) AND a drop target (drop another annotation onto it to make it
;; a child). `over?` is a local atom driving the drop-target highlight.
(defn- ann-drag-props [a authed? over?]
(defn- ann-drag-props [a authed? over? source-parent]
(when authed?
{:draggable true
;; cards nest, so stop each drag event at the card it fires on — otherwise it
@ -1215,7 +1215,7 @@
(.stopPropagation e)
(.. e -dataTransfer (setData "text/ann" (name (:id a))))
(set! (.. e -dataTransfer -effectAllowed) "move")
(rf/dispatch [::events/ann-drag-start (:id a)]))
(rf/dispatch [::events/ann-drag-start (:id a) source-parent]))
:on-drag-end (fn [_] (reset! over? false) (rf/dispatch [::events/ann-drag-end]))
:on-drag-over (fn [e]
(when (has-type? e "text/ann")
@ -1227,12 +1227,12 @@
(.stopPropagation e) (.preventDefault e) (reset! over? false)
(rf/dispatch [::events/reparent (keyword src) (:id a)]))))}))
(defn- annotation-card [a scene ctx segs nmap authed? open by-parent seen]
(defn- annotation-card [a scene ctx segs nmap authed? open by-parent revealed source-parent seen]
(r/with-let [over? (r/atom false) hov? (r/atom false)]
(let [active? @(rf/subscribe [::subs/annotation-active? (:id a)])
dragging @(rf/subscribe [::subs/dragging-ann])
drop-ok? (and dragging (not= dragging (:id a)))
drag-props (merge (ann-drag-props a authed? over?)
drag-props (merge (ann-drag-props a authed? over? source-parent)
{:class (str (when active? "active ")
(when (and drop-ok? @over?) "drop-over ")
(when drop-ok? "drop-ready"))})]
@ -1250,7 +1250,7 @@
(:name a)]
[:div {:style {:display "flex" :gap "2px" :visibility (if @hov? "visible" "hidden")}}
[:button.expand-btn {:title "Expand" :on-click #(rf/dispatch [::events/expand (:id a)])} "⤢"]
[:button.edit-btn {:title "Edit" :on-click #(rf/dispatch [::events/edit-draft (:id a)])} "✎"]]]
[:button.edit-btn {:title "Edit" :on-click #(rf/dispatch [::events/edit-annotation (:id a)])} "✎"]]]
[:div.ann (merge drag-props
{:id (str "ann-" (name (:id a)))
;; grey out an annotation with dangling marks (it sorts to the
@ -1268,7 +1268,7 @@
[:button.expand-btn {:title "Expand" :on-click #(rf/dispatch [::events/expand (:id a)])}
"⤢" (when (pos? (:nested a)) [:span.nest-badge (:nested a)])]
(when authed?
[:button.edit-btn {:title "Edit" :on-click #(rf/dispatch [::events/edit-draft (:id a)])} "✎"])
[:button.edit-btn {:title "Edit" :on-click #(rf/dispatch [::events/edit-annotation (:id a)])} "✎"])
(when authed?
[:button.del-btn {:title "Delete"
:on-click #(when (js/confirm (str "Delete \"" (:name a) "\"?"))
@ -1282,15 +1282,15 @@
(into [:div.ann-tags]
(for [t (:tags a)] ^{:key t} [tag-chip t])))
(when (pos? (:nested a))
(let [shown? (contains? @(rf/subscribe [::subs/revealed]) (:id a))]
(let [shown? (contains? revealed (:id a))]
[:button.show-children {:on-click #(rf/dispatch [::events/toggle-children (:id a)])}
(str (if shown? "▾ Hide " "▸ Show ") (:nested a)
(if (= 1 (:nested a)) " annotation" " annotations"))]))
(when-let [kids (seq (remove #(contains? seen (:id %)) (get by-parent (:id a))))]
(when-let [kids (subs/visible-child-annotations by-parent revealed (:id a) seen)]
(into [:div.ann-children]
(for [k kids]
^{:key (:id k)}
[annotation-card k scene ctx segs nmap authed? open by-parent (conj seen (:id a))])))]))))
[annotation-card k scene ctx segs nmap authed? open by-parent revealed (:id a) (conj seen (:id a))])))]))))
(defn commentary []
(let [open (r/atom nil)]
@ -1300,7 +1300,8 @@
scene @(rf/subscribe [::subs/scene])
ctx @(rf/subscribe [::subs/context])
segs @(rf/subscribe [::subs/segments])
nmap (into {} (map (juxt :id identity)) @(rf/subscribe [::subs/notes]))]
nmap (into {} (map (juxt :id identity)) @(rf/subscribe [::subs/notes]))
revealed @(rf/subscribe [::subs/revealed])]
[:div.commentary
;; this context's own description (links resolve in its parent), with an
;; edit button — Edit drops into the parent timeline so marks are editable.
@ -1317,12 +1318,11 @@
;; group by REFERENCE parent(s): an annotation is listed under every
;; timeline its marks were authored in (:parents), so a transcluded one
;; shows under each context it belongs to, not just its structural parent.
(let [by-parent (reduce (fn [m a] (reduce #(update %1 %2 (fnil conj []) a) m (:parents a)))
{} anns)]
(let [by-parent (subs/annotations-by-parent anns)]
(doall
(for [a (get by-parent ctx)]
^{:key (:id a)}
[annotation-card a scene ctx segs nmap authed? open by-parent #{}])))
[annotation-card a scene ctx segs nmap authed? open by-parent revealed ctx #{}])))
[:div.ann-empty "No annotations here."])]))))
(defn- to-frame [v len]
@ -1502,8 +1502,11 @@
nmap (into {} (map (juxt :id identity)) notes)
live @(rf/subscribe [::subs/active-note-set])
active @(rf/subscribe [::subs/active-mark])
rows (scene/marks->rows scene (:marks d))
broken (set (scene/broken-marks scene gid)) ; marks whose refs no longer resolve
;; The root timeline's mark is absolute numeric [start/end], not a ref
;; mark. Root editing is description-only, so do not run it through the
;; annotation mark-row machinery.
rows (when-not root? (scene/marks->rows scene (:marks d)))
broken (if root? #{} (set (scene/broken-marks scene gid))) ; marks whose refs no longer resolve
valid? (or root? (and (not (str/blank? (:name d))) (seq (:marks d))))
save #(when valid?
(rf/dispatch [::events/save-group gid (dissoc d :draft :gid)

75
tl/test/tl/flow_test.cljs
View file

@ -51,6 +51,57 @@
(defn bars-in [ctx gid]
(s/lane-bars (scene*) gid (s/content-segments (scene*) ctx)))
(deftest editing-nested-annotation-temporarily-enters-parent
(testing "card edit pushes the parent timeline, and finish-edit pops it back"
(setup! (seed) [:root])
(rf/dispatch-sync [::ev/edit-annotation :annC])
(is (= [:root :annA] (get-in @rdb/app-db [:view :stack])))
(is (= :edit (get-in (scene*) [:groups :annC :draft])))
(is (= :annA (get-in @rdb/app-db [:view :edit-pop-parent])))
(rf/dispatch-sync [::ev/finish-edit])
(is (= [:root] (get-in @rdb/app-db [:view :stack])))
(is (nil? (get-in @rdb/app-db [:view :edit-pop-parent]))))
(testing "editing from the parent context does not push a duplicate parent"
(setup! (seed) [:root :annA])
(rf/dispatch-sync [::ev/edit-annotation :annC])
(is (= [:root :annA] (get-in @rdb/app-db [:view :stack])))
(is (nil? (get-in @rdb/app-db [:view :edit-pop-parent])))
(rf/dispatch-sync [::ev/finish-edit])
(is (= [:root :annA] (get-in @rdb/app-db [:view :stack])))))
(deftest dragging-transcluded-annotation-to-root-rehomes-it
(testing "drag/drop root owns placement even when marks were authored under two annotations"
(setup! (seed) [:root])
(rf/dispatch-sync [::ev/expand :annB])
(rf/dispatch-sync [::ev/open-draft])
(rf/dispatch-sync [::ev/draft-select-range 50 150])
(let [draft-gid (some (fn [[gid g]] (when (:draft g) gid)) (:groups (scene*)))]
(rf/dispatch-sync [::ev/associate-marks draft-gid :annC]))
(rf/dispatch-sync [::ev/save-group :annC (dissoc (get-in (scene*) [:groups :annC]) :draft) nil])
(rf/dispatch-sync [::ev/finish-edit])
(is (= #{:annA :annB} (s/mark-homes (scene*) :annC)))
(let [original-b-mark (second (get-in (scene*) [:groups :annC :marks]))]
(rf/dispatch-sync [::ev/reparent :annC :root])
(is (= :root (get-in (scene*) [:groups :annC :parent])))
(is (nil? (get-in (scene*) [:groups :annC :home])))
(is (= #{:annA :root} (s/mark-homes (scene*) :annC)))
(is (= [:annA :root]
(mapv #(s/mark-home (scene*) %)
(get-in (scene*) [:groups :annC :marks]))))
(is (s/child-of? (scene*) :root :annC))
(is (s/child-of? (scene*) :annA :annC))
(is (not (s/child-of? (scene*) :annB :annC)))
(rf/dispatch-sync [::ev/collapse])
(let [ids (set (map :id @(rf/subscribe [::subs/all-annotations])))]
(is (contains? ids :annC)))
(rf/dispatch-sync [::ev/reparent :annC :annB])
(let [restored-b-mark (second (get-in (scene*) [:groups :annC :marks]))]
(is (= #{:annA :annB} (s/mark-homes (scene*) :annC)))
(is (= original-b-mark (dissoc restored-b-mark :home-marks)))
(is (contains? (:home-marks restored-b-mark) :root))
(is (not (s/child-of? (scene*) :root :annC)))
(is (s/child-of? (scene*) :annB :annC))))))
(deftest tie-marks-to-annotation-in-another-context-then-drag
(testing "author a range while drilled into annB, tie it to annC (parented under
annA), then drag its handle — it must stay one proxy, stay visible in
@ -104,6 +155,8 @@
under (fn [p] (->> anns (filter #(contains? (:parents %) p)) (map :id) set))]
(is c "annC is present in ::all-annotations while viewing annB")
(is (contains? (:parents c) :annB) "annC's reference parents include annB")
(is (false? (:oor c)) "transclusion is not out-of-range just because its structural parent is elsewhere")
(is (false? (:broken c)) "transclusion does not render as a broken warning")
(is (contains? (under :annB) :annC) "the pane lists annC under annB")
(is (not (contains? (under :annB) :annA)) "annA is root's child, not annB's"))
@ -116,9 +169,27 @@
(is (not (contains? ids :annC)) "annC does NOT leak into root (grandchild)"))
(rf/dispatch-sync [::ev/toggle-children :annA])
(let [anns @(rf/subscribe [::subs/all-annotations])
c (some #(when (= :annC (:id %)) %) anns)]
c (some #(when (= :annC (:id %)) %) anns)
by-parent (subs/annotations-by-parent anns)
revealed (get-in @rdb/app-db [:view :revealed])]
(is c "revealing annA surfaces annC as its child in the toggle")
(is (contains? (:parents c) :annA)))
(is (contains? (:parents c) :annA))
(is (= [:annC] (mapv :id (subs/visible-child-annotations by-parent revealed :annA #{})))
"annA's open panel renders annC")
(is (nil? (subs/visible-child-annotations by-parent revealed :annB #{}))
"annB's closed panel does not render the same transcluded child"))
(rf/dispatch-sync [::ev/toggle-children :annB])
(let [anns @(rf/subscribe [::subs/all-annotations])
by-parent (subs/annotations-by-parent anns)
revealed (get-in @rdb/app-db [:view :revealed])]
(is (= [:annC] (mapv :id (subs/visible-child-annotations by-parent revealed :annB #{})))
"annB renders annC only after its own panel opens"))
(rf/dispatch-sync [::ev/toggle-children :annB])
(let [anns @(rf/subscribe [::subs/all-annotations])
by-parent (subs/annotations-by-parent anns)
revealed (get-in @rdb/app-db [:view :revealed])]
(is (nil? (subs/visible-child-annotations by-parent revealed :annB #{}))
"hiding annB's panel removes annC from that panel even though annA still reveals it"))
;; BUG 2 — back in annB, dragging the handle must not delete the mark
;; (::reroll-proxy must roll against the VIEWED context, not annC's :parent).