From c0665ba58e1763344a54f43ed34ef6a449e3c061 Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 4 Apr 2026 20:49:02 +0000 Subject: [PATCH] Adopt Step 7 language features across SX codebase MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 112 conversions across 19 .sx files using match, let-match, and pipe operators: match (17): type/value dispatch replacing cond/if chains - lib/vm.sx: HO form dispatch (for-each/map/filter/reduce/some/every?) - lib/tree-tools.sx: node-display, node-matches?, rename, count, replace, free-symbols - lib/types.sx: narrow-type, substitute-in-type, infer-type, resolve-type - web/engine.sx: default-trigger, resolve-target, classify-trigger - web/deps.sx: scan-refs-walk, scan-io-refs-walk let-match (89): dict destructuring replacing (get d "key") patterns - shared/page-functions.sx (20), blog/admin.sx (17), pub-api.sx (13) - events/ layouts/page/tickets/entries/forms (27 total) - specs-explorer.sx (7), federation/social.sx (3), lib/ small files (3) -> pipes (6): replacing triple-chained gets in lib/vm.sx - frame-closure → closure-code → code-bytecode chains Also: lib/vm.sx accessor upgrades (get vm "sp" → vm-sp vm throughout) 2650/2650 tests pass, zero regressions. Co-Authored-By: Claude Opus 4.6 (1M context) --- blog/sx/admin.sx | 703 +++++--- events/sx/entries.sx | 184 +- events/sx/forms.sx | 49 +- events/sx/layouts.sx | 338 ++-- events/sx/page.sx | 334 ++-- events/sx/tickets.sx | 202 ++- federation/sx/social.sx | 197 +- lib/freeze.sx | 169 +- lib/highlight.sx | 509 +++--- lib/sx-swap.sx | 554 +++--- lib/tree-tools.sx | 182 +- lib/types.sx | 1583 ++++++++++------- lib/vm.sx | 133 +- .../templates/client-libs/page-functions.sx | 382 ++-- spec/signals.sx | 371 ++-- sx/sx/handlers/pub-api.sx | 357 ++-- sx/sx/specs-explorer.sx | 279 +-- web/deps.sx | 654 ++++--- web/engine.sx | 1565 ++++++++-------- 19 files changed, 4974 insertions(+), 3771 deletions(-) diff --git a/blog/sx/admin.sx b/blog/sx/admin.sx index 58fb5209..b0085aca 100644 --- a/blog/sx/admin.sx +++ b/blog/sx/admin.sx @@ -144,78 +144,140 @@ edit-form delete-form)) ;; Data-driven snippets list (replaces Python _snippets_sx loop) -(defcomp ~admin/snippets-from-data (&key snippets user-id is-admin csrf badge-colours) +(defcomp + ~admin/snippets-from-data + (&key snippets user-id is-admin csrf badge-colours) (~admin/snippets-list - :rows (<> (map (lambda (s) - (let* ((s-id (get s "id")) - (s-name (get s "name")) - (s-uid (get s "user_id")) - (s-vis (get s "visibility")) - (owner (if (= s-uid user-id) "You" (str "User #" s-uid))) - (badge-cls (or (get badge-colours s-vis) "bg-stone-200 text-stone-700")) - (extra (<> - (when is-admin - (~admin/snippet-visibility-select - :patch-url (get s "patch_url") - :hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}") - :options (<> - (~admin/snippet-option :value "private" :selected (= s-vis "private") :label "private") - (~admin/snippet-option :value "shared" :selected (= s-vis "shared") :label "shared") - (~admin/snippet-option :value "admin" :selected (= s-vis "admin") :label "admin")) - :cls "text-sm border border-stone-300 rounded px-2 py-1")) - (when (or (= s-uid user-id) is-admin) - (~shared:misc/delete-btn :url (get s "delete_url") :trigger-target "#snippets-list" - :title "Delete snippet?" - :text (str "Delete \u201c" s-name "\u201d?") - :sx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}") - :cls "px-3 py-1 text-sm bg-red-200 hover:bg-red-300 rounded text-red-800 flex-shrink-0"))))) - (~admin/snippet-row :name s-name :owner owner :badge-cls badge-cls - :visibility s-vis :extra extra))) - (or snippets (list)))))) + :rows (<> + (map + (lambda + (s) + (let-match + {:visibility s-vis :delete_url delete-url :patch_url patch-url :id s-id :user_id s-uid :name s-name} + s + (let* + ((owner (if (= s-uid user-id) "You" (str "User #" s-uid))) + (badge-cls + (or (get badge-colours s-vis) "bg-stone-200 text-stone-700")) + (extra + (<> + (when + is-admin + (~admin/snippet-visibility-select + :patch-url patch-url + :hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}") + :options (<> + (~admin/snippet-option + :value "private" + :selected (= s-vis "private") + :label "private") + (~admin/snippet-option + :value "shared" + :selected (= s-vis "shared") + :label "shared") + (~admin/snippet-option + :value "admin" + :selected (= s-vis "admin") + :label "admin")) + :cls "text-sm border border-stone-300 rounded px-2 py-0.5")) + (when + (or (= s-uid user-id) is-admin) + (~shared:misc/delete-btn + :url delete-url + :trigger-target "#snippets-list" + :title "Delete snippet?" + :text (str "Delete \"" s-name "\"?") + :sx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}") + :cls "px-3 py-1 text-sm bg-red-200 hover:bg-red-300 text-red-800 rounded-full"))))) + (~admin/snippet-row + :name s-name + :owner owner + :badge-cls badge-cls + :visibility s-vis + :extra extra)))) + (or snippets (list)))))) ;; Data-driven menu items list (replaces Python _menu_items_list_sx loop) -(defcomp ~admin/menu-items-from-data (&key items csrf) +(defcomp + ~admin/menu-items-from-data + (&key items csrf) (~admin/menu-items-list - :rows (<> (map (lambda (item) - (let* ((img (~shared:misc/img-or-placeholder :src (get item "feature_image") :alt (get item "label") - :size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0"))) - (~admin/menu-item-row - :img img :label (get item "label") :slug (get item "slug") - :sort-order (get item "sort_order") :edit-url (get item "edit_url") - :delete-url (get item "delete_url") - :confirm-text (str "Remove " (get item "label") " from the menu?") - :hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")))) - (or items (list)))))) + :rows (<> + (map + (lambda + (item) + (let-match + {:delete_url delete-url :sort_order sort-order :edit_url edit-url :feature_image feature-image :label label :slug slug} + item + (let + ((img (~shared:misc/img-or-placeholder :src feature-image :alt label :size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0"))) + (~admin/menu-item-row + :img img + :label label + :slug slug + :sort-order sort-order + :edit-url edit-url + :delete-url delete-url + :confirm-text (str "Remove " label " from the menu?") + :hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}"))))) + (or items (list)))))) ;; Data-driven tag groups main (replaces Python _tag_groups_main_panel_sx loops) -(defcomp ~admin/tag-groups-from-data (&key groups unassigned-tags csrf create-url) +(defcomp + ~admin/tag-groups-from-data + (&key groups unassigned-tags csrf create-url) (~admin/tag-groups-main :form (~admin/tag-groups-create-form :create-url create-url :csrf csrf) - :groups (if (empty? (or groups (list))) - (~shared:misc/empty-state :message "No tag groups yet." :cls "text-stone-500 text-sm") + :groups (if + (empty? (or groups (list))) + (~shared:misc/empty-state + :message "No tag groups yet." + :cls "text-stone-500 text-sm") (~admin/tag-groups-list - :items (<> (map (lambda (g) - (let* ((icon (if (get g "feature_image") - (~admin/tag-group-icon-image :src (get g "feature_image") :name (get g "name")) - (~admin/tag-group-icon-color :style (get g "style") :initial (get g "initial"))))) - (~admin/tag-group-li :icon icon :edit-href (get g "edit_href") - :name (get g "name") :slug (get g "slug") :sort-order (get g "sort_order")))) - groups)))) - :unassigned (when (not (empty? (or unassigned-tags (list)))) + :items (<> + (map + (lambda + (g) + (let-match + {:sort_order sort-order :feature_image feature-image :slug slug :edit_href edit-href :initial initial :name name :style style} + g + (let + ((icon (if feature-image (~admin/tag-group-icon-image :src feature-image :name name) (~admin/tag-group-icon-color :style style :initial initial)))) + (~admin/tag-group-li + :icon icon + :edit-href edit-href + :name name + :slug slug + :sort-order sort-order)))) + groups)))) + :unassigned (when + (not (empty? (or unassigned-tags (list)))) (~admin/unassigned-tags :heading (str "Unassigned Tags (" (len unassigned-tags) ")") - :spans (<> (map (lambda (t) - (~admin/unassigned-tag :name (get t "name"))) - unassigned-tags)))))) + :spans (<> + (map + (lambda (t) (~admin/unassigned-tag :name (get t "name"))) + unassigned-tags)))))) ;; Data-driven tag group edit (replaces Python _tag_groups_edit_main_panel_sx loop) -(defcomp ~admin/tag-checkboxes-from-data (&key tags) - (<> (map (lambda (t) - (~admin/tag-checkbox - :tag-id (get t "tag_id") :checked (get t "checked") - :img (when (get t "feature_image") (~admin/tag-checkbox-image :src (get t "feature_image"))) - :name (get t "name"))) - (or tags (list))))) +(defcomp + ~admin/tag-checkboxes-from-data + (&key tags) + (<> + (map + (lambda + (t) + (let-match + {:tag_id tag-id :checked checked :feature_image feature-image :name name} + t + (~admin/tag-checkbox + :tag-id tag-id + :checked checked + :img (when + feature-image + (~admin/tag-checkbox-image :src feature-image)) + :name name))) + (or tags (list))))) ;; Preview panel components @@ -258,113 +320,175 @@ ;; --------------------------------------------------------------------------- ;; Snippets — receives serialized snippet dicts from service -(defcomp ~admin/snippets-content (&key snippets is-admin csrf) +(defcomp + ~admin/snippets-content + (&key snippets is-admin csrf) (~admin/snippets-panel - :list (if (empty? (or snippets (list))) - (~shared:misc/empty-state :icon "fa fa-puzzle-piece" + :list (if + (empty? (or snippets (list))) + (~shared:misc/empty-state + :icon "fa fa-puzzle-piece" :message "No snippets yet. Create one from the blog editor.") (~admin/snippets-list - :rows (map (lambda (s) - (let* ((badge-colours (dict - "private" "bg-stone-200 text-stone-700" - "shared" "bg-blue-100 text-blue-700" - "admin" "bg-amber-100 text-amber-700")) - (vis (or (get s "visibility") "private")) - (badge-cls (or (get badge-colours vis) "bg-stone-200 text-stone-700")) - (name (get s "name")) - (owner (get s "owner")) - (can-delete (get s "can_delete"))) - (~admin/snippet-row - :name name :owner owner :badge-cls badge-cls :visibility vis - :extra (<> - (when is-admin - (~admin/snippet-visibility-select - :patch-url (get s "patch_url") - :hx-headers {:X-CSRFToken csrf} - :options (<> - (~admin/snippet-option :value "private" :selected (= vis "private") :label "private") - (~admin/snippet-option :value "shared" :selected (= vis "shared") :label "shared") - (~admin/snippet-option :value "admin" :selected (= vis "admin") :label "admin")))) - (when can-delete - (~shared:misc/delete-btn - :url (get s "delete_url") - :trigger-target "#snippets-list" - :title "Delete snippet?" - :text (str "Delete \u201c" name "\u201d?") - :sx-headers {:X-CSRFToken csrf} - :cls "px-3 py-1 text-sm bg-red-200 hover:bg-red-300 rounded text-red-800 flex-shrink-0")))))) + :rows (map + (lambda + (s) + (let-match + {:visibility vis* :delete_url delete-url :owner owner :can_delete can-delete :patch_url patch-url :name name} + s + (let* + ((vis (or vis* "private")) + (badge-colours + (dict + "private" + "bg-stone-200 text-stone-700" + "shared" + "bg-blue-100 text-blue-700" + "admin" + "bg-amber-100 text-amber-700")) + (badge-cls + (or (get badge-colours vis) "bg-stone-200 text-stone-700"))) + (~admin/snippet-row + :name name + :owner owner + :badge-cls badge-cls + :visibility vis + :extra (<> + (when + is-admin + (~admin/snippet-visibility-select + :patch-url patch-url + :hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}") + :options (<> + (~admin/snippet-option + :value "private" + :selected (= vis "private") + :label "private") + (~admin/snippet-option + :value "shared" + :selected (= vis "shared") + :label "shared") + (~admin/snippet-option + :value "admin" + :selected (= vis "admin") + :label "admin")))) + (when + can-delete + (~shared:misc/delete-btn + :url delete-url + :trigger-target "#snippets-list" + :title "Delete snippet?" + :text (str "Delete \"" name "\"?") + :sx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}") + :cls "px-3 py-1 text-sm bg-red-200 hover:bg-red-300 text-red-800 rounded-full"))))))) (or snippets (list))))))) ;; Menu Items — receives serialized menu item dicts from service -(defcomp ~admin/menu-items-content (&key menu-items new-url csrf) +(defcomp + ~admin/menu-items-content + (&key menu-items new-url csrf) (~admin/menu-items-panel :new-url new-url - :list (if (empty? (or menu-items (list))) - (~shared:misc/empty-state :icon "fa fa-inbox" + :list (if + (empty? (or menu-items (list))) + (~shared:misc/empty-state + :icon "fa fa-inbox" :message "No menu items yet. Add one to get started!") (~admin/menu-items-list - :rows (map (lambda (mi) - (~admin/menu-item-row - :img (~shared:misc/img-or-placeholder - :src (get mi "feature_image") :alt (get mi "label") - :size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0") - :label (get mi "label") - :slug (get mi "url") - :sort-order (str (or (get mi "sort_order") 0)) - :edit-url (get mi "edit_url") - :delete-url (get mi "delete_url") - :confirm-text (str "Remove " (get mi "label") " from the menu?") - :hx-headers {:X-CSRFToken csrf})) + :rows (map + (lambda + (mi) + (let-match + {:delete_url delete-url :url url :sort_order sort-order :edit_url edit-url :feature_image feature-image :label label} + mi + (~admin/menu-item-row + :img (~shared:misc/img-or-placeholder + :src feature-image + :alt label + :size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0") + :label label + :slug url + :sort-order (str (or sort-order 0)) + :edit-url edit-url + :delete-url delete-url + :confirm-text (str "Remove " label " from the menu?") + :hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")))) (or menu-items (list))))))) ;; Tag Groups — receives serialized tag group data from service -(defcomp ~admin/tag-groups-content (&key groups unassigned-tags create-url csrf) +(defcomp + ~admin/tag-groups-content + (&key groups unassigned-tags create-url csrf) (~admin/tag-groups-main :form (~admin/tag-groups-create-form :create-url create-url :csrf csrf) - :groups (if (empty? (or groups (list))) - (~shared:misc/empty-state :icon "fa fa-tags" :message "No tag groups yet.") + :groups (if + (empty? (or groups (list))) + (~shared:misc/empty-state + :icon "fa fa-tags" + :message "No tag groups yet.") (~admin/tag-groups-list - :items (map (lambda (g) - (let* ((fi (get g "feature_image")) - (colour (get g "colour")) - (name (get g "name")) - (initial (slice (or name "?") 0 1)) - (icon (if fi - (~admin/tag-group-icon-image :src fi :name name) - (~admin/tag-group-icon-color - :style (if colour (str "background:" colour) "background:#e7e5e4") - :initial initial)))) - (~admin/tag-group-li - :icon icon - :edit-href (get g "edit_href") - :name name - :slug (or (get g "slug") "") - :sort-order (or (get g "sort_order") 0)))) + :items (map + (lambda + (g) + (let-match + {:colour colour :sort_order sort-order* :feature_image fi :edit_href edit-href :slug slug* :name name} + g + (let* + ((initial (slice (or name "?") 0 1)) + (icon + (if + fi + (~admin/tag-group-icon-image :src fi :name name) + (~admin/tag-group-icon-color + :style (if + colour + (str "background:" colour) + "background:#e7e5e4") + :initial initial)))) + (~admin/tag-group-li + :icon icon + :edit-href edit-href + :name name + :slug (or slug* "") + :sort-order (or sort-order* 0))))) (or groups (list))))) - :unassigned (when (not (empty? (or unassigned-tags (list)))) + :unassigned (when + (not (empty? (or unassigned-tags (list)))) (~admin/unassigned-tags :heading (str (len (or unassigned-tags (list))) " Unassigned Tags") - :spans (map (lambda (t) - (~admin/unassigned-tag :name (get t "name"))) + :spans (map + (lambda (t) (~admin/unassigned-tag :name (get t "name"))) (or unassigned-tags (list))))))) ;; Tag Group Edit — receives serialized tag group + tags from service -(defcomp ~admin/tag-group-edit-content (&key group all-tags save-url delete-url csrf) +(defcomp + ~admin/tag-group-edit-content + (&key group all-tags save-url delete-url csrf) (~admin/tag-group-edit-main - :edit-form (~admin/tag-group-edit-form - :save-url save-url :csrf csrf - :name (get group "name") - :colour (get group "colour") - :sort-order (get group "sort_order") - :feature-image (get group "feature_image") - :tags (map (lambda (t) - (~admin/tag-checkbox - :tag-id (get t "id") - :checked (get t "checked") - :img (when (get t "feature_image") - (~admin/tag-checkbox-image :src (get t "feature_image"))) - :name (get t "name"))) - (or all-tags (list)))) + :edit-form (let-match + {:colour colour :sort_order sort-order :feature_image feature-image :name name} + group + (~admin/tag-group-edit-form + :save-url save-url + :csrf csrf + :name name + :colour colour + :sort-order sort-order + :feature-image feature-image + :tags (map + (lambda + (t) + (let-match + {:checked checked :feature_image t-feature-image :id tag-id :name t-name} + t + (~admin/tag-checkbox + :tag-id tag-id + :checked checked + :img (when + t-feature-image + (~admin/tag-checkbox-image :src t-feature-image)) + :name t-name))) + (or all-tags (list))))) :delete-form (~admin/tag-group-delete-form :delete-url delete-url :csrf csrf))) ;; --------------------------------------------------------------------------- @@ -400,31 +524,54 @@ (code value) value)))) -(defcomp ~admin/data-scalar-table (&key columns) - (div :class "w-full overflow-x-auto sm:overflow-visible" - (table :class "w-full table-fixed text-sm border border-neutral-200 rounded-xl overflow-hidden" - (thead :class "bg-neutral-50/70" - (tr (th :class "px-3 py-2 text-left font-medium w-40 sm:w-56" "Field") - (th :class "px-3 py-2 text-left font-medium" "Value"))) +(defcomp + ~admin/data-scalar-table + (&key columns) + (div + :class "w-full overflow-x-auto sm:overflow-visible" + (table + :class "w-full table-fixed text-sm border border-neutral-200 rounded-xl overflow-hidden" + (thead + :class "bg-neutral-50/70" + (tr + (th :class "px-3 py-2 text-left font-medium w-40 sm:w-56" "Field") + (th :class "px-3 py-2 text-left font-medium" "Value"))) (tbody - (map (lambda (col) - (tr :class "border-t border-neutral-200 align-top" - (td :class "px-3 py-2 whitespace-nowrap text-neutral-600 align-top" (get col "key")) - (td :class "px-3 py-2 align-top" - (~admin/data-value-cell :value (get col "value") :value-type (get col "type"))))) + (map + (lambda + (col) + (let-match + {:value value :key key :type type} + col + (tr + :class "border-t border-neutral-200 align-top" + (td :class "px-3 py-2 whitespace-nowrap text-neutral-600" key) + (td + :class "px-3 py-2 align-top" + (~admin/data-value-cell :value value :value-type type))))) (or columns (list))))))) -(defcomp ~admin/data-relationship-item (&key index summary children) - (tr :class "border-t border-neutral-200 align-top" +(defcomp + ~admin/data-relationship-item + (&key index summary children) + (tr + :class "border-t border-neutral-200 align-top" (td :class "px-2 py-1 whitespace-nowrap align-top" (str index)) - (td :class "px-2 py-1 align-top" - (pre :class "whitespace-pre-wrap break-words break-all text-xs" + (td + :class "px-2 py-1 align-top" + (pre + :class "whitespace-pre-wrap break-words break-all text-xs" (code summary)) - (when children - (div :class "mt-2 pl-3 border-l border-neutral-200" - (~admin/data-model-content - :columns (get children "columns") - :relationships (get children "relationships"))))))) + (when + children + (div + :class "mt-2 pl-3 border-l border-neutral-200" + (let-match + {:relationships relationships :columns columns} + children + (~admin/data-model-content + :columns columns + :relationships relationships))))))) (defcomp ~admin/data-relationship (&key name cardinality class-name loaded value) (div :class "rounded-xl border border-neutral-200" @@ -463,29 +610,50 @@ :columns (get (get value "children") "columns") :relationships (get (get value "children") "relationships")))))))))) -(defcomp ~admin/data-model-content (&key columns relationships) - (div :class "space-y-4" +(defcomp + ~admin/data-model-content + (&key columns relationships) + (div + :class "space-y-4" (~admin/data-scalar-table :columns columns) - (when (not (empty? (or relationships (list)))) - (div :class "space-y-3" - (map (lambda (rel) - (~admin/data-relationship - :name (get rel "name") - :cardinality (get rel "cardinality") - :class-name (get rel "class_name") - :loaded (get rel "loaded") - :value (get rel "value"))) + (when + (not (empty? (or relationships (list)))) + (div + :class "space-y-3" + (map + (lambda + (rel) + (let-match + {:cardinality cardinality :class_name class-name :loaded loaded :value value :name name} + rel + (~admin/data-relationship + :name name + :cardinality cardinality + :class-name class-name + :loaded loaded + :value value))) relationships))))) -(defcomp ~admin/data-table-content (&key tablename model-data) - (if (not model-data) +(defcomp + ~admin/data-table-content + (&key tablename model-data) + (if + (not model-data) (div :class "px-4 py-8 text-stone-400" "No post data available.") - (div :class "px-4 py-8" - (div :class "mb-6 text-sm text-neutral-500" - "Model: " (code "Post") " \u2022 Table: " (code tablename)) - (~admin/data-model-content - :columns (get model-data "columns") - :relationships (get model-data "relationships"))))) + (div + :class "px-4 py-8" + (div + :class "mb-6 text-sm text-neutral-500" + "Model: " + (code "Post") + " • Table: " + (code tablename)) + (let-match + {:relationships relationships :columns columns} + model-data + (~admin/data-model-content + :columns columns + :relationships relationships))))) ;; --------------------------------------------------------------------------- ;; Calendar month view for browsing/toggling entries (B1) @@ -518,59 +686,117 @@ :sx-on:afterSwap "document.body.dispatchEvent(new CustomEvent('entryToggled'))" (span :class "truncate block" name))) -(defcomp ~admin/calendar-view (&key cal-id year month-name - current-url prev-month-url prev-year-url - next-month-url next-year-url - weekday-names days csrf) - (let* ((target (str "#calendar-view-" cal-id))) - (div :id (str "calendar-view-" cal-id) - :sx-get current-url :sx-trigger "entryToggled from:body" :sx-swap "outerHTML" - (header :class "flex items-center justify-center mb-4" - (nav :class "flex items-center gap-2 text-xl" - (a :class "px-2 py-1 hover:bg-stone-100 rounded" - :sx-get prev-year-url :sx-target target :sx-swap "outerHTML" +(defcomp + ~admin/calendar-view + (&key + cal-id + year + month-name + current-url + prev-month-url + prev-year-url + next-month-url + next-year-url + weekday-names + days + csrf) + (let* + ((target (str "#calendar-view-" cal-id))) + (div + :id (str "calendar-view-" cal-id) + :sx-get current-url + :sx-trigger "entryToggled from:body" + :sx-swap "outerHTML" + (header + :class "flex items-center justify-center mb-4" + (nav + :class "flex items-center gap-2 text-xl" + (a + :class "px-2 py-1 hover:bg-stone-100 rounded" + :sx-get prev-year-url + :sx-target target + :sx-swap "outerHTML" (raw! "«")) - (a :class "px-2 py-1 hover:bg-stone-100 rounded" - :sx-get prev-month-url :sx-target target :sx-swap "outerHTML" + (a + :class "px-2 py-1 hover:bg-stone-100 rounded" + :sx-get prev-month-url + :sx-target target + :sx-swap "outerHTML" (raw! "‹")) (div :class "px-3 font-medium" (str month-name " " year)) - (a :class "px-2 py-1 hover:bg-stone-100 rounded" - :sx-get next-month-url :sx-target target :sx-swap "outerHTML" + (a + :class "px-2 py-1 hover:bg-stone-100 rounded" + :sx-get next-month-url + :sx-target target + :sx-swap "outerHTML" (raw! "›")) - (a :class "px-2 py-1 hover:bg-stone-100 rounded" - :sx-get next-year-url :sx-target target :sx-swap "outerHTML" + (a + :class "px-2 py-1 hover:bg-stone-100 rounded" + :sx-get next-year-url + :sx-target target + :sx-swap "outerHTML" (raw! "»")))) - (div :class "rounded border bg-white" - (div :class "hidden sm:grid grid-cols-7 text-center text-xs font-semibold text-stone-700 bg-stone-50 border-b" - (map (lambda (wd) (div :class "py-2" wd)) (or weekday-names (list)))) - (div :class "grid grid-cols-1 sm:grid-cols-7 gap-px bg-stone-200" - (map (lambda (day) - (let* ((extra-cls (if (get day "in_month") "" " bg-stone-50 text-stone-400")) - (entries (or (get day "entries") (list)))) - (div :class (str "min-h-20 bg-white px-2 py-2 text-xs" extra-cls) - (div :class "font-medium mb-1" (str (get day "day"))) - (when (not (empty? entries)) - (div :class "space-y-0.5" - (map (lambda (e) - (if (get e "is_associated") - (~admin/cal-entry-associated - :name (get e "name") :toggle-url (get e "toggle_url") :csrf csrf) - (~admin/cal-entry-unassociated - :name (get e "name") :toggle-url (get e "toggle_url") :csrf csrf))) - entries)))))) + (div + :class "rounded border bg-white" + (div + :class "hidden sm:grid grid-cols-7 text-center text-xs font-semibold text-stone-700 bg-stone-50 border-b" + (map + (lambda (wd) (div :class "py-2" wd)) + (or weekday-names (list)))) + (div + :class "grid grid-cols-1 sm:grid-cols-7 gap-px bg-stone-200" + (map + (lambda + (day) + (let-match + {:entries entries* :in_month in-month :day day-num} + day + (let* + ((extra-cls (if in-month "" " bg-stone-50 text-stone-400")) + (entries (or entries* (list)))) + (div + :class (str "min-h-20 bg-white px-2 py-2 text-xs" extra-cls) + (div :class "font-medium mb-1" (str day-num)) + (when + (not (empty? entries)) + (div + :class "space-y-0.5" + (map + (lambda + (e) + (let-match + {:is_associated is-associated :toggle_url toggle-url :name name} + e + (if + is-associated + (~admin/cal-entry-associated + :name name + :toggle-url toggle-url + :csrf csrf) + (~admin/cal-entry-unassociated + :name name + :toggle-url toggle-url + :csrf csrf)))) + entries))))))) (or days (list)))))))) ;; --------------------------------------------------------------------------- ;; Nav entries OOB — renders associated entry/calendar items in scroll wrapper (B2) ;; --------------------------------------------------------------------------- -(defcomp ~admin/nav-entries-oob (&key entries calendars) - (let* ((entry-list (or entries (list))) - (cal-list (or calendars (list))) - (has-items (or (not (empty? entry-list)) (not (empty? cal-list)))) - (nav-cls "justify-center cursor-pointer flex flex-row items-center gap-2 rounded bg-stone-200 text-black [.hover-capable_&]:hover:bg-yellow-300 aria-selected:bg-stone-500 aria-selected:text-white [.hover-capable_&[aria-selected=true]:hover]:bg-orange-500 p-2") - (scroll-hs "on load or scroll if window.innerWidth >= 640 and my.scrollWidth > my.clientWidth remove .hidden from .entries-nav-arrow add .flex to .entries-nav-arrow else add .hidden to .entries-nav-arrow remove .flex from .entries-nav-arrow end")) - (if (not has-items) +(defcomp + ~admin/nav-entries-oob + (&key entries calendars) + (let* + ((entry-list (or entries (list))) + (cal-list (or calendars (list))) + (has-items (or (not (empty? entry-list)) (not (empty? cal-list)))) + (nav-cls + "justify-center cursor-pointer flex flex-row items-center gap-2 rounded bg-stone-200 text-black [.hover-capable_&]:hover:bg-yellow-300 aria-selected:bg-stone-500 aria-selected:text-white [.hover-capable_&[aria-selected=true]:hover]:bg-orange-500 p-2") + (scroll-hs + "on load or scroll if window.innerWidth >= 640 and my.scrollWidth > my.clientWidth remove .hidden from .entries-nav-arrow add .flex to .entries-nav-arrow else add .hidden to .entries-nav-arrow remove .flex from .entries-nav-arrow end")) + (if + (not has-items) (~shared:nav/blog-nav-entries-empty) (~shared:misc/scroll-nav-wrapper :wrapper-id "entries-calendars-nav-wrapper" @@ -580,14 +806,27 @@ :scroll-hs scroll-hs :right-hs "on click set #associated-items-container.scrollLeft to #associated-items-container.scrollLeft + 200" :items (<> - (map (lambda (e) - (~shared:navigation/calendar-entry-nav - :href (get e "href") :nav-class nav-cls - :name (get e "name") :date-str (get e "date_str"))) + (map + (lambda + (e) + (let-match + {:href href :date_str date-str :name name} + e + (~shared:navigation/calendar-entry-nav + :href href + :nav-class nav-cls + :name name + :date-str date-str))) entry-list) - (map (lambda (c) - (~shared:nav/blog-nav-calendar-item - :href (get c "href") :nav-cls nav-cls - :name (get c "name"))) + (map + (lambda + (c) + (let-match + {:href href :name name} + c + (~shared:nav/blog-nav-calendar-item + :href href + :nav-cls nav-cls + :name name))) cal-list)) :oob true)))) diff --git a/events/sx/entries.sx b/events/sx/entries.sx index d85046f5..73790f31 100644 --- a/events/sx/entries.sx +++ b/events/sx/entries.sx @@ -159,91 +159,147 @@ :btn (~page/tw-plus)))))) ;; Entry card (list view) from data -(defcomp ~entries/entry-card-from-data (&key entry-href name day-href - page-badge-href page-badge-title cal-name - date-str start-time end-time is-page-scoped - cost has-ticket ticket-data) +(defcomp + ~entries/entry-card-from-data + (&key + entry-href + name + day-href + page-badge-href + page-badge-title + cal-name + date-str + start-time + end-time + is-page-scoped + cost + has-ticket + ticket-data) (~entries/entry-card - :title (if entry-href + :title (if + entry-href (~entries/entry-title-linked :href entry-href :name name) (~entries/entry-title-plain :name name)) :badges (<> - (when page-badge-title - (~entries/entry-page-badge :href page-badge-href :title page-badge-title)) - (when cal-name - (~entries/entry-cal-badge :name cal-name))) + (when + page-badge-title + (~entries/entry-page-badge + :href page-badge-href + :title page-badge-title)) + (when cal-name (~entries/entry-cal-badge :name cal-name))) :time-parts (<> - (when (and day-href (not is-page-scoped)) + (when + (and day-href (not is-page-scoped)) (~entries/entry-time-linked :href day-href :date-str date-str)) - (when (and (not day-href) (not is-page-scoped) date-str) + (when + (and (not day-href) (not is-page-scoped) date-str) (~entries/entry-time-plain :date-str date-str)) start-time - (when end-time (str " \u2013 " end-time))) + (when end-time (str " – " end-time))) :cost (when cost (~entries/entry-cost :cost cost)) - :widget (when has-ticket - (~entries/entry-widget-wrapper - :widget (~entries/tw-widget-from-data - :entry-id (get ticket-data "entry-id") - :price (get ticket-data "price") - :qty (get ticket-data "qty") - :ticket-url (get ticket-data "ticket-url") - :csrf (get ticket-data "csrf")))))) + :widget (when + has-ticket + (let-match + {:csrf csrf :entry-id entry-id :qty qty :price price :ticket-url ticket-url} + ticket-data + (~entries/entry-widget-wrapper + :widget (~entries/tw-widget-from-data + :entry-id entry-id + :price price + :qty qty + :ticket-url ticket-url + :csrf csrf)))))) ;; Entry card (tile view) from data -(defcomp ~entries/entry-card-tile-from-data (&key entry-href name day-href - page-badge-href page-badge-title cal-name - date-str time-str - cost has-ticket ticket-data) +(defcomp + ~entries/entry-card-tile-from-data + (&key + entry-href + name + day-href + page-badge-href + page-badge-title + cal-name + date-str + time-str + cost + has-ticket + ticket-data) (~entries/entry-card-tile - :title (if entry-href + :title (if + entry-href (~entries/entry-title-tile-linked :href entry-href :name name) (~entries/entry-title-tile-plain :name name)) :badges (<> - (when page-badge-title - (~entries/entry-page-badge :href page-badge-href :title page-badge-title)) - (when cal-name - (~entries/entry-cal-badge :name cal-name))) + (when + page-badge-title + (~entries/entry-page-badge + :href page-badge-href + :title page-badge-title)) + (when cal-name (~entries/entry-cal-badge :name cal-name))) :time time-str :cost (when cost (~entries/entry-cost :cost cost)) - :widget (when has-ticket - (~entries/entry-tile-widget-wrapper - :widget (~entries/tw-widget-from-data - :entry-id (get ticket-data "entry-id") - :price (get ticket-data "price") - :qty (get ticket-data "qty") - :ticket-url (get ticket-data "ticket-url") - :csrf (get ticket-data "csrf")))))) + :widget (when + has-ticket + (let-match + {:csrf csrf :entry-id entry-id :qty qty :price price :ticket-url ticket-url} + ticket-data + (~entries/entry-tile-widget-wrapper + :widget (~entries/tw-widget-from-data + :entry-id entry-id + :price price + :qty qty + :ticket-url ticket-url + :csrf csrf)))))) ;; Entry cards list (with date separators + sentinel) from data -(defcomp ~entries/entry-cards-from-data (&key items view page has-more next-url) +(defcomp + ~entries/entry-cards-from-data + (&key items view page has-more next-url) (<> - (map (lambda (item) - (if (get item "is-separator") - (~entries/date-separator :date-str (get item "date-str")) - (if (= view "tile") - (~entries/entry-card-tile-from-data - :entry-href (get item "entry-href") :name (get item "name") - :day-href (get item "day-href") - :page-badge-href (get item "page-badge-href") - :page-badge-title (get item "page-badge-title") - :cal-name (get item "cal-name") - :date-str (get item "date-str") :time-str (get item "time-str") - :cost (get item "cost") :has-ticket (get item "has-ticket") - :ticket-data (get item "ticket-data")) - (~entries/entry-card-from-data - :entry-href (get item "entry-href") :name (get item "name") - :day-href (get item "day-href") - :page-badge-href (get item "page-badge-href") - :page-badge-title (get item "page-badge-title") - :cal-name (get item "cal-name") - :date-str (get item "date-str") - :start-time (get item "start-time") :end-time (get item "end-time") - :is-page-scoped (get item "is-page-scoped") - :cost (get item "cost") :has-ticket (get item "has-ticket") - :ticket-data (get item "ticket-data"))))) + (map + (lambda + (item) + (let-match + {:date-str date-str :time-str time-str :has-ticket has-ticket :is-separator is-separator :ticket-data ticket-data :day-href day-href :page-badge-title page-badge-title :entry-href entry-href :start-time start-time :end-time end-time :is-page-scoped is-page-scoped :page-badge-href page-badge-href :cal-name cal-name :cost cost :name name} + item + (if + is-separator + (~entries/date-separator :date-str date-str) + (if + (= view "tile") + (~entries/entry-card-tile-from-data + :entry-href entry-href + :name name + :day-href day-href + :page-badge-href page-badge-href + :page-badge-title page-badge-title + :cal-name cal-name + :date-str date-str + :time-str time-str + :cost cost + :has-ticket has-ticket + :ticket-data ticket-data) + (~entries/entry-card-from-data + :entry-href entry-href + :name name + :day-href day-href + :page-badge-href page-badge-href + :page-badge-title page-badge-title + :cal-name cal-name + :date-str date-str + :start-time start-time + :end-time end-time + :is-page-scoped is-page-scoped + :cost cost + :has-ticket has-ticket + :ticket-data ticket-data))))) (or items (list))) - (when has-more - (~shared:misc/sentinel-simple :id (str "sentinel-" page) :next-url next-url)))) + (when + has-more + (~shared:misc/sentinel-simple + :id (str "sentinel-" page) + :next-url next-url)))) ;; Events main panel (toggle + cards grid) from data (defcomp ~entries/main-panel-from-data (&key toggle items view page has-more next-url) diff --git a/events/sx/forms.sx b/events/sx/forms.sx index c3cab5ac..b1ab34d5 100644 --- a/events/sx/forms.sx +++ b/events/sx/forms.sx @@ -323,28 +323,43 @@ ;; --------------------------------------------------------------------------- ;; Day checkboxes from data — replaces Python loop -(defcomp ~forms/day-checkboxes-from-data (&key days-data all-checked) +(defcomp + ~forms/day-checkboxes-from-data + (&key days-data all-checked) (<> (~forms/day-all-checkbox :checked (when all-checked "checked")) - (map (lambda (d) - (~forms/day-checkbox - :name (get d "name") - :label (get d "label") - :checked (when (get d "checked") "checked"))) + (map + (lambda + (d) + (let-match + {:checked checked :label label :name name} + d + (~forms/day-checkbox + :name name + :label label + :checked (when checked "checked")))) (or days-data (list))))) ;; Slot options from data — replaces _slot_options_html Python loop -(defcomp ~forms/slot-options-from-data (&key slots) - (<> (map (lambda (s) - (~forms/slot-option - :value (get s "value") - :data-start (get s "data-start") - :data-end (get s "data-end") - :data-flexible (get s "data-flexible") - :data-cost (get s "data-cost") - :selected (get s "selected") - :label (get s "label"))) - (or slots (list))))) +(defcomp + ~forms/slot-options-from-data + (&key slots) + (<> + (map + (lambda + (s) + (let-match + {:data-end data-end :data-flexible data-flexible :selected selected :value value :data-cost data-cost :label label :data-start data-start} + s + (~forms/slot-option + :value value + :data-start data-start + :data-end data-end + :data-flexible data-flexible + :data-cost data-cost + :selected selected + :label label))) + (or slots (list))))) ;; Slot picker from data — wraps picker + options (defcomp ~forms/slot-picker-from-data (&key id slots) diff --git a/events/sx/layouts.sx b/events/sx/layouts.sx index 2fde1a11..5cdf2e2c 100644 --- a/events/sx/layouts.sx +++ b/events/sx/layouts.sx @@ -5,155 +5,247 @@ ;; Auto-fetching header macros — calendar, day, entry, slot, tickets ;; --------------------------------------------------------------------------- -(defmacro ~events-calendar-header-auto (oob) +(defmacro + ~events-calendar-header-auto + (oob) "Calendar header row using (events-calendar-ctx)." (quasiquote - (let ((__cal (events-calendar-ctx)) - (__sc (select-colours))) - (when (get __cal "slug") - (~shared:layout/menu-row-sx :id "calendar-row" :level 3 - :link-href (url-for "calendar.get" - :calendar-slug (get __cal "slug")) - :link-label-content (~header/calendar-label - :name (get __cal "name") - :description (get __cal "description")) - :nav (<> - (~shared:layout/nav-link :href (url-for "defpage_slots_listing" - :calendar-slug (get __cal "slug")) - :icon "fa fa-clock" :label "Slots" - :select-colours __sc) - (let ((__rights (app-rights))) - (when (get __rights "admin") - (~shared:layout/nav-link :href (url-for "defpage_calendar_admin" - :calendar-slug (get __cal "slug")) - :icon "fa fa-cog" - :select-colours __sc)))) - :child-id "calendar-header-child" - :oob (unquote oob)))))) + (let + ((__cal (events-calendar-ctx)) (__sc (select-colours))) + (let-match + {:description description :slug slug :name name} + __cal + (when + slug + (~shared:layout/menu-row-sx + :id "calendar-row" + :level 3 + :link-href (url-for "calendar.get" :calendar-slug slug) + :link-label-content (~header/calendar-label :name name :description description) + :nav (<> + (~shared:layout/nav-link + :href (url-for "defpage_slots_listing" :calendar-slug slug) + :icon "fa fa-clock" + :label "Slots" + :select-colours __sc) + (let + ((__rights (app-rights))) + (when + (get __rights "admin") + (~shared:layout/nav-link + :href (url-for "defpage_calendar_admin" :calendar-slug slug) + :icon "fa fa-cog" + :select-colours __sc)))) + :child-id "calendar-header-child" + :oob (unquote oob))))))) -(defmacro ~events-calendar-admin-header-auto (oob) +(defmacro + ~events-calendar-admin-header-auto + (oob) "Calendar admin header row." (quasiquote - (let ((__cal (events-calendar-ctx)) - (__sc (select-colours))) - (when (get __cal "slug") - (~shared:layout/menu-row-sx :id "calendar-admin-row" :level 4 - :link-label "admin" :icon "fa fa-cog" - :nav (<> - (~shared:layout/nav-link :href (url-for "defpage_slots_listing" - :calendar-slug (get __cal "slug")) - :label "slots" :select-colours __sc) - (~shared:layout/nav-link :href (url-for "calendar.admin.calendar_description_edit" - :calendar-slug (get __cal "slug")) - :label "description" :select-colours __sc)) - :child-id "calendar-admin-header-child" - :oob (unquote oob)))))) + (let + ((__cal (events-calendar-ctx)) (__sc (select-colours))) + (let-match + {:slug slug} + __cal + (when + slug + (~shared:layout/menu-row-sx + :id "calendar-admin-row" + :level 4 + :link-label "admin" + :icon "fa fa-cog" + :nav (<> + (~shared:layout/nav-link + :href (url-for "defpage_slots_listing" :calendar-slug slug) + :label "slots" + :select-colours __sc) + (~shared:layout/nav-link + :href (url-for + "calendar.admin.calendar_description_edit" + :calendar-slug slug) + :label "description" + :select-colours __sc)) + :child-id "calendar-admin-header-child" + :oob (unquote oob))))))) -(defmacro ~events-day-header-auto (oob) +(defmacro + ~events-day-header-auto + (oob) "Day header row using (events-day-ctx)." (quasiquote - (let ((__day (events-day-ctx)) - (__cal (events-calendar-ctx))) - (when (get __day "date-str") - (~shared:layout/menu-row-sx :id "day-row" :level 4 - :link-href (url-for "calendar.day.show_day" - :calendar-slug (get __cal "slug") - :year (get __day "year") - :month (get __day "month") - :day (get __day "day")) - :link-label-content (~header/day-label - :date-str (get __day "date-str")) - :nav (get __day "nav") - :child-id "day-header-child" - :oob (unquote oob)))))) + (let + ((__day (events-day-ctx)) (__cal (events-calendar-ctx))) + (let-match + {:date-str date-str :nav nav :year year :day day :month month} + __day + (when + date-str + (let-match + {:slug cal-slug} + __cal + (~shared:layout/menu-row-sx + :id "day-row" + :level 4 + :link-href (url-for + "calendar.day.show_day" + :calendar-slug cal-slug + :year year + :month month + :day day) + :link-label-content (~header/day-label :date-str date-str) + :nav nav + :child-id "day-header-child" + :oob (unquote oob)))))))) -(defmacro ~events-day-admin-header-auto (oob) +(defmacro + ~events-day-admin-header-auto + (oob) "Day admin header row." (quasiquote - (let ((__day (events-day-ctx)) - (__cal (events-calendar-ctx))) - (when (get __day "date-str") - (~shared:layout/menu-row-sx :id "day-admin-row" :level 5 - :link-href (url-for "defpage_day_admin" - :calendar-slug (get __cal "slug") - :year (get __day "year") - :month (get __day "month") - :day (get __day "day")) - :link-label "admin" :icon "fa fa-cog" - :child-id "day-admin-header-child" - :oob (unquote oob)))))) + (let + ((__day (events-day-ctx)) (__cal (events-calendar-ctx))) + (let-match + {:date-str date-str :year year :day day :month month} + __day + (when + date-str + (let-match + {:slug cal-slug} + __cal + (~shared:layout/menu-row-sx + :id "day-admin-row" + :level 5 + :link-href (url-for + "defpage_day_admin" + :calendar-slug cal-slug + :year year + :month month + :day day) + :link-label "admin" + :icon "fa fa-cog" + :child-id "day-admin-header-child" + :oob (unquote oob)))))))) -(defmacro ~events-entry-header-auto (oob) +(defmacro + ~events-entry-header-auto + (oob) "Entry header row using (events-entry-ctx)." (quasiquote - (let ((__ectx (events-entry-ctx))) - (when (get __ectx "id") - (~shared:layout/menu-row-sx :id "entry-row" :level 5 - :link-href (get __ectx "link-href") - :link-label-content (~header/entry-label - :entry-id (get __ectx "id") - :title (~admin/entry-title :name (get __ectx "name")) - :times (~admin/entry-times :time-str (get __ectx "time-str"))) - :nav (get __ectx "nav") - :child-id "entry-header-child" - :oob (unquote oob)))))) + (let + ((__ectx (events-entry-ctx))) + (let-match + {:time-str time-str :nav nav :link-href link-href :id id :name name} + __ectx + (when + id + (~shared:layout/menu-row-sx + :id "entry-row" + :level 5 + :link-href link-href + :link-label-content (~header/entry-label + :entry-id id + :title (~admin/entry-title :name name) + :times (~admin/entry-times :time-str time-str)) + :nav nav + :child-id "entry-header-child" + :oob (unquote oob))))))) -(defmacro ~events-entry-admin-header-auto (oob) +(defmacro + ~events-entry-admin-header-auto + (oob) "Entry admin header row." (quasiquote - (let ((__ectx (events-entry-ctx))) - (when (get __ectx "id") - (~shared:layout/menu-row-sx :id "entry-admin-row" :level 6 - :link-href (get __ectx "admin-href") - :link-label "admin" :icon "fa fa-cog" - :nav (when (get __ectx "is-admin") - (~shared:layout/nav-link :href (get __ectx "ticket-types-href") - :label "ticket_types" - :select-colours (get __ectx "select-colours"))) - :child-id "entry-admin-header-child" - :oob (unquote oob)))))) + (let + ((__ectx (events-entry-ctx))) + (let-match + {:admin-href admin-href :is-admin is-admin :ticket-types-href ticket-types-href :select-colours select-colours :id id} + __ectx + (when + id + (~shared:layout/menu-row-sx + :id "entry-admin-row" + :level 6 + :link-href admin-href + :link-label "admin" + :icon "fa fa-cog" + :nav (when + is-admin + (~shared:layout/nav-link + :href ticket-types-href + :label "ticket_types" + :select-colours select-colours)) + :child-id "entry-admin-header-child" + :oob (unquote oob))))))) -(defmacro ~events-slot-header-auto (oob) +(defmacro + ~events-slot-header-auto + (oob) "Slot detail header row using (events-slot-ctx)." (quasiquote - (let ((__slot (events-slot-ctx))) - (when (get __slot "name") - (~shared:layout/menu-row-sx :id "slot-row" :level 5 - :link-label-content (~header/slot-label - :name (get __slot "name") - :description (get __slot "description")) - :child-id "slot-header-child" - :oob (unquote oob)))))) + (let + ((__slot (events-slot-ctx))) + (let-match + {:description description :name name} + __slot + (when + name + (~shared:layout/menu-row-sx + :id "slot-row" + :level 5 + :link-label-content (~header/slot-label :name name :description description) + :child-id "slot-header-child" + :oob (unquote oob))))))) -(defmacro ~events-ticket-types-header-auto (oob) +(defmacro + ~events-ticket-types-header-auto + (oob) "Ticket types header row." (quasiquote - (let ((__ectx (events-entry-ctx)) - (__cal (events-calendar-ctx))) - (when (get __ectx "id") - (~shared:layout/menu-row-sx :id "ticket_types-row" :level 7 - :link-href (get __ectx "ticket-types-href") - :link-label-content (<> - (i :class "fa fa-ticket") - (div :class "shrink-0" "ticket types")) - :nav (~forms/admin-placeholder-nav) - :child-id "ticket_type-header-child" - :oob (unquote oob)))))) + (let + ((__ectx (events-entry-ctx)) (__cal (events-calendar-ctx))) + (let-match + {:ticket-types-href ticket-types-href :id id} + __ectx + (when + id + (~shared:layout/menu-row-sx + :id "ticket_types-row" + :level 7 + :link-href ticket-types-href + :link-label-content (<> + (i :class "fa fa-ticket") + (div :class "shrink-0" "ticket types")) + :nav (~forms/admin-placeholder-nav) + :child-id "ticket_type-header-child" + :oob (unquote oob))))))) -(defmacro ~events-ticket-type-header-auto (oob) +(defmacro + ~events-ticket-type-header-auto + (oob) "Single ticket type header row using (events-ticket-type-ctx)." (quasiquote - (let ((__tt (events-ticket-type-ctx))) - (when (get __tt "id") - (~shared:layout/menu-row-sx :id "ticket_type-row" :level 8 - :link-href (get __tt "link-href") - :link-label-content (div :class "flex flex-col md:flex-row md:gap-2 items-center" - (div :class "flex flex-row items-center gap-2" - (i :class "fa fa-ticket") - (div :class "shrink-0" (get __tt "name")))) - :nav (~forms/admin-placeholder-nav) - :child-id "ticket_type-header-child-inner" - :oob (unquote oob)))))) + (let + ((__tt (events-ticket-type-ctx))) + (let-match + {:link-href link-href :id id :name name} + __tt + (when + id + (~shared:layout/menu-row-sx + :id "ticket_type-row" + :level 8 + :link-href link-href + :link-label-content (div + :class "flex flex-col md:flex-row md:gap-2 items-baseline" + (div + :class "flex flex-row items-center gap-2" + (i :class "fa fa-ticket") + (div :class "shrink-0" name))) + :nav (~forms/admin-placeholder-nav) + :child-id "ticket_type-header-child-inner" + :oob (unquote oob))))))) (defmacro ~events-markets-header-auto (oob) "Markets section header row." diff --git a/events/sx/page.sx b/events/sx/page.sx index f0c3fe19..ba868005 100644 --- a/events/sx/page.sx +++ b/events/sx/page.sx @@ -98,24 +98,47 @@ (~page/slot-description-oob :description (or description ""))))) ;; Slots table from data -(defcomp ~page/slots-table-from-data (&key list-container slots pre-action add-url - tr-cls pill-cls action-btn hx-select csrf-hdr) +(defcomp + ~page/slots-table-from-data + (&key + list-container + slots + pre-action + add-url + tr-cls + pill-cls + action-btn + hx-select + csrf-hdr) (~page/slots-table :list-container list-container - :rows (if (empty? (or slots (list))) + :rows (if + (empty? (or slots (list))) (~page/slots-empty-row) - (<> (map (lambda (s) - (~page/slots-row - :tr-cls tr-cls :slot-href (get s "slot-href") - :pill-cls pill-cls :hx-select hx-select - :slot-name (get s "slot-name") :description (get s "description") - :flexible (get s "flexible") - :days (~page/days-pills-from-data :days (get s "days")) - :time-str (get s "time-str") - :cost-str (get s "cost-str") :action-btn action-btn - :del-url (get s "del-url") :csrf-hdr csrf-hdr)) - (or slots (list))))) - :pre-action pre-action :add-url add-url)) + (<> + (map + (lambda + (s) + (let-match + {:slot-name slot-name :time-str time-str :flexible flexible :description description :days days :cost-str cost-str :del-url del-url :slot-href slot-href} + s + (~page/slots-row + :tr-cls tr-cls + :slot-href slot-href + :pill-cls pill-cls + :hx-select hx-select + :slot-name slot-name + :description description + :flexible flexible + :days (~page/days-pills-from-data :days days) + :time-str time-str + :cost-str cost-str + :action-btn action-btn + :del-url del-url + :csrf-hdr csrf-hdr))) + (or slots (list))))) + :pre-action pre-action + :add-url add-url)) (defcomp ~page/ticket-type-col (&key label value) (div :class "flex flex-col" @@ -203,47 +226,87 @@ :onclick hide-js "Cancel")))) ;; Data-driven buy form — Python passes pre-resolved data, .sx does layout + iteration -(defcomp ~page/buy-form (&key entry-id info-sold info-remaining info-basket - ticket-types user-ticket-counts-by-type - user-ticket-count price-str adjust-url csrf state - my-tickets-href) - (if (!= state "confirmed") +(defcomp + ~page/buy-form + (&key + entry-id + info-sold + info-remaining + info-basket + ticket-types + user-ticket-counts-by-type + user-ticket-count + price-str + adjust-url + csrf + state + my-tickets-href) + (if + (!= state "confirmed") (~page/buy-not-confirmed :entry-id (str entry-id)) - (let ((eid-s (str entry-id)) - (target (str "#ticket-buy-" entry-id))) - (div :id (str "ticket-buy-" entry-id) :class "rounded-xl border border-stone-200 bg-white p-4" - (h3 :class "text-sm font-semibold text-stone-700 mb-3" - (i :class "fa fa-ticket mr-1" :aria-hidden "true") "Tickets") - ;; Info bar - (when (or info-sold info-remaining info-basket) - (div :class "flex items-center gap-3 mb-3 text-xs text-stone-500" + (let + ((eid-s (str entry-id)) (target (str "#ticket-buy-" entry-id))) + (div + :id (str "ticket-buy-" entry-id) + :class "rounded-xl border border-stone-200 bg-white p-4" + (h3 + :class "text-sm font-semibold text-stone-700 mb-3" + (i :class "fa fa-ticket mr-1" :aria-hidden "true") + "Tickets") + (when + (or info-sold info-remaining info-basket) + (div + :class "flex items-center gap-3 mb-3 text-xs text-stone-500" (when info-sold (span (str info-sold " sold"))) (when info-remaining (span (str info-remaining " remaining"))) - (when info-basket - (span :class "text-emerald-600 font-medium" - (i :class "fa fa-shopping-cart text-[0.6rem]" :aria-hidden "true") + (when + info-basket + (span + :class "text-emerald-600 font-medium" + (i + :class "fa fa-shopping-cart text-[0.6rem]" + :aria-hidden "true") (str " " info-basket " in basket"))))) - ;; Body — multi-type or default - (if (and ticket-types (not (empty? ticket-types))) - (div :class "space-y-2" - (map (fn (tt) - (let ((tt-count (if user-ticket-counts-by-type - (get user-ticket-counts-by-type (str (get tt "id")) 0) - 0)) - (tt-id (get tt "id"))) - (div :class "flex items-center justify-between p-3 rounded-lg bg-stone-50 border border-stone-100" - (div (div :class "font-medium text-sm" (get tt "name")) - (div :class "text-xs text-stone-500" (get tt "cost_str"))) - (~page/adjust-inline :csrf csrf :adjust-url adjust-url :target target - :entry-id eid-s :count tt-count :ticket-type-id tt-id - :my-tickets-href my-tickets-href)))) + (if + (and ticket-types (not (empty? ticket-types))) + (div + :class "space-y-2" + (map + (fn + (tt) + (let-match + {:cost_str cost-str :id tt-id :name tt-name} + tt + (let + ((tt-count (if user-ticket-counts-by-type (get user-ticket-counts-by-type (str tt-id) 0) 0))) + (div + :class "flex items-center justify-between p-3 rounded-lg bg-stone-50 border border-stone-100" + (div + (div :class "font-medium text-sm" tt-name) + (div :class "text-xs text-stone-500" cost-str)) + (~page/adjust-inline + :csrf csrf + :adjust-url adjust-url + :target target + :entry-id eid-s + :count tt-count + :ticket-type-id tt-id + :my-tickets-href my-tickets-href))))) ticket-types)) - (<> (div :class "flex items-center justify-between mb-4" - (div (span :class "font-medium text-green-600" price-str) - (span :class "text-sm text-stone-500 ml-2" "per ticket"))) - (~page/adjust-inline :csrf csrf :adjust-url adjust-url :target target - :entry-id eid-s :count (if user-ticket-count user-ticket-count 0) - :ticket-type-id nil :my-tickets-href my-tickets-href))))))) + (<> + (div + :class "flex items-center justify-between mb-4" + (div + (span :class "font-medium text-green-600" price-str) + (span :class "text-sm text-stone-500 ml-2" "per ticket"))) + (~page/adjust-inline + :csrf csrf + :adjust-url adjust-url + :target target + :entry-id eid-s + :count (if user-ticket-count user-ticket-count 0) + :ticket-type-id nil + :my-tickets-href my-tickets-href))))))) ;; Inline +/- controls (used by both default and per-type) (defcomp ~page/adjust-inline (&key csrf adjust-url target entry-id count ticket-type-id my-tickets-href) @@ -285,26 +348,53 @@ "Tickets available once this event is confirmed.")) -(defcomp ~page/buy-result (&key entry-id tickets remaining my-tickets-href) - (let ((count (len tickets)) - (suffix (if (= count 1) "" "s"))) - (div :id (str "ticket-buy-" entry-id) :class "rounded-xl border border-emerald-200 bg-emerald-50 p-4" - (div :class "flex items-center gap-2 mb-3" +(defcomp + ~page/buy-result + (&key entry-id tickets remaining my-tickets-href) + (let + ((count (len tickets)) (suffix (if (= count 1) "" "s"))) + (div + :id (str "ticket-buy-" entry-id) + :class "rounded-xl border border-emerald-200 bg-emerald-50 p-4" + (div + :class "flex items-center gap-2 mb-3" (i :class "fa fa-check-circle text-emerald-600" :aria-hidden "true") - (span :class "font-semibold text-emerald-800" (str count " ticket" suffix " reserved"))) - (div :class "space-y-2 mb-4" - (map (fn (t) - (a :href (get t "href") :class "flex items-center justify-between p-2 rounded-lg bg-white border border-emerald-100 hover:border-emerald-300 transition text-sm" - (div :class "flex items-center gap-2" - (i :class "fa fa-ticket text-emerald-500" :aria-hidden "true") - (span :class "font-mono text-xs text-stone-500" (get t "code_short"))) - (span :class "text-xs text-emerald-600 font-medium" "View ticket"))) + (span + :class "font-semibold text-emerald-800" + (str count " ticket" suffix " reserved"))) + (div + :class "space-y-2 mb-4" + (map + (fn + (t) + (let-match + {:href href :code_short code-short} + t + (a + :href href + :class "flex items-center justify-between p-2 rounded-lg bg-white border border-emerald-100 hover:border-emerald-300 transition text-sm" + (div + :class "flex items-center gap-2" + (i + :class "fa fa-ticket text-emerald-500" + :aria-hidden "true") + (span :class "font-mono text-xs text-stone-500" code-short)) + (span + :class "text-xs text-emerald-600 font-medium" + "View ticket")))) tickets)) - (when (not (nil? remaining)) - (let ((r-suffix (if (= remaining 1) "" "s"))) - (p :class "text-xs text-stone-500" (str remaining " ticket" r-suffix " remaining")))) - (div :class "mt-3 flex gap-2" - (a :href my-tickets-href :class "text-sm text-emerald-700 hover:text-emerald-900 underline" + (when + (not (nil? remaining)) + (let + ((r-suffix (if (= remaining 1) "" "s"))) + (p + :class "text-xs text-stone-500" + (str remaining " ticket" r-suffix " remaining")))) + (div + :class "mt-3 flex gap-2" + (a + :href my-tickets-href + :class "text-sm text-emerald-700 hover:text-emerald-900 underline" "View all my tickets"))))) ;; Single response wrappers for POST routes (include OOB cart icon) @@ -477,27 +567,46 @@ (~page/post-img-placeholder))) ;; Entry posts nav OOB from data -(defcomp ~page/entry-posts-nav-oob-from-data (&key nav-btn posts) - (if (empty? (or posts (list))) +(defcomp + ~page/entry-posts-nav-oob-from-data + (&key nav-btn posts) + (if + (empty? (or posts (list))) (~page/entry-posts-nav-oob-empty) (~page/entry-posts-nav-oob - :items (<> (map (lambda (p) - (~page/entry-nav-post - :href (get p "href") :nav-btn nav-btn - :img (~page/post-img-from-data :src (get p "img") :alt (get p "title")) - :title (get p "title"))) - posts))))) + :items (<> + (map + (lambda + (p) + (let-match + {:href href :title title :img img} + p + (~page/entry-nav-post + :href href + :nav-btn nav-btn + :img (~page/post-img-from-data :src img :alt title) + :title title))) + posts))))) ;; Entry posts nav (non-OOB) from data — for desktop nav embedding -(defcomp ~page/entry-posts-nav-inner-from-data (&key posts) - (when (not (empty? (or posts (list)))) +(defcomp + ~page/entry-posts-nav-inner-from-data + (&key posts) + (when + (not (empty? (or posts (list)))) (~page/entry-posts-nav-oob - :items (<> (map (lambda (p) - (~page/entry-nav-post-link - :href (get p "href") - :img (~page/post-img-from-data :src (get p "img") :alt (get p "title")) - :title (get p "title"))) - posts))))) + :items (<> + (map + (lambda + (p) + (let-match + {:href href :title title :img img} + p + (~page/entry-nav-post-link + :href href + :img (~page/post-img-from-data :src img :alt title) + :title title))) + posts))))) ;; Post nav entries+calendars OOB from data (defcomp ~page/post-nav-wrapper-from-data (&key nav-btn entries calendars hyperscript) @@ -602,14 +711,23 @@ (~shared:layout/nav-link :href admin-href :icon "fa fa-cog")))) ;; Post search results from data -(defcomp ~page/post-search-results-from-data (&key items page next-url has-more) +(defcomp + ~page/post-search-results-from-data + (&key items page next-url has-more) (<> - (map (lambda (item) - (~forms/post-search-item - :post-url (get item "post-url") :entry-id (get item "entry-id") - :csrf (get item "csrf") :post-id (get item "post-id") - :img (~page/post-img-from-data :src (get item "img") :alt (get item "title")) - :title (get item "title"))) + (map + (lambda + (item) + (let-match + {:csrf csrf :entry-id entry-id :post-url post-url :title title :img img :post-id post-id} + item + (~forms/post-search-item + :post-url post-url + :entry-id entry-id + :csrf csrf + :post-id post-id + :img (~page/post-img-from-data :src img :alt title) + :title title))) (or items (list))) (cond (has-more (~forms/post-search-sentinel :page page :next-url next-url)) @@ -617,16 +735,26 @@ (true "")))) ;; Entry options from data — state-driven button composition -(defcomp ~page/entry-options-from-data (&key entry-id state buttons) +(defcomp + ~page/entry-options-from-data + (&key entry-id state buttons) (~admin/entry-options :entry-id entry-id - :buttons (<> (map (lambda (b) - (~admin/entry-option-button - :url (get b "url") :target (str "#calendar_entry_options_" entry-id) - :csrf (get b "csrf") :btn-type (get b "btn-type") - :action-btn (get b "action-btn") - :confirm-title (get b "confirm-title") - :confirm-text (get b "confirm-text") - :label (get b "label") - :is-btn (get b "is-btn"))) - (or buttons (list)))))) + :buttons (<> + (map + (lambda + (b) + (let-match + {:csrf csrf :confirm-title confirm-title :url url :btn-type btn-type :action-btn action-btn :confirm-text confirm-text :label label :is-btn is-btn} + b + (~admin/entry-option-button + :url url + :target (str "#calendar_entry_options_" entry-id) + :csrf csrf + :btn-type btn-type + :action-btn action-btn + :confirm-title confirm-title + :confirm-text confirm-text + :label label + :is-btn is-btn))) + (or buttons (list)))))) diff --git a/events/sx/tickets.sx b/events/sx/tickets.sx index 72cfcbdb..1abc1ba1 100644 --- a/events/sx/tickets.sx +++ b/events/sx/tickets.sx @@ -211,18 +211,28 @@ ;; --------------------------------------------------------------------------- ;; My tickets panel from data -(defcomp ~tickets/panel-from-data (&key (list-container :as string) (tickets :as list?)) +(defcomp + ~tickets/panel-from-data + (&key (list-container :as string) (tickets :as list?)) (~tickets/panel :list-container list-container :has-tickets (not (empty? (or tickets (list)))) - :cards (<> (map (lambda (t) - (~tickets/card - :href (get t "href") :entry-name (get t "entry-name") - :type-name (get t "type-name") :time-str (get t "time-str") - :cal-name (get t "cal-name") - :badge (~entries/ticket-state-badge :state (get t "state")) - :code-prefix (get t "code-prefix"))) - (or tickets (list)))))) + :cards (<> + (map + (lambda + (t) + (let-match + {:time-str time-str :href href :type-name type-name :code-prefix code-prefix :entry-name entry-name :cal-name cal-name :state state} + t + (~tickets/card + :href href + :entry-name entry-name + :type-name type-name + :time-str time-str + :cal-name cal-name + :badge (~entries/ticket-state-badge :state state) + :code-prefix code-prefix))) + (or tickets (list)))))) ;; Ticket detail from data — uses lg badge variant (defcomp ~tickets/detail-from-data (&key (list-container :as string) (back-href :as string) (header-bg :as string) (entry-name :as string) @@ -256,54 +266,106 @@ (true nil)))) ;; Ticket admin panel from data -(defcomp ~tickets/admin-panel-from-data (&key (list-container :as string) (lookup-url :as string) (tickets :as list?) - (total :as number?) (confirmed :as number?) (checked-in :as number?) (reserved :as number?)) +(defcomp + ~tickets/admin-panel-from-data + (&key + (list-container :as string) + (lookup-url :as string) + (tickets :as list?) + (total :as number?) + (confirmed :as number?) + (checked-in :as number?) + (reserved :as number?)) (~tickets/admin-panel :list-container list-container :stats (<> - (~tickets/admin-stat :border "border-stone-200" :bg "" - :text-cls "text-stone-900" :label-cls "text-stone-500" - :value (str (or total 0)) :label "Total") - (~tickets/admin-stat :border "border-emerald-200" :bg "bg-emerald-50" - :text-cls "text-emerald-700" :label-cls "text-emerald-600" - :value (str (or confirmed 0)) :label "Confirmed") - (~tickets/admin-stat :border "border-blue-200" :bg "bg-blue-50" - :text-cls "text-blue-700" :label-cls "text-blue-600" - :value (str (or checked-in 0)) :label "Checked In") - (~tickets/admin-stat :border "border-amber-200" :bg "bg-amber-50" - :text-cls "text-amber-700" :label-cls "text-amber-600" - :value (str (or reserved 0)) :label "Reserved")) + (~tickets/admin-stat + :border "border-stone-200" + :bg "" + :text-cls "text-stone-900" + :label-cls "text-stone-500" + :value (str (or total 0)) + :label "Total") + (~tickets/admin-stat + :border "border-emerald-200" + :bg "bg-emerald-50" + :text-cls "text-emerald-700" + :label-cls "text-emerald-600" + :value (str (or confirmed 0)) + :label "Confirmed") + (~tickets/admin-stat + :border "border-blue-200" + :bg "bg-blue-50" + :text-cls "text-blue-700" + :label-cls "text-blue-600" + :value (str (or checked-in 0)) + :label "Checked In") + (~tickets/admin-stat + :border "border-amber-200" + :bg "bg-amber-50" + :text-cls "text-amber-700" + :label-cls "text-amber-600" + :value (str (or reserved 0)) + :label "Reserved")) :lookup-url lookup-url :has-tickets (not (empty? (or tickets (list)))) - :rows (<> (map (lambda (t) - (~tickets/admin-row-from-data - :code (get t "code") :code-short (get t "code-short") - :entry-name (get t "entry-name") :date-str (get t "date-str") - :type-name (get t "type-name") :state (get t "state") - :checkin-url (get t "checkin-url") :csrf (get t "csrf") - :checked-in-time (get t "checked-in-time"))) - (or tickets (list)))))) + :rows (<> + (map + (lambda + (t) + (let-match + {:date-str date-str :csrf csrf :type-name type-name :code-short code-short :entry-name entry-name :code code :checkin-url checkin-url :checked-in-time checked-in-time :state state} + t + (~tickets/admin-row-from-data + :code code + :code-short code-short + :entry-name entry-name + :date-str date-str + :type-name type-name + :state state + :checkin-url checkin-url + :csrf csrf + :checked-in-time checked-in-time))) + (or tickets (list)))))) ;; Entry tickets admin from data -(defcomp ~tickets/entry-tickets-admin-from-data (&key (entry-name :as string) (count-label :as string) (tickets :as list?) (csrf :as string)) +(defcomp + ~tickets/entry-tickets-admin-from-data + (&key + (entry-name :as string) + (count-label :as string) + (tickets :as list?) + (csrf :as string)) (~tickets/entry-tickets-admin-panel - :entry-name entry-name :count-label count-label - :body (if (empty? (or tickets (list))) + :entry-name entry-name + :count-label count-label + :body (if + (empty? (or tickets (list))) (~tickets/entry-tickets-admin-empty) (~tickets/entry-tickets-admin-table - :rows (<> (map (lambda (t) - (~tickets/entry-tickets-admin-row - :code (get t "code") :code-short (get t "code-short") - :type-name (get t "type-name") - :badge (~entries/ticket-state-badge :state (get t "state")) - :action (cond - ((or (= (get t "state") "confirmed") (= (get t "state") "reserved")) - (~tickets/entry-tickets-admin-checkin - :checkin-url (get t "checkin-url") :code (get t "code") :csrf csrf)) - ((= (get t "state") "checked_in") - (~tickets/admin-checked-in :time-str (or (get t "checked-in-time") ""))) - (true nil)))) - (or tickets (list)))))))) + :rows (<> + (map + (lambda + (t) + (let-match + {:type-name type-name :code-short code-short :code code :checkin-url checkin-url :checked-in-time checked-in-time :state state} + t + (~tickets/entry-tickets-admin-row + :code code + :code-short code-short + :type-name type-name + :badge (~entries/ticket-state-badge :state state) + :action (cond + ((or (= state "confirmed") (= state "paid")) + (~tickets/entry-tickets-admin-checkin + :checkin-url checkin-url + :code code + :csrf csrf)) + ((= state "checked-in") + (~tickets/admin-checked-in + :time-str (or checked-in-time ""))) + (true nil))))) + (or tickets (list)))))))) ;; Checkin success row from data (defcomp ~tickets/checkin-success-row-from-data (&key (code :as string) (code-short :as string) (entry-name :as string) (date-str :as string?) (type-name :as string) (time-str :as string)) @@ -316,21 +378,43 @@ :time-str time-str)) ;; Ticket types table from data -(defcomp ~tickets/types-table-from-data (&key (list-container :as string) (ticket-types :as list?) (action-btn :as string) (add-url :as string) - (tr-cls :as string) (pill-cls :as string) (hx-select :as string) (csrf-hdr :as string)) +(defcomp + ~tickets/types-table-from-data + (&key + (list-container :as string) + (ticket-types :as list?) + (action-btn :as string) + (add-url :as string) + (tr-cls :as string) + (pill-cls :as string) + (hx-select :as string) + (csrf-hdr :as string)) (~page/ticket-types-table :list-container list-container - :rows (if (empty? (or ticket-types (list))) + :rows (if + (empty? (or ticket-types (list))) (~page/ticket-types-empty-row) - (<> (map (lambda (tt) - (~page/ticket-types-row - :tr-cls tr-cls :tt-href (get tt "tt-href") - :pill-cls pill-cls :hx-select hx-select - :tt-name (get tt "tt-name") :cost-str (get tt "cost-str") - :count (get tt "count") :action-btn action-btn - :del-url (get tt "del-url") :csrf-hdr csrf-hdr)) - (or ticket-types (list))))) - :action-btn action-btn :add-url add-url)) + (<> + (map + (lambda + (tt) + (let-match + {:tt-href tt-href :count count :cost-str cost-str :tt-name tt-name :del-url del-url} + tt + (~page/ticket-types-row + :tr-cls tr-cls + :tt-href tt-href + :pill-cls pill-cls + :hx-select hx-select + :tt-name tt-name + :cost-str cost-str + :count count + :action-btn action-btn + :del-url del-url + :csrf-hdr csrf-hdr))) + (or ticket-types (list))))) + :action-btn action-btn + :add-url add-url)) ;; Lookup result from data (defcomp ~tickets/lookup-result-from-data (&key (entry-name :as string) (type-name :as string?) (date-str :as string?) (cal-name :as string?) diff --git a/federation/sx/social.sx b/federation/sx/social.sx index f89c0d15..1fbeca40 100644 --- a/federation/sx/social.sx +++ b/federation/sx/social.sx @@ -92,52 +92,95 @@ ;; --- Data-driven post card (replaces Python _post_card_sx loop) --- -(defcomp ~social/post-card-from-data (&key (d :as dict) (has-actor :as boolean) (csrf :as string) - (like-url :as string) (unlike-url :as string) - (boost-url :as string) (unboost-url :as string)) - (let* ((boosted-by (get d "boosted_by")) - (actor-icon (get d "actor_icon")) - (actor-name (get d "actor_name")) - (initial (or (get d "initial") "?")) - (avatar (~shared:misc/avatar - :src actor-icon - :cls (if actor-icon "w-10 h-10 rounded-full" - "w-10 h-10 rounded-full bg-stone-300 flex items-center justify-center text-stone-600 font-bold text-sm") - :initial (when (not actor-icon) initial))) - (boost (when boosted-by (~social/boost-label :name boosted-by))) - (content-sx (if (get d "summary") - (~social/content :content (get d "content") :summary (get d "summary")) - (~social/content :content (get d "content")))) - (original (when (get d "original_url") - (~social/original-link :url (get d "original_url")))) - (safe-id (get d "safe_id")) - (interactions (when has-actor - (let* ((oid (get d "object_id")) - (ainbox (get d "author_inbox")) - (target (str "#interactions-" safe-id)) - (liked (get d "liked_by_me")) - (boosted-me (get d "boosted_by_me")) - (l-action (if liked unlike-url like-url)) - (l-cls (str "flex items-center gap-1 " (if liked "text-red-500 hover:text-red-600" "hover:text-red-500"))) - (l-icon (if liked "\u2665" "\u2661")) - (b-action (if boosted-me unboost-url boost-url)) - (b-cls (str "flex items-center gap-1 " (if boosted-me "text-green-600 hover:text-green-700" "hover:text-green-600"))) - (reply-url (get d "reply_url")) - (reply (when reply-url (~social/reply-link :url reply-url))) - (like-form (~social/like-form - :action l-action :target target :oid oid :ainbox ainbox - :csrf csrf :cls l-cls :icon l-icon :count (get d "like_count"))) - (boost-form (~social/boost-form - :action b-action :target target :oid oid :ainbox ainbox - :csrf csrf :cls b-cls :count (get d "boost_count")))) - (div :id (str "interactions-" safe-id) - (~social/interaction-buttons :like like-form :boost boost-form :reply reply)))))) - (~social/post-card - :boost boost :avatar avatar - :actor-name actor-name :actor-username (get d "actor_username") - :domain (get d "domain") :time (get d "time") - :content content-sx :original original - :interactions interactions))) +(defcomp + ~social/post-card-from-data + (&key + (d :as dict) + (has-actor :as boolean) + (csrf :as string) + (like-url :as string) + (unlike-url :as string) + (boost-url :as string) + (unboost-url :as string)) + (let-match + {:actor_name actor-name :liked_by_me liked :boosted_by_me boosted-me :time time :actor_username actor-username :domain domain :content content :object_id oid :boosted_by boosted-by :summary summary :original_url original-url :safe_id safe-id :author_inbox ainbox :reply_url reply-url :like_count like-count :boost_count boost-count :actor_icon actor-icon :initial initial*} + d + (let* + ((initial (or initial* "?")) + (avatar + (~shared:misc/avatar + :src actor-icon + :cls (if + actor-icon + "w-10 h-10 rounded-full" + "w-10 h-10 rounded-full bg-stone-300 flex items-center justify-center text-stone-600 font-bold text-sm") + :initial (when (not actor-icon) initial))) + (boost (when boosted-by (~social/boost-label :name boosted-by))) + (content-sx + (if + summary + (~social/content :content content :summary summary) + (~social/content :content content))) + (original + (when original-url (~social/original-link :url original-url))) + (interactions + (when + has-actor + (let* + ((target (str "#interactions-" safe-id)) + (l-action (if liked unlike-url like-url)) + (l-cls + (str + "flex items-center gap-1 " + (if + liked + "text-red-500 hover:text-red-600" + "hover:text-red-500"))) + (l-icon (if liked "♥" "♡")) + (b-action (if boosted-me unboost-url boost-url)) + (b-cls + (str + "flex items-center gap-1 " + (if + boosted-me + "text-green-600 hover:text-green-700" + "hover:text-green-600"))) + (reply (when reply-url (~social/reply-link :url reply-url))) + (like-form + (~social/like-form + :action l-action + :target target + :oid oid + :ainbox ainbox + :csrf csrf + :cls l-cls + :icon l-icon + :count like-count)) + (boost-form + (~social/boost-form + :action b-action + :target target + :oid oid + :ainbox ainbox + :csrf csrf + :cls b-cls + :count boost-count))) + (div + :id (str "interactions-" safe-id) + (~social/interaction-buttons + :like like-form + :boost boost-form + :reply reply)))))) + (~social/post-card + :boost boost + :avatar avatar + :actor-name actor-name + :actor-username actor-username + :domain domain + :time time + :content content-sx + :original original + :interactions interactions)))) ;; Data-driven timeline items (replaces Python _timeline_items_sx loop) (defcomp ~social/timeline-items-from-data (&key (items :as list) (next-url :as string?) (has-actor :as boolean) (csrf :as string) @@ -174,35 +217,53 @@ ;; Assembled social nav — replaces Python _social_nav_sx ;; --------------------------------------------------------------------------- -(defcomp ~social/nav (&key actor) - (if (not actor) - (~social/nav-choose-username :url (url-for "identity.choose_username_form")) - (let* ((rp (request-path)) - (links (list - (dict :endpoint "social.defpage_home_timeline" :label "Timeline") - (dict :endpoint "social.defpage_public_timeline" :label "Public") - (dict :endpoint "social.defpage_compose_form" :label "Compose") - (dict :endpoint "social.defpage_following_list" :label "Following") - (dict :endpoint "social.defpage_followers_list" :label "Followers") - (dict :endpoint "social.defpage_search" :label "Search")))) +(defcomp + ~social/nav + (&key actor) + (if + (not actor) + (~social/nav-choose-username + :url (url-for "identity.choose_username_form")) + (let* + ((rp (request-path)) + (links + (list + (dict :endpoint "social.defpage_home_timeline" :label "Timeline") + (dict :endpoint "social.defpage_public_timeline" :label "Public") + (dict :endpoint "social.defpage_compose_form" :label "Compose") + (dict :endpoint "social.defpage_following_list" :label "Following") + (dict :endpoint "social.defpage_followers_list" :label "Followers") + (dict :endpoint "social.defpage_search" :label "Search")))) (~social/nav-bar :items (<> - (map (lambda (lnk) - (let* ((href (url-for (get lnk "endpoint"))) - (bold (if (= rp href) " font-bold" ""))) - (a :href href - :class (str "px-2 py-1 rounded hover:bg-stone-200" bold) - (get lnk "label")))) + (map + (lambda + (lnk) + (let-match + {:label label :endpoint endpoint} + lnk + (let* + ((href (url-for endpoint)) + (bold (if (= rp href) " font-bold" ""))) + (a + :href href + :class (str "px-2 py-1 rounded hover:bg-stone-200" bold) + label)))) links) - (let* ((notif-url (url-for "social.defpage_notifications")) - (notif-bold (if (= rp notif-url) " font-bold" ""))) + (let* + ((notif-url (url-for "social.defpage_notifications")) + (notif-bold (if (= rp notif-url) " font-bold" ""))) (~social/nav-notification-link :href notif-url :cls (str "px-2 py-1 rounded hover:bg-stone-200 relative" notif-bold) :count-url (url-for "social.notification_count"))) - (a :href (url-for "activitypub.actor_profile" :username (get actor "preferred_username")) - :class "px-2 py-1 rounded hover:bg-stone-200" - (str "@" (get actor "preferred_username")))))))) + (let-match + {:preferred_username username} + actor + (a + :href (url-for "activitypub.actor_profile" :username username) + :class "px-2 py-1 rounded hover:bg-stone-200" + (str "@" username)))))))) ;; --------------------------------------------------------------------------- ;; Assembled post card — replaces Python _post_card_sx diff --git a/lib/freeze.sx b/lib/freeze.sx index 561e11f2..f224b414 100644 --- a/lib/freeze.sx +++ b/lib/freeze.sx @@ -21,7 +21,8 @@ ;; Registry of freeze scopes: name → list of {name signal} entries -(define-library (sx freeze) +(define-library + (sx freeze) (export freeze-registry freeze-signal @@ -33,82 +34,96 @@ freeze-to-sx thaw-from-sx) (begin - -(define freeze-registry (dict)) - -;; Register a signal in the current freeze scope -(define freeze-signal :effects [mutation] - (fn (name sig) - (let ((scope-name (context "sx-freeze-scope" nil))) - (when scope-name - (let ((entries (or (get freeze-registry scope-name) (list)))) - (append! entries (dict "name" name "signal" sig)) - (dict-set! freeze-registry scope-name entries)))))) - -;; Freeze scope delimiter — collects signals registered within body -(define freeze-scope :effects [mutation] - (fn (name body-fn) - (scope-push! "sx-freeze-scope" name) - ;; Initialize empty entry list for this scope - (dict-set! freeze-registry name (list)) - (cek-call body-fn nil) - (scope-pop! "sx-freeze-scope") - nil)) - -;; Freeze a named scope → SX dict of signal values -(define cek-freeze-scope :effects [] - (fn (name) - (let ((entries (or (get freeze-registry name) (list))) - (signals-dict (dict))) - (for-each (fn (entry) - (dict-set! signals-dict - (get entry "name") - (signal-value (get entry "signal")))) - entries) - (dict "name" name "signals" signals-dict)))) - -;; Freeze all scopes -(define cek-freeze-all :effects [] - (fn () - (map (fn (name) (cek-freeze-scope name)) - (keys freeze-registry)))) - -;; Thaw a named scope — restore signal values from frozen data -(define cek-thaw-scope :effects [mutation] - (fn (name frozen) - (let ((entries (or (get freeze-registry name) (list))) - (values (get frozen "signals"))) - (when values - (for-each (fn (entry) - (let ((sig-name (get entry "name")) - (sig (get entry "signal")) - (val (get values sig-name))) - (when (not (nil? val)) - (reset! sig val)))) - entries))))) - -;; Thaw all scopes from a list of frozen scope dicts -(define cek-thaw-all :effects [mutation] - (fn (frozen-list) - (for-each (fn (frozen) - (cek-thaw-scope (get frozen "name") frozen)) - frozen-list))) - -;; Serialize a frozen scope to SX text -(define freeze-to-sx :effects [] - (fn (name) - (sx-serialize (cek-freeze-scope name)))) - -;; Restore from SX text -(define thaw-from-sx :effects [mutation] - (fn (sx-text) - (let ((parsed (sx-parse sx-text))) - (when (not (empty? parsed)) - (let ((frozen (first parsed))) - (cek-thaw-scope (get frozen "name") frozen)))))) - - -)) ;; end define-library + (define freeze-registry (dict)) + (define + freeze-signal + :effects (mutation) + (fn + (name sig) + (let + ((scope-name (context "sx-freeze-scope" nil))) + (when + scope-name + (let + ((entries (or (get freeze-registry scope-name) (list)))) + (append! entries (dict "name" name "signal" sig)) + (dict-set! freeze-registry scope-name entries)))))) + (define + freeze-scope + :effects (mutation) + (fn + (name body-fn) + (scope-push! "sx-freeze-scope" name) + (dict-set! freeze-registry name (list)) + (cek-call body-fn nil) + (scope-pop! "sx-freeze-scope") + nil)) + (define + cek-freeze-scope + :effects () + (fn + (name) + (let + ((entries (or (get freeze-registry name) (list))) + (signals-dict (dict))) + (for-each + (fn + (entry) + (dict-set! + signals-dict + (get entry "name") + (signal-value (get entry "signal")))) + entries) + (dict "name" name "signals" signals-dict)))) + (define + cek-freeze-all + :effects () + (fn + () + (map (fn (name) (cek-freeze-scope name)) (keys freeze-registry)))) + (define + cek-thaw-scope + :effects (mutation) + (fn + (name frozen) + (let + ((entries (or (get freeze-registry name) (list))) + (values (get frozen "signals"))) + (when + values + (for-each + (fn + (entry) + (let + ((sig-name (get entry "name")) + (sig (get entry "signal")) + (val (get values sig-name))) + (when (not (nil? val)) (reset! sig val)))) + entries))))) + (define + cek-thaw-all + :effects (mutation) + (fn + (frozen-list) + (for-each + (fn (frozen) (cek-thaw-scope (get frozen "name") frozen)) + frozen-list))) + (define + freeze-to-sx + :effects () + (fn (name) (sx-serialize (cek-freeze-scope name)))) + (define + thaw-from-sx + :effects (mutation) + (fn + (sx-text) + (let + ((parsed (sx-parse sx-text))) + (when + (not (empty? parsed)) + (let + ((frozen (first parsed))) + (cek-thaw-scope (get frozen "name") frozen)))))))) ;; end define-library ;; Re-export to global namespace for backward compatibility (import (sx freeze)) diff --git a/lib/highlight.sx b/lib/highlight.sx index d0289e01..0e632e5f 100644 --- a/lib/highlight.sx +++ b/lib/highlight.sx @@ -1,6 +1,7 @@ -(define-library (sx highlight) +(define-library + (sx highlight) (export sx-specials sx-special? @@ -16,204 +17,184 @@ highlight-sx highlight) (begin - -(define - sx-specials - (list - "defcomp" - "defrelation" - "defisland" - "defpage" - "defhelper" - "define" - "defmacro" - "defconfig" - "deftest" - "if" - "when" - "cond" - "case" - "and" - "or" - "not" - "let" - "let*" - "lambda" - "fn" - "do" - "begin" - "quote" - "quasiquote" - "->" - "map" - "filter" - "reduce" - "some" - "every?" - "map-indexed" - "for-each" - "&key" - "&rest" - "set!")) - -(define sx-special? (fn (s) (some (fn (x) (= x s)) sx-specials))) - -(define hl-digit? (fn (c) (and (>= c "0") (<= c "9")))) - -(define - hl-alpha? - (fn (c) (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))) - -(define - hl-sym-char? - (fn - (c) - (or - (hl-alpha? c) - (hl-digit? c) - (= c "_") - (= c "-") - (= c "?") - (= c "!") - (= c "+") - (= c "*") - (= c "/") - (= c "<") - (= c ">") - (= c "=") - (= c "&") - (= c ".")))) - -(define hl-ws? (fn (c) (or (= c " ") (= c "\n") (= c "\t") (= c "\r")))) - -(define hl-escape (fn (s) s)) - -(define - hl-span - (fn - (class text) - (if - (= class "") - (list (quote span) text) - (list (quote span) (make-keyword "class") class text)))) - -(define - tokenize-sx - (fn - (code) - (let - ((tokens (list)) (i 0) (len (string-length code))) - (let - loop - () - (when - (< i len) + (define + sx-specials + (list + "defcomp" + "defrelation" + "defisland" + "defpage" + "defhelper" + "define" + "defmacro" + "defconfig" + "deftest" + "if" + "when" + "cond" + "case" + "and" + "or" + "not" + "let" + "let*" + "lambda" + "fn" + "do" + "begin" + "quote" + "quasiquote" + "->" + "map" + "filter" + "reduce" + "some" + "every?" + "map-indexed" + "for-each" + "&key" + "&rest" + "set!" + "satisfies?" + "match" + "let-match" + "define-protocol" + "implement" + "->>" + "|>" + "as->" + "define-library" + "import" + "perform" + "guard" + "call/cc" + "raise" + "define-syntax" + "syntax-rules" + "make-parameter" + "parameterize")) + (define sx-special? (fn (s) (some (fn (x) (= x s)) sx-specials))) + (define hl-digit? (fn (c) (and (>= c "0") (<= c "9")))) + (define + hl-alpha? + (fn + (c) + (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))) + (define + hl-sym-char? + (fn + (c) + (or + (hl-alpha? c) + (hl-digit? c) + (= c "_") + (= c "-") + (= c "?") + (= c "!") + (= c "+") + (= c "*") + (= c "/") + (= c "<") + (= c ">") + (= c "=") + (= c "&") + (= c ".")))) + (define + hl-ws? + (fn (c) (or (= c " ") (= c "\n") (= c "\t") (= c "\r")))) + (define hl-escape (fn (s) s)) + (define + hl-span + (fn + (class text) + (if + (= class "") + (list (quote span) text) + (list (quote span) (make-keyword "class") class text)))) + (define + tokenize-sx + (fn + (code) + (let + ((tokens (list)) (i 0) (len (string-length code))) (let - ((c (substring code i (+ i 1)))) - (if - (= c ";") + loop + () + (when + (< i len) (let - ((start i)) - (set! i (+ i 1)) - (let - scan - () - (when - (and - (< i len) - (not (= (substring code i (+ i 1)) "\n"))) - (set! i (+ i 1)) - (scan))) - (set! - tokens - (append - tokens - (list (list "comment" (substring code start i)))))) - (if - (= c "\"") - (let - ((start i)) - (set! i (+ i 1)) - (let - sloop - () - (when - (< i len) - (let - ((sc (substring code i (+ i 1)))) - (if - (= sc "\\") - (do (set! i (+ i 2)) (sloop)) - (if - (= sc "\"") - (set! i (+ i 1)) - (do (set! i (+ i 1)) (sloop))))))) - (set! - tokens - (append - tokens - (list (list "string" (substring code start i)))))) + ((c (substring code i (+ i 1)))) (if - (= c ":") + (= c ";") (let ((start i)) (set! i (+ i 1)) - (when - (and - (< i len) - (hl-alpha? (substring code i (+ i 1)))) - (let - scan - () - (when - (and - (< i len) - (hl-sym-char? (substring code i (+ i 1)))) - (set! i (+ i 1)) - (scan)))) + (let + scan + () + (when + (and + (< i len) + (not (= (substring code i (+ i 1)) "\n"))) + (set! i (+ i 1)) + (scan))) (set! tokens (append tokens - (list (list "keyword" (substring code start i)))))) + (list (list "comment" (substring code start i)))))) (if - (= c "~") + (= c "\"") (let ((start i)) (set! i (+ i 1)) (let - scan + sloop () (when - (and - (< i len) - (let - ((x (substring code i (+ i 1)))) - (or (hl-sym-char? x) (= x "/")))) - (set! i (+ i 1)) - (scan))) + (< i len) + (let + ((sc (substring code i (+ i 1)))) + (if + (= sc "\\") + (do (set! i (+ i 2)) (sloop)) + (if + (= sc "\"") + (set! i (+ i 1)) + (do (set! i (+ i 1)) (sloop))))))) (set! tokens (append tokens - (list (list "component" (substring code start i)))))) + (list (list "string" (substring code start i)))))) (if - (or - (= c "(") - (= c ")") - (= c "[") - (= c "]") - (= c "{") - (= c "}")) - (do + (= c ":") + (let + ((start i)) + (set! i (+ i 1)) + (when + (and + (< i len) + (hl-alpha? (substring code i (+ i 1)))) + (let + scan + () + (when + (and + (< i len) + (hl-sym-char? (substring code i (+ i 1)))) + (set! i (+ i 1)) + (scan)))) (set! tokens - (append tokens (list (list "paren" c)))) - (set! i (+ i 1))) + (append + tokens + (list (list "keyword" (substring code start i)))))) (if - (hl-digit? c) + (= c "~") (let ((start i)) + (set! i (+ i 1)) (let scan () @@ -222,53 +203,30 @@ (< i len) (let ((x (substring code i (+ i 1)))) - (or (hl-digit? x) (= x ".")))) + (or (hl-sym-char? x) (= x "/")))) (set! i (+ i 1)) (scan))) (set! tokens (append tokens - (list (list "number" (substring code start i)))))) + (list + (list "component" (substring code start i)))))) (if - (hl-sym-char? c) - (let - ((start i)) - (let - scan - () - (when - (and - (< i len) - (hl-sym-char? (substring code i (+ i 1)))) - (set! i (+ i 1)) - (scan))) - (let - ((text (substring code start i))) - (if - (or - (= text "true") - (= text "false") - (= text "nil")) - (set! - tokens - (append - tokens - (list (list "boolean" text)))) - (if - (sx-special? text) - (set! - tokens - (append - tokens - (list (list "special" text)))) - (set! - tokens - (append - tokens - (list (list "symbol" text)))))))) + (or + (= c "(") + (= c ")") + (= c "[") + (= c "]") + (= c "{") + (= c "}")) + (do + (set! + tokens + (append tokens (list (list "paren" c)))) + (set! i (+ i 1))) (if - (hl-ws? c) + (hl-digit? c) (let ((start i)) (let @@ -277,49 +235,106 @@ (when (and (< i len) - (hl-ws? (substring code i (+ i 1)))) + (let + ((x (substring code i (+ i 1)))) + (or (hl-digit? x) (= x ".")))) (set! i (+ i 1)) (scan))) (set! tokens (append tokens - (list (list "ws" (substring code start i)))))) - (do - (set! - tokens - (append tokens (list (list "other" c)))) - (set! i (+ i 1)))))))))))) - (loop))) - tokens))) - -(define sx-token-classes {:boolean "text-orange-600" :component "text-rose-600 font-semibold" :number "text-amber-700" :string "text-emerald-700" :special "text-sky-700 font-semibold" :paren "text-stone-400" :keyword "text-violet-600" :comment "text-stone-400 italic"}) - -(define - render-sx-tokens - (fn - (tokens) - (map + (list + (list "number" (substring code start i)))))) + (if + (hl-sym-char? c) + (let + ((start i)) + (let + scan + () + (when + (and + (< i len) + (hl-sym-char? + (substring code i (+ i 1)))) + (set! i (+ i 1)) + (scan))) + (let + ((text (substring code start i))) + (if + (or + (= text "true") + (= text "false") + (= text "nil")) + (set! + tokens + (append + tokens + (list (list "boolean" text)))) + (if + (sx-special? text) + (set! + tokens + (append + tokens + (list (list "special" text)))) + (set! + tokens + (append + tokens + (list (list "symbol" text)))))))) + (if + (hl-ws? c) + (let + ((start i)) + (let + scan + () + (when + (and + (< i len) + (hl-ws? (substring code i (+ i 1)))) + (set! i (+ i 1)) + (scan))) + (set! + tokens + (append + tokens + (list + (list "ws" (substring code start i)))))) + (do + (set! + tokens + (append tokens (list (list "other" c)))) + (set! i (+ i 1)))))))))))) + (loop))) + tokens))) + (define sx-token-classes {:boolean "text-orange-600" :component "text-rose-600 font-semibold" :number "text-amber-700" :string "text-emerald-700" :special "text-sky-700 font-semibold" :paren "text-stone-400" :keyword "text-violet-600" :comment "text-stone-400 italic"}) + (define + render-sx-tokens (fn - (tok) - (let - ((cls (or (dict-get sx-token-classes (first tok)) ""))) - (hl-span cls (nth tok 1)))) - tokens))) - -(define highlight-sx (fn (code) (render-sx-tokens (tokenize-sx code)))) - -(define - highlight - (fn - (code lang) - (if - (or (= lang "lisp") (= lang "sx") (= lang "sexp") (= lang "scheme")) - (highlight-sx code) - (list (quote code) code)))) - - -)) ;; end define-library + (tokens) + (map + (fn + (tok) + (let + ((cls (or (dict-get sx-token-classes (first tok)) ""))) + (hl-span cls (nth tok 1)))) + tokens))) + (define highlight-sx (fn (code) (-> code tokenize-sx render-sx-tokens))) + (define + highlight + (fn + (code lang) + (if + (or + (= lang "lisp") + (= lang "sx") + (= lang "sexp") + (= lang "scheme")) + (highlight-sx code) + (list (quote code) code)))))) ;; end define-library ;; Re-export to global namespace for backward compatibility (import (sx highlight)) diff --git a/lib/sx-swap.sx b/lib/sx-swap.sx index 3090f62c..e3b99b78 100644 --- a/lib/sx-swap.sx +++ b/lib/sx-swap.sx @@ -1,6 +1,7 @@ -(define-library (sx swap) +(define-library + (sx swap) (export _skip-string _find-close @@ -16,310 +17,311 @@ strip-oob apply-response) (begin - -(define - _skip-string - (fn - (src i) - (if - (>= i (len src)) - i - (let - ((ch (nth src i))) - (cond - (= ch "\\") - (_skip-string src (+ i 2)) - (= ch "\"") - (+ i 1) - :else (_skip-string src (+ i 1))))))) - -(define - _find-close - (fn - (src i depth in-str) - (if - (>= i (len src)) - -1 - (let - ((ch (nth src i))) - (cond - in-str - (cond - (= ch "\\") - (_find-close src (+ i 2) depth true) - (= ch "\"") - (_find-close src (+ i 1) depth false) - :else (_find-close src (+ i 1) depth true)) - (= ch "\"") - (_find-close src (+ i 1) depth true) - (= ch "(") - (_find-close src (+ i 1) (+ depth 1) false) - (= ch ")") - (if (= depth 1) i (_find-close src (+ i 1) (- depth 1) false)) - :else (_find-close src (+ i 1) depth false)))))) - -(define - _skip-ws - (fn - (src i) - (if - (>= i (len src)) - i - (let - ((ch (nth src i))) + (define + _skip-string + (fn + (src i) (if - (or (= ch " ") (= ch "\n") (= ch "\t") (= ch "\r")) - (_skip-ws src (+ i 1)) - i))))) - -(define - _skip-token - (fn - (src i) - (if - (>= i (len src)) - i - (let - ((ch (nth src i))) - (if - (or - (= ch " ") - (= ch "\n") - (= ch "\t") - (= ch "\r") - (= ch "(") - (= ch ")") - (= ch "\"")) + (>= i (len src)) i - (_skip-token src (+ i 1))))))) - -(define - _skip-value - (fn - (src i) - (if - (>= i (len src)) - i - (let - ((ch (nth src i))) - (cond - (= ch "\"") - (_skip-string src (+ i 1)) - (= ch "(") (let - ((close (_find-close src (+ i 1) 1 false))) - (if (= close -1) (len src) (+ close 1))) - :else (_skip-token src i)))))) - -(define - _find-children-start - (fn - (src elem-start elem-end) - (let - ((after-open (+ elem-start 1))) - (let - ((after-tag (_skip-token src (_skip-ws src after-open)))) - (define - _skip-attrs - (fn - (j) - (let - ((pos (_skip-ws src j))) - (if - (>= pos elem-end) - pos - (if - (= (nth src pos) ":") - (let - ((after-kw (_skip-token src pos))) - (_skip-attrs (_skip-value src (_skip-ws src after-kw)))) - pos))))) - (_skip-attrs after-tag))))) - -(define - _scan-back - (fn - (src i) - (if (< i 0) -1 (if (= (nth src i) "(") i (_scan-back src (- i 1)))))) - -(define - find-element-by-id - (fn - (src target-id) - (let - ((pattern (str ":id \"" target-id "\""))) - (let - ((pos (index-of src pattern))) + ((ch (nth src i))) + (cond + (= ch "\\") + (_skip-string src (+ i 2)) + (= ch "\"") + (+ i 1) + :else (_skip-string src (+ i 1))))))) + (define + _find-close + (fn + (src i depth in-str) (if - (= pos -1) - nil + (>= i (len src)) + -1 (let - ((elem-start (_scan-back src (- pos 1)))) + ((ch (nth src i))) + (cond + in-str + (cond + (= ch "\\") + (_find-close src (+ i 2) depth true) + (= ch "\"") + (_find-close src (+ i 1) depth false) + :else (_find-close src (+ i 1) depth true)) + (= ch "\"") + (_find-close src (+ i 1) depth true) + (= ch "(") + (_find-close src (+ i 1) (+ depth 1) false) + (= ch ")") + (if + (= depth 1) + i + (_find-close src (+ i 1) (- depth 1) false)) + :else (_find-close src (+ i 1) depth false)))))) + (define + _skip-ws + (fn + (src i) + (if + (>= i (len src)) + i + (let + ((ch (nth src i))) (if - (= elem-start -1) + (or (= ch " ") (= ch "\n") (= ch "\t") (= ch "\r")) + (_skip-ws src (+ i 1)) + i))))) + (define + _skip-token + (fn + (src i) + (if + (>= i (len src)) + i + (let + ((ch (nth src i))) + (if + (or + (= ch " ") + (= ch "\n") + (= ch "\t") + (= ch "\r") + (= ch "(") + (= ch ")") + (= ch "\"")) + i + (_skip-token src (+ i 1))))))) + (define + _skip-value + (fn + (src i) + (if + (>= i (len src)) + i + (let + ((ch (nth src i))) + (cond + (= ch "\"") + (_skip-string src (+ i 1)) + (= ch "(") + (let + ((close (_find-close src (+ i 1) 1 false))) + (if (= close -1) (len src) (+ close 1))) + :else (_skip-token src i)))))) + (define + _find-children-start + (fn + (src elem-start elem-end) + (let + ((after-open (+ elem-start 1))) + (let + ((after-tag (_skip-token src (_skip-ws src after-open)))) + (define + _skip-attrs + (fn + (j) + (let + ((pos (_skip-ws src j))) + (if + (>= pos elem-end) + pos + (if + (= (nth src pos) ":") + (let + ((after-kw (_skip-token src pos))) + (_skip-attrs + (_skip-value src (_skip-ws src after-kw)))) + pos))))) + (_skip-attrs after-tag))))) + (define + _scan-back + (fn + (src i) + (if + (< i 0) + -1 + (if (= (nth src i) "(") i (_scan-back src (- i 1)))))) + (define + find-element-by-id + (fn + (src target-id) + (let + ((pattern (str ":id \"" target-id "\""))) + (let + ((pos (index-of src pattern))) + (if + (= pos -1) nil (let - ((elem-end (_find-close src (+ elem-start 1) 1 false))) + ((elem-start (_scan-back src (- pos 1)))) (if - (= elem-end -1) + (= elem-start -1) nil (let - ((cs (_find-children-start src elem-start elem-end))) - {:end elem-end :start elem-start :children-start cs})))))))))) - -(define - sx-swap - (fn - (src mode target-id new-content) - (let - ((info (find-element-by-id src target-id))) - (if - (nil? info) - src - (let - ((s (get info "start")) - (e (get info "end")) - (cs (get info "children-start"))) - (case - mode - "innerHTML" - (str (slice src 0 cs) new-content (slice src e (len src))) - "outerHTML" - (str (slice src 0 s) new-content (slice src (+ e 1) (len src))) - "beforeend" - (str (slice src 0 e) " " new-content (slice src e (len src))) - "afterbegin" - (str (slice src 0 cs) new-content " " (slice src cs (len src))) - "beforebegin" - (str (slice src 0 s) new-content (slice src s (len src))) - "afterend" - (str - (slice src 0 (+ e 1)) - new-content - (slice src (+ e 1) (len src))) - "delete" - (str (slice src 0 s) (slice src (+ e 1) (len src))) - "none" - src - :else src)))))) - -(define - _extract-attr-value - (fn - (src keyword-end) - (let - ((val-start (_skip-ws src keyword-end))) - (if - (= (nth src val-start) "\"") - (let - ((str-end (_skip-string src (+ val-start 1)))) - (slice src (+ val-start 1) (- str-end 1))) - (let - ((tok-end (_skip-token src val-start))) - (slice src val-start tok-end)))))) - -(define - find-oob-elements - (fn - (src) + ((elem-end (_find-close src (+ elem-start 1) 1 false))) + (if + (= elem-end -1) + nil + (let + ((cs (_find-children-start src elem-start elem-end))) + {:end elem-end :start elem-start :children-start cs})))))))))) (define - _scan + sx-swap (fn - (from results) + (src mode target-id new-content) (let - ((rel-pos (index-of (slice src from (len src)) ":sx-swap-oob"))) + ((info (find-element-by-id src target-id))) (if - (= rel-pos -1) - results + (nil? info) + src + (let-match + {:end e :start s :children-start cs} + info + (case + mode + "innerHTML" + (str (slice src 0 cs) new-content (slice src e (len src))) + "outerHTML" + (str + (slice src 0 s) + new-content + (slice src (+ e 1) (len src))) + "beforeend" + (str + (slice src 0 e) + " " + new-content + (slice src e (len src))) + "afterbegin" + (str + (slice src 0 cs) + new-content + " " + (slice src cs (len src))) + "beforebegin" + (str (slice src 0 s) new-content (slice src s (len src))) + "afterend" + (str + (slice src 0 (+ e 1)) + new-content + (slice src (+ e 1) (len src))) + "delete" + (str (slice src 0 s) (slice src (+ e 1) (len src))) + "none" + src + :else src)))))) + (define + _extract-attr-value + (fn + (src keyword-end) + (let + ((val-start (_skip-ws src keyword-end))) + (if + (= (nth src val-start) "\"") (let - ((abs-pos (+ from rel-pos))) - (let - ((mode (_extract-attr-value src (+ abs-pos 12)))) + ((str-end (_skip-string src (+ val-start 1)))) + (slice src (+ val-start 1) (- str-end 1))) + (let + ((tok-end (_skip-token src val-start))) + (slice src val-start tok-end)))))) + (define + find-oob-elements + (fn + (src) + (define + _scan + (fn + (from results) + (let + ((rel-pos (index-of (slice src from (len src)) ":sx-swap-oob"))) + (if + (= rel-pos -1) + results (let - ((elem-start (_scan-back src (- abs-pos 1)))) - (if - (= elem-start -1) - results + ((abs-pos (+ from rel-pos))) + (let + ((mode (_extract-attr-value src (+ abs-pos 12)))) (let - ((elem-end (_find-close src (+ elem-start 1) 1 false))) + ((elem-start (_scan-back src (- abs-pos 1)))) (if - (= elem-end -1) + (= elem-start -1) results (let - ((id-pattern ":id \"")) - (let - ((id-pos (index-of (slice src elem-start (+ elem-end 1)) id-pattern))) - (if - (= id-pos -1) - (_scan (+ elem-end 1) results) + ((elem-end (_find-close src (+ elem-start 1) 1 false))) + (if + (= elem-end -1) + results + (let + ((id-pattern ":id \"")) (let - ((id-abs (+ elem-start id-pos))) - (let - ((id-val (_extract-attr-value src (+ id-abs 3)))) + ((id-pos (index-of (slice src elem-start (+ elem-end 1)) id-pattern))) + (if + (= id-pos -1) + (_scan (+ elem-end 1) results) (let - ((cs (_find-children-start src elem-start elem-end))) + ((id-abs (+ elem-start id-pos))) (let - ((children-str (slice src cs elem-end))) - (_scan - (+ elem-end 1) - (append results (list {:end elem-end :mode mode :content children-str :start elem-start :id id-val})))))))))))))))))))) - (_scan 0 (list)))) - -(define - strip-oob - (fn - (src oob-list) - (if - (empty? oob-list) - src - (let - ((sorted (reverse oob-list))) - (define - _strip - (fn - (s items) - (if - (empty? items) - s - (let - ((item (first items))) - (let - ((before (slice s 0 (get item "start"))) - (after (slice s (+ (get item "end") 1) (len s)))) - (_strip (str before after) (rest items))))))) - (_strip src sorted))))) - -(define - apply-response - (fn - (page response primary-mode primary-target) - (let - ((oobs (find-oob-elements response))) - (let - ((main-content (strip-oob response oobs))) - (let - ((result (sx-swap page primary-mode primary-target main-content))) - (do + ((id-val (_extract-attr-value src (+ id-abs 3)))) + (let + ((cs (_find-children-start src elem-start elem-end))) + (let + ((children-str (slice src cs elem-end))) + (_scan + (+ elem-end 1) + (append results (list {:end elem-end :mode mode :content children-str :start elem-start :id id-val})))))))))))))))))))) + (_scan 0 (list)))) + (define + strip-oob + (fn + (src oob-list) + (if + (empty? oob-list) + src + (let + ((sorted (reverse oob-list))) (define - _apply-oobs + _strip (fn - (page-acc items) + (s items) (if (empty? items) - page-acc + s (let - ((oob (first items))) - (_apply-oobs - (sx-swap - page-acc - (get oob "mode") - (get oob "id") - (get oob "content")) - (rest items)))))) - (_apply-oobs result oobs))))))) - - -)) ;; end define-library + ((item (first items))) + (let + ((before (slice s 0 (get item "start"))) + (after (slice s (+ (get item "end") 1) (len s)))) + (_strip (str before after) (rest items))))))) + (_strip src sorted))))) + (define + apply-response + (fn + (page response primary-mode primary-target) + (let + ((oobs (find-oob-elements response))) + (let + ((main-content (strip-oob response oobs))) + (let + ((result (sx-swap page primary-mode primary-target main-content))) + (do + (define + _apply-oobs + (fn + (page-acc items) + (if + (empty? items) + page-acc + (let + ((oob (first items))) + (_apply-oobs + (sx-swap + page-acc + (get oob "mode") + (get oob "id") + (get oob "content")) + (rest items)))))) + (_apply-oobs result oobs))))))))) ;; end define-library ;; Re-export to global namespace for backward compatibility (import (sx swap)) diff --git a/lib/tree-tools.sx b/lib/tree-tools.sx index 2f1b4d30..b13366a4 100644 --- a/lib/tree-tools.sx +++ b/lib/tree-tools.sx @@ -63,33 +63,28 @@ :effects () (fn (node) - (cond - (nil? node) - "nil" - (= (type-of node) "symbol") - (symbol-name node) - (= (type-of node) "keyword") - (str ":" (keyword-name node)) - (= (type-of node) "string") - (let - ((s (if (> (len node) 40) (str (slice node 0 37) "...") node))) - (str "\"" s "\"")) - (= (type-of node) "number") - (str node) - (= (type-of node) "boolean") - (if node "true" "false") - (list? node) - (if - (empty? node) - "()" - (str - "(" - (node-display (first node)) - (if (> (len node) 1) " ..." "") - ")")) - (= (type-of node) "dict") - "{...}" - :else (str node)))) + (match + (type-of node) + ("nil" "nil") + ("symbol" (symbol-name node)) + ("keyword" (str ":" (keyword-name node))) + ("string" + (let + ((s (if (> (len node) 40) (str (slice node 0 37) "...") node))) + (str "\"" s "\""))) + ("number" (str node)) + ("boolean" (if node "true" "false")) + ("list" + (if + (empty? node) + "()" + (str + "(" + (node-display (first node)) + (if (> (len node) 1) " ..." "") + ")"))) + ("dict" "{...}") + (_ (str node))))) (define summarise @@ -244,17 +239,16 @@ :effects () (fn (node pattern) - (cond - (= (type-of node) "symbol") - (contains? (symbol-name node) pattern) - (string? node) - (contains? node pattern) - (and - (list? node) - (not (empty? node)) - (= (type-of (first node)) "symbol")) - (contains? (symbol-name (first node)) pattern) - :else false))) + (match + (type-of node) + ("symbol" (contains? (symbol-name node) pattern)) + ("string" (contains? node pattern)) + ("list" + (if + (empty? node) + false + (some (fn (child) (node-matches? child pattern)) node))) + (_ false)))) (define node-summary-short @@ -546,33 +540,33 @@ :effects () (fn (node replacement) - (cond - (and (= (type-of node) "symbol") (= (symbol-name node) "_")) - replacement - (list? node) - (let - ((found false) - (result - (map - (fn - (child) - (if - found - child + (match + (type-of node) + ("symbol" (if (= (symbol-name node) "_") replacement nil)) + ("list" + (let + ((found false) + (result + (map + (fn + (child) (if - (and - (= (type-of child) "symbol") - (= (symbol-name child) "_")) - (do (set! found true) replacement) + found + child (if - (list? child) - (let - ((sub (replace-placeholder child replacement))) - (if (nil? sub) child (do (set! found true) sub))) - child)))) - node))) - (if found result nil)) - :else nil))) + (and + (= (type-of child) "symbol") + (= (symbol-name child) "_")) + (do (set! found true) replacement) + (if + (list? child) + (let + ((sub (replace-placeholder child replacement))) + (if (nil? sub) child (do (set! found true) sub))) + child)))) + node))) + (if found result nil))) + (_ nil)))) (define tree-set @@ -851,12 +845,13 @@ :effects () (fn (node old-name new-name) - (cond - (and (= (type-of node) "symbol") (= (symbol-name node) old-name)) - (make-symbol new-name) - (list? node) - (map (fn (child) (rename-in-node child old-name new-name)) node) - :else node))) + (match + (type-of node) + ("symbol" + (if (= (symbol-name node) old-name) (make-symbol new-name) node)) + ("list" + (map (fn (child) (rename-in-node child old-name new-name)) node)) + (_ node)))) (define count-renames @@ -873,12 +868,12 @@ :effects () (fn (node old-name hits) - (cond - (and (= (type-of node) "symbol") (= (symbol-name node) old-name)) - (append! hits true) - (list? node) - (for-each (fn (child) (count-in-node child old-name hits)) node) - :else nil))) + (match + (type-of node) + ("symbol" (when (= (symbol-name node) old-name) (append! hits true))) + ("list" + (for-each (fn (child) (count-in-node child old-name hits)) node)) + (_ nil)))) (define replace-by-pattern @@ -1341,17 +1336,30 @@ (walk node (dict)) result))) -(define find-use-declarations :effects () - (fn (nodes) - (let ((uses (list))) - (for-each (fn (node) - (when (and (list? node) (>= (len node) 2) - (= (type-of (first node)) "symbol") - (= (symbol-name (first node)) "use")) - (for-each (fn (arg) - (cond - (= (type-of arg) "symbol") (append! uses (symbol-name arg)) - (= (type-of arg) "string") (append! uses arg))) - (rest node)))) +(define + find-use-declarations + :effects () + (fn + (nodes) + (let + ((uses (list))) + (for-each + (fn + (node) + (when + (and + (list? node) + (>= (len node) 2) + (= (type-of (first node)) "symbol") + (= (symbol-name (first node)) "use")) + (for-each + (fn + (arg) + (cond + (= (type-of arg) "symbol") + (append! uses (symbol-name arg)) + (= (type-of arg) "string") + (append! uses arg))) + (rest node)))) (if (list? nodes) nodes (list nodes))) uses))) diff --git a/lib/types.sx b/lib/types.sx index 6799d07d..9e255128 100644 --- a/lib/types.sx +++ b/lib/types.sx @@ -47,41 +47,62 @@ ;; (-> t1 t2 ... treturn) — function type (last is return) ;; Base type names -(define base-types - (list "number" "string" "boolean" "nil" "symbol" "keyword" - "element" "any" "never" "list" "dict" - "lambda" "component" "island" "macro" "signal")) +(define + base-types + (list + "number" + "string" + "boolean" + "nil" + "symbol" + "keyword" + "element" + "any" + "never" + "list" + "dict" + "lambda" + "component" + "island" + "macro" + "signal")) ;; -------------------------------------------------------------------------- ;; 2. Type predicates ;; -------------------------------------------------------------------------- -(define type-any? - (fn (t) (= t "any"))) +(define type-any? (fn (t) (= t "any"))) -(define type-never? - (fn (t) (= t "never"))) +(define type-never? (fn (t) (= t "never"))) -(define type-nullable? - (fn (t) - ;; A type is nullable if it's "any", "nil", a "?" shorthand, or - ;; a union containing "nil". - (if (= t "any") true - (if (= t "nil") true - (if (and (= (type-of t) "string") (ends-with? t "?")) true - (if (and (= (type-of t) "list") - (not (empty? t)) - (= (first t) "or")) +(define + type-nullable? + (fn + (t) + (if + (= t "any") + true + (if + (= t "nil") + true + (if + (and (= (type-of t) "string") (ends-with? t "?")) + true + (if + (and + (= (type-of t) "list") + (not (empty? t)) + (= (first t) "or")) (contains? (rest t) "nil") false)))))) -(define nullable-base - (fn (t) - ;; Strip "?" from nullable shorthand: "string?" → "string" - (if (and (= (type-of t) "string") - (ends-with? t "?") - (not (= t "?"))) +(define + nullable-base + (fn + (t) + (if + (and (= (type-of t) "string") (ends-with? t "?") (not (= t "?"))) (slice t 0 (- (string-length t) 1)) t))) @@ -91,53 +112,65 @@ ;; -------------------------------------------------------------------------- ;; subtype?(a, b) — is type `a` assignable to type `b`? -(define subtype? - (fn (a b) - ;; any accepts everything - (if (type-any? b) true - ;; never is subtype of everything - (if (type-never? a) true - ;; any is not a subtype of a specific type - (if (type-any? a) false - ;; identical types - (if (= a b) true - ;; nil is subtype of nullable types - (if (= a "nil") +(define + subtype? + (fn + (a b) + (if + (type-any? b) + true + (if + (type-never? a) + true + (if + (type-any? a) + false + (if + (= a b) + true + (if + (= a "nil") (type-nullable? b) - ;; nullable shorthand: "string?" = (or string nil) - (if (and (= (type-of b) "string") (ends-with? b "?")) - (let ((base (nullable-base b))) + (if + (and (= (type-of b) "string") (ends-with? b "?")) + (let + ((base (nullable-base b))) (or (= a base) (= a "nil"))) - ;; a is a union: (or t1 t2 ...) <: b if ALL members <: b - ;; Must check before b-union — (or A B) <: (or A B C) needs - ;; each member of a checked against the full union b. - (if (and (= (type-of a) "list") - (not (empty? a)) - (= (first a) "or")) + (if + (and + (= (type-of a) "list") + (not (empty? a)) + (= (first a) "or")) (every? (fn (member) (subtype? member b)) (rest a)) - ;; union: a <: (or t1 t2 ...) if a <: any member - (if (and (= (type-of b) "list") - (not (empty? b)) - (= (first b) "or")) + (if + (and + (= (type-of b) "list") + (not (empty? b)) + (= (first b) "or")) (some (fn (member) (subtype? a member)) (rest b)) - ;; list-of covariance - (if (and (= (type-of a) "list") (= (type-of b) "list") - (= (len a) 2) (= (len b) 2) - (= (first a) "list-of") (= (first b) "list-of")) + (if + (and + (= (type-of a) "list") + (= (type-of b) "list") + (= (len a) 2) + (= (len b) 2) + (= (first a) "list-of") + (= (first b) "list-of")) (subtype? (nth a 1) (nth b 1)) - ;; "list" <: (list-of any) - (if (and (= a "list") - (= (type-of b) "list") - (= (len b) 2) - (= (first b) "list-of")) + (if + (and + (= a "list") + (= (type-of b) "list") + (= (len b) 2) + (= (first b) "list-of")) (type-any? (nth b 1)) - ;; (list-of t) <: "list" - (if (and (= (type-of a) "list") - (= (len a) 2) - (= (first a) "list-of") - (= b "list")) + (if + (and + (= (type-of a) "list") + (= (len a) 2) + (= (first a) "list-of") + (= b "list")) true - ;; "element" is subtype of "string?" (rendered HTML) false))))))))))))) @@ -145,26 +178,45 @@ ;; 4. Type union ;; -------------------------------------------------------------------------- -(define type-union - (fn (a b) - ;; Compute the smallest type that encompasses both a and b. - (if (= a b) a - (if (type-any? a) "any" - (if (type-any? b) "any" - (if (type-never? a) b - (if (type-never? b) a - (if (subtype? a b) b - (if (subtype? b a) a - ;; neither is subtype — create a union - (if (= a "nil") - ;; nil + string → string? - (if (and (= (type-of b) "string") - (not (ends-with? b "?"))) +(define + type-union + (fn + (a b) + (if + (= a b) + a + (if + (type-any? a) + "any" + (if + (type-any? b) + "any" + (if + (type-never? a) + b + (if + (type-never? b) + a + (if + (subtype? a b) + b + (if + (subtype? b a) + a + (if + (= a "nil") + (if + (and + (= (type-of b) "string") + (not (ends-with? b "?"))) (str b "?") (list "or" a b)) - (if (= b "nil") - (if (and (= (type-of a) "string") - (not (ends-with? a "?"))) + (if + (= b "nil") + (if + (and + (= (type-of a) "string") + (not (ends-with? a "?"))) (str a "?") (list "or" a b)) (list "or" a b)))))))))))) @@ -174,56 +226,69 @@ ;; 5. Type narrowing ;; -------------------------------------------------------------------------- -(define narrow-type - (fn (t (predicate-name :as string)) - ;; Narrow type based on a predicate test in a truthy branch. - ;; (if (nil? x) ..then.. ..else..) → in else, x excludes nil. - ;; Returns (narrowed-then narrowed-else). - (if (= predicate-name "nil?") - (list "nil" (narrow-exclude-nil t)) - (if (= predicate-name "string?") - (list "string" (narrow-exclude t "string")) - (if (= predicate-name "number?") - (list "number" (narrow-exclude t "number")) - (if (= predicate-name "list?") - (list "list" (narrow-exclude t "list")) - (if (= predicate-name "dict?") - (list "dict" (narrow-exclude t "dict")) - (if (= predicate-name "boolean?") - (list "boolean" (narrow-exclude t "boolean")) - ;; Unknown predicate — no narrowing - (list t t))))))))) +(define + narrow-type + (fn + (t (predicate-name :as string)) + (match + predicate-name + ("nil?" (list "nil" (narrow-exclude-nil t))) + ("string?" (list "string" (narrow-exclude t "string"))) + ("number?" (list "number" (narrow-exclude t "number"))) + ("list?" (list "list" (narrow-exclude t "list"))) + ("dict?" (list "dict" (narrow-exclude t "dict"))) + ("boolean?" (list "boolean" (narrow-exclude t "boolean"))) + (_ (list t t))))) -(define narrow-exclude-nil - (fn (t) - ;; Remove nil from a type. - (if (= t "nil") "never" - (if (= t "any") "any" ;; can't narrow any - (if (and (= (type-of t) "string") (ends-with? t "?")) +(define + narrow-exclude-nil + (fn + (t) + (if + (= t "nil") + "never" + (if + (= t "any") + "any" + (if + (and (= (type-of t) "string") (ends-with? t "?")) (nullable-base t) - (if (and (= (type-of t) "list") - (not (empty? t)) - (= (first t) "or")) - (let ((members (filter (fn (m) (not (= m "nil"))) (rest t)))) - (if (= (len members) 1) (first members) - (if (empty? members) "never" - (cons "or" members)))) + (if + (and + (= (type-of t) "list") + (not (empty? t)) + (= (first t) "or")) + (let + ((members (filter (fn (m) (not (= m "nil"))) (rest t)))) + (if + (= (len members) 1) + (first members) + (if (empty? members) "never" (cons "or" members)))) t)))))) -(define narrow-exclude - (fn (t excluded) - ;; Remove a specific type from a union. - (if (= t excluded) "never" - (if (= t "any") "any" - (if (and (= (type-of t) "list") - (not (empty? t)) - (= (first t) "or")) - (let ((members (filter (fn (m) (not (= m excluded))) (rest t)))) - (if (= (len members) 1) (first members) - (if (empty? members) "never" - (cons "or" members)))) +(define + narrow-exclude + (fn + (t excluded) + (if + (= t excluded) + "never" + (if + (= t "any") + "any" + (if + (and + (= (type-of t) "list") + (not (empty? t)) + (= (first t) "or")) + (let + ((members (filter (fn (m) (not (= m excluded))) (rest t)))) + (if + (= (len members) 1) + (first members) + (if (empty? members) "never" (cons "or" members)))) t))))) @@ -233,146 +298,203 @@ ;; infer-type walks an AST node and returns its inferred type. ;; type-env is a dict mapping variable names → types. -(define infer-type - (fn (node (type-env :as dict) (prim-types :as dict) type-registry) - (let ((kind (type-of node))) - (if (= kind "number") "number" - (if (= kind "string") "string" - (if (= kind "boolean") "boolean" - (if (nil? node) "nil" - (if (= kind "keyword") "keyword" - (if (= kind "symbol") - (let ((name (symbol-name node))) - ;; Look up in type env - (if (has-key? type-env name) - (get type-env name) - ;; Builtins - (if (= name "true") "boolean" - (if (= name "false") "boolean" - (if (= name "nil") "nil" - ;; Check primitive return types - (if (has-key? prim-types name) - (get prim-types name) - "any")))))) - (if (= kind "dict") "dict" - (if (= kind "list") - (infer-list-type node type-env prim-types type-registry) - "any"))))))))))) +(define + infer-type + (fn + (node (type-env :as dict) (prim-types :as dict) type-registry) + (let + ((kind (type-of node))) + (match + kind + ("number" "number") + ("string" "string") + ("boolean" "boolean") + ("keyword" "keyword") + ("symbol" + (let + ((name (symbol-name node))) + (if + (has-key? type-env name) + (get type-env name) + (if + (= name "true") + "boolean" + (if + (= name "false") + "boolean" + (if + (= name "nil") + "nil" + (if + (has-key? prim-types name) + (get prim-types name) + "any"))))))) + ("dict" "dict") + ("list" (infer-list-type node type-env prim-types type-registry)) + (_ (if (nil? node) "nil" "any")))))) -(define infer-list-type - (fn (node (type-env :as dict) (prim-types :as dict) type-registry) - ;; Infer type of a list expression (function call, special form, etc.) - (if (empty? node) "list" - (let ((head (first node)) - (args (rest node))) - (if (not (= (type-of head) "symbol")) - "any" ;; complex head — can't infer - (let ((name (symbol-name head))) - ;; Special forms - (if (= name "if") - (infer-if-type args type-env prim-types type-registry) - (if (= name "when") - (if (>= (len args) 2) - (type-union (infer-type (last args) type-env prim-types type-registry) "nil") - "nil") - (if (or (= name "cond") (= name "case")) - "any" ;; complex — could be refined later - (if (= name "let") - (infer-let-type args type-env prim-types type-registry) - (if (or (= name "do") (= name "begin")) - (if (empty? args) "nil" - (infer-type (last args) type-env prim-types type-registry)) - (if (or (= name "lambda") (= name "fn")) - "lambda" - (if (= name "and") - (if (empty? args) "boolean" - (infer-type (last args) type-env prim-types type-registry)) - (if (= name "or") - (if (empty? args) "boolean" - ;; or returns first truthy — union of all args - (reduce type-union "never" - (map (fn (a) (infer-type a type-env prim-types type-registry)) args))) - (if (= name "map") - ;; map returns a list - (if (>= (len args) 2) - (let ((fn-type (infer-type (first args) type-env prim-types type-registry))) - ;; If the fn's return type is known, produce (list-of return-type) - (if (and (= (type-of fn-type) "list") - (= (first fn-type) "->")) - (list "list-of" (last fn-type)) - "list")) - "list") - (if (= name "filter") - ;; filter preserves element type - (if (>= (len args) 2) - (infer-type (nth args 1) type-env prim-types type-registry) - "list") - (if (= name "reduce") - ;; reduce returns the accumulator type — too complex to infer - "any" - (if (= name "list") - "list" - (if (= name "dict") - "dict" - (if (= name "quote") - "any" - (if (= name "str") - "string" - (if (= name "not") - "boolean" - (if (= name "get") - ;; get — resolve record field type from type registry - (if (and (>= (len args) 2) (not (nil? type-registry))) - (let ((dict-type (infer-type (first args) type-env prim-types type-registry)) +(define + infer-list-type + (fn + (node (type-env :as dict) (prim-types :as dict) type-registry) + (if + (empty? node) + "list" + (let + ((head (first node)) (args (rest node))) + (if + (not (= (type-of head) "symbol")) + "any" + (let + ((name (symbol-name head))) + (match + name + ("if" (infer-if-type args type-env prim-types type-registry)) + ("when" + (if + (>= (len args) 2) + (type-union + (infer-type (last args) type-env prim-types type-registry) + "nil") + "nil")) + ("cond" "any") + ("case" "any") + ("let" (infer-let-type args type-env prim-types type-registry)) + ("do" + (if + (empty? args) + "nil" + (infer-type (last args) type-env prim-types type-registry))) + ("begin" + (if + (empty? args) + "nil" + (infer-type (last args) type-env prim-types type-registry))) + ("lambda" "lambda") + ("fn" "lambda") + ("and" + (if + (empty? args) + "boolean" + (infer-type (last args) type-env prim-types type-registry))) + ("or" + (if + (empty? args) + "boolean" + (reduce + type-union + "never" + (map + (fn + (a) + (infer-type a type-env prim-types type-registry)) + args)))) + ("map" + (if + (>= (len args) 2) + (let + ((fn-type (infer-type (first args) type-env prim-types type-registry))) + (if + (and + (= (type-of fn-type) "list") + (= (first fn-type) "->")) + (list "list-of" (last fn-type)) + "list")) + "list")) + ("filter" + (if + (>= (len args) 2) + (infer-type (nth args 1) type-env prim-types type-registry) + "list")) + ("reduce" "any") + ("list" "list") + ("dict" "dict") + ("quote" "any") + ("str" "string") + ("not" "boolean") + ("get" + (if + (and (>= (len args) 2) (not (nil? type-registry))) + (let + ((dict-type (infer-type (first args) type-env prim-types type-registry)) (key-arg (nth args 1)) - (key-name (cond - (= (type-of key-arg) "keyword") (keyword-name key-arg) - (= (type-of key-arg) "string") key-arg - :else nil))) - (if (and key-name - (= (type-of dict-type) "string") - (has-key? type-registry dict-type)) - (let ((resolved (resolve-type dict-type type-registry))) - (if (and (= (type-of resolved) "dict") - (has-key? resolved key-name)) - (get resolved key-name) - "any")) - "any")) - "any") - (if (starts-with? name "~") - "element" ;; component call - ;; Regular function call: look up return type - (if (has-key? prim-types name) - (get prim-types name) - "any"))))))))))))))))))))))))) + (key-name + (cond + (= (type-of key-arg) "keyword") + (keyword-name key-arg) + (= (type-of key-arg) "string") + key-arg + :else nil))) + (if + (and + key-name + (= (type-of dict-type) "string") + (has-key? type-registry dict-type)) + (let + ((resolved (resolve-type dict-type type-registry))) + (if + (and + (= (type-of resolved) "dict") + (has-key? resolved key-name)) + (get resolved key-name) + "any")) + "any")) + "any")) + (_ + (if + (starts-with? name "~") + "element" + (if (has-key? prim-types name) (get prim-types name) "any")))))))))) -(define infer-if-type - (fn ((args :as list) (type-env :as dict) (prim-types :as dict) type-registry) - ;; (if test then else?) → union of then and else types - (if (< (len args) 2) "nil" - (let ((then-type (infer-type (nth args 1) type-env prim-types type-registry))) - (if (>= (len args) 3) - (type-union then-type (infer-type (nth args 2) type-env prim-types type-registry)) +(define + infer-if-type + (fn + ((args :as list) + (type-env :as dict) + (prim-types :as dict) + type-registry) + (if + (< (len args) 2) + "nil" + (let + ((then-type (infer-type (nth args 1) type-env prim-types type-registry))) + (if + (>= (len args) 3) + (type-union + then-type + (infer-type (nth args 2) type-env prim-types type-registry)) (type-union then-type "nil")))))) -(define infer-let-type - (fn ((args :as list) (type-env :as dict) (prim-types :as dict) type-registry) - ;; (let ((x expr) ...) body) → type of body in extended type-env - (if (< (len args) 2) "nil" - (let ((bindings (first args)) - (body (last args)) - (extended (merge type-env (dict)))) - ;; Add binding types +(define + infer-let-type + (fn + ((args :as list) + (type-env :as dict) + (prim-types :as dict) + type-registry) + (if + (< (len args) 2) + "nil" + (let + ((bindings (first args)) + (body (last args)) + (extended (merge type-env (dict)))) (for-each - (fn (binding) - (when (and (= (type-of binding) "list") (>= (len binding) 2)) - (let ((name (if (= (type-of (first binding)) "symbol") - (symbol-name (first binding)) - (str (first binding)))) - (val-type (infer-type (nth binding 1) extended prim-types type-registry))) + (fn + (binding) + (when + (and (= (type-of binding) "list") (>= (len binding) 2)) + (let + ((name (if (= (type-of (first binding)) "symbol") (symbol-name (first binding)) (str (first binding)))) + (val-type + (infer-type + (nth binding 1) + extended + prim-types + type-registry))) (dict-set! extended name val-type)))) bindings) (infer-type body extended prim-types type-registry))))) @@ -387,121 +509,209 @@ ;; :component "~name" (or nil for top-level) ;; :expr } -(define make-diagnostic - (fn ((level :as string) (message :as string) component expr) - {:level level - :message message - :component component - :expr expr})) +(define + make-diagnostic + (fn ((level :as string) (message :as string) component expr) {:level level :component component :expr expr :message message})) ;; -------------------------------------------------------------------------- ;; 8. Call-site checking ;; -------------------------------------------------------------------------- -(define check-primitive-call - (fn ((name :as string) (args :as list) (type-env :as dict) (prim-types :as dict) prim-param-types (comp-name :as string) type-registry) - ;; Check a primitive call site against declared param types. - ;; prim-param-types is a dict: {prim-name → {:positional [...] :rest-type type-or-nil}} - ;; Each positional entry is a list (name type-or-nil). - ;; Returns list of diagnostics. - (let ((diagnostics (list))) - (when (and (not (nil? prim-param-types)) - (has-key? prim-param-types name)) - (let ((sig (get prim-param-types name)) - (positional (get sig "positional")) - (rest-type (get sig "rest-type"))) - ;; Check each positional arg +(define + check-primitive-call + (fn + ((name :as string) + (args :as list) + (type-env :as dict) + (prim-types :as dict) + prim-param-types + (comp-name :as string) + type-registry) + (let + ((diagnostics (list))) + (when + (and (not (nil? prim-param-types)) (has-key? prim-param-types name)) + (let + ((sig (get prim-param-types name)) + (positional (get sig "positional")) + (rest-type (get sig "rest-type"))) (for-each - (fn (idx) - (when (< idx (len args)) - (if (< idx (len positional)) - ;; Positional param — check against declared type - (let ((param-info (nth positional idx)) - (arg-expr (nth args idx))) - (let ((expected-type (nth param-info 1))) - (when (not (nil? expected-type)) - (let ((actual (infer-type arg-expr type-env prim-types type-registry))) - (when (and (not (type-any? expected-type)) - (not (type-any? actual)) - (not (subtype-resolved? actual expected-type type-registry))) - (append! diagnostics - (make-diagnostic "error" - (str "Argument " (+ idx 1) " of `" name - "` expects " expected-type ", got " actual) - comp-name arg-expr))))))) - ;; Rest param — check against rest-type - (when (not (nil? rest-type)) - (let ((arg-expr (nth args idx)) - (actual (infer-type arg-expr type-env prim-types type-registry))) - (when (and (not (type-any? rest-type)) - (not (type-any? actual)) - (not (subtype-resolved? actual rest-type type-registry))) - (append! diagnostics - (make-diagnostic "error" - (str "Argument " (+ idx 1) " of `" name - "` expects " rest-type ", got " actual) - comp-name arg-expr)))))))) + (fn + (idx) + (when + (< idx (len args)) + (if + (< idx (len positional)) + (let + ((param-info (nth positional idx)) + (arg-expr (nth args idx))) + (let + ((expected-type (nth param-info 1))) + (when + (not (nil? expected-type)) + (let + ((actual (infer-type arg-expr type-env prim-types type-registry))) + (when + (and + (not (type-any? expected-type)) + (not (type-any? actual)) + (not + (subtype-resolved? + actual + expected-type + type-registry))) + (append! + diagnostics + (make-diagnostic + "error" + (str + "Argument " + (+ idx 1) + " of `" + name + "` expects " + expected-type + ", got " + actual) + comp-name + arg-expr))))))) + (when + (not (nil? rest-type)) + (let + ((arg-expr (nth args idx)) + (actual + (infer-type + arg-expr + type-env + prim-types + type-registry))) + (when + (and + (not (type-any? rest-type)) + (not (type-any? actual)) + (not + (subtype-resolved? actual rest-type type-registry))) + (append! + diagnostics + (make-diagnostic + "error" + (str + "Argument " + (+ idx 1) + " of `" + name + "` expects " + rest-type + ", got " + actual) + comp-name + arg-expr)))))))) (range 0 (len args) 1)))) diagnostics))) -(define check-component-call - (fn ((comp-name :as string) (comp :as component) (call-args :as list) (type-env :as dict) (prim-types :as dict) type-registry) - ;; Check a component call site against its declared param types. - ;; comp is the component value, call-args is the list of args - ;; from the call site (after the component name). - (let ((diagnostics (list)) - (param-types (component-param-types comp)) - (params (component-params comp))) - (when (and (not (nil? param-types)) - (not (empty? (keys param-types)))) - ;; Parse keyword args from call site - (let ((i 0) - (provided-keys (list))) +(define + check-component-call + (fn + ((comp-name :as string) + (comp :as component) + (call-args :as list) + (type-env :as dict) + (prim-types :as dict) + type-registry) + (let + ((diagnostics (list)) + (param-types (component-param-types comp)) + (params (component-params comp))) + (when + (and (not (nil? param-types)) (not (empty? (keys param-types)))) + (let + ((i 0) (provided-keys (list))) (for-each - (fn (idx) - (when (< idx (len call-args)) - (let ((arg (nth call-args idx))) - (when (= (type-of arg) "keyword") - (let ((key-name (keyword-name arg))) + (fn + (idx) + (when + (< idx (len call-args)) + (let + ((arg (nth call-args idx))) + (when + (= (type-of arg) "keyword") + (let + ((key-name (keyword-name arg))) (append! provided-keys key-name) - (when (< (+ idx 1) (len call-args)) - (let ((val-expr (nth call-args (+ idx 1)))) - ;; Check type of value against declared param type - (when (has-key? param-types key-name) - (let ((expected (get param-types key-name)) - (actual (infer-type val-expr type-env prim-types type-registry))) - (when (and (not (type-any? expected)) - (not (type-any? actual)) - (not (subtype-resolved? actual expected type-registry))) - (append! diagnostics - (make-diagnostic "error" - (str "Keyword :" key-name " of " comp-name - " expects " expected ", got " actual) - comp-name val-expr)))))))))))) + (when + (< (+ idx 1) (len call-args)) + (let + ((val-expr (nth call-args (+ idx 1)))) + (when + (has-key? param-types key-name) + (let + ((expected (get param-types key-name)) + (actual + (infer-type + val-expr + type-env + prim-types + type-registry))) + (when + (and + (not (type-any? expected)) + (not (type-any? actual)) + (not + (subtype-resolved? + actual + expected + type-registry))) + (append! + diagnostics + (make-diagnostic + "error" + (str + "Keyword :" + key-name + " of " + comp-name + " expects " + expected + ", got " + actual) + comp-name + val-expr)))))))))))) (range 0 (len call-args) 1)) - - ;; Check for missing required params (those with declared types) (for-each - (fn (param-name) - (when (and (has-key? param-types param-name) - (not (contains? provided-keys param-name)) - (not (type-nullable? (get param-types param-name)))) - (append! diagnostics - (make-diagnostic "warning" - (str "Required param :" param-name " of " comp-name " not provided") - comp-name nil)))) + (fn + (param-name) + (when + (and + (has-key? param-types param-name) + (not (contains? provided-keys param-name)) + (not (type-nullable? (get param-types param-name)))) + (append! + diagnostics + (make-diagnostic + "warning" + (str + "Required param :" + param-name + " of " + comp-name + " not provided") + comp-name + nil)))) params) - - ;; Check for unknown kwargs (for-each - (fn (key) - (when (not (contains? params key)) - (append! diagnostics - (make-diagnostic "warning" + (fn + (key) + (when + (not (contains? params key)) + (append! + diagnostics + (make-diagnostic + "warning" (str "Unknown keyword :" key " passed to " comp-name) - comp-name nil)))) + comp-name + nil)))) provided-keys))) diagnostics))) @@ -510,89 +720,163 @@ ;; 9. AST walker — check a component body ;; -------------------------------------------------------------------------- -(define check-body-walk - (fn (node (comp-name :as string) (type-env :as dict) (prim-types :as dict) prim-param-types env (diagnostics :as list) type-registry effect-annotations) - ;; Recursively walk an AST and collect diagnostics. - ;; prim-param-types: dict of {name → {:positional [...] :rest-type t}} or nil - ;; type-registry: dict of {type-name → type-def} or nil - ;; effect-annotations: dict of {fn-name → effect-list} or nil - (let ((kind (type-of node))) - (when (= kind "list") - (when (not (empty? node)) - (let ((head (first node)) - (args (rest node))) - ;; Check calls when head is a symbol - (when (= (type-of head) "symbol") - (let ((name (symbol-name head))) - ;; Component call - (when (starts-with? name "~") - (let ((comp-val (env-get env name))) - (when (= (type-of comp-val) "component") +(define + check-body-walk + (fn + (node + (comp-name :as string) + (type-env :as dict) + (prim-types :as dict) + prim-param-types + env + (diagnostics :as list) + type-registry + effect-annotations) + (let + ((kind (type-of node))) + (when + (= kind "list") + (when + (not (empty? node)) + (let + ((head (first node)) (args (rest node))) + (when + (= (type-of head) "symbol") + (let + ((name (symbol-name head))) + (when + (starts-with? name "~") + (let + ((comp-val (env-get env name))) + (when + (= (type-of comp-val) "component") (for-each (fn (d) (append! diagnostics d)) - (check-component-call name comp-val args - type-env prim-types type-registry)))) - ;; Effect check for component calls - (when (not (nil? effect-annotations)) - (let ((caller-effects (get-effects comp-name effect-annotations))) + (check-component-call + name + comp-val + args + type-env + prim-types + type-registry)))) + (when + (not (nil? effect-annotations)) + (let + ((caller-effects (get-effects comp-name effect-annotations))) (for-each (fn (d) (append! diagnostics d)) - (check-effect-call name caller-effects effect-annotations comp-name))))) - - ;; Primitive call — check param types - (when (and (not (starts-with? name "~")) - (not (nil? prim-param-types)) - (has-key? prim-param-types name)) + (check-effect-call + name + caller-effects + effect-annotations + comp-name))))) + (when + (and + (not (starts-with? name "~")) + (not (nil? prim-param-types)) + (has-key? prim-param-types name)) (for-each (fn (d) (append! diagnostics d)) - (check-primitive-call name args type-env prim-types - prim-param-types comp-name type-registry))) - - ;; Effect check for function calls - (when (and (not (starts-with? name "~")) - (not (nil? effect-annotations))) - (let ((caller-effects (get-effects comp-name effect-annotations))) + (check-primitive-call + name + args + type-env + prim-types + prim-param-types + comp-name + type-registry))) + (when + (and + (not (starts-with? name "~")) + (not (nil? effect-annotations))) + (let + ((caller-effects (get-effects comp-name effect-annotations))) (for-each (fn (d) (append! diagnostics d)) - (check-effect-call name caller-effects effect-annotations comp-name)))) - - ;; Recurse into let with extended type env - (when (or (= name "let") (= name "let*")) - (when (>= (len args) 2) - (let ((bindings (first args)) - (body-exprs (rest args)) - (extended (merge type-env (dict)))) + (check-effect-call + name + caller-effects + effect-annotations + comp-name)))) + (when + (or (= name "let") (= name "let*")) + (when + (>= (len args) 2) + (let + ((bindings (first args)) + (body-exprs (rest args)) + (extended (merge type-env (dict)))) (for-each - (fn (binding) - (when (and (= (type-of binding) "list") - (>= (len binding) 2)) - (let ((bname (if (= (type-of (first binding)) "symbol") - (symbol-name (first binding)) - (str (first binding)))) - (val-type (infer-type (nth binding 1) extended prim-types type-registry))) + (fn + (binding) + (when + (and + (= (type-of binding) "list") + (>= (len binding) 2)) + (let + ((bname (if (= (type-of (first binding)) "symbol") (symbol-name (first binding)) (str (first binding)))) + (val-type + (infer-type + (nth binding 1) + extended + prim-types + type-registry))) (dict-set! extended bname val-type)))) bindings) (for-each - (fn (body) - (check-body-walk body comp-name extended prim-types prim-param-types env diagnostics type-registry effect-annotations)) + (fn + (body) + (check-body-walk + body + comp-name + extended + prim-types + prim-param-types + env + diagnostics + type-registry + effect-annotations)) body-exprs)))) - - ;; Recurse into define with type binding - (when (= name "define") - (when (>= (len args) 2) - (let ((def-name (if (= (type-of (first args)) "symbol") - (symbol-name (first args)) - nil)) - (def-val (nth args 1))) - (when def-name - (dict-set! type-env def-name - (infer-type def-val type-env prim-types type-registry))) - (check-body-walk def-val comp-name type-env prim-types prim-param-types env diagnostics type-registry effect-annotations)))))) - - ;; Recurse into all child expressions + (when + (= name "define") + (when + (>= (len args) 2) + (let + ((def-name (if (= (type-of (first args)) "symbol") (symbol-name (first args)) nil)) + (def-val (nth args 1))) + (when + def-name + (dict-set! + type-env + def-name + (infer-type + def-val + type-env + prim-types + type-registry))) + (check-body-walk + def-val + comp-name + type-env + prim-types + prim-param-types + env + diagnostics + type-registry + effect-annotations)))))) (for-each - (fn (child) - (check-body-walk child comp-name type-env prim-types prim-param-types env diagnostics type-registry effect-annotations)) + (fn + (child) + (check-body-walk + child + comp-name + type-env + prim-types + prim-param-types + env + diagnostics + type-registry + effect-annotations)) args))))))) @@ -600,34 +884,48 @@ ;; 10. Check a single component ;; -------------------------------------------------------------------------- -(define check-component - (fn ((comp-name :as string) env (prim-types :as dict) prim-param-types type-registry effect-annotations) - ;; Type-check a component's body. Returns list of diagnostics. - ;; prim-param-types: dict of param type info, or nil to skip primitive checking. - ;; type-registry: dict of {type-name → type-def} or nil - ;; effect-annotations: dict of {fn-name → effect-list} or nil - (let ((comp (env-get env comp-name)) - (diagnostics (list))) - (when (= (type-of comp) "component") - (let ((body (component-body comp)) - (params (component-params comp)) - (param-types (component-param-types comp)) - ;; Build initial type env from component params - (type-env (dict))) - ;; Add param types (annotated or default to any) +(define + check-component + (fn + ((comp-name :as string) + env + (prim-types :as dict) + prim-param-types + type-registry + effect-annotations) + (let + ((comp (env-get env comp-name)) (diagnostics (list))) + (when + (= (type-of comp) "component") + (let + ((body (component-body comp)) + (params (component-params comp)) + (param-types (component-param-types comp)) + (type-env (dict))) (for-each - (fn (p) - (dict-set! type-env p - (if (and (not (nil? param-types)) - (has-key? param-types p)) + (fn + (p) + (dict-set! + type-env + p + (if + (and (not (nil? param-types)) (has-key? param-types p)) (get param-types p) "any"))) params) - ;; Add children as (list-of element) if component has children - (when (component-has-children comp) + (when + (component-has-children comp) (dict-set! type-env "children" (list "list-of" "element"))) - - (check-body-walk body comp-name type-env prim-types prim-param-types env diagnostics type-registry effect-annotations))) + (check-body-walk + body + comp-name + type-env + prim-types + prim-param-types + env + diagnostics + type-registry + effect-annotations))) diagnostics))) @@ -635,21 +933,32 @@ ;; 11. Check all components in an environment ;; -------------------------------------------------------------------------- -(define check-all - (fn (env (prim-types :as dict) prim-param-types type-registry effect-annotations) - ;; Type-check every component in the environment. - ;; prim-param-types: dict of param type info, or nil to skip primitive checking. - ;; type-registry: dict of {type-name → type-def} or nil - ;; effect-annotations: dict of {fn-name → effect-list} or nil - ;; Returns list of all diagnostics. - (let ((all-diagnostics (list))) +(define + check-all + (fn + (env + (prim-types :as dict) + prim-param-types + type-registry + effect-annotations) + (let + ((all-diagnostics (list))) (for-each - (fn (name) - (let ((val (env-get env name))) - (when (= (type-of val) "component") + (fn + (name) + (let + ((val (env-get env name))) + (when + (= (type-of val) "component") (for-each (fn (d) (append! all-diagnostics d)) - (check-component name env prim-types prim-param-types type-registry effect-annotations))))) + (check-component + name + env + prim-types + prim-param-types + type-registry + effect-annotations))))) (keys env)) all-diagnostics))) @@ -661,23 +970,28 @@ ;; the declarations parsed by boundary_parser.py. ;; This is called by the host at startup with the parsed declarations. -(define build-type-registry - (fn ((prim-declarations :as list) (io-declarations :as list)) - ;; Both are lists of dicts: {:name "+" :returns "number" :params (...)} - ;; Returns a flat dict: {"+" "number", "str" "string", ...} - (let ((registry (dict))) +(define + build-type-registry + (fn + ((prim-declarations :as list) (io-declarations :as list)) + (let + ((registry (dict))) (for-each - (fn (decl) - (let ((name (get decl "name")) - (returns (get decl "returns"))) - (when (and (not (nil? name)) (not (nil? returns))) + (fn + (decl) + (let + ((name (get decl "name")) (returns (get decl "returns"))) + (when + (and (not (nil? name)) (not (nil? returns))) (dict-set! registry name returns)))) prim-declarations) (for-each - (fn (decl) - (let ((name (get decl "name")) - (returns (get decl "returns"))) - (when (and (not (nil? name)) (not (nil? returns))) + (fn + (decl) + (let + ((name (get decl "name")) (returns (get decl "returns"))) + (when + (and (not (nil? name)) (not (nil? returns))) (dict-set! registry name returns)))) io-declarations) registry))) @@ -699,115 +1013,113 @@ (deftype (maybe a) (union a nil)) ;; A type definition entry in the registry -(deftype type-def - {:name string :params list :body any}) +(deftype type-def {:body any :params list :name string}) ;; A diagnostic produced by the type checker -(deftype diagnostic - {:level string :message string :component string? :expr any}) +(deftype diagnostic {:level string :component string? :expr any :message string}) ;; Primitive parameter type signature -(deftype prim-param-sig - {:positional list :rest-type string?}) +(deftype prim-param-sig {:rest-type string? :positional list}) ;; Effect declarations (defeffect io) (defeffect mutation) (defeffect render) -(define type-def-name - (fn (td) (get td "name"))) +(define type-def-name (fn (td) (get td "name"))) -(define type-def-params - (fn (td) (get td "params"))) +(define type-def-params (fn (td) (get td "params"))) -(define type-def-body - (fn (td) (get td "body"))) +(define type-def-body (fn (td) (get td "body"))) -(define resolve-type - (fn (t registry) - ;; Resolve a type through the registry. - ;; Returns the resolved type representation. - (if (nil? registry) t - (cond - ;; String — might be a named type alias - (= (type-of t) "string") - (if (has-key? registry t) - (let ((td (get registry t))) - (let ((params (type-def-params td)) - (body (type-def-body td))) - (if (empty? params) - ;; Simple alias — resolve the body recursively - (resolve-type body registry) - ;; Parameterized with no args — return as-is - t))) - t) - ;; List — might be parameterized type application or compound - (= (type-of t) "list") - (if (empty? t) t - (let ((head (first t))) +(define + resolve-type + (fn + (t registry) + (if + (nil? registry) + t + (match + (type-of t) + ("string" + (if + (has-key? registry t) + (let + ((td (get registry t))) + (let + ((params (type-def-params td)) (body (type-def-body td))) + (if (empty? params) (resolve-type body registry) t))) + t)) + ("list" + (if + (empty? t) + t + (let + ((head (first t))) (cond - ;; (or ...), (list-of ...), (-> ...) — recurse into members - (or (= head "or") (= head "list-of") (= head "->") - (= head "dict-of")) - (cons head (map (fn (m) (resolve-type m registry)) (rest t))) - ;; Parameterized type application: ("maybe" "string") etc. - (and (= (type-of head) "string") - (has-key? registry head)) - (let ((td (get registry head)) - (params (type-def-params td)) - (body (type-def-body td)) - (args (rest t))) - (if (= (len params) (len args)) - (resolve-type - (substitute-type-vars body params args) - registry) - ;; Wrong arity — return as-is - t)) - :else t))) - ;; Dict — record type, resolve field types - (= (type-of t) "dict") - (map-dict (fn (k v) (resolve-type v registry)) t) - ;; Anything else — return as-is - :else t)))) + (or + (= head "or") + (= head "list-of") + (= head "->") + (= head "dict-of")) + (cons + head + (map (fn (m) (resolve-type m registry)) (rest t))) + (and (= (type-of head) "string") (has-key? registry head)) + (let + ((td (get registry head)) + (params (type-def-params td)) + (body (type-def-body td)) + (args (rest t))) + (if + (= (len params) (len args)) + (resolve-type + (substitute-type-vars body params args) + registry) + t)) + :else t)))) + ("dict" (map-dict (fn (k v) (resolve-type v registry)) t)) + (_ t))))) -(define substitute-type-vars - (fn (body (params :as list) (args :as list)) - ;; Substitute type variables in body. - ;; params is a list of type var names, args is corresponding types. - (let ((subst (dict))) +(define + substitute-type-vars + (fn + (body (params :as list) (args :as list)) + (let + ((subst (dict))) (for-each - (fn (i) - (dict-set! subst (nth params i) (nth args i))) + (fn (i) (dict-set! subst (nth params i) (nth args i))) (range 0 (len params) 1)) (substitute-in-type body subst)))) -(define substitute-in-type - (fn (t (subst :as dict)) - ;; Recursively substitute type variables. - (cond - (= (type-of t) "string") - (if (has-key? subst t) (get subst t) t) - (= (type-of t) "list") - (map (fn (m) (substitute-in-type m subst)) t) - (= (type-of t) "dict") - (map-dict (fn (k v) (substitute-in-type v subst)) t) - :else t))) +(define + substitute-in-type + (fn + (t (subst :as dict)) + (match + (type-of t) + ("string" (if (has-key? subst t) (get subst t) t)) + ("list" (map (fn (m) (substitute-in-type m subst)) t)) + ("dict" (map-dict (fn (k v) (substitute-in-type v subst)) t)) + (_ t)))) -(define subtype-resolved? - (fn (a b registry) - ;; Resolve both sides through the registry, then check subtype. - (if (nil? registry) +(define + subtype-resolved? + (fn + (a b registry) + (if + (nil? registry) (subtype? a b) - (let ((ra (resolve-type a registry)) - (rb (resolve-type b registry))) - ;; Handle record structural subtyping: dict a <: dict b - ;; if every field in b exists in a with compatible type - (if (and (= (type-of ra) "dict") (= (type-of rb) "dict")) + (let + ((ra (resolve-type a registry)) (rb (resolve-type b registry))) + (if + (and (= (type-of ra) "dict") (= (type-of rb) "dict")) (every? - (fn (key) - (and (has-key? ra key) - (subtype-resolved? (get ra key) (get rb key) registry))) + (fn + (key) + (and + (has-key? ra key) + (subtype-resolved? (get ra key) (get rb key) registry))) (keys rb)) (subtype? ra rb)))))) @@ -818,53 +1130,78 @@ ;; Effects are annotations on functions/components describing their ;; side effects. A pure function cannot call IO functions. -(define get-effects - (fn ((name :as string) effect-annotations) - ;; Look up declared effects for a function/component. - ;; Returns list of effect strings, or nil if unannotated. - (if (nil? effect-annotations) nil - (if (has-key? effect-annotations name) +(define + get-effects + (fn + ((name :as string) effect-annotations) + (if + (nil? effect-annotations) + nil + (if + (has-key? effect-annotations name) (get effect-annotations name) nil)))) -(define effects-subset? - (fn (callee-effects caller-effects) - ;; Are all callee effects allowed by caller? - ;; nil effects = unannotated = assumed to have all effects. - ;; Empty list = pure = no effects. - (if (nil? caller-effects) true ;; unannotated caller allows everything - (if (nil? callee-effects) true ;; unannotated callee — skip check - (every? - (fn (e) (contains? caller-effects e)) - callee-effects))))) +(define + effects-subset? + (fn + (callee-effects caller-effects) + (if + (nil? caller-effects) + true + (if + (nil? callee-effects) + true + (every? (fn (e) (contains? caller-effects e)) callee-effects))))) -(define check-effect-call - (fn ((callee-name :as string) caller-effects effect-annotations (comp-name :as string)) - ;; Check that callee's effects are allowed by caller's effects. - ;; Returns list of diagnostics. - (let ((diagnostics (list)) - (callee-effects (get-effects callee-name effect-annotations))) - (when (and (not (nil? caller-effects)) - (not (nil? callee-effects)) - (not (effects-subset? callee-effects caller-effects))) - (append! diagnostics - (make-diagnostic "error" - (str "`" callee-name "` has effects " - (join ", " callee-effects) - " but `" comp-name "` only allows " - (if (empty? caller-effects) "[pure]" - (join ", " caller-effects))) - comp-name nil))) +(define + check-effect-call + (fn + ((callee-name :as string) + caller-effects + effect-annotations + (comp-name :as string)) + (let + ((diagnostics (list)) + (callee-effects (get-effects callee-name effect-annotations))) + (when + (and + (not (nil? caller-effects)) + (not (nil? callee-effects)) + (not (effects-subset? callee-effects caller-effects))) + (append! + diagnostics + (make-diagnostic + "error" + (str + "`" + callee-name + "` has effects " + (join ", " callee-effects) + " but `" + comp-name + "` only allows " + (if + (empty? caller-effects) + "[pure]" + (join ", " caller-effects))) + comp-name + nil))) diagnostics))) -(define build-effect-annotations - (fn ((io-declarations :as list)) - ;; Assign [io] effect to all IO primitives. - (let ((annotations (dict))) +(define + build-effect-annotations + (fn + ((io-declarations :as list)) + (let + ((annotations (dict))) (for-each - (fn (decl) - (let ((name (get decl "name"))) - (when (not (nil? name)) + (fn + (decl) + (let + ((name (get decl "name"))) + (when + (not (nil? name)) (dict-set! annotations name (list "io"))))) io-declarations) annotations))) @@ -876,27 +1213,41 @@ ;; Validates that components respect their declared effect annotations. ;; Delegates to check-body-walk with nil type checking (effects only). -(define check-component-effects - (fn ((comp-name :as string) env effect-annotations) - ;; Check a single component's effect usage. Returns diagnostics list. - ;; Skips type checking — only checks effect violations. - (let ((comp (env-get env comp-name)) - (diagnostics (list))) - (when (= (type-of comp) "component") - (let ((body (component-body comp))) - (check-body-walk body comp-name (dict) (dict) nil env - diagnostics nil effect-annotations))) +(define + check-component-effects + (fn + ((comp-name :as string) env effect-annotations) + (let + ((comp (env-get env comp-name)) (diagnostics (list))) + (when + (= (type-of comp) "component") + (let + ((body (component-body comp))) + (check-body-walk + body + comp-name + (dict) + (dict) + nil + env + diagnostics + nil + effect-annotations))) diagnostics))) -(define check-all-effects - (fn (env effect-annotations) - ;; Check all components in env for effect violations. - ;; Returns list of all diagnostics. - (let ((all-diagnostics (list))) +(define + check-all-effects + (fn + (env effect-annotations) + (let + ((all-diagnostics (list))) (for-each - (fn (name) - (let ((val (env-get env name))) - (when (= (type-of val) "component") + (fn + (name) + (let + ((val (env-get env name))) + (when + (= (type-of val) "component") (for-each (fn (d) (append! all-diagnostics d)) (check-component-effects name env effect-annotations))))) diff --git a/lib/vm.sx b/lib/vm.sx index 6e0224a6..fbd63557 100644 --- a/lib/vm.sx +++ b/lib/vm.sx @@ -79,35 +79,35 @@ (fn (vm value) (let - ((sp (get vm "sp")) (stack (get vm "stack"))) + ((sp (vm-sp vm)) (stack (vm-stack vm))) (when (>= sp (vm-stack-length stack)) (let - ((new-stack (make-vm-stack (* sp 2)))) + ((new-stack (vm-stack-grow stack sp))) (vm-stack-copy! stack new-stack sp) - (dict-set! vm "stack" new-stack) + (vm-set-stack! vm new-stack) (set! stack new-stack))) (vm-stack-set! stack sp value) - (dict-set! vm "sp" (+ sp 1))))) + (vm-set-sp! vm (+ sp 1))))) (define vm-pop (fn (vm) (let - ((sp (- (get vm "sp") 1))) - (dict-set! vm "sp" sp) - (vm-stack-get (get vm "stack") sp)))) + ((sp (- (vm-sp vm) 1))) + (vm-set-sp! vm sp) + (vm-stack-get (vm-stack vm) sp)))) (define vm-peek - (fn (vm) (vm-stack-get (get vm "stack") (- (get vm "sp") 1)))) + (fn (vm) (vm-stack-get (vm-stack vm) (- (vm-sp vm) 1)))) (define frame-read-u8 (fn (frame) (let - ((ip (get frame "ip")) - (bc (get (get (get frame "closure") "vm-code") "vc-bytecode"))) - (let ((v (nth bc ip))) (dict-set! frame "ip" (+ ip 1)) v)))) + ((ip (frame-ip frame)) + (bc (-> frame frame-closure closure-code code-bytecode))) + (let ((v (nth bc ip))) (frame-set-ip! frame (+ ip 1)) v)))) (define frame-read-u16 (fn @@ -206,31 +206,28 @@ (if (has-key? cells key) (uv-get (get cells key)) - (vm-stack-get (get vm "stack") (+ (get frame "base") slot)))))) + (vm-stack-get (vm-stack vm) (+ (frame-base frame) slot)))))) (define frame-local-set (fn (vm frame slot value) - "Write a local variable — to shared cell if captured, else to stack." + "Write a local variable — to shared cell or stack." (let ((cells (get frame "local-cells")) (key (str slot))) (if (has-key? cells key) (uv-set! (get cells key) value) - (vm-stack-set! - (get vm "stack") - (+ (get frame "base") slot) - value))))) + (vm-stack-set! (vm-stack vm) (+ (frame-base frame) slot) value))))) (define frame-upvalue-get (fn (frame idx) - (uv-get (nth (get (get frame "closure") "vm-upvalues") idx)))) + (uv-get (nth (-> frame frame-closure closure-upvalues) idx)))) (define frame-upvalue-set (fn (frame idx value) - (uv-set! (nth (get (get frame "closure") "vm-upvalues") idx) value))) + (uv-set! (nth (-> frame frame-closure closure-upvalues) idx) value))) (define frame-ip (fn (frame) (get frame "ip"))) (define frame-set-ip! (fn (frame val) (dict-set! frame "ip" val))) (define frame-base (fn (frame) (get frame "base"))) @@ -302,12 +299,12 @@ (vm frame name) "Look up a global: globals table → closure env → primitives → HO wrappers" (let - ((globals (get vm "globals"))) + ((globals (vm-globals-ref vm))) (if (has-key? globals name) (get globals name) (let - ((closure-env (get (get frame "closure") "closure-env"))) + ((closure-env (-> frame frame-closure closure-env))) (if (nil? closure-env) (cek-try @@ -325,41 +322,42 @@ vm-resolve-ho-form (fn (vm name) - (cond - (= name "for-each") - (fn - (f coll) - (for-each (fn (x) (vm-call-external vm f (list x))) coll)) - (= name "map") - (fn - (f coll) - (map (fn (x) (vm-call-external vm f (list x))) coll)) - (= name "map-indexed") - (fn - (f coll) - (map-indexed - (fn (i x) (vm-call-external vm f (list i x))) - coll)) - (= name "filter") - (fn - (f coll) - (filter (fn (x) (vm-call-external vm f (list x))) coll)) - (= name "reduce") - (fn - (f init coll) - (reduce - (fn (acc x) (vm-call-external vm f (list acc x))) - init - coll)) - (= name "some") - (fn - (f coll) - (some (fn (x) (vm-call-external vm f (list x))) coll)) - (= name "every?") - (fn - (f coll) - (every? (fn (x) (vm-call-external vm f (list x))) coll)) - :else (error (str "VM undefined: " name))))) + (match + name + ("for-each" + (fn + (f coll) + (for-each (fn (x) (vm-call-external vm f (list x))) coll))) + ("map" + (fn + (f coll) + (map (fn (x) (vm-call-external vm f (list x))) coll))) + ("map-indexed" + (fn + (f coll) + (map-indexed + (fn (i x) (vm-call-external vm f (list i x))) + coll))) + ("filter" + (fn + (f coll) + (filter (fn (x) (vm-call-external vm f (list x))) coll))) + ("reduce" + (fn + (f init coll) + (reduce + (fn (acc x) (vm-call-external vm f (list acc x))) + init + coll))) + ("some" + (fn + (f coll) + (some (fn (x) (vm-call-external vm f (list x))) coll))) + ("every?" + (fn + (f coll) + (every? (fn (x) (vm-call-external vm f (list x))) coll))) + (_ (error (str "VM undefined: " name)))))) (define vm-call-external (fn @@ -372,14 +370,14 @@ vm-global-set (fn (vm frame name value) - "Set a global: write to closure env if name exists there, else globals." + "Set a global: write to closure env if found, else globals table." (let - ((closure-env (get (get frame "closure") "vm-closure-env")) + ((closure-env (get (frame-closure frame) "vm-closure-env")) (written false)) (when (not (nil? closure-env)) (set! written (env-walk-set! closure-env name value))) - (when (not written) (dict-set! (get vm "globals") name value))))) + (when (not written) (dict-set! (vm-globals-ref vm) name value))))) (define env-walk (fn @@ -414,20 +412,15 @@ (let ((code (code-from-value code-val)) (uv-count - (if - (dict? code-val) - (let - ((n (get code-val "upvalue-count"))) - (if (nil? n) 0 n)) - 0))) + (if (dict? code-val) (or (get code-val "upvalue-count") 0) 0))) (let - ((upvalues (let ((result (list)) (i 0)) (define capture-loop (fn () (when (< i uv-count) (let ((is-local (frame-read-u8 frame)) (index (frame-read-u8 frame))) (let ((cell (if (= is-local 1) (let ((cells (get frame "local-cells")) (key (str index))) (if (has-key? cells key) (get cells key) (let ((c (make-upvalue-cell (vm-stack-get (get vm "stack") (+ (get frame "base") index))))) (dict-set! cells key c) c))) (nth (get (get frame "closure") "vm-upvalues") index)))) (append! result cell) (set! i (+ i 1)) (capture-loop)))))) (capture-loop) result))) - (make-vm-closure code upvalues nil (get vm "globals") nil))))) + ((upvalues (let ((result (list)) (i 0)) (define capture-loop (fn () (when (< i uv-count) (let ((is-local (frame-read-u8 frame)) (index (frame-read-u8 frame))) (let ((cell (if (= is-local 1) (let ((cells (get frame "local-cells")) (key (str index))) (if (has-key? cells key) (get cells key) (let ((c (make-upvalue-cell (vm-stack-get (vm-stack vm) (+ (frame-base frame) index))))) (dict-set! cells key c) c))) (nth (-> frame frame-closure closure-upvalues) index)))) (append! result cell) (set! i (+ i 1)) (capture-loop)))))) (capture-loop) result))) + (make-vm-closure code upvalues nil (vm-globals-ref vm) nil))))) (define vm-run (fn (vm) - "Execute bytecode until all frames are consumed." + "Execute bytecode until all frames are done or IO suspension." (define loop (fn @@ -438,9 +431,9 @@ ((frame (first (vm-frames vm))) (rest-frames (rest (vm-frames vm)))) (let - ((bc (code-bytecode (closure-code (frame-closure frame)))) + ((bc (-> frame frame-closure closure-code code-bytecode)) (consts - (code-constants (closure-code (frame-closure frame))))) + (-> frame frame-closure closure-code code-constants))) (if (>= (frame-ip frame) (len bc)) (vm-set-frames! vm (list)) diff --git a/shared/sx/templates/client-libs/page-functions.sx b/shared/sx/templates/client-libs/page-functions.sx index 3de6ea80..e81f6e9e 100644 --- a/shared/sx/templates/client-libs/page-functions.sx +++ b/shared/sx/templates/client-libs/page-functions.sx @@ -121,57 +121,63 @@ (case slug "bundle-analyzer" - (let - ((data (helper "bundle-analyzer-data"))) + (let-match + {:total-macros total-macros :pages pages :io-count io-count :pure-count pure-count :total-components total-components} + (helper "bundle-analyzer-data") (quasiquote (~analyzer/bundle-analyzer-content - :pages (unquote (get data "pages")) - :total-components (unquote (get data "total-components")) - :total-macros (unquote (get data "total-macros")) - :pure-count (unquote (get data "pure-count")) - :io-count (unquote (get data "io-count"))))) + :pages (unquote pages) + :total-components (unquote total-components) + :total-macros (unquote total-macros) + :pure-count (unquote pure-count) + :io-count (unquote io-count)))) "routing-analyzer" - (let - ((data (helper "routing-analyzer-data"))) + (let-match + {:pages pages :total-pages total-pages :server-count server-count :registry-sample registry-sample :client-count client-count} + (helper "routing-analyzer-data") (quasiquote (~routing-analyzer/content - :pages (unquote (get data "pages")) - :total-pages (unquote (get data "total-pages")) - :client-count (unquote (get data "client-count")) - :server-count (unquote (get data "server-count")) - :registry-sample (unquote (get data "registry-sample"))))) + :pages (unquote pages) + :total-pages (unquote total-pages) + :client-count (unquote client-count) + :server-count (unquote server-count) + :registry-sample (unquote registry-sample)))) "data-test" - (let - ((data (helper "data-test-data"))) + (let-match + {:server-time server-time :transport transport :phase phase :items items} + (helper "data-test-data") (quasiquote (~data-test/content - :server-time (unquote (get data "server-time")) - :items (unquote (get data "items")) - :phase (unquote (get data "phase")) - :transport (unquote (get data "transport"))))) + :server-time (unquote server-time) + :items (unquote items) + :phase (unquote phase) + :transport (unquote transport)))) "async-io" (quote (~async-io-demo/content)) "affinity" - (let - ((data (helper "affinity-demo-data"))) + (let-match + {:components components :page-plans page-plans} + (helper "affinity-demo-data") (quasiquote (~affinity-demo/content - :components (unquote (get data "components")) - :page-plans (unquote (get data "page-plans"))))) + :components (unquote components) + :page-plans (unquote page-plans)))) "optimistic" - (let - ((data (helper "optimistic-demo-data"))) + (let-match + {:server-time server-time :items items} + (helper "optimistic-demo-data") (quasiquote (~optimistic-demo/content - :items (unquote (get data "items")) - :server-time (unquote (get data "server-time"))))) + :items (unquote items) + :server-time (unquote server-time)))) "offline" - (let - ((data (helper "offline-demo-data"))) + (let-match + {:server-time server-time :notes notes} + (helper "offline-demo-data") (quasiquote (~offline-demo/content - :notes (unquote (get data "notes")) - :server-time (unquote (get data "server-time"))))) + :notes (unquote notes) + :server-time (unquote server-time)))) :else (quote (~plans/isomorphic/plan-isomorphic-content)))))) (define @@ -262,15 +268,18 @@ ((found-spec (find-spec slug))) (if found-spec - (let - ((src (helper "read-spec-file" (get found-spec "filename")))) - (quasiquote - (~specs/detail-content - :spec-title (unquote (get found-spec "title")) - :spec-desc (unquote (get found-spec "desc")) - :spec-filename (unquote (get found-spec "filename")) - :spec-source (unquote src) - :spec-prose (unquote (get found-spec "prose"))))) + (let-match + {:desc desc :prose prose :title title :filename filename} + found-spec + (let + ((src (helper "read-spec-file" filename))) + (quasiquote + (~specs/detail-content + :spec-title (unquote title) + :spec-desc (unquote desc) + :spec-filename (unquote filename) + :spec-source (unquote src) + :spec-prose (unquote prose))))) (quasiquote (~specs/not-found :slug (unquote slug))))))))) (define @@ -324,54 +333,67 @@ (case slug "self-hosting" - (quasiquote - (~specs/bootstrapper-self-hosting-content - :py-sx-source (unquote (get data "py-sx-source")) - :g0-output (unquote (get data "g0-output")) - :g1-output (unquote (get data "g1-output")) - :defines-matched (unquote (get data "defines-matched")) - :defines-total (unquote (get data "defines-total")) - :g0-lines (unquote (get data "g0-lines")) - :g0-bytes (unquote (get data "g0-bytes")) - :verification-status (unquote (get data "verification-status")))) + (let-match + {:g1-output g1-output :py-sx-source py-sx-source :g0-bytes g0-bytes :verification-status verification-status :g0-output g0-output :defines-total defines-total :defines-matched defines-matched :g0-lines g0-lines} + data + (quasiquote + (~specs/bootstrapper-self-hosting-content + :py-sx-source (unquote py-sx-source) + :g0-output (unquote g0-output) + :g1-output (unquote g1-output) + :defines-matched (unquote defines-matched) + :defines-total (unquote defines-total) + :g0-lines (unquote g0-lines) + :g0-bytes (unquote g0-bytes) + :verification-status (unquote verification-status)))) "self-hosting-js" - (quasiquote - (~specs/bootstrapper-self-hosting-js-content - :js-sx-source (unquote (get data "js-sx-source")) - :defines-matched (unquote (get data "defines-matched")) - :defines-total (unquote (get data "defines-total")) - :js-sx-lines (unquote (get data "js-sx-lines")) - :verification-status (unquote (get data "verification-status")))) + (let-match + {:js-sx-source js-sx-source :verification-status verification-status :js-sx-lines js-sx-lines :defines-total defines-total :defines-matched defines-matched} + data + (quasiquote + (~specs/bootstrapper-self-hosting-js-content + :js-sx-source (unquote js-sx-source) + :defines-matched (unquote defines-matched) + :defines-total (unquote defines-total) + :js-sx-lines (unquote js-sx-lines) + :verification-status (unquote verification-status)))) "python" - (quasiquote - (~specs/bootstrapper-py-content - :bootstrapper-source (unquote (get data "bootstrapper-source")) - :bootstrapped-output (unquote (get data "bootstrapped-output")))) + (let-match + {:bootstrapper-source bootstrapper-source :bootstrapped-output bootstrapped-output} + data + (quasiquote + (~specs/bootstrapper-py-content + :bootstrapper-source (unquote bootstrapper-source) + :bootstrapped-output (unquote bootstrapped-output)))) "page-helpers" - (let - ((ph-data (helper "page-helpers-demo-data"))) + (let-match + {:attr-result attr-result :sf-source sf-source :ref-ms ref-ms :req-attrs req-attrs :attr-detail attr-detail :attr-keys attr-keys :server-total-ms server-total-ms :attr-ms attr-ms :comp-ms comp-ms :routing-ms routing-ms :comp-source comp-source :routing-result routing-result :sf-categories sf-categories :sf-total sf-total :sf-ms sf-ms :ref-sample ref-sample} + (helper "page-helpers-demo-data") (quasiquote (~page-helpers-demo/content - :sf-categories (unquote (get ph-data "sf-categories")) - :sf-total (unquote (get ph-data "sf-total")) - :sf-ms (unquote (get ph-data "sf-ms")) - :ref-sample (unquote (get ph-data "ref-sample")) - :ref-ms (unquote (get ph-data "ref-ms")) - :attr-result (unquote (get ph-data "attr-result")) - :attr-ms (unquote (get ph-data "attr-ms")) - :comp-source (unquote (get ph-data "comp-source")) - :comp-ms (unquote (get ph-data "comp-ms")) - :routing-result (unquote (get ph-data "routing-result")) - :routing-ms (unquote (get ph-data "routing-ms")) - :server-total-ms (unquote (get ph-data "server-total-ms")) - :sf-source (unquote (get ph-data "sf-source")) - :attr-detail (unquote (get ph-data "attr-detail")) - :req-attrs (unquote (get ph-data "req-attrs")) - :attr-keys (unquote (get ph-data "attr-keys"))))) - :else (quasiquote - (~specs/bootstrapper-js-content - :bootstrapper-source (unquote (get data "bootstrapper-source")) - :bootstrapped-output (unquote (get data "bootstrapped-output")))))))))) + :sf-categories (unquote sf-categories) + :sf-total (unquote sf-total) + :sf-ms (unquote sf-ms) + :ref-sample (unquote ref-sample) + :ref-ms (unquote ref-ms) + :attr-result (unquote attr-result) + :attr-ms (unquote attr-ms) + :comp-source (unquote comp-source) + :comp-ms (unquote comp-ms) + :routing-result (unquote routing-result) + :routing-ms (unquote routing-ms) + :server-total-ms (unquote server-total-ms) + :sf-source (unquote sf-source) + :attr-detail (unquote attr-detail) + :req-attrs (unquote req-attrs) + :attr-keys (unquote attr-keys)))) + :else (let-match + {:bootstrapper-source bootstrapper-source :bootstrapped-output bootstrapped-output} + data + (quasiquote + (~specs/bootstrapper-js-content + :bootstrapper-source (unquote bootstrapper-source) + :bootstrapped-output (unquote bootstrapped-output)))))))))) (define test @@ -379,24 +401,26 @@ (slug) (if (nil? slug) - (let - ((data (helper "run-modular-tests" "all"))) + (let-match + {:server-results server-results :parser-source parser-source :framework-source framework-source :eval-source eval-source :router-source router-source :engine-source engine-source :render-source render-source :deps-source deps-source} + (helper "run-modular-tests" "all") (quasiquote (~testing/overview-content - :server-results (unquote (get data "server-results")) - :framework-source (unquote (get data "framework-source")) - :eval-source (unquote (get data "eval-source")) - :parser-source (unquote (get data "parser-source")) - :router-source (unquote (get data "router-source")) - :render-source (unquote (get data "render-source")) - :deps-source (unquote (get data "deps-source")) - :engine-source (unquote (get data "engine-source"))))) + :server-results (unquote server-results) + :framework-source (unquote framework-source) + :eval-source (unquote eval-source) + :parser-source (unquote parser-source) + :router-source (unquote router-source) + :render-source (unquote render-source) + :deps-source (unquote deps-source) + :engine-source (unquote engine-source)))) (case slug "runners" (quote (~testing/runners-content)) - :else (let - ((data (helper "run-modular-tests" slug))) + :else (let-match + {:server-results server-results :spec-source spec-source :framework-source framework-source} + (helper "run-modular-tests" slug) (case slug "eval" @@ -404,67 +428,67 @@ (~testing/spec-content :spec-name "eval" :spec-title "Evaluator Tests" - :spec-desc "81 tests covering the core evaluator and all primitives." - :spec-source (unquote (get data "spec-source")) - :framework-source (unquote (get data "framework-source")) - :server-results (unquote (get data "server-results")))) + :spec-desc "81 tests covering the core evaluator — literals, symbols, special forms, closures." + :spec-source (unquote spec-source) + :framework-source (unquote framework-source) + :server-results (unquote server-results))) "parser" (quasiquote (~testing/spec-content :spec-name "parser" :spec-title "Parser Tests" :spec-desc "39 tests covering tokenization and parsing." - :spec-source (unquote (get data "spec-source")) - :framework-source (unquote (get data "framework-source")) - :server-results (unquote (get data "server-results")))) + :spec-source (unquote spec-source) + :framework-source (unquote framework-source) + :server-results (unquote server-results))) "router" (quasiquote (~testing/spec-content :spec-name "router" :spec-title "Router Tests" :spec-desc "18 tests covering client-side route matching." - :spec-source (unquote (get data "spec-source")) - :framework-source (unquote (get data "framework-source")) - :server-results (unquote (get data "server-results")))) + :spec-source (unquote spec-source) + :framework-source (unquote framework-source) + :server-results (unquote server-results))) "render" (quasiquote (~testing/spec-content :spec-name "render" :spec-title "Renderer Tests" :spec-desc "23 tests covering HTML rendering." - :spec-source (unquote (get data "spec-source")) - :framework-source (unquote (get data "framework-source")) - :server-results (unquote (get data "server-results")))) + :spec-source (unquote spec-source) + :framework-source (unquote framework-source) + :server-results (unquote server-results))) "deps" (quasiquote (~testing/spec-content :spec-name "deps" :spec-title "Dependency Analysis Tests" :spec-desc "33 tests covering component dependency analysis." - :spec-source (unquote (get data "spec-source")) - :framework-source (unquote (get data "framework-source")) - :server-results (unquote (get data "server-results")))) + :spec-source (unquote spec-source) + :framework-source (unquote framework-source) + :server-results (unquote server-results))) "engine" (quasiquote (~testing/spec-content :spec-name "engine" :spec-title "Engine Tests" :spec-desc "37 tests covering engine pure functions." - :spec-source (unquote (get data "spec-source")) - :framework-source (unquote (get data "framework-source")) - :server-results (unquote (get data "server-results")))) + :spec-source (unquote spec-source) + :framework-source (unquote framework-source) + :server-results (unquote server-results))) "orchestration" (quasiquote (~testing/spec-content :spec-name "orchestration" :spec-title "Orchestration Tests" :spec-desc "17 tests covering orchestration." - :spec-source (unquote (get data "spec-source")) - :framework-source (unquote (get data "framework-source")) - :server-results (unquote (get data "server-results")))) + :spec-source (unquote spec-source) + :framework-source (unquote framework-source) + :server-results (unquote server-results))) :else (quasiquote (~testing/overview-content - :server-results (unquote (get data "server-results")))))))))) + :server-results (unquote server-results))))))))) (define reference @@ -478,26 +502,32 @@ (case slug "attributes" - (quasiquote - (~reference/attrs-content - :req-table (~docs/attr-table-from-data - :title "Request Attributes" - :attrs (unquote (get data "req-attrs"))) - :beh-table (~docs/attr-table-from-data - :title "Behavior Attributes" - :attrs (unquote (get data "beh-attrs"))) - :uniq-table (~docs/attr-table-from-data - :title "Unique to sx" - :attrs (unquote (get data "uniq-attrs"))))) + (let-match + {:req-attrs req-attrs :beh-attrs beh-attrs :uniq-attrs uniq-attrs} + data + (quasiquote + (~reference/attrs-content + :req-table (~docs/attr-table-from-data + :title "Request Attributes" + :attrs (unquote req-attrs)) + :beh-table (~docs/attr-table-from-data + :title "Behavior Attributes" + :attrs (unquote beh-attrs)) + :uniq-table (~docs/attr-table-from-data + :title "Unique to sx" + :attrs (unquote uniq-attrs))))) "headers" - (quasiquote - (~reference/headers-content - :req-table (~docs/headers-table-from-data - :title "Request Headers" - :headers (unquote (get data "req-headers"))) - :resp-table (~docs/headers-table-from-data - :title "Response Headers" - :headers (unquote (get data "resp-headers"))))) + (let-match + {:req-headers req-headers :resp-headers resp-headers} + data + (quasiquote + (~reference/headers-content + :req-table (~docs/headers-table-from-data + :title "Request Headers" + :headers (unquote req-headers)) + :resp-table (~docs/headers-table-from-data + :title "Response Headers" + :headers (unquote resp-headers))))) "events" (quasiquote (~reference/events-content @@ -514,17 +544,20 @@ :col1 "Method" :col2 "Description" :items (unquote (get data "js-api-list"))))) - :else (quasiquote - (~reference/attrs-content - :req-table (~docs/attr-table-from-data - :title "Request Attributes" - :attrs (unquote (get data "req-attrs"))) - :beh-table (~docs/attr-table-from-data - :title "Behavior Attributes" - :attrs (unquote (get data "beh-attrs"))) - :uniq-table (~docs/attr-table-from-data - :title "Unique to sx" - :attrs (unquote (get data "uniq-attrs")))))))))) + :else (let-match + {:req-attrs req-attrs :beh-attrs beh-attrs :uniq-attrs uniq-attrs} + data + (quasiquote + (~reference/attrs-content + :req-table (~docs/attr-table-from-data + :title "Request Attributes" + :attrs (unquote req-attrs)) + :beh-table (~docs/attr-table-from-data + :title "Behavior Attributes" + :attrs (unquote beh-attrs)) + :uniq-table (~docs/attr-table-from-data + :title "Unique to sx" + :attrs (unquote uniq-attrs)))))))))) (define reference-detail @@ -541,39 +574,48 @@ (if (get data "attr-not-found") (quasiquote (~reference/attr-not-found :slug (unquote slug))) - (quasiquote - (~reference/attr-detail-content - :title (unquote (get data "attr-title")) - :description (unquote (get data "attr-description")) - :demo (unquote (get data "attr-demo")) - :example-code (unquote (get data "attr-example")) - :handler-code (unquote (get data "attr-handler")) - :wire-placeholder-id (unquote (get data "attr-wire-id")))))) + (let-match + {:attr-handler attr-handler :attr-title attr-title :attr-example attr-example :attr-description attr-description :attr-demo attr-demo :attr-wire-id attr-wire-id} + data + (quasiquote + (~reference/attr-detail-content + :title (unquote attr-title) + :description (unquote attr-description) + :demo (unquote attr-demo) + :example-code (unquote attr-example) + :handler-code (unquote attr-handler) + :wire-placeholder-id (unquote attr-wire-id)))))) "headers" (let ((data (helper "header-detail-data" slug))) (if (get data "header-not-found") (quasiquote (~reference/attr-not-found :slug (unquote slug))) - (quasiquote - (~reference/header-detail-content - :title (unquote (get data "header-title")) - :direction (unquote (get data "header-direction")) - :description (unquote (get data "header-description")) - :example-code (unquote (get data "header-example")) - :demo (unquote (get data "header-demo")))))) + (let-match + {:header-description header-description :header-demo header-demo :header-title header-title :header-example header-example :header-direction header-direction} + data + (quasiquote + (~reference/header-detail-content + :title (unquote header-title) + :direction (unquote header-direction) + :description (unquote header-description) + :example-code (unquote header-example) + :demo (unquote header-demo)))))) "events" (let ((data (helper "event-detail-data" slug))) (if (get data "event-not-found") (quasiquote (~reference/attr-not-found :slug (unquote slug))) - (quasiquote - (~reference/event-detail-content - :title (unquote (get data "event-title")) - :description (unquote (get data "event-description")) - :example-code (unquote (get data "event-example")) - :demo (unquote (get data "event-demo")))))) + (let-match + {:event-example event-example :event-demo event-demo :event-description event-description :event-title event-title} + data + (quasiquote + (~reference/event-detail-content + :title (unquote event-title) + :description (unquote event-description) + :example-code (unquote event-example) + :demo (unquote event-demo)))))) :else nil)))) (define diff --git a/spec/signals.sx b/spec/signals.sx index da8f8885..db112d87 100644 --- a/spec/signals.sx +++ b/spec/signals.sx @@ -1,6 +1,7 @@ -(define-library (sx signals) +(define-library + (sx signals) (export make-signal signal? @@ -26,205 +27,193 @@ with-island-scope register-in-scope) (begin - -(define - make-signal - (fn - (value) - (dict "__signal" true "value" value "subscribers" (list) "deps" (list)))) - -(define signal? (fn (x) (and (dict? x) (has-key? x "__signal")))) - -(define signal-value (fn (s) (get s "value"))) - -(define signal-set-value! (fn (s v) (dict-set! s "value" v))) - -(define signal-subscribers (fn (s) (get s "subscribers"))) - -(define - signal-add-sub! - (fn - (s f) - (when - (not (contains? (get s "subscribers") f)) - (dict-set! s "subscribers" (append (get s "subscribers") (list f)))))) - -(define - signal-remove-sub! - (fn - (s f) - (dict-set! - s - "subscribers" - (filter (fn (sub) (not (identical? sub f))) (get s "subscribers"))))) - -(define signal-deps (fn (s) (get s "deps"))) - -(define signal-set-deps! (fn (s deps) (dict-set! s "deps" deps))) - -(define - signal - :effects () - (fn ((initial-value :as any)) (make-signal initial-value))) - -(define - deref - :effects () - (fn - ((s :as any)) - (if - (not (signal? s)) - s - (let - ((ctx (context "sx-reactive" nil))) + (define + make-signal + (fn + (value) + (dict + "__signal" + true + "value" + value + "subscribers" + (list) + "deps" + (list)))) + (define signal? (fn (x) (and (dict? x) (has-key? x "__signal")))) + (define signal-value (fn (s) (get s "value"))) + (define signal-set-value! (fn (s v) (dict-set! s "value" v))) + (define signal-subscribers (fn (s) (get s "subscribers"))) + (define + signal-add-sub! + (fn + (s f) (when - ctx + (not (contains? (get s "subscribers") f)) + (dict-set! + s + "subscribers" + (append (get s "subscribers") (list f)))))) + (define + signal-remove-sub! + (fn + (s f) + (dict-set! + s + "subscribers" + (filter + (fn (sub) (not (identical? sub f))) + (get s "subscribers"))))) + (define signal-deps (fn (s) (get s "deps"))) + (define signal-set-deps! (fn (s deps) (dict-set! s "deps" deps))) + (define + signal + :effects () + (fn ((initial-value :as any)) (make-signal initial-value))) + (define + deref + :effects () + (fn + ((s :as any)) + (if + (not (signal? s)) + s (let - ((dep-list (get ctx "deps")) (notify-fn (get ctx "notify"))) + ((ctx (context "sx-reactive" nil))) (when - (not (contains? dep-list s)) - (append! dep-list s) - (signal-add-sub! s notify-fn)))) - (signal-value s))))) - -(define - reset! - :effects (mutation) - (fn - ((s :as signal) value) - (when - (signal? s) - (let - ((old (signal-value s))) + ctx + (let + {:notify notify-fn :deps dep-list} + ctx + (when + (not (contains? dep-list s)) + (append! dep-list s) + (signal-add-sub! s notify-fn)))) + (signal-value s))))) + (define + reset! + :effects (mutation) + (fn + ((s :as signal) value) (when - (not (identical? old value)) - (signal-set-value! s value) - (notify-subscribers s)))))) - -(define - swap! - :effects (mutation) - (fn - ((s :as signal) (f :as callable) &rest args) - (when - (signal? s) - (let - ((old (signal-value s)) - (new-val (trampoline (apply f (cons old args))))) + (signal? s) + (let + ((old (signal-value s))) + (when + (not (identical? old value)) + (signal-set-value! s value) + (notify-subscribers s)))))) + (define + swap! + :effects (mutation) + (fn + ((s :as signal) (f :as callable) &rest args) (when - (not (identical? old new-val)) - (signal-set-value! s new-val) - (notify-subscribers s)))))) - -(define - computed - :effects (mutation) - (fn - ((compute-fn :as lambda)) - (let - ((s (make-signal nil)) (deps (list)) (compute-ctx nil)) - (let - ((recompute (fn () (for-each (fn ((dep :as signal)) (signal-remove-sub! dep recompute)) (signal-deps s)) (signal-set-deps! s (list)) (let ((ctx (dict "deps" (list) "notify" recompute))) (scope-push! "sx-reactive" ctx) (let ((new-val (cek-call compute-fn nil))) (scope-pop! "sx-reactive") (signal-set-deps! s (get ctx "deps")) (let ((old (signal-value s))) (signal-set-value! s new-val) (when (not (identical? old new-val)) (notify-subscribers s)))))))) - (recompute) - (register-in-scope (fn () (dispose-computed s))) - s)))) - -(define - effect - :effects (mutation) - (fn - ((effect-fn :as lambda)) - (let - ((deps (list)) (disposed false) (cleanup-fn nil)) - (let - ((run-effect (fn () (when (not disposed) (when cleanup-fn (cek-call cleanup-fn nil)) (for-each (fn ((dep :as signal)) (signal-remove-sub! dep run-effect)) deps) (set! deps (list)) (let ((ctx (dict "deps" (list) "notify" run-effect))) (scope-push! "sx-reactive" ctx) (let ((result (cek-call effect-fn nil))) (scope-pop! "sx-reactive") (set! deps (get ctx "deps")) (when (callable? result) (set! cleanup-fn result)))))))) - (run-effect) + (signal? s) + (let + ((old (signal-value s)) + (new-val (trampoline (apply f (cons old args))))) + (when + (not (identical? old new-val)) + (signal-set-value! s new-val) + (notify-subscribers s)))))) + (define + computed + :effects (mutation) + (fn + ((compute-fn :as lambda)) (let - ((dispose-fn (fn () (set! disposed true) (when cleanup-fn (cek-call cleanup-fn nil)) (for-each (fn ((dep :as signal)) (signal-remove-sub! dep run-effect)) deps) (set! deps (list))))) - (register-in-scope dispose-fn) - dispose-fn))))) - -(define *batch-depth* 0) - -(define *batch-queue* (list)) - -(define - batch - :effects (mutation) - (fn - ((thunk :as lambda)) - (set! *batch-depth* (+ *batch-depth* 1)) - (cek-call thunk nil) - (set! *batch-depth* (- *batch-depth* 1)) - (when - (= *batch-depth* 0) - (let - ((queue *batch-queue*)) - (set! *batch-queue* (list)) + ((s (make-signal nil)) (deps (list)) (compute-ctx nil)) + (let + ((recompute (fn () (for-each (fn ((dep :as signal)) (signal-remove-sub! dep recompute)) (signal-deps s)) (signal-set-deps! s (list)) (let ((ctx (dict "deps" (list) "notify" recompute))) (scope-push! "sx-reactive" ctx) (let ((new-val (cek-call compute-fn nil))) (scope-pop! "sx-reactive") (signal-set-deps! s (get ctx "deps")) (let ((old (signal-value s))) (signal-set-value! s new-val) (when (not (identical? old new-val)) (notify-subscribers s)))))))) + (recompute) + (register-in-scope (fn () (dispose-computed s))) + s)))) + (define + effect + :effects (mutation) + (fn + ((effect-fn :as lambda)) (let - ((seen (list)) (pending (list))) - (for-each - (fn - ((s :as signal)) + ((deps (list)) (disposed false) (cleanup-fn nil)) + (let + ((run-effect (fn () (when (not disposed) (when cleanup-fn (cek-call cleanup-fn nil)) (for-each (fn ((dep :as signal)) (signal-remove-sub! dep run-effect)) deps) (set! deps (list)) (let ((ctx (dict "deps" (list) "notify" run-effect))) (scope-push! "sx-reactive" ctx) (let ((result (cek-call effect-fn nil))) (scope-pop! "sx-reactive") (set! deps (get ctx "deps")) (when (callable? result) (set! cleanup-fn result)))))))) + (run-effect) + (let + ((dispose-fn (fn () (set! disposed true) (when cleanup-fn (cek-call cleanup-fn nil)) (for-each (fn ((dep :as signal)) (signal-remove-sub! dep run-effect)) deps) (set! deps (list))))) + (register-in-scope dispose-fn) + dispose-fn))))) + (define *batch-depth* 0) + (define *batch-queue* (list)) + (define + batch + :effects (mutation) + (fn + ((thunk :as lambda)) + (set! *batch-depth* (+ *batch-depth* 1)) + (cek-call thunk nil) + (set! *batch-depth* (- *batch-depth* 1)) + (when + (= *batch-depth* 0) + (let + ((queue *batch-queue*)) + (set! *batch-queue* (list)) + (let + ((seen (list)) (pending (list))) (for-each (fn - ((sub :as lambda)) - (when - (not (contains? seen sub)) - (append! seen sub) - (append! pending sub))) - (signal-subscribers s))) - queue) - (for-each (fn ((sub :as lambda)) (sub)) pending)))))) - -(define - notify-subscribers - :effects (mutation) - (fn - ((s :as signal)) - (if - (> *batch-depth* 0) - (when (not (contains? *batch-queue* s)) (append! *batch-queue* s)) - (flush-subscribers s)))) - -(define - flush-subscribers - :effects (mutation) - (fn - ((s :as dict)) - (for-each (fn (sub) (cek-call sub nil)) (signal-subscribers s)))) - -(define - dispose-computed - :effects (mutation) - (fn - ((s :as signal)) - (when - (signal? s) - (for-each - (fn ((dep :as signal)) (signal-remove-sub! dep nil)) - (signal-deps s)) - (signal-set-deps! s (list))))) - -(define - with-island-scope - :effects (mutation) - (fn - ((scope-fn :as lambda) (body-fn :as lambda)) - (scope-push! "sx-island-scope" scope-fn) - (let ((result (body-fn))) (scope-pop! "sx-island-scope") result))) - -(define - register-in-scope - :effects (mutation) - (fn - ((disposable :as lambda)) - (let - ((collector (scope-peek "sx-island-scope"))) - (when collector (cek-call collector (list disposable)))))) - - -)) ;; end define-library + ((s :as signal)) + (for-each + (fn + ((sub :as lambda)) + (when + (not (contains? seen sub)) + (append! seen sub) + (append! pending sub))) + (signal-subscribers s))) + queue) + (for-each (fn ((sub :as lambda)) (sub)) pending)))))) + (define + notify-subscribers + :effects (mutation) + (fn + ((s :as signal)) + (if + (> *batch-depth* 0) + (when (not (contains? *batch-queue* s)) (append! *batch-queue* s)) + (flush-subscribers s)))) + (define + flush-subscribers + :effects (mutation) + (fn + ((s :as dict)) + (for-each (fn (sub) (cek-call sub nil)) (signal-subscribers s)))) + (define + dispose-computed + :effects (mutation) + (fn + ((s :as signal)) + (when + (signal? s) + (for-each + (fn ((dep :as signal)) (signal-remove-sub! dep nil)) + (signal-deps s)) + (signal-set-deps! s (list))))) + (define + with-island-scope + :effects (mutation) + (fn + ((scope-fn :as lambda) (body-fn :as lambda)) + (scope-push! "sx-island-scope" scope-fn) + (let ((result (body-fn))) (scope-pop! "sx-island-scope") result))) + (define + register-in-scope + :effects (mutation) + (fn + ((disposable :as lambda)) + (let + ((collector (scope-peek "sx-island-scope"))) + (when collector (cek-call collector (list disposable)))))))) ;; end define-library ;; Re-export to global namespace for backward compatibility (import (sx signals)) diff --git a/sx/sx/handlers/pub-api.sx b/sx/sx/handlers/pub-api.sx index a99b7497..5525b178 100644 --- a/sx/sx/handlers/pub-api.sx +++ b/sx/sx/handlers/pub-api.sx @@ -9,71 +9,89 @@ ;; Actor ;; -------------------------------------------------------------------------- -(defhandler pub-actor +(defhandler + pub-actor :path "/pub/actor" :method :get :returns "element" (&key) - (let ((actor (helper "pub-actor-data"))) + (let-match + {:domain domain :summary summary :display-name display-name :public-key-pem public-key-pem} + (helper "pub-actor-data") (do (set-response-header "Content-Type" "text/sx; charset=utf-8") (str "(SxActor" - "\n :id \"https://" (get actor "domain") "/pub/actor\"" + "\n :id \"https://" + domain + "/pub/actor\"" "\n :type \"SxPublisher\"" - "\n :name \"" (get actor "display-name") "\"" - "\n :summary \"" (get actor "summary") "\"" + "\n :name \"" + display-name + "\"" + "\n :summary \"" + summary + "\"" "\n :inbox \"/pub/inbox\"" "\n :outbox \"/pub/outbox\"" "\n :followers \"/pub/followers\"" "\n :following \"/pub/following\"" - "\n :public-key-pem \"" (get actor "public-key-pem") "\")")))) + "\n :public-key-pem \"" + public-key-pem + "\")")))) ;; -------------------------------------------------------------------------- ;; Webfinger ;; -------------------------------------------------------------------------- -(defhandler pub-webfinger +(defhandler + pub-webfinger :path "/pub/webfinger" :method :get :returns "element" (&key) - (let ((resource (helper "request-arg" "resource" "")) - (actor (helper "pub-actor-data"))) - (let ((expected (str "acct:" (get actor "preferred-username") "@" (get actor "domain")))) - (if (!= resource expected) - (do - (set-response-status 404) - (str "(Error :message \"Resource not found\")")) - (do - (set-response-header "Content-Type" "text/sx; charset=utf-8") - (str - "(SxWebfinger" - "\n :subject \"" expected "\"" - "\n :actor \"https://" (get actor "domain") "/pub/actor\"" - "\n :type \"SxPublisher\")")))))) + (let + ((resource (helper "request-arg" "resource" ""))) + (let-match + {:domain domain :preferred-username preferred-username} + (helper "pub-actor-data") + (let + ((expected (str "acct:" preferred-username "@" domain))) + (if + (!= resource expected) + (do + (set-response-status 404) + (str "(Error :message \"Resource not found\")")) + (do + (set-response-header "Content-Type" "text/sx; charset=utf-8") + (str + "(SxWebfinger" + "\n :subject \"" + expected + "\"" + "\n :actor \"https://" + domain + "/pub/actor\"" + "\n :type \"SxPublisher\")"))))))) ;; -------------------------------------------------------------------------- ;; Collections ;; -------------------------------------------------------------------------- -(defhandler pub-collections +(defhandler + pub-collections :path "/pub/collections" :method :get :returns "element" (&key) - (let ((collections (helper "pub-collections-data"))) + (let + ((collections (helper "pub-collections-data"))) (do (set-response-header "Content-Type" "text/sx; charset=utf-8") - (let ((items (map (fn (c) - (str "\n (SxCollection" - " :slug \"" (get c "slug") "\"" - " :name \"" (get c "name") "\"" - " :description \"" (get c "description") "\"" - " :href \"/pub/" (get c "slug") "\")")) - collections))) + (let + ((items (map (fn (c) (let-match {:description description :slug slug :name name} c (str "\n (SxCollection" " :slug \"" slug "\"" " :name \"" name "\"" " :description \"" description "\"" " :href \"/pub/" slug "\")"))) collections))) (str "(SxCollections" (join "" items) ")"))))) @@ -81,21 +99,33 @@ ;; Status ;; -------------------------------------------------------------------------- -(defhandler pub-status +(defhandler + pub-status :path "/pub/status" :method :get :returns "element" (&key) - (let ((status (helper "pub-status-data"))) + (let-match + {:db db :domain domain :healthy healthy :ipfs ipfs :actor actor} + (helper "pub-status-data") (do (set-response-header "Content-Type" "text/sx; charset=utf-8") (str "(SxPubStatus" - "\n :healthy " (get status "healthy") - "\n :db \"" (get status "db") "\"" - "\n :ipfs \"" (get status "ipfs") "\"" - "\n :actor \"" (get status "actor") "\"" - "\n :domain \"" (or (get status "domain") "unknown") "\")")))) + "\n :healthy " + healthy + "\n :db \"" + db + "\"" + "\n :ipfs \"" + ipfs + "\"" + "\n :actor \"" + actor + "\"" + "\n :domain \"" + (or domain "unknown") + "\")")))) ;; ========================================================================== @@ -107,72 +137,100 @@ ;; Publish ;; -------------------------------------------------------------------------- -(defhandler pub-publish +(defhandler + pub-publish :path "/pub/publish" :method :post :csrf false :returns "element" (&key) - (let ((collection (helper "request-form" "collection" "")) - (slug (helper "request-form" "slug" "")) - (content (helper "request-form" "content" "")) - (title (helper "request-form" "title" "")) - (summary (helper "request-form" "summary" ""))) - (if (or (= collection "") (= slug "") (= content "")) + (let + ((collection (helper "request-form" "collection" "")) + (slug (helper "request-form" "slug" "")) + (content (helper "request-form" "content" "")) + (title (helper "request-form" "title" "")) + (summary (helper "request-form" "summary" ""))) + (if + (or (= collection "") (= slug "") (= content "")) (do (set-response-status 400) (set-response-header "Content-Type" "text/sx; charset=utf-8") "(Error :message \"Missing collection, slug, or content\")") - (let ((result (helper "pub-publish" collection slug content title summary))) - (if (get result "error") + (let + ((result (helper "pub-publish" collection slug content title summary))) + (if + (get result "error") (do (set-response-status 500) (set-response-header "Content-Type" "text/sx; charset=utf-8") (str "(Error :message \"" (get result "error") "\")")) - (do - (set-response-header "Content-Type" "text/sx; charset=utf-8") - (str - "(Published" - "\n :path \"" (get result "path") "\"" - "\n :cid \"" (get result "cid") "\"" - "\n :hash \"" (get result "hash") "\"" - "\n :size " (get result "size") - "\n :collection \"" (get result "collection") "\"" - "\n :slug \"" (get result "slug") "\"" - "\n :title \"" (get result "title") "\")"))))))) + (let-match + {:cid cid :hash hash :size size :title title :path path :slug slug :collection collection} + result + (do + (set-response-header "Content-Type" "text/sx; charset=utf-8") + (str + "(Published" + "\n :path \"" + path + "\"" + "\n :cid \"" + cid + "\"" + "\n :hash \"" + hash + "\"" + "\n :size " + size + "\n :collection \"" + collection + "\"" + "\n :slug \"" + slug + "\"" + "\n :title \"" + title + "\")")))))))) ;; -------------------------------------------------------------------------- ;; Browse collection ;; -------------------------------------------------------------------------- -(defhandler pub-browse-collection +(defhandler + pub-browse-collection :path "/pub/browse/" :method :get :returns "element" (&key collection_slug) - (let ((data (helper "pub-collection-items" collection_slug))) - (if (get data "error") + (let + ((data (helper "pub-collection-items" collection_slug))) + (if + (get data "error") (do (set-response-status 404) (set-response-header "Content-Type" "text/sx; charset=utf-8") (str "(Error :message \"" (get data "error") "\")")) - (do - (set-response-header "Content-Type" "text/sx; charset=utf-8") - (let ((items (map (fn (d) - (str "\n (SxDocument" - " :slug \"" (get d "slug") "\"" - " :title \"" (get d "title") "\"" - " :summary \"" (get d "summary") "\"" - " :cid \"" (get d "cid") "\"" - " :size " (get d "size") ")")) - (get data "items")))) - (str - "(SxCollection" - "\n :slug \"" (get data "collection") "\"" - "\n :name \"" (get data "name") "\"" - "\n :description \"" (get data "description") "\"" - (join "" items) ")")))))) + (let-match + {:description description :items items-data :collection collection :name name} + data + (do + (set-response-header "Content-Type" "text/sx; charset=utf-8") + (let + ((items (map (fn (d) (let-match {:cid cid :size size :summary summary :title title :slug slug} d (str "\n (SxDocument" " :slug \"" slug "\"" " :title \"" title "\"" " :summary \"" summary "\"" " :cid \"" cid "\"" " :size " size ")"))) items-data))) + (str + "(SxCollection" + "\n :slug \"" + collection + "\"" + "\n :name \"" + name + "\"" + "\n :description \"" + description + "\"" + (join "" items) + ")"))))))) ;; -------------------------------------------------------------------------- @@ -226,26 +284,30 @@ ;; Outbox ;; -------------------------------------------------------------------------- -(defhandler pub-outbox +(defhandler + pub-outbox :path "/pub/outbox" :method :get :returns "element" (&key) - (let ((page (helper "request-arg" "page" "")) - (data (helper "pub-outbox-data" page))) + (let + ((page (helper "request-arg" "page" "")) + (data (helper "pub-outbox-data" page))) (do (set-response-header "Content-Type" "text/sx; charset=utf-8") - (let ((items (map (fn (a) - (str "\n (" (get a "type") - " :object-type \"" (get a "object-type") "\"" - " :published \"" (get a "published") "\"" - " :cid \"" (get a "cid") "\")")) - (get data "items")))) - (str - "(SxOutbox" - "\n :total " (get data "total") - "\n :page " (get data "page") - (join "" items) ")"))))) + (let-match + {:total total :page page :items items-data} + data + (let + ((items (map (fn (a) (let-match {:cid cid :type type :object-type object-type :published published} a (str "\n (" type " :object-type \"" object-type "\"" " :published \"" published "\"" " :cid \"" cid "\")"))) items-data))) + (str + "(SxOutbox" + "\n :total " + total + "\n :page " + page + (join "" items) + ")")))))) ;; -------------------------------------------------------------------------- @@ -275,48 +337,59 @@ ;; Follow a remote server ;; -------------------------------------------------------------------------- -(defhandler pub-follow +(defhandler + pub-follow :path "/pub/follow" :method :post :csrf false :returns "element" (&key) - (let ((actor-url (helper "request-form" "actor_url" ""))) - (if (= actor-url "") + (let + ((actor-url (helper "request-form" "actor_url" ""))) + (if + (= actor-url "") (do (set-response-status 400) (set-response-header "Content-Type" "text/sx; charset=utf-8") "(Error :message \"Missing actor_url\")") - (let ((result (helper "pub-follow-remote" actor-url))) + (let + ((result (helper "pub-follow-remote" actor-url))) (do (set-response-header "Content-Type" "text/sx; charset=utf-8") - (if (get result "error") + (if + (get result "error") (do (set-response-status 502) (str "(Error :message \"" (get result "error") "\")")) - (str - "(FollowSent" - "\n :actor-url \"" (get result "actor-url") "\"" - "\n :status \"" (get result "status") "\")"))))))) + (let-match + {:status status :actor-url actor-url} + result + (str + "(FollowSent" + "\n :actor-url \"" + actor-url + "\"" + "\n :status \"" + status + "\")")))))))) ;; -------------------------------------------------------------------------- ;; Followers ;; -------------------------------------------------------------------------- -(defhandler pub-followers +(defhandler + pub-followers :path "/pub/followers" :method :get :returns "element" (&key) - (let ((data (helper "pub-followers-data"))) + (let + ((data (helper "pub-followers-data"))) (do (set-response-header "Content-Type" "text/sx; charset=utf-8") - (let ((items (map (fn (f) - (str "\n (SxFollower" - " :acct \"" (get f "acct") "\"" - " :actor-url \"" (get f "actor-url") "\")")) - data))) + (let + ((items (map (fn (f) (let-match {:actor-url actor-url :acct acct} f (str "\n (SxFollower" " :acct \"" acct "\"" " :actor-url \"" actor-url "\")"))) data))) (str "(SxFollowers" (join "" items) ")"))))) @@ -348,48 +421,80 @@ ;; Anchor pending activities ;; -------------------------------------------------------------------------- -(defhandler pub-anchor +(defhandler + pub-anchor :path "/pub/anchor" :method :post :csrf false :returns "element" (&key) - (let ((result (helper "pub-anchor-pending"))) + (let-match + {:tree-cid tree-cid :status status :count count :ots-proof-cid ots-proof-cid :merkle-root merkle-root} + (helper "pub-anchor-pending") (do (set-response-header "Content-Type" "text/sx; charset=utf-8") - (if (= (get result "status") "nothing-to-anchor") + (if + (= status "nothing-to-anchor") "(Anchor :status \"nothing-to-anchor\" :count 0)" (str "(Anchor" - "\n :status \"" (get result "status") "\"" - "\n :count " (get result "count") - "\n :merkle-root \"" (get result "merkle-root") "\"" - "\n :tree-cid \"" (get result "tree-cid") "\"" - "\n :ots-proof-cid \"" (get result "ots-proof-cid") "\")"))))) + "\n :status \"" + status + "\"" + "\n :count " + count + "\n :merkle-root \"" + merkle-root + "\"" + "\n :tree-cid \"" + tree-cid + "\"" + "\n :ots-proof-cid \"" + ots-proof-cid + "\")"))))) ;; -------------------------------------------------------------------------- ;; Verify a CID's anchor ;; -------------------------------------------------------------------------- -(defhandler pub-verify +(defhandler + pub-verify :path "/pub/verify/" :method :get :returns "element" (&key cid) - (let ((data (helper "pub-verify-anchor" cid))) + (let + ((data (helper "pub-verify-anchor" cid))) (do (set-response-header "Content-Type" "text/sx; charset=utf-8") - (if (get data "error") + (if + (get data "error") (do (set-response-status 404) (str "(Error :message \"" (get data "error") "\")")) - (str - "(AnchorVerification" - "\n :cid \"" (get data "cid") "\"" - "\n :status \"" (get data "status") "\"" - "\n :verified " (get data "verified") - "\n :merkle-root \"" (get data "merkle-root") "\"" - "\n :tree-cid \"" (get data "tree-cid") "\"" - "\n :ots-proof-cid \"" (get data "ots-proof-cid") "\"" - "\n :published \"" (get data "published") "\")"))))) + (let-match + {:cid cid* :tree-cid tree-cid :status status :verified verified :ots-proof-cid ots-proof-cid :merkle-root merkle-root :published published} + data + (str + "(AnchorVerification" + "\n :cid \"" + cid* + "\"" + "\n :status \"" + status + "\"" + "\n :verified " + verified + "\n :merkle-root \"" + merkle-root + "\"" + "\n :tree-cid \"" + tree-cid + "\"" + "\n :ots-proof-cid \"" + ots-proof-cid + "\"" + "\n :published \"" + published + "\")")))))) diff --git a/sx/sx/specs-explorer.sx b/sx/sx/specs-explorer.sx index 13ad81e5..351eaba0 100644 --- a/sx/sx/specs-explorer.sx +++ b/sx/sx/specs-explorer.sx @@ -2,25 +2,27 @@ ~specs-explorer/spec-explorer-content (&key data) :affinity :server - (~docs/page - :title (str (get data "title") " — Explorer") - (~specs-explorer/spec-explorer-header - :filename (get data "filename") - :title (get data "title") - :desc (get data "desc") - :slug (replace (get data "filename") ".sx" "")) - (~specs-explorer/spec-explorer-stats :stats (get data "stats")) - (map - (fn - (section) - (~specs-explorer/spec-explorer-section - :section section - :filename (get data "filename"))) - (get data "sections")) - (when - (not (empty? (get data "platform-interface"))) - (~specs-explorer/spec-platform-interface - :items (get data "platform-interface"))))) + (let-match + {:stats stats :desc desc :title title :filename filename :platform-interface platform-interface :sections sections} + data + (~docs/page + :title (str title " — Explorer") + (~specs-explorer/spec-explorer-header + :filename filename + :title title + :desc desc + :slug (replace filename ".sx" "")) + (~specs-explorer/spec-explorer-stats :stats stats) + (map + (fn + (section) + (~specs-explorer/spec-explorer-section + :section section + :filename filename)) + sections) + (when + (not (empty? platform-interface)) + (~specs-explorer/spec-platform-interface :items platform-interface))))) (defcomp ~specs-explorer/spec-explorer-header @@ -46,80 +48,91 @@ (defcomp ~specs-explorer/spec-explorer-stats (&key stats) - (div - (~tw :tokens "flex flex-wrap gap-2 mb-6 text-xs") - (span - (~tw :tokens "bg-stone-100 text-stone-600 px-2 py-0.5 rounded font-medium") - (str (get stats "total-defines") " defines")) - (when - (> (get stats "pure-count") 0) + (let-match + {:lines lines :io-count io-count :render-count render-count :pure-count pure-count :mutation-count mutation-count :test-total test-total :total-defines total-defines} + stats + (div + (~tw :tokens "flex flex-wrap gap-2 mb-6 text-xs") (span - (~tw :tokens "bg-green-100 text-green-700 px-2 py-0.5 rounded") - (str (get stats "pure-count") " pure"))) - (when - (> (get stats "mutation-count") 0) + (~tw + :tokens "bg-stone-100 text-stone-600 px-2 py-0.5 rounded font-medium") + (str total-defines " defines")) + (when + (> pure-count 0) + (span + (~tw :tokens "bg-green-100 text-green-700 px-2 py-0.5 rounded") + (str pure-count " pure"))) + (when + (> mutation-count 0) + (span + (~tw :tokens "bg-amber-100 text-amber-700 px-2 py-0.5 rounded") + (str mutation-count " mutation"))) + (when + (> io-count 0) + (span + (~tw :tokens "bg-orange-100 text-orange-700 px-2 py-0.5 rounded") + (str io-count " io"))) + (when + (> render-count 0) + (span + (~tw :tokens "bg-sky-100 text-sky-700 px-2 py-0.5 rounded") + (str render-count " render"))) + (when + (> test-total 0) + (span + (~tw :tokens "bg-violet-100 text-violet-700 px-2 py-0.5 rounded") + (str test-total " tests"))) (span - (~tw :tokens "bg-amber-100 text-amber-700 px-2 py-0.5 rounded") - (str (get stats "mutation-count") " mutation"))) - (when - (> (get stats "io-count") 0) - (span - (~tw :tokens "bg-orange-100 text-orange-700 px-2 py-0.5 rounded") - (str (get stats "io-count") " io"))) - (when - (> (get stats "render-count") 0) - (span - (~tw :tokens "bg-sky-100 text-sky-700 px-2 py-0.5 rounded") - (str (get stats "render-count") " render"))) - (when - (> (get stats "test-total") 0) - (span - (~tw :tokens "bg-violet-100 text-violet-700 px-2 py-0.5 rounded") - (str (get stats "test-total") " tests"))) - (span - (~tw :tokens "bg-stone-100 text-stone-500 px-2 py-0.5 rounded") - (str (get stats "lines") " lines")))) + (~tw :tokens "bg-stone-100 text-stone-500 px-2 py-0.5 rounded") + (str lines " lines"))))) (defcomp ~specs-explorer/spec-explorer-section (&key section filename) - (div - (~tw :tokens "mb-6") - (h2 - (~tw :tokens "text-base font-semibold text-stone-600 mb-2 border-b border-stone-200 pb-1") - :id (replace (lower (get section "title")) " " "-") - (get section "title")) - (when - (get section "comment") - (p (~tw :tokens "text-sm text-stone-500 mb-2") (get section "comment"))) + (let-match + {:defines defines :title title :comment comment} + section (div - (~tw :tokens "space-y-0.5") - (map - (fn - (d) - (~specs-explorer/spec-explorer-define :d d :filename filename)) - (get section "defines"))))) + (~tw :tokens "mb-6") + (h2 + (~tw + :tokens "text-base font-semibold text-stone-600 mb-2 border-b border-stone-200 pb-1") + :id (replace (lower title) " " "-") + title) + (when comment (p (~tw :tokens "text-sm text-stone-500 mb-2") comment)) + (div + (~tw :tokens "space-y-0.5") + (map + (fn + (d) + (~specs-explorer/spec-explorer-define :d d :filename filename)) + defines))))) (defcomp ~specs-explorer/spec-explorer-define (&key d filename) - (div - (~tw :tokens "flex items-center gap-2 py-1.5 px-2 rounded hover:bg-stone-50 cursor-pointer group") - :id (str "fn-" (get d "name")) - :sx-get (str - "/sx/(language.(spec.(explore." - (replace filename ".sx" "") - "." - (get d "name") - ")))") - :sx-target "#sx-content" - :sx-select "#sx-content" - :sx-swap "innerHTML" - :sx-push-url "true" - (span - (~tw :tokens "font-mono text-sm font-medium text-stone-800 group-hover:text-violet-700") - (get d "name")) - (span (~tw :tokens "text-xs text-stone-400") (get d "kind")))) + (let-match + {:kind kind :name name} + d + (div + (~tw + :tokens "flex items-center gap-2 py-1.5 px-2 rounded hover:bg-stone-50 cursor-pointer group") + :id (str "fn-" name) + :sx-get (str + "/sx/(language.(spec.(explore." + (replace filename ".sx" "") + "." + name + ")))") + :sx-target "#sx-content" + :sx-select "#sx-content" + :sx-swap "innerHTML" + :sx-push-url "true" + (span + (~tw + :tokens "font-mono text-sm font-medium text-stone-800 group-hover:text-violet-700") + name) + (span (~tw :tokens "text-xs text-stone-400") kind)))) (defcomp ~specs-explorer/spec-explorer-define-detail @@ -144,33 +157,39 @@ :sx-swap "innerHTML" :sx-push-url "true" (str "← Back to " (replace filename ".sx" "")))) - (div - (~tw :tokens "rounded border border-violet-200 bg-violet-50/30 p-4") + (let-match + {:kind kind :effects effects :params params :source source :name name} + d (div - (~tw :tokens "flex items-center gap-2 flex-wrap mb-3") - (span - (~tw :tokens "font-mono text-lg font-semibold text-stone-800") - (get d "name")) - (span (~tw :tokens "text-xs text-stone-400") (get d "kind")) - (if - (empty? (get d "effects")) + (~tw :tokens "rounded border border-violet-200 bg-violet-50/30 p-4") + (div + (~tw :tokens "flex items-center gap-2 flex-wrap mb-3") (span - (~tw :tokens "text-xs px-1.5 py-0.5 rounded bg-green-100 text-green-700") - "pure") - (map - (fn (eff) (~specs-explorer/spec-effect-badge :effect eff)) - (get d "effects")))) - (when - (not (empty? (get d "params"))) - (~specs-explorer/spec-param-list :params (get d "params"))) - (details - :open "true" - (summary - (~tw :tokens "px-3 py-1.5 bg-stone-50 text-xs font-medium text-stone-600 cursor-pointer select-none mt-3 rounded") - "SX Source") - (pre - (~tw :tokens "text-xs p-3 overflow-x-auto bg-white rounded mt-1 border border-stone-200") - (code (~tw :tokens "language-sx") (get d "source"))))))) + (~tw :tokens "font-mono text-lg font-semibold text-stone-800") + name) + (span (~tw :tokens "text-xs text-stone-400") kind) + (if + (empty? effects) + (span + (~tw + :tokens "text-xs px-1.5 py-0.5 rounded bg-green-100 text-green-700") + "pure") + (map + (fn (eff) (~specs-explorer/spec-effect-badge :effect eff)) + effects))) + (when + (not (empty? params)) + (~specs-explorer/spec-param-list :params params)) + (details + :open "true" + (summary + (~tw + :tokens "px-3 py-1.5 bg-stone-50 text-xs font-medium text-stone-600 cursor-pointer select-none mt-3 rounded") + "SX Source") + (pre + (~tw + :tokens "text-xs p-3 overflow-x-auto bg-white rounded mt-1 border border-stone-200") + (code (~tw :tokens "language-sx") source))))))) (defcomp ~specs-explorer/spec-effect-badge @@ -197,13 +216,15 @@ (map (fn (p) - (let - ((name (get p "name")) (typ (get p "type"))) + (let-match + {:type typ :name name} + p (if (or (= name "&rest") (= name "&key")) (span (~tw :tokens "text-xs font-mono text-violet-500") name) (span - (~tw :tokens "text-xs font-mono px-1 py-0.5 rounded bg-stone-50 border border-stone-200") + (~tw + :tokens "text-xs font-mono px-1 py-0.5 rounded bg-stone-50 border border-stone-200") (if typ (<> @@ -300,7 +321,8 @@ (div (~tw :tokens "mt-8") (h2 - (~tw :tokens "text-lg font-semibold text-stone-700 border-b border-stone-200 pb-1 mb-3") + (~tw + :tokens "text-lg font-semibold text-stone-700 border-b border-stone-200 pb-1 mb-3") "Platform Interface") (p (~tw :tokens "text-sm text-stone-500 mb-3") @@ -314,22 +336,29 @@ (~tw :tokens "border-b border-stone-200 bg-stone-50") (th (~tw :tokens "px-3 py-2 font-medium text-stone-600") "Name") (th (~tw :tokens "px-3 py-2 font-medium text-stone-600") "Params") - (th (~tw :tokens "px-3 py-2 font-medium text-stone-600") "Returns") - (th (~tw :tokens "px-3 py-2 font-medium text-stone-600") "Description"))) + (th + (~tw :tokens "px-3 py-2 font-medium text-stone-600") + "Returns") + (th + (~tw :tokens "px-3 py-2 font-medium text-stone-600") + "Description"))) (tbody (map (fn (item) - (tr - (~tw :tokens "border-b border-stone-100") - (td - (~tw :tokens "px-3 py-2 font-mono text-sm text-violet-700") - (get item "name")) - (td - (~tw :tokens "px-3 py-2 font-mono text-xs text-stone-500") - (get item "params")) - (td - (~tw :tokens "px-3 py-2 font-mono text-xs text-stone-500") - (get item "returns")) - (td (~tw :tokens "px-3 py-2 text-stone-600") (get item "doc")))) + (let-match + {:doc doc :params params :returns returns :name name} + item + (tr + (~tw :tokens "border-b border-stone-100") + (td + (~tw :tokens "px-3 py-2 font-mono text-sm text-violet-700") + name) + (td + (~tw :tokens "px-3 py-2 font-mono text-xs text-stone-500") + params) + (td + (~tw :tokens "px-3 py-2 font-mono text-xs text-stone-500") + returns) + (td (~tw :tokens "px-3 py-2 text-stone-600") doc)))) items)))))) diff --git a/web/deps.sx b/web/deps.sx index fca9ff79..2e69170d 100644 --- a/web/deps.sx +++ b/web/deps.sx @@ -1,6 +1,7 @@ -(define-library (web deps) +(define-library + (web deps) (export scan-refs scan-refs-walk @@ -22,347 +23,340 @@ page-render-plan env-components) (begin - -(define - scan-refs - :effects () - (fn (node) (let ((refs (list))) (scan-refs-walk node refs) refs))) - -(define - scan-refs-walk - :effects () - (fn - (node (refs :as list)) - (cond - (= (type-of node) "symbol") - (let - ((name (symbol-name node))) - (when - (starts-with? name "~") - (when (not (contains? refs name)) (append! refs name)))) - (= (type-of node) "list") - (for-each (fn (item) (scan-refs-walk item refs)) node) - (= (type-of node) "dict") - (for-each - (fn (key) (scan-refs-walk (dict-get node key) refs)) - (keys node)) - :else nil))) - -(define - transitive-deps-walk - :effects () - (fn - ((n :as string) (seen :as list) (env :as dict)) - (when - (not (contains? seen n)) - (append! seen n) - (let - ((val (env-get env n))) - (cond - (or (= (type-of val) "component") (= (type-of val) "island")) - (for-each - (fn ((ref :as string)) (transitive-deps-walk ref seen env)) - (scan-refs (component-body val))) - (= (type-of val) "macro") - (for-each - (fn ((ref :as string)) (transitive-deps-walk ref seen env)) - (scan-refs (macro-body val))) - :else nil))))) - -(define - transitive-deps - :effects () - (fn - ((name :as string) (env :as dict)) - (let - ((seen (list)) - (key (if (starts-with? name "~") name (str "~" name)))) - (transitive-deps-walk key seen env) - (filter (fn ((x :as string)) (not (= x key))) seen)))) - -(define - compute-all-deps - :effects (mutation) - (fn - ((env :as dict)) - (for-each + (define + scan-refs + :effects () + (fn (node) (let ((refs (list))) (scan-refs-walk node refs) refs))) + (define + scan-refs-walk + :effects () (fn - ((name :as string)) - (let - ((val (env-get env name))) - (when - (or (= (type-of val) "component") (= (type-of val) "island")) - (component-set-deps! val (transitive-deps name env))))) - (env-components env)))) - -(define - scan-components-from-source - :effects () - (fn - ((source :as string)) - (let - ((matches (regex-find-all "\\(~([a-zA-Z_][a-zA-Z0-9_\\-:/]*)" source))) - (map (fn ((m :as string)) (str "~" m)) matches)))) - -(define - components-needed - :effects () - (fn - ((page-source :as string) (env :as dict)) - (let - ((direct (scan-components-from-source page-source)) - (all-needed (list))) - (for-each - (fn - ((name :as string)) - (when (not (contains? all-needed name)) (append! all-needed name)) - (let - ((val (env-get env name))) + (node (refs :as list)) + (match + (type-of node) + ("symbol" (let - ((deps (if (and (= (type-of val) "component") (not (empty? (component-deps val)))) (component-deps val) (transitive-deps name env)))) - (for-each - (fn - ((dep :as string)) - (when - (not (contains? all-needed dep)) - (append! all-needed dep))) - deps)))) - direct) - all-needed))) - -(define - page-component-bundle - :effects () - (fn - ((page-source :as string) (env :as dict)) - (components-needed page-source env))) - -(define - page-css-classes - :effects () - (fn - ((page-source :as string) (env :as dict)) - (let - ((needed (components-needed page-source env)) (classes (list))) - (for-each - (fn - ((name :as string)) - (let - ((val (env-get env name))) - (when - (= (type-of val) "component") - (for-each - (fn - ((cls :as string)) - (when (not (contains? classes cls)) (append! classes cls))) - (component-css-classes val))))) - needed) - (for-each - (fn - ((cls :as string)) - (when (not (contains? classes cls)) (append! classes cls))) - (scan-css-classes page-source)) - classes))) - -(define - scan-io-refs-walk - :effects () - (fn - (node (io-names :as list) (refs :as list)) - (cond - (= (type-of node) "symbol") - (let - ((name (symbol-name node))) - (when - (contains? io-names name) - (when (not (contains? refs name)) (append! refs name)))) - (= (type-of node) "list") - (for-each (fn (item) (scan-io-refs-walk item io-names refs)) node) - (= (type-of node) "dict") - (for-each - (fn (key) (scan-io-refs-walk (dict-get node key) io-names refs)) - (keys node)) - :else nil))) - -(define - scan-io-refs - :effects () - (fn - (node (io-names :as list)) - (let ((refs (list))) (scan-io-refs-walk node io-names refs) refs))) - -(define - transitive-io-refs-walk - :effects () - (fn - ((n :as string) - (seen :as list) - (all-refs :as list) - (env :as dict) - (io-names :as list)) - (when - (not (contains? seen n)) - (append! seen n) - (let - ((val (env-get env n))) - (cond - (= (type-of val) "component") - (do + ((name (symbol-name node))) + (when + (starts-with? name "~") + (when (not (contains? refs name)) (append! refs name))))) + ("list" (for-each (fn (child) (scan-refs-walk child refs)) node)) + ("dict" (for-each - (fn - ((ref :as string)) - (when (not (contains? all-refs ref)) (append! all-refs ref))) - (scan-io-refs (component-body val) io-names)) - (for-each - (fn - ((dep :as string)) - (transitive-io-refs-walk dep seen all-refs env io-names)) - (scan-refs (component-body val)))) - (= (type-of val) "macro") - (do - (for-each - (fn - ((ref :as string)) - (when (not (contains? all-refs ref)) (append! all-refs ref))) - (scan-io-refs (macro-body val) io-names)) - (for-each - (fn - ((dep :as string)) - (transitive-io-refs-walk dep seen all-refs env io-names)) - (scan-refs (macro-body val)))) - :else nil))))) - -(define - transitive-io-refs - :effects () - (fn - ((name :as string) (env :as dict) (io-names :as list)) - (let - ((all-refs (list)) - (seen (list)) - (key (if (starts-with? name "~") name (str "~" name)))) - (transitive-io-refs-walk key seen all-refs env io-names) - all-refs))) - -(define - compute-all-io-refs - :effects (mutation) - (fn - ((env :as dict) (io-names :as list)) - (for-each + (fn (key) (scan-refs-walk (dict-get node key) refs)) + (keys node))) + (_ nil)))) + (define + transitive-deps-walk + :effects () (fn - ((name :as string)) - (let - ((val (env-get env name))) - (when - (= (type-of val) "component") - (component-set-io-refs! - val - (transitive-io-refs name env io-names))))) - (env-components env)))) - -(define - component-io-refs-cached - :effects () - (fn - ((name :as string) (env :as dict) (io-names :as list)) - (let - ((key (if (starts-with? name "~") name (str "~" name)))) - (let - ((val (env-get env key))) - (if - (and - (= (type-of val) "component") - (not (nil? (component-io-refs val))) - (not (empty? (component-io-refs val)))) - (component-io-refs val) - (transitive-io-refs name env io-names)))))) - -(define - component-pure? - :effects () - (fn - (name (env :as dict) (io-names :as list)) - (let - ((key (if (starts-with? name "~") name (str "~" name)))) - (let - ((val (if (env-has? env key) (env-get env key) nil))) - (if - (and - (= (type-of val) "component") - (not (nil? (component-io-refs val))) - (not (empty? (component-io-refs val)))) - false - (empty? (transitive-io-refs name env io-names))))))) - -(define - render-target - :effects () - (fn - (name (env :as dict) (io-names :as list)) - (let - ((key (if (starts-with? name "~") name (str "~" name)))) - (let - ((val (if (env-has? env key) (env-get env key) nil))) - (if - (not (= (type-of val) "component")) - "server" + ((n :as string) (seen :as list) (env :as dict)) + (when + (not (contains? seen n)) + (append! seen n) (let - ((affinity (component-affinity val))) + ((val (env-get env n))) (cond - (= affinity "server") - "server" - (= affinity "client") - "client" - (not (component-pure? name env io-names)) - "server" - :else "client"))))))) - -(define - page-render-plan - :effects () - (fn - ((page-source :as string) (env :as dict) (io-names :as list)) - (let - ((needed (components-needed page-source env)) - (comp-targets (dict)) - (server-list (list)) - (client-list (list)) - (io-deps (list))) - (for-each - (fn - ((name :as string)) + (or (= (type-of val) "component") (= (type-of val) "island")) + (for-each + (fn ((ref :as string)) (transitive-deps-walk ref seen env)) + (scan-refs (component-body val))) + (= (type-of val) "macro") + (for-each + (fn ((ref :as string)) (transitive-deps-walk ref seen env)) + (scan-refs (macro-body val))) + :else nil))))) + (define + transitive-deps + :effects () + (fn + ((name :as string) (env :as dict)) + (let + ((seen (list)) + (key (if (starts-with? name "~") name (str "~" name)))) + (transitive-deps-walk key seen env) + (filter (fn ((x :as string)) (not (= x key))) seen)))) + (define + compute-all-deps + :effects (mutation) + (fn + ((env :as dict)) + (for-each + (fn + ((name :as string)) + (let + ((val (env-get env name))) + (when + (or + (= (type-of val) "component") + (= (type-of val) "island")) + (component-set-deps! val (transitive-deps name env))))) + (env-components env)))) + (define + scan-components-from-source + :effects () + (fn + ((source :as string)) + (let + ((matches (regex-find-all "\\(~([a-zA-Z_][a-zA-Z0-9_\\-:/]*)" source))) + (map (fn ((m :as string)) (str "~" m)) matches)))) + (define + components-needed + :effects () + (fn + ((page-source :as string) (env :as dict)) + (let + ((direct (scan-components-from-source page-source)) + (all-needed (list))) + (for-each + (fn + ((name :as string)) + (when + (not (contains? all-needed name)) + (append! all-needed name)) + (let + ((val (env-get env name))) + (let + ((deps (if (and (= (type-of val) "component") (not (empty? (component-deps val)))) (component-deps val) (transitive-deps name env)))) + (for-each + (fn + ((dep :as string)) + (when + (not (contains? all-needed dep)) + (append! all-needed dep))) + deps)))) + direct) + all-needed))) + (define + page-component-bundle + :effects () + (fn + ((page-source :as string) (env :as dict)) + (components-needed page-source env))) + (define + page-css-classes + :effects () + (fn + ((page-source :as string) (env :as dict)) + (let + ((needed (components-needed page-source env)) (classes (list))) + (for-each + (fn + ((name :as string)) + (let + ((val (env-get env name))) + (when + (= (type-of val) "component") + (for-each + (fn + ((cls :as string)) + (when + (not (contains? classes cls)) + (append! classes cls))) + (component-css-classes val))))) + needed) + (for-each + (fn + ((cls :as string)) + (when (not (contains? classes cls)) (append! classes cls))) + (scan-css-classes page-source)) + classes))) + (define + scan-io-refs-walk + :effects () + (fn + (node (io-names :as list) (refs :as list)) + (match + (type-of node) + ("symbol" + (let + ((name (symbol-name node))) + (when + (contains? io-names name) + (when (not (contains? refs name)) (append! refs name))))) + ("list" + (for-each + (fn (item) (scan-io-refs-walk item io-names refs)) + node)) + ("dict" + (for-each + (fn + (key) + (scan-io-refs-walk (dict-get node key) io-names refs)) + (keys node))) + (_ nil)))) + (define + scan-io-refs + :effects () + (fn + (node (io-names :as list)) + (let ((refs (list))) (scan-io-refs-walk node io-names refs) refs))) + (define + transitive-io-refs-walk + :effects () + (fn + ((n :as string) + (seen :as list) + (all-refs :as list) + (env :as dict) + (io-names :as list)) + (when + (not (contains? seen n)) + (append! seen n) (let - ((target (render-target name env io-names))) - (dict-set! comp-targets name target) - (if - (= target "server") + ((val (env-get env n))) + (cond + (= (type-of val) "component") (do - (append! server-list name) (for-each (fn - ((io-ref :as string)) + ((ref :as string)) (when - (not (contains? io-deps io-ref)) - (append! io-deps io-ref))) - (component-io-refs-cached name env io-names))) - (append! client-list name)))) - needed) - {:io-deps io-deps :server server-list :components comp-targets :client client-list}))) - -(define - env-components - :effects () - (fn - ((env :as dict)) - (filter + (not (contains? all-refs ref)) + (append! all-refs ref))) + (scan-io-refs (component-body val) io-names)) + (for-each + (fn + ((dep :as string)) + (transitive-io-refs-walk dep seen all-refs env io-names)) + (scan-refs (component-body val)))) + (= (type-of val) "macro") + (do + (for-each + (fn + ((ref :as string)) + (when + (not (contains? all-refs ref)) + (append! all-refs ref))) + (scan-io-refs (macro-body val) io-names)) + (for-each + (fn + ((dep :as string)) + (transitive-io-refs-walk dep seen all-refs env io-names)) + (scan-refs (macro-body val)))) + :else nil))))) + (define + transitive-io-refs + :effects () (fn - ((k :as string)) - (let ((v (env-get env k))) (or (component? v) (macro? v)))) - (keys env)))) - - -)) ;; end define-library + ((name :as string) (env :as dict) (io-names :as list)) + (let + ((all-refs (list)) + (seen (list)) + (key (if (starts-with? name "~") name (str "~" name)))) + (transitive-io-refs-walk key seen all-refs env io-names) + all-refs))) + (define + compute-all-io-refs + :effects (mutation) + (fn + ((env :as dict) (io-names :as list)) + (for-each + (fn + ((name :as string)) + (let + ((val (env-get env name))) + (when + (= (type-of val) "component") + (component-set-io-refs! + val + (transitive-io-refs name env io-names))))) + (env-components env)))) + (define + component-io-refs-cached + :effects () + (fn + ((name :as string) (env :as dict) (io-names :as list)) + (let + ((key (if (starts-with? name "~") name (str "~" name)))) + (let + ((val (env-get env key))) + (if + (and + (= (type-of val) "component") + (not (nil? (component-io-refs val))) + (not (empty? (component-io-refs val)))) + (component-io-refs val) + (transitive-io-refs name env io-names)))))) + (define + component-pure? + :effects () + (fn + (name (env :as dict) (io-names :as list)) + (let + ((key (if (starts-with? name "~") name (str "~" name)))) + (let + ((val (if (env-has? env key) (env-get env key) nil))) + (if + (and + (= (type-of val) "component") + (not (nil? (component-io-refs val))) + (not (empty? (component-io-refs val)))) + false + (empty? (transitive-io-refs name env io-names))))))) + (define + render-target + :effects () + (fn + (name (env :as dict) (io-names :as list)) + (let + ((key (if (starts-with? name "~") name (str "~" name)))) + (let + ((val (if (env-has? env key) (env-get env key) nil))) + (if + (not (= (type-of val) "component")) + "server" + (let + ((affinity (component-affinity val))) + (cond + (= affinity "server") + "server" + (= affinity "client") + "client" + (not (component-pure? name env io-names)) + "server" + :else "client"))))))) + (define + page-render-plan + :effects () + (fn + ((page-source :as string) (env :as dict) (io-names :as list)) + (let + ((needed (components-needed page-source env)) + (comp-targets (dict)) + (server-list (list)) + (client-list (list)) + (io-deps (list))) + (for-each + (fn + ((name :as string)) + (let + ((target (render-target name env io-names))) + (dict-set! comp-targets name target) + (if + (= target "server") + (do + (append! server-list name) + (for-each + (fn + ((io-ref :as string)) + (when + (not (contains? io-deps io-ref)) + (append! io-deps io-ref))) + (component-io-refs-cached name env io-names))) + (append! client-list name)))) + needed) + {:io-deps io-deps :server server-list :components comp-targets :client client-list}))) + (define + env-components + :effects () + (fn + ((env :as dict)) + (filter + (fn + ((k :as string)) + (let ((v (env-get env k))) (or (component? v) (macro? v)))) + (keys env)))))) ;; end define-library ;; Re-export to global namespace for backward compatibility (import (web deps)) diff --git a/web/engine.sx b/web/engine.sx index 42a00f7d..207abff3 100644 --- a/web/engine.sx +++ b/web/engine.sx @@ -4,7 +4,8 @@ (import (sx dom)) (import (sx browser)) -(define-library (web engine) +(define-library + (web engine) (export ENGINE_VERBS DEFAULT_SWAP @@ -40,818 +41,802 @@ should-boost-form? parse-sse-swap) (begin - -(define ENGINE_VERBS (list "get" "post" "put" "delete" "patch")) - -(define DEFAULT_SWAP "outerHTML") - -(define - parse-time - :effects () - (fn - ((s :as string)) - (if - (nil? s) - 0 - (if - (ends-with? s "ms") - (parse-int s 0) - (if - (ends-with? s "s") - (* (parse-int (replace s "s" "") 0) 1000) - (parse-int s 0)))))) - -(define - parse-trigger-spec - :effects () - (fn - ((spec :as string)) - (if - (nil? spec) - nil - (let - ((raw-parts (split spec ","))) - (filter - (fn (x) (not (nil? x))) - (map - (fn - ((part :as string)) - (let - ((tokens (split (trim part) " "))) - (if - (empty? tokens) - nil - (if - (and (= (first tokens) "every") (>= (len tokens) 2)) - (dict - "event" - "every" - "modifiers" - (dict "interval" (parse-time (nth tokens 1)))) - (let - ((mods (dict))) - (for-each - (fn - ((tok :as string)) - (cond - (= tok "once") - (dict-set! mods "once" true) - (= tok "changed") - (dict-set! mods "changed" true) - (starts-with? tok "delay:") - (dict-set! - mods - "delay" - (parse-time (slice tok 6))) - (starts-with? tok "from:") - (dict-set! mods "from" (slice tok 5)))) - (rest tokens)) - (let - ((raw-event (first tokens))) - (let - ((bracket-idx (index-of raw-event "["))) - (if - (>= bracket-idx 0) - (do - (dict-set! - mods - "filter" - (slice - raw-event - (+ bracket-idx 1) - (- (len raw-event) 1))) - (dict - "event" - (slice raw-event 0 bracket-idx) - "modifiers" - mods)) - (dict "event" raw-event "modifiers" mods))))))))) - raw-parts)))))) - -(define - default-trigger - :effects () - (fn - ((tag-name :as string)) - (cond - (= tag-name "form") - (list (dict "event" "submit" "modifiers" (dict))) - (or - (= tag-name "input") - (= tag-name "select") - (= tag-name "textarea")) - (list (dict "event" "change" "modifiers" (dict))) - :else (list (dict "event" "click" "modifiers" (dict)))))) - -(define - get-verb-info - :effects (io) - (fn - (el) - (some + (define ENGINE_VERBS (list "get" "post" "put" "delete" "patch")) + (define DEFAULT_SWAP "outerHTML") + (define + parse-time + :effects () (fn - (verb) - (let - ((url (dom-get-attr el (str "sx-" verb)))) - (if url (dict "method" (upper verb) "url" url) nil))) - ENGINE_VERBS))) - -(define - build-request-headers - :effects (io) - (fn - (el (loaded-components :as list)) - (let - ((headers (dict "SX-Request" "true" "SX-Current-URL" (browser-location-href)))) - (let - ((target-sel (dom-get-attr el "sx-target"))) - (when target-sel (dict-set! headers "SX-Target" target-sel))) - (let - ((comp-hash (dom-get-attr (dom-query "script[data-components][data-hash]") "data-hash"))) - (when comp-hash (dict-set! headers "SX-Components-Hash" comp-hash))) - (let - ((extra-h (dom-get-attr el "sx-headers"))) - (when - extra-h - (let - ((parsed (parse-header-value extra-h))) - (when - parsed - (for-each - (fn - ((key :as string)) - (dict-set! headers key (str (get parsed key)))) - (keys parsed)))))) - headers))) - -(define - process-response-headers - :effects () - (fn - ((get-header :as lambda)) - (dict - "redirect" - (get-header "SX-Redirect") - "refresh" - (get-header "SX-Refresh") - "trigger" - (get-header "SX-Trigger") - "retarget" - (get-header "SX-Retarget") - "reswap" - (get-header "SX-Reswap") - "location" - (get-header "SX-Location") - "replace-url" - (get-header "SX-Replace-Url") - "trigger-swap" - (get-header "SX-Trigger-After-Swap") - "trigger-settle" - (get-header "SX-Trigger-After-Settle") - "content-type" - (get-header "Content-Type") - "cache-invalidate" - (get-header "SX-Cache-Invalidate") - "cache-update" - (get-header "SX-Cache-Update")))) - -(define - parse-swap-spec - :effects () - (fn - ((raw-swap :as string) (global-transitions? :as boolean)) - (let - ((parts (split (or raw-swap DEFAULT_SWAP) " ")) - (style (first parts)) - (use-transition global-transitions?)) - (for-each - (fn - ((p :as string)) - (cond - (= p "transition:true") - (set! use-transition true) - (= p "transition:false") - (set! use-transition false))) - (rest parts)) - (dict "style" style "transition" use-transition)))) - -(define - parse-retry-spec - :effects () - (fn - ((retry-attr :as string)) - (if - (nil? retry-attr) - nil - (let - ((parts (split retry-attr ":"))) - (dict - "strategy" - (first parts) - "start-ms" - (parse-int (nth parts 1) 1000) - "cap-ms" - (parse-int (nth parts 2) 30000)))))) - -(define - next-retry-ms - :effects () - (fn - ((current-ms :as number) (cap-ms :as number)) - (min (* current-ms 2) cap-ms))) - -(define - filter-params - :effects () - (fn - ((params-spec :as string) (all-params :as list)) - (if - (nil? params-spec) - all-params - (if - (= params-spec "none") - (list) + ((s :as string)) (if - (= params-spec "*") + (nil? s) + 0 + (if + (ends-with? s "ms") + (parse-int s 0) + (if + (ends-with? s "s") + (* (parse-int (replace s "s" "") 0) 1000) + (parse-int s 0)))))) + (define + parse-trigger-spec + :effects () + (fn + ((spec :as string)) + (if + (nil? spec) + nil + (let + ((raw-parts (split spec ","))) + (filter + (fn (x) (not (nil? x))) + (map + (fn + ((part :as string)) + (let + ((tokens (split (trim part) " "))) + (if + (empty? tokens) + nil + (if + (and + (= (first tokens) "every") + (>= (len tokens) 2)) + (dict + "event" + "every" + "modifiers" + (dict "interval" (parse-time (nth tokens 1)))) + (let + ((mods (dict))) + (for-each + (fn + ((tok :as string)) + (cond + (= tok "once") + (dict-set! mods "once" true) + (= tok "changed") + (dict-set! mods "changed" true) + (starts-with? tok "delay:") + (dict-set! + mods + "delay" + (parse-time (slice tok 6))) + (starts-with? tok "from:") + (dict-set! mods "from" (slice tok 5)))) + (rest tokens)) + (let + ((raw-event (first tokens))) + (let + ((bracket-idx (index-of raw-event "["))) + (if + (>= bracket-idx 0) + (do + (dict-set! + mods + "filter" + (slice + raw-event + (+ bracket-idx 1) + (- (len raw-event) 1))) + (dict + "event" + (slice raw-event 0 bracket-idx) + "modifiers" + mods)) + (dict "event" raw-event "modifiers" mods))))))))) + raw-parts)))))) + (define + default-trigger + :effects () + (fn + ((tag-name :as string)) + (match + tag-name + ("form" (list (dict "event" "submit" "modifiers" (dict)))) + ("input" (list (dict "event" "change" "modifiers" (dict)))) + ("select" (list (dict "event" "change" "modifiers" (dict)))) + ("textarea" (list (dict "event" "change" "modifiers" (dict)))) + (_ (list (dict "event" "click" "modifiers" (dict))))))) + (define + get-verb-info + :effects (io) + (fn + (el) + (some + (fn + (verb) + (let + ((url (dom-get-attr el (str "sx-" verb)))) + (if url (dict "method" (upper verb) "url" url) nil))) + ENGINE_VERBS))) + (define + build-request-headers + :effects (io) + (fn + (el (loaded-components :as list)) + (let + ((headers (dict "SX-Request" "true" "SX-Current-URL" (browser-location-href)))) + (let + ((target-sel (dom-get-attr el "sx-target"))) + (when target-sel (dict-set! headers "SX-Target" target-sel))) + (let + ((comp-hash (dom-get-attr (dom-query "script[data-components][data-hash]") "data-hash"))) + (when + comp-hash + (dict-set! headers "SX-Components-Hash" comp-hash))) + (let + ((extra-h (dom-get-attr el "sx-headers"))) + (when + extra-h + (let + ((parsed (parse-header-value extra-h))) + (when + parsed + (for-each + (fn + ((key :as string)) + (dict-set! headers key (str (get parsed key)))) + (keys parsed)))))) + headers))) + (define + process-response-headers + :effects () + (fn + ((get-header :as lambda)) + (dict + "redirect" + (get-header "SX-Redirect") + "refresh" + (get-header "SX-Refresh") + "trigger" + (get-header "SX-Trigger") + "retarget" + (get-header "SX-Retarget") + "reswap" + (get-header "SX-Reswap") + "location" + (get-header "SX-Location") + "replace-url" + (get-header "SX-Replace-Url") + "trigger-swap" + (get-header "SX-Trigger-After-Swap") + "trigger-settle" + (get-header "SX-Trigger-After-Settle") + "content-type" + (get-header "Content-Type") + "cache-invalidate" + (get-header "SX-Cache-Invalidate") + "cache-update" + (get-header "SX-Cache-Update")))) + (define + parse-swap-spec + :effects () + (fn + ((raw-swap :as string) (global-transitions? :as boolean)) + (let + ((parts (split (or raw-swap DEFAULT_SWAP) " ")) + (style (first parts)) + (use-transition global-transitions?)) + (for-each + (fn + ((p :as string)) + (cond + (= p "transition:true") + (set! use-transition true) + (= p "transition:false") + (set! use-transition false))) + (rest parts)) + (dict "style" style "transition" use-transition)))) + (define + parse-retry-spec + :effects () + (fn + ((retry-attr :as string)) + (if + (nil? retry-attr) + nil + (let + ((parts (split retry-attr ":"))) + (dict + "strategy" + (first parts) + "start-ms" + (parse-int (nth parts 1) 1000) + "cap-ms" + (parse-int (nth parts 2) 30000)))))) + (define + next-retry-ms + :effects () + (fn + ((current-ms :as number) (cap-ms :as number)) + (min (* current-ms 2) cap-ms))) + (define + filter-params + :effects () + (fn + ((params-spec :as string) (all-params :as list)) + (if + (nil? params-spec) all-params (if - (starts-with? params-spec "not ") - (let - ((excluded (map trim (split (slice params-spec 4) ",")))) - (filter - (fn ((p :as list)) (not (contains? excluded (first p)))) - all-params)) - (let - ((allowed (map trim (split params-spec ",")))) - (filter - (fn ((p :as list)) (contains? allowed (first p))) - all-params)))))))) - -(define - resolve-target - :effects (io) - (fn - (el) - (let - ((sel (dom-get-attr el "sx-target"))) - (cond - (or (nil? sel) (= sel "this")) - el - (= sel "closest") - (dom-parent el) - :else (dom-query sel))))) - -(define - apply-optimistic - :effects (mutation io) - (fn - (el) - (let - ((directive (dom-get-attr el "sx-optimistic"))) - (if - (nil? directive) - nil - (let - ((target (or (resolve-target el) el)) - (state (dict "target" target "directive" directive))) - (cond - (= directive "remove") - (do - (dict-set! state "opacity" (dom-get-style target "opacity")) - (dom-set-style target "opacity" "0") - (dom-set-style target "pointer-events" "none")) - (= directive "disable") - (do - (dict-set! state "disabled" (dom-get-prop target "disabled")) - (dom-set-prop target "disabled" true)) - (starts-with? directive "add-class:") - (let - ((cls (slice directive 10))) - (dict-set! state "add-class" cls) - (dom-add-class target cls))) - state))))) - -(define - revert-optimistic - :effects (mutation io) - (fn - ((state :as dict)) - (when - state - (let - ((target (get state "target")) (directive (get state "directive"))) - (cond - (= directive "remove") - (do - (dom-set-style target "opacity" (or (get state "opacity") "")) - (dom-set-style target "pointer-events" "")) - (= directive "disable") - (dom-set-prop target "disabled" (or (get state "disabled") false)) - (get state "add-class") - (dom-remove-class target (get state "add-class"))))))) - -(define - find-oob-swaps - :effects (mutation io) - (fn - (container) - (let - ((results (list))) - (for-each - (fn - ((attr :as string)) - (let - ((oob-els (dom-query-all container (str "[" attr "]")))) - (for-each - (fn - (oob) + (= params-spec "none") + (list) + (if + (= params-spec "*") + all-params + (if + (starts-with? params-spec "not ") (let - ((swap-type (or (dom-get-attr oob attr) "outerHTML")) - (target-id (dom-id oob))) - (dom-remove-attr oob attr) - (when - target-id - (append! - results - (dict - "element" - oob - "swap-type" - swap-type - "target-id" - target-id))))) - oob-els))) - (list "sx-swap-oob" "hx-swap-oob")) - results))) - -(define - morph-node - :effects (mutation io) - (fn - (old-node new-node) - (cond - (or - (dom-has-attr? old-node "sx-preserve") - (dom-has-attr? old-node "sx-ignore")) - nil - (and - (dom-has-attr? old-node "data-sx-island") - (is-processed? old-node "island-hydrated") - (dom-has-attr? new-node "data-sx-island") - (= - (dom-get-attr old-node "data-sx-island") - (dom-get-attr new-node "data-sx-island"))) - (let - ((old-state (dom-get-attr old-node "data-sx-state")) - (new-state (dom-get-attr new-node "data-sx-state"))) - (sync-attrs old-node new-node) - (if - (and new-state (not (= old-state new-state))) - (do (dispose-island old-node) (hydrate-island old-node)) - (morph-island-children old-node new-node))) - (or - (not (= (dom-node-type old-node) (dom-node-type new-node))) - (not (= (dom-node-name old-node) (dom-node-name new-node)))) - (dom-replace-child - (dom-parent old-node) - (dom-clone new-node true) - old-node) - (or (= (dom-node-type old-node) 3) (= (dom-node-type old-node) 8)) - (when - (not (= (dom-text-content old-node) (dom-text-content new-node))) - (dom-set-text-content old-node (dom-text-content new-node))) - (= (dom-node-type old-node) 1) - (do + ((excluded (map trim (split (slice params-spec 4) ",")))) + (filter + (fn + ((p :as list)) + (not (contains? excluded (first p)))) + all-params)) + (let + ((allowed (map trim (split params-spec ",")))) + (filter + (fn ((p :as list)) (contains? allowed (first p))) + all-params)))))))) + (define + resolve-target + :effects (io) + (fn + (el) + (let + ((sel (dom-get-attr el "sx-target"))) + (match + sel + (nil el) + ("this" el) + ("closest" (dom-parent el)) + (_ (dom-query sel)))))) + (define + apply-optimistic + :effects (mutation io) + (fn + (el) + (let + ((directive (dom-get-attr el "sx-optimistic"))) + (if + (nil? directive) + nil + (let + ((target (or (resolve-target el) el)) + (state (dict "target" target "directive" directive))) + (cond + (= directive "remove") + (do + (dict-set! state "opacity" (dom-get-style target "opacity")) + (dom-set-style target "opacity" "0") + (dom-set-style target "pointer-events" "none")) + (= directive "disable") + (do + (dict-set! + state + "disabled" + (dom-get-prop target "disabled")) + (dom-set-prop target "disabled" true)) + (starts-with? directive "add-class:") + (let + ((cls (slice directive 10))) + (dict-set! state "add-class" cls) + (dom-add-class target cls))) + state))))) + (define + revert-optimistic + :effects (mutation io) + (fn + ((state :as dict)) (when + state + (let + ((target (get state "target")) + (directive (get state "directive"))) + (cond + (= directive "remove") + (do + (dom-set-style + target + "opacity" + (or (get state "opacity") "")) + (dom-set-style target "pointer-events" "")) + (= directive "disable") + (dom-set-prop + target + "disabled" + (or (get state "disabled") false)) + (get state "add-class") + (dom-remove-class target (get state "add-class"))))))) + (define + find-oob-swaps + :effects (mutation io) + (fn + (container) + (let + ((results (list))) + (for-each + (fn + ((attr :as string)) + (let + ((oob-els (dom-query-all container (str "[" attr "]")))) + (for-each + (fn + (oob) + (let + ((swap-type (or (dom-get-attr oob attr) "outerHTML")) + (target-id (dom-id oob))) + (dom-remove-attr oob attr) + (when + target-id + (append! + results + (dict + "element" + oob + "swap-type" + swap-type + "target-id" + target-id))))) + oob-els))) + (list "sx-swap-oob" "hx-swap-oob")) + results))) + (define + morph-node + :effects (mutation io) + (fn + (old-node new-node) + (cond + (or + (dom-has-attr? old-node "sx-preserve") + (dom-has-attr? old-node "sx-ignore")) + nil (and (dom-has-attr? old-node "data-sx-island") + (is-processed? old-node "island-hydrated") (dom-has-attr? new-node "data-sx-island") + (= + (dom-get-attr old-node "data-sx-island") + (dom-get-attr new-node "data-sx-island"))) + (let + ((old-state (dom-get-attr old-node "data-sx-state")) + (new-state (dom-get-attr new-node "data-sx-state"))) + (sync-attrs old-node new-node) + (if + (and new-state (not (= old-state new-state))) + (do (dispose-island old-node) (hydrate-island old-node)) + (morph-island-children old-node new-node))) + (or + (not (= (dom-node-type old-node) (dom-node-type new-node))) + (not (= (dom-node-name old-node) (dom-node-name new-node)))) + (dom-replace-child + (dom-parent old-node) + (dom-clone new-node true) + old-node) + (or + (= (dom-node-type old-node) 3) + (= (dom-node-type old-node) 8)) + (when (not - (= - (dom-get-attr old-node "data-sx-island") - (dom-get-attr new-node "data-sx-island")))) - (dispose-island old-node) - (dispose-islands-in old-node)) - (sync-attrs old-node new-node) - (when - (not - (and - (dom-is-active-element? old-node) - (dom-is-input-element? old-node))) - (morph-children old-node new-node)))))) - -(define - sync-attrs - :effects (mutation io) - (fn - (old-el new-el) - (let - ((ra-str (or (dom-get-attr old-el "data-sx-reactive-attrs") "")) - (reactive-attrs (if (empty? ra-str) (list) (split ra-str ",")))) - (for-each - (fn - ((attr :as list)) - (let - ((name (first attr)) (val (nth attr 1))) + (= (dom-text-content old-node) (dom-text-content new-node))) + (dom-set-text-content old-node (dom-text-content new-node))) + (= (dom-node-type old-node) 1) + (do (when (and - (not (= (dom-get-attr old-el name) val)) - (not (contains? reactive-attrs name))) - (dom-set-attr old-el name val)))) - (dom-attr-list new-el)) - (for-each - (fn - ((attr :as list)) - (let - ((aname (first attr))) + (dom-has-attr? old-node "data-sx-island") + (dom-has-attr? new-node "data-sx-island") + (not + (= + (dom-get-attr old-node "data-sx-island") + (dom-get-attr new-node "data-sx-island")))) + (dispose-island old-node) + (dispose-islands-in old-node)) + (sync-attrs old-node new-node) (when - (and - (not (dom-has-attr? new-el aname)) - (not (contains? reactive-attrs aname)) - (not (= aname "data-sx-reactive-attrs"))) - (dom-remove-attr old-el aname)))) - (dom-attr-list old-el))))) - -(define - morph-children - :effects (mutation io) - (fn - (old-parent new-parent) - (let - ((old-kids (dom-child-list old-parent)) - (new-kids (dom-child-list new-parent)) - (old-by-id (dict)) - (old-idx-by-id (dict)) - (consumed (dict)) - (oi 0) - (idx 0)) - (for-each - (fn - (kid) - (let - ((id (dom-id kid))) - (when - (and id (not (empty? id))) - (dict-set! old-by-id id kid) - (dict-set! old-idx-by-id id idx))) - (set! idx (inc idx))) - old-kids) - (for-each - (fn - (new-child) - (let - ((raw-id (dom-id new-child)) - (match-id (if (and raw-id (not (empty? raw-id))) raw-id nil)) - (match-by-id (if match-id (dict-get old-by-id match-id) nil))) - (cond - (and match-by-id (not (nil? match-by-id))) - (do - (let - ((matched-idx (dict-get old-idx-by-id match-id))) - (when - matched-idx - (dict-set! consumed (str matched-idx) true))) + (not + (and + (dom-is-active-element? old-node) + (dom-is-input-element? old-node))) + (morph-children old-node new-node)))))) + (define + sync-attrs + :effects (mutation io) + (fn + (old-el new-el) + (let + ((ra-str (or (dom-get-attr old-el "data-sx-reactive-attrs") "")) + (reactive-attrs (if (empty? ra-str) (list) (split ra-str ",")))) + (for-each + (fn + ((attr :as list)) + (let + ((name (first attr)) (val (nth attr 1))) (when (and - (< oi (len old-kids)) - (not (= match-by-id (nth old-kids oi)))) - (dom-insert-before - old-parent - match-by-id - (if (< oi (len old-kids)) (nth old-kids oi) nil))) - (morph-node match-by-id new-child) - (set! oi (inc oi))) - (< oi (len old-kids)) + (not (= (dom-get-attr old-el name) val)) + (not (contains? reactive-attrs name))) + (dom-set-attr old-el name val)))) + (dom-attr-list new-el)) + (for-each + (fn + ((attr :as list)) (let - ((old-child (nth old-kids oi))) - (let - ((old-id (dom-id old-child))) - (if - (and old-id (not (empty? old-id)) (not match-id)) - (dom-insert-before - old-parent - (dom-clone new-child true) - old-child) - (do - (dict-set! consumed (str oi) true) - (morph-node old-child new-child) - (set! oi (inc oi)))))) - :else (dom-append old-parent (dom-clone new-child true))))) - new-kids) - (for-each - (fn - (i) - (when - (not (dict-get consumed (str i))) - (let - ((leftover (nth old-kids i))) - (when - (and - (dom-is-child-of? leftover old-parent) - (not (dom-has-attr? leftover "sx-preserve")) - (not (dom-has-attr? leftover "sx-ignore"))) - (dom-remove-child old-parent leftover))))) - (range 0 (len old-kids)))))) - -(define - morph-island-children - :effects (mutation io) - (fn - (old-island new-island) - (let - ((old-lakes (dom-query-all old-island "[data-sx-lake]")) - (new-lakes (dom-query-all new-island "[data-sx-lake]")) - (old-marshes (dom-query-all old-island "[data-sx-marsh]")) - (new-marshes (dom-query-all new-island "[data-sx-marsh]"))) - (let - ((new-lake-map (dict)) (new-marsh-map (dict))) - (for-each - (fn - (lake) - (let - ((id (dom-get-attr lake "data-sx-lake"))) - (when id (dict-set! new-lake-map id lake)))) - new-lakes) - (for-each - (fn - (marsh) - (let - ((id (dom-get-attr marsh "data-sx-marsh"))) - (when id (dict-set! new-marsh-map id marsh)))) - new-marshes) - (for-each - (fn - (old-lake) - (let - ((id (dom-get-attr old-lake "data-sx-lake"))) - (let - ((new-lake (dict-get new-lake-map id))) + ((aname (first attr))) (when - new-lake - (sync-attrs old-lake new-lake) - (morph-children old-lake new-lake))))) - old-lakes) - (for-each - (fn - (old-marsh) - (let - ((id (dom-get-attr old-marsh "data-sx-marsh"))) - (let - ((new-marsh (dict-get new-marsh-map id))) - (when new-marsh (morph-marsh old-marsh new-marsh old-island))))) - old-marshes) - (process-signal-updates new-island))))) - -(define - morph-marsh - :effects (mutation io) - (fn - (old-marsh new-marsh island-el) - (let - ((transform (dom-get-data old-marsh "sx-marsh-transform")) - (env (dom-get-data old-marsh "sx-marsh-env")) - (new-html (dom-inner-html new-marsh))) - (if - (and env new-html (not (empty? new-html))) + (and + (not (dom-has-attr? new-el aname)) + (not (contains? reactive-attrs aname)) + (not (= aname "data-sx-reactive-attrs"))) + (dom-remove-attr old-el aname)))) + (dom-attr-list old-el))))) + (define + morph-children + :effects (mutation io) + (fn + (old-parent new-parent) (let - ((parsed (parse new-html))) - (let - ((sx-content (if transform (cek-call transform (list parsed)) parsed))) - (dispose-marsh-scope old-marsh) - (with-marsh-scope - old-marsh - (fn - () - (let - ((new-dom (render-to-dom sx-content env nil))) - (dom-remove-children-after old-marsh nil) - (dom-append old-marsh new-dom)))))) - (do - (sync-attrs old-marsh new-marsh) - (morph-children old-marsh new-marsh)))))) - -(define - process-signal-updates - :effects (mutation io) - (fn - (root) - (let - ((signal-els (dom-query-all root "[data-sx-signal]"))) - (for-each - (fn - (el) - (let - ((spec (dom-get-attr el "data-sx-signal"))) - (when - spec + ((old-kids (dom-child-list old-parent)) + (new-kids (dom-child-list new-parent)) + (old-by-id (dict)) + (old-idx-by-id (dict)) + (consumed (dict)) + (oi 0) + (idx 0)) + (for-each + (fn + (kid) (let - ((colon-idx (index-of spec ":"))) + ((id (dom-id kid))) (when - (> colon-idx 0) - (let - ((store-name (slice spec 0 colon-idx)) - (raw-value (slice spec (+ colon-idx 1)))) + (and id (not (empty? id))) + (dict-set! old-by-id id kid) + (dict-set! old-idx-by-id id idx))) + (set! idx (inc idx))) + old-kids) + (for-each + (fn + (new-child) + (let + ((raw-id (dom-id new-child)) + (match-id + (if (and raw-id (not (empty? raw-id))) raw-id nil)) + (match-by-id + (if match-id (dict-get old-by-id match-id) nil))) + (cond + (and match-by-id (not (nil? match-by-id))) + (do (let - ((parsed (json-parse raw-value))) - (reset! (use-store store-name) parsed)) - (dom-remove-attr el "data-sx-signal"))))))) - signal-els)))) - -(define - swap-dom-nodes - :effects (mutation io) - (fn - (target new-nodes (strategy :as string)) - (case - strategy - "innerHTML" - (if - (dom-is-fragment? new-nodes) - (morph-children target new-nodes) - (let - ((wrapper (dom-create-element "div" nil))) - (dom-append wrapper new-nodes) - (morph-children target wrapper))) - "outerHTML" - (let - ((parent (dom-parent target)) (new-el (dom-clone new-nodes true))) - (if - (dom-is-fragment? new-nodes) - (let - ((fc (dom-first-child new-nodes))) - (if - fc - (do - (set! new-el (dom-clone fc true)) - (dom-replace-child parent new-el target) + ((matched-idx (dict-get old-idx-by-id match-id))) + (when + matched-idx + (dict-set! consumed (str matched-idx) true))) + (when + (and + (< oi (len old-kids)) + (not (= match-by-id (nth old-kids oi)))) + (dom-insert-before + old-parent + match-by-id + (if (< oi (len old-kids)) (nth old-kids oi) nil))) + (morph-node match-by-id new-child) + (set! oi (inc oi))) + (< oi (len old-kids)) + (let + ((old-child (nth old-kids oi))) + (let + ((old-id (dom-id old-child))) + (if + (and old-id (not (empty? old-id)) (not match-id)) + (dom-insert-before + old-parent + (dom-clone new-child true) + old-child) + (do + (dict-set! consumed (str oi) true) + (morph-node old-child new-child) + (set! oi (inc oi)))))) + :else (dom-append old-parent (dom-clone new-child true))))) + new-kids) + (for-each + (fn + (i) + (when + (not (dict-get consumed (str i))) (let - ((sib (dom-next-sibling fc))) - (insert-remaining-siblings parent new-el sib))) - (dom-remove-child parent target))) - (dom-replace-child parent new-el target)) - new-el) - "afterend" - (dom-insert-after target new-nodes) - "beforeend" - (dom-append target new-nodes) - "afterbegin" - (dom-prepend target new-nodes) - "beforebegin" - (dom-insert-before (dom-parent target) new-nodes target) - "delete" - (dom-remove-child (dom-parent target) target) - "none" - nil - :else (if - (dom-is-fragment? new-nodes) - (morph-children target new-nodes) + ((leftover (nth old-kids i))) + (when + (and + (dom-is-child-of? leftover old-parent) + (not (dom-has-attr? leftover "sx-preserve")) + (not (dom-has-attr? leftover "sx-ignore"))) + (dom-remove-child old-parent leftover))))) + (range 0 (len old-kids)))))) + (define + morph-island-children + :effects (mutation io) + (fn + (old-island new-island) (let - ((wrapper (dom-create-element "div" nil))) - (dom-append wrapper new-nodes) - (morph-children target wrapper)))))) - -(define - insert-remaining-siblings - :effects (mutation io) - (fn - (parent ref-node sib) - (when - sib - (let - ((next (dom-next-sibling sib))) - (dom-insert-after ref-node sib) - (insert-remaining-siblings parent sib next))))) - -(define - swap-html-string - :effects (mutation io) - (fn - (target (html :as string) (strategy :as string)) - (case - strategy - "innerHTML" - (dom-set-inner-html target html) - "outerHTML" - (let - ((parent (dom-parent target))) - (dom-insert-adjacent-html target "afterend" html) - (dom-remove-child parent target) - parent) - "afterend" - (dom-insert-adjacent-html target "afterend" html) - "beforeend" - (dom-insert-adjacent-html target "beforeend" html) - "afterbegin" - (dom-insert-adjacent-html target "afterbegin" html) - "beforebegin" - (dom-insert-adjacent-html target "beforebegin" html) - "delete" - (dom-remove-child (dom-parent target) target) - "none" - nil - :else (dom-set-inner-html target html)))) - -(define - handle-history - :effects (io) - (fn - (el (url :as string) (resp-headers :as dict)) - (let - ((push-url (dom-get-attr el "sx-push-url")) - (replace-url (dom-get-attr el "sx-replace-url")) - (hdr-replace (get resp-headers "replace-url"))) - (cond - hdr-replace - (browser-replace-state hdr-replace) - (and push-url (not (= push-url "false"))) - (do - (save-scroll-position) - (browser-push-state (if (= push-url "true") url push-url))) - (and replace-url (not (= replace-url "false"))) - (browser-replace-state (if (= replace-url "true") url replace-url)))))) - -(define PRELOAD_TTL 30000) - -(define - preload-cache-get - :effects (mutation) - (fn - ((cache :as dict) (url :as string)) - (let - ((entry (dict-get cache url))) - (if - (nil? entry) - nil - (if - (> (- (now-ms) (get entry "timestamp")) PRELOAD_TTL) - (do (dict-delete! cache url) nil) - (do (dict-delete! cache url) entry)))))) - -(define - preload-cache-set - :effects (mutation) - (fn - ((cache :as dict) - (url :as string) - (text :as string) - (content-type :as string)) - (dict-set! - cache - url - (dict "text" text "content-type" content-type "timestamp" (now-ms))))) - -(define - classify-trigger - :effects () - (fn - ((trigger :as dict)) - (let - ((event (get trigger "event"))) - (cond - (= event "every") - "poll" - (= event "intersect") - "intersect" - (= event "load") - "load" - (= event "revealed") - "revealed" - :else "event")))) - -(define - should-boost-link? - :effects (io) - (fn - (link) - (let - ((href (dom-get-attr link "href"))) - (and - href - (not (starts-with? href "#")) - (not (starts-with? href "javascript:")) - (not (starts-with? href "mailto:")) - (browser-same-origin? href) - (not (dom-has-attr? link "sx-get")) - (not (dom-has-attr? link "sx-post")) - (not (dom-has-attr? link "sx-disable")))))) - -(define - should-boost-form? - :effects (io) - (fn - (form) - (and - (not (dom-has-attr? form "sx-get")) - (not (dom-has-attr? form "sx-post")) - (not (dom-has-attr? form "sx-disable"))))) - -(define - parse-sse-swap - :effects (io) - (fn (el) (or (dom-get-attr el "sx-sse-swap") "message"))) - - -)) ;; end define-library + ((old-lakes (dom-query-all old-island "[data-sx-lake]")) + (new-lakes (dom-query-all new-island "[data-sx-lake]")) + (old-marshes (dom-query-all old-island "[data-sx-marsh]")) + (new-marshes (dom-query-all new-island "[data-sx-marsh]"))) + (let + ((new-lake-map (dict)) (new-marsh-map (dict))) + (for-each + (fn + (lake) + (let + ((id (dom-get-attr lake "data-sx-lake"))) + (when id (dict-set! new-lake-map id lake)))) + new-lakes) + (for-each + (fn + (marsh) + (let + ((id (dom-get-attr marsh "data-sx-marsh"))) + (when id (dict-set! new-marsh-map id marsh)))) + new-marshes) + (for-each + (fn + (old-lake) + (let + ((id (dom-get-attr old-lake "data-sx-lake"))) + (let + ((new-lake (dict-get new-lake-map id))) + (when + new-lake + (sync-attrs old-lake new-lake) + (morph-children old-lake new-lake))))) + old-lakes) + (for-each + (fn + (old-marsh) + (let + ((id (dom-get-attr old-marsh "data-sx-marsh"))) + (let + ((new-marsh (dict-get new-marsh-map id))) + (when + new-marsh + (morph-marsh old-marsh new-marsh old-island))))) + old-marshes) + (process-signal-updates new-island))))) + (define + morph-marsh + :effects (mutation io) + (fn + (old-marsh new-marsh island-el) + (let + ((transform (dom-get-data old-marsh "sx-marsh-transform")) + (env (dom-get-data old-marsh "sx-marsh-env")) + (new-html (dom-inner-html new-marsh))) + (if + (and env new-html (not (empty? new-html))) + (let + ((parsed (parse new-html))) + (let + ((sx-content (if transform (cek-call transform (list parsed)) parsed))) + (dispose-marsh-scope old-marsh) + (with-marsh-scope + old-marsh + (fn + () + (let + ((new-dom (render-to-dom sx-content env nil))) + (dom-remove-children-after old-marsh nil) + (dom-append old-marsh new-dom)))))) + (do + (sync-attrs old-marsh new-marsh) + (morph-children old-marsh new-marsh)))))) + (define + process-signal-updates + :effects (mutation io) + (fn + (root) + (let + ((signal-els (dom-query-all root "[data-sx-signal]"))) + (for-each + (fn + (el) + (let + ((spec (dom-get-attr el "data-sx-signal"))) + (when + spec + (let + ((colon-idx (index-of spec ":"))) + (when + (> colon-idx 0) + (let + ((store-name (slice spec 0 colon-idx)) + (raw-value (slice spec (+ colon-idx 1)))) + (let + ((parsed (json-parse raw-value))) + (reset! (use-store store-name) parsed)) + (dom-remove-attr el "data-sx-signal"))))))) + signal-els)))) + (define + swap-dom-nodes + :effects (mutation io) + (fn + (target new-nodes (strategy :as string)) + (case + strategy + "innerHTML" + (if + (dom-is-fragment? new-nodes) + (morph-children target new-nodes) + (let + ((wrapper (dom-create-element "div" nil))) + (dom-append wrapper new-nodes) + (morph-children target wrapper))) + "outerHTML" + (let + ((parent (dom-parent target)) + (new-el (dom-clone new-nodes true))) + (if + (dom-is-fragment? new-nodes) + (let + ((fc (dom-first-child new-nodes))) + (if + fc + (do + (set! new-el (dom-clone fc true)) + (dom-replace-child parent new-el target) + (let + ((sib (dom-next-sibling fc))) + (insert-remaining-siblings parent new-el sib))) + (dom-remove-child parent target))) + (dom-replace-child parent new-el target)) + new-el) + "afterend" + (dom-insert-after target new-nodes) + "beforeend" + (dom-append target new-nodes) + "afterbegin" + (dom-prepend target new-nodes) + "beforebegin" + (dom-insert-before (dom-parent target) new-nodes target) + "delete" + (dom-remove-child (dom-parent target) target) + "none" + nil + :else (if + (dom-is-fragment? new-nodes) + (morph-children target new-nodes) + (let + ((wrapper (dom-create-element "div" nil))) + (dom-append wrapper new-nodes) + (morph-children target wrapper)))))) + (define + insert-remaining-siblings + :effects (mutation io) + (fn + (parent ref-node sib) + (when + sib + (let + ((next (dom-next-sibling sib))) + (dom-insert-after ref-node sib) + (insert-remaining-siblings parent sib next))))) + (define + swap-html-string + :effects (mutation io) + (fn + (target (html :as string) (strategy :as string)) + (case + strategy + "innerHTML" + (dom-set-inner-html target html) + "outerHTML" + (let + ((parent (dom-parent target))) + (dom-insert-adjacent-html target "afterend" html) + (dom-remove-child parent target) + parent) + "afterend" + (dom-insert-adjacent-html target "afterend" html) + "beforeend" + (dom-insert-adjacent-html target "beforeend" html) + "afterbegin" + (dom-insert-adjacent-html target "afterbegin" html) + "beforebegin" + (dom-insert-adjacent-html target "beforebegin" html) + "delete" + (dom-remove-child (dom-parent target) target) + "none" + nil + :else (dom-set-inner-html target html)))) + (define + handle-history + :effects (io) + (fn + (el (url :as string) (resp-headers :as dict)) + (let + ((push-url (dom-get-attr el "sx-push-url")) + (replace-url (dom-get-attr el "sx-replace-url")) + (hdr-replace (get resp-headers "replace-url"))) + (cond + hdr-replace + (browser-replace-state hdr-replace) + (and push-url (not (= push-url "false"))) + (do + (save-scroll-position) + (browser-push-state (if (= push-url "true") url push-url))) + (and replace-url (not (= replace-url "false"))) + (browser-replace-state + (if (= replace-url "true") url replace-url)))))) + (define PRELOAD_TTL 30000) + (define + preload-cache-get + :effects (mutation) + (fn + ((cache :as dict) (url :as string)) + (let + ((entry (dict-get cache url))) + (if + (nil? entry) + nil + (if + (> (- (now-ms) (get entry "timestamp")) PRELOAD_TTL) + (do (dict-delete! cache url) nil) + (do (dict-delete! cache url) entry)))))) + (define + preload-cache-set + :effects (mutation) + (fn + ((cache :as dict) + (url :as string) + (text :as string) + (content-type :as string)) + (dict-set! + cache + url + (dict "text" text "content-type" content-type "timestamp" (now-ms))))) + (define + classify-trigger + :effects () + (fn + ((trigger :as dict)) + (let + ((event (get trigger "event"))) + (match + event + ("every" "poll") + ("intersect" "intersect") + ("load" "load") + ("revealed" "revealed") + (_ "event"))))) + (define + should-boost-link? + :effects (io) + (fn + (link) + (let + ((href (dom-get-attr link "href"))) + (and + href + (not (starts-with? href "#")) + (not (starts-with? href "javascript:")) + (not (starts-with? href "mailto:")) + (browser-same-origin? href) + (not (dom-has-attr? link "sx-get")) + (not (dom-has-attr? link "sx-post")) + (not (dom-has-attr? link "sx-disable")))))) + (define + should-boost-form? + :effects (io) + (fn + (form) + (and + (not (dom-has-attr? form "sx-get")) + (not (dom-has-attr? form "sx-post")) + (not (dom-has-attr? form "sx-disable"))))) + (define + parse-sse-swap + :effects (io) + (fn (el) (or (dom-get-attr el "sx-sse-swap") "message"))))) ;; end define-library ;; Re-export to global namespace for backward compatibility (import (web engine))