coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adopt Step 7 language features across SX codebase

Browse Source 
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) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-04 20:49:02 +00:00
parent aee4770a6a
commit c0665ba58e
19 changed files with 4974 additions and 3771 deletions
Download Patch File Download Diff File Expand all files Collapse all files

703
blog/sx/admin.sx
View File

@@ -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! "&laquo;"))
(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! "&lsaquo;"))
(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! "&rsaquo;"))
(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! "&raquo;"))))
(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))))

184
events/sx/entries.sx
View File

@@ -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)

49
events/sx/forms.sx
View File

@@ -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)

338
events/sx/layouts.sx
View File

@@ -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."

334
events/sx/page.sx
View File

@@ -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))))))

202
events/sx/tickets.sx
View File

@@ -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?)

197
federation/sx/social.sx
View File

@@ -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

169
lib/freeze.sx
View File

@@ -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))

509
lib/highlight.sx
View File

@@ -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))

554
lib/sx-swap.sx
View File

@@ -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))

182
lib/tree-tools.sx
View File

@@ -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)))

1583
lib/types.sx
View File

File diff suppressed because it is too large Load Diff

133
lib/vm.sx
View File

@@ -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))

382
shared/sx/templates/client-libs/page-functions.sx
View File

@@ -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

371
spec/signals.sx
View File

@@ -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))

357
sx/sx/handlers/pub-api.sx
View File

@@ -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/<collection_slug>"
: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/<cid>"
: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
"\")"))))))

279
sx/sx/specs-explorer.sx
View File

@@ -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))))))

654
web/deps.sx
View File

@@ -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))

1565
web/engine.sx
View File

File diff suppressed because it is too large Load Diff