

(import (web boot-helpers))
(import (sx dom))
(import (sx browser))

(define-library
  (web engine)
  (export
    ENGINE_VERBS
    DEFAULT_SWAP
    parse-time
    parse-trigger-spec
    default-trigger
    get-verb-info
    build-request-headers
    process-response-headers
    parse-swap-spec
    parse-retry-spec
    next-retry-ms
    filter-params
    resolve-target
    apply-optimistic
    revert-optimistic
    find-oob-swaps
    morph-node
    sync-attrs
    morph-children
    morph-island-children
    morph-marsh
    process-signal-updates
    swap-dom-nodes
    insert-remaining-siblings
    swap-html-string
    handle-history
    PRELOAD_TTL
    preload-cache-get
    preload-cache-set
    classify-trigger
    should-boost-link?
    should-boost-form?
    parse-sse-swap)
  (begin
    (define ENGINE_VERBS (list "get" "post" "put" "delete" "patch"))
    (define DEFAULT_SWAP "outerHTML")
    (define
      parse-time
      :effects ()
      (fn
        ((s :as string))
        (if
          (nil? s)
          0
          (if
            (ends-with? s "ms")
            (parse-int s 0)
            (if
              (ends-with? s "s")
              (* (parse-int (replace s "s" "") 0) 1000)
              (parse-int s 0))))))
    (define
      parse-trigger-spec
      :effects ()
      (fn
        ((spec :as string))
        (if
          (nil? spec)
          nil
          (let
            ((raw-parts (split spec ",")))
            (filter
              (fn (x) (not (nil? x)))
              (map
                (fn
                  ((part :as string))
                  (let
                    ((tokens (split (trim part) " ")))
                    (if
                      (empty? tokens)
                      nil
                      (if
                        (and
                          (= (first tokens) "every")
                          (>= (len tokens) 2))
                        (dict
                          "event"
                          "every"
                          "modifiers"
                          (dict "interval" (parse-time (nth tokens 1))))
                        (let
                          ((mods (dict)))
                          (for-each
                            (fn
                              ((tok :as string))
                              (cond
                                (= tok "once")
                                (dict-set! mods "once" true)
                                (= tok "changed")
                                (dict-set! mods "changed" true)
                                (starts-with? tok "delay:")
                                (dict-set!
                                  mods
                                  "delay"
                                  (parse-time (slice tok 6)))
                                (starts-with? tok "from:")
                                (dict-set! mods "from" (slice tok 5))))
                            (rest tokens))
                          (let
                            ((raw-event (first tokens)))
                            (let
                              ((bracket-idx (index-of raw-event "[")))
                              (if
                                (>= bracket-idx 0)
                                (do
                                  (dict-set!
                                    mods
                                    "filter"
                                    (slice
                                      raw-event
                                      (+ bracket-idx 1)
                                      (- (len raw-event) 1)))
                                  (dict
                                    "event"
                                    (slice raw-event 0 bracket-idx)
                                    "modifiers"
                                    mods))
                                (dict "event" raw-event "modifiers" mods)))))))))
                raw-parts))))))
    (define
      default-trigger
      :effects ()
      (fn
        ((tag-name :as string))
        (match
          tag-name
          ("form" (list (dict "event" "submit" "modifiers" (dict))))
          ("input" (list (dict "event" "change" "modifiers" (dict))))
          ("select" (list (dict "event" "change" "modifiers" (dict))))
          ("textarea" (list (dict "event" "change" "modifiers" (dict))))
          (_ (list (dict "event" "click" "modifiers" (dict)))))))
    (define
      get-verb-info
      :effects (io)
      (fn
        (el)
        (some
          (fn
            (verb)
            (let
              ((url (dom-get-attr el (str "sx-" verb))))
              (if url (dict "method" (upper verb) "url" url) nil)))
          ENGINE_VERBS)))
    (define
      build-request-headers
      :effects (io)
      (fn
        (el (loaded-components :as list))
        (let
          ((headers (dict "SX-Request" "true" "SX-Current-URL" (browser-location-href))))
          (let
            ((target-sel (dom-get-attr el "sx-target")))
            (when target-sel (dict-set! headers "SX-Target" target-sel)))
          (let
            ((comp-hash (dom-get-attr (dom-query "script[data-components][data-hash]") "data-hash")))
            (when
              comp-hash
              (dict-set! headers "SX-Components-Hash" comp-hash)))
          (let
            ((extra-h (dom-get-attr el "sx-headers")))
            (when
              extra-h
              (let
                ((parsed (parse-header-value extra-h)))
                (when
                  parsed
                  (for-each
                    (fn
                      ((key :as string))
                      (dict-set! headers key (str (get parsed key))))
                    (keys parsed))))))
          headers)))
    (define
      process-response-headers
      :effects ()
      (fn
        ((get-header :as lambda))
        (dict
          "redirect"
          (get-header "SX-Redirect")
          "refresh"
          (get-header "SX-Refresh")
          "trigger"
          (get-header "SX-Trigger")
          "retarget"
          (get-header "SX-Retarget")
          "reswap"
          (get-header "SX-Reswap")
          "location"
          (get-header "SX-Location")
          "replace-url"
          (get-header "SX-Replace-Url")
          "trigger-swap"
          (get-header "SX-Trigger-After-Swap")
          "trigger-settle"
          (get-header "SX-Trigger-After-Settle")
          "content-type"
          (get-header "Content-Type")
          "cache-invalidate"
          (get-header "SX-Cache-Invalidate")
          "cache-update"
          (get-header "SX-Cache-Update"))))
    (define
      parse-swap-spec
      :effects ()
      (fn
        ((raw-swap :as string) (global-transitions? :as boolean))
        (let
          ((parts (split (or raw-swap DEFAULT_SWAP) " "))
            (style (first parts))
            (use-transition global-transitions?))
          (for-each
            (fn
              ((p :as string))
              (cond
                (= p "transition:true")
                (set! use-transition true)
                (= p "transition:false")
                (set! use-transition false)))
            (rest parts))
          (dict "style" style "transition" use-transition))))
    (define
      parse-retry-spec
      :effects ()
      (fn
        ((retry-attr :as string))
        (if
          (nil? retry-attr)
          nil
          (let
            ((parts (split retry-attr ":")))
            (dict
              "strategy"
              (first parts)
              "start-ms"
              (parse-int (nth parts 1) 1000)
              "cap-ms"
              (parse-int (nth parts 2) 30000))))))
    (define
      next-retry-ms
      :effects ()
      (fn
        ((current-ms :as number) (cap-ms :as number))
        (min (* current-ms 2) cap-ms)))
    (define
      filter-params
      :effects ()
      (fn
        ((params-spec :as string) (all-params :as list))
        (if
          (nil? params-spec)
          all-params
          (if
            (= params-spec "none")
            (list)
            (if
              (= params-spec "*")
              all-params
              (if
                (starts-with? params-spec "not ")
                (let
                  ((excluded (map trim (split (slice params-spec 4) ","))))
                  (filter
                    (fn
                      ((p :as list))
                      (not (contains? excluded (first p))))
                    all-params))
                (let
                  ((allowed (map trim (split params-spec ","))))
                  (filter
                    (fn ((p :as list)) (contains? allowed (first p)))
                    all-params))))))))
    (define
      resolve-target
      :effects (io)
      (fn
        (el)
        (let
          ((sel (dom-get-attr el "sx-target")))
          (match
            sel
            (nil el)
            ("this" el)
            ("closest" (dom-parent el))
            (_ (dom-query sel))))))
    (define
      apply-optimistic
      :effects (mutation io)
      (fn
        (el)
        (let
          ((directive (dom-get-attr el "sx-optimistic")))
          (if
            (nil? directive)
            nil
            (let
              ((target (or (resolve-target el) el))
                (state (dict "target" target "directive" directive)))
              (cond
                (= directive "remove")
                (do
                  (dict-set! state "opacity" (dom-get-style target "opacity"))
                  (dom-set-style target "opacity" "0")
                  (dom-set-style target "pointer-events" "none"))
                (= directive "disable")
                (do
                  (dict-set!
                    state
                    "disabled"
                    (dom-get-prop target "disabled"))
                  (dom-set-prop target "disabled" true))
                (starts-with? directive "add-class:")
                (let
                  ((cls (slice directive 10)))
                  (dict-set! state "add-class" cls)
                  (dom-add-class target cls)))
              state)))))
    (define
      revert-optimistic
      :effects (mutation io)
      (fn
        ((state :as dict))
        (when
          state
          (let
            ((target (get state "target"))
              (directive (get state "directive")))
            (cond
              (= directive "remove")
              (do
                (dom-set-style
                  target
                  "opacity"
                  (or (get state "opacity") ""))
                (dom-set-style target "pointer-events" ""))
              (= directive "disable")
              (dom-set-prop
                target
                "disabled"
                (or (get state "disabled") false))
              (get state "add-class")
              (dom-remove-class target (get state "add-class")))))))
    (define
      find-oob-swaps
      :effects (mutation io)
      (fn
        (container)
        (let
          ((results (list)))
          (for-each
            (fn
              ((attr :as string))
              (let
                ((oob-els (dom-query-all container (str "[" attr "]"))))
                (for-each
                  (fn
                    (oob)
                    (let
                      ((swap-type (or (dom-get-attr oob attr) "outerHTML"))
                        (target-id (dom-id oob)))
                      (dom-remove-attr oob attr)
                      (when
                        target-id
                        (append!
                          results
                          (dict
                            "element"
                            oob
                            "swap-type"
                            swap-type
                            "target-id"
                            target-id)))))
                  oob-els)))
            (list "sx-swap-oob" "hx-swap-oob"))
          results)))
    (define
      morph-node
      :effects (mutation io)
      (fn
        (old-node new-node)
        (cond
          (or
            (dom-has-attr? old-node "sx-preserve")
            (dom-has-attr? old-node "sx-ignore"))
          nil
          (and
            (dom-has-attr? old-node "data-sx-island")
            (is-processed? old-node "island-hydrated")
            (dom-has-attr? new-node "data-sx-island")
            (=
              (dom-get-attr old-node "data-sx-island")
              (dom-get-attr new-node "data-sx-island")))
          (let
            ((old-state (dom-get-attr old-node "data-sx-state"))
              (new-state (dom-get-attr new-node "data-sx-state")))
            (sync-attrs old-node new-node)
            (if
              (and new-state (not (= old-state new-state)))
              (do (dispose-island old-node) (hydrate-island old-node))
              (morph-island-children old-node new-node)))
          (or
            (not (= (dom-node-type old-node) (dom-node-type new-node)))
            (not (= (dom-node-name old-node) (dom-node-name new-node))))
          (dom-replace-child
            (dom-parent old-node)
            (dom-clone new-node true)
            old-node)
          (or
            (= (dom-node-type old-node) 3)
            (= (dom-node-type old-node) 8))
          (when
            (not
              (= (dom-text-content old-node) (dom-text-content new-node)))
            (dom-set-text-content old-node (dom-text-content new-node)))
          (= (dom-node-type old-node) 1)
          (do
            (when
              (and
                (dom-has-attr? old-node "data-sx-island")
                (dom-has-attr? new-node "data-sx-island")
                (not
                  (=
                    (dom-get-attr old-node "data-sx-island")
                    (dom-get-attr new-node "data-sx-island"))))
              (dispose-island old-node)
              (dispose-islands-in old-node))
            (sync-attrs old-node new-node)
            (when
              (not
                (and
                  (dom-is-active-element? old-node)
                  (dom-is-input-element? old-node)))
              (morph-children old-node new-node))))))
    (define
      sync-attrs
      :effects (mutation io)
      (fn
        (old-el new-el)
        (let
          ((ra-str (or (dom-get-attr old-el "data-sx-reactive-attrs") ""))
            (reactive-attrs (if (empty? ra-str) (list) (split ra-str ","))))
          (for-each
            (fn
              ((attr :as list))
              (let
                ((name (first attr)) (val (nth attr 1)))
                (when
                  (and
                    (not (= (dom-get-attr old-el name) val))
                    (not (contains? reactive-attrs name)))
                  (dom-set-attr old-el name val))))
            (dom-attr-list new-el))
          (for-each
            (fn
              ((attr :as list))
              (let
                ((aname (first attr)))
                (when
                  (and
                    (not (dom-has-attr? new-el aname))
                    (not (contains? reactive-attrs aname))
                    (not (= aname "data-sx-reactive-attrs")))
                  (dom-remove-attr old-el aname))))
            (dom-attr-list old-el)))))
    (define
      morph-children
      :effects (mutation io)
      (fn
        (old-parent new-parent)
        (let
          ((old-kids (dom-child-list old-parent))
            (new-kids (dom-child-list new-parent))
            (old-by-id (dict))
            (old-idx-by-id (dict))
            (consumed (dict))
            (oi 0)
            (idx 0))
          (for-each
            (fn
              (kid)
              (let
                ((id (dom-id kid)))
                (when
                  (and id (not (empty? id)))
                  (dict-set! old-by-id id kid)
                  (dict-set! old-idx-by-id id idx)))
              (set! idx (inc idx)))
            old-kids)
          (for-each
            (fn
              (new-child)
              (let
                ((raw-id (dom-id new-child))
                  (match-id
                    (if (and raw-id (not (empty? raw-id))) raw-id nil))
                  (match-by-id
                    (if match-id (dict-get old-by-id match-id) nil)))
                (cond
                  (and match-by-id (not (nil? match-by-id)))
                  (do
                    (let
                      ((matched-idx (dict-get old-idx-by-id match-id)))
                      (when
                        matched-idx
                        (dict-set! consumed (str matched-idx) true)))
                    (when
                      (and
                        (< oi (len old-kids))
                        (not (= match-by-id (nth old-kids oi))))
                      (dom-insert-before
                        old-parent
                        match-by-id
                        (if (< oi (len old-kids)) (nth old-kids oi) nil)))
                    (morph-node match-by-id new-child)
                    (set! oi (inc oi)))
                  (< oi (len old-kids))
                  (let
                    ((old-child (nth old-kids oi)))
                    (let
                      ((old-id (dom-id old-child)))
                      (if
                        (and old-id (not (empty? old-id)) (not match-id))
                        (dom-insert-before
                          old-parent
                          (dom-clone new-child true)
                          old-child)
                        (do
                          (dict-set! consumed (str oi) true)
                          (morph-node old-child new-child)
                          (set! oi (inc oi))))))
                  :else (dom-append old-parent (dom-clone new-child true)))))
            new-kids)
          (for-each
            (fn
              (i)
              (when
                (not (dict-get consumed (str i)))
                (let
                  ((leftover (nth old-kids i)))
                  (when
                    (and
                      (dom-is-child-of? leftover old-parent)
                      (not (dom-has-attr? leftover "sx-preserve"))
                      (not (dom-has-attr? leftover "sx-ignore")))
                    (dom-remove-child old-parent leftover)))))
            (range 0 (len old-kids))))))
    (define
      morph-island-children
      :effects (mutation io)
      (fn
        (old-island new-island)
        (let
          ((old-lakes (dom-query-all old-island "[data-sx-lake]"))
            (new-lakes (dom-query-all new-island "[data-sx-lake]"))
            (old-marshes (dom-query-all old-island "[data-sx-marsh]"))
            (new-marshes (dom-query-all new-island "[data-sx-marsh]")))
          (let
            ((new-lake-map (dict)) (new-marsh-map (dict)))
            (for-each
              (fn
                (lake)
                (let
                  ((id (dom-get-attr lake "data-sx-lake")))
                  (when id (dict-set! new-lake-map id lake))))
              new-lakes)
            (for-each
              (fn
                (marsh)
                (let
                  ((id (dom-get-attr marsh "data-sx-marsh")))
                  (when id (dict-set! new-marsh-map id marsh))))
              new-marshes)
            (for-each
              (fn
                (old-lake)
                (let
                  ((id (dom-get-attr old-lake "data-sx-lake")))
                  (let
                    ((new-lake (dict-get new-lake-map id)))
                    (when
                      new-lake
                      (sync-attrs old-lake new-lake)
                      (morph-children old-lake new-lake)))))
              old-lakes)
            (for-each
              (fn
                (old-marsh)
                (let
                  ((id (dom-get-attr old-marsh "data-sx-marsh")))
                  (let
                    ((new-marsh (dict-get new-marsh-map id)))
                    (when
                      new-marsh
                      (morph-marsh old-marsh new-marsh old-island)))))
              old-marshes)
            (process-signal-updates new-island)))))
    (define
      morph-marsh
      :effects (mutation io)
      (fn
        (old-marsh new-marsh island-el)
        (let
          ((transform (dom-get-data old-marsh "sx-marsh-transform"))
            (env (dom-get-data old-marsh "sx-marsh-env"))
            (new-html (dom-inner-html new-marsh)))
          (if
            (and env new-html (not (empty? new-html)))
            (let
              ((parsed (parse new-html)))
              (let
                ((sx-content (if transform (cek-call transform (list parsed)) parsed)))
                (dispose-marsh-scope old-marsh)
                (with-marsh-scope
                  old-marsh
                  (fn
                    ()
                    (let
                      ((new-dom (render-to-dom sx-content env nil)))
                      (dom-remove-children-after old-marsh nil)
                      (dom-append old-marsh new-dom))))))
            (do
              (sync-attrs old-marsh new-marsh)
              (morph-children old-marsh new-marsh))))))
    (define
      process-signal-updates
      :effects (mutation io)
      (fn
        (root)
        (let
          ((signal-els (dom-query-all root "[data-sx-signal]")))
          (for-each
            (fn
              (el)
              (let
                ((spec (dom-get-attr el "data-sx-signal")))
                (when
                  spec
                  (let
                    ((colon-idx (index-of spec ":")))
                    (when
                      (> colon-idx 0)
                      (let
                        ((store-name (slice spec 0 colon-idx))
                          (raw-value (slice spec (+ colon-idx 1))))
                        (let
                          ((parsed (json-parse raw-value)))
                          (reset! (use-store store-name) parsed))
                        (dom-remove-attr el "data-sx-signal")))))))
            signal-els))))
    (define
      swap-dom-nodes
      :effects (mutation io)
      (fn
        (target new-nodes (strategy :as string))
        (case
          strategy
          "innerHTML"
          (if
            (dom-is-fragment? new-nodes)
            (morph-children target new-nodes)
            (let
              ((wrapper (dom-create-element "div" nil)))
              (dom-append wrapper new-nodes)
              (morph-children target wrapper)))
          "outerHTML"
          (let
            ((parent (dom-parent target))
              (new-el (dom-clone new-nodes true)))
            (if
              (dom-is-fragment? new-nodes)
              (let
                ((fc (dom-first-child new-nodes)))
                (if
                  fc
                  (do
                    (set! new-el (dom-clone fc true))
                    (dom-replace-child parent new-el target)
                    (let
                      ((sib (dom-next-sibling fc)))
                      (insert-remaining-siblings parent new-el sib)))
                  (dom-remove-child parent target)))
              (dom-replace-child parent new-el target))
            new-el)
          "afterend"
          (dom-insert-after target new-nodes)
          "beforeend"
          (dom-append target new-nodes)
          "afterbegin"
          (dom-prepend target new-nodes)
          "beforebegin"
          (dom-insert-before (dom-parent target) new-nodes target)
          "delete"
          (dom-remove-child (dom-parent target) target)
          "none"
          nil
          :else (if
            (dom-is-fragment? new-nodes)
            (morph-children target new-nodes)
            (let
              ((wrapper (dom-create-element "div" nil)))
              (dom-append wrapper new-nodes)
              (morph-children target wrapper))))))
    (define
      insert-remaining-siblings
      :effects (mutation io)
      (fn
        (parent ref-node sib)
        (when
          sib
          (let
            ((next (dom-next-sibling sib)))
            (dom-insert-after ref-node sib)
            (insert-remaining-siblings parent sib next)))))
    (define
      swap-html-string
      :effects (mutation io)
      (fn
        (target (html :as string) (strategy :as string))
        (case
          strategy
          "innerHTML"
          (dom-set-inner-html target html)
          "outerHTML"
          (let
            ((parent (dom-parent target)))
            (dom-insert-adjacent-html target "afterend" html)
            (dom-remove-child parent target)
            parent)
          "afterend"
          (dom-insert-adjacent-html target "afterend" html)
          "beforeend"
          (dom-insert-adjacent-html target "beforeend" html)
          "afterbegin"
          (dom-insert-adjacent-html target "afterbegin" html)
          "beforebegin"
          (dom-insert-adjacent-html target "beforebegin" html)
          "delete"
          (dom-remove-child (dom-parent target) target)
          "none"
          nil
          :else (dom-set-inner-html target html))))
    (define
      handle-history
      :effects (io)
      (fn
        (el (url :as string) (resp-headers :as dict))
        (let
          ((push-url (dom-get-attr el "sx-push-url"))
            (replace-url (dom-get-attr el "sx-replace-url"))
            (hdr-replace (get resp-headers "replace-url")))
          (cond
            hdr-replace
            (browser-replace-state hdr-replace)
            (and push-url (not (= push-url "false")))
            (do
              (save-scroll-position)
              (browser-push-state (if (= push-url "true") url push-url)))
            (and replace-url (not (= replace-url "false")))
            (browser-replace-state
              (if (= replace-url "true") url replace-url))))))
    (define PRELOAD_TTL 30000)
    (define
      preload-cache-get
      :effects (mutation)
      (fn
        ((cache :as dict) (url :as string))
        (let
          ((entry (dict-get cache url)))
          (if
            (nil? entry)
            nil
            (if
              (> (- (now-ms) (get entry "timestamp")) PRELOAD_TTL)
              (do (dict-delete! cache url) nil)
              (do (dict-delete! cache url) entry))))))
    (define
      preload-cache-set
      :effects (mutation)
      (fn
        ((cache :as dict)
          (url :as string)
          (text :as string)
          (content-type :as string))
        (dict-set!
          cache
          url
          (dict "text" text "content-type" content-type "timestamp" (now-ms)))))
    (define
      classify-trigger
      :effects ()
      (fn
        ((trigger :as dict))
        (let
          ((event (get trigger "event")))
          (match
            event
            ("every" "poll")
            ("intersect" "intersect")
            ("load" "load")
            ("revealed" "revealed")
            (_ "event")))))
    (define
      should-boost-link?
      :effects (io)
      (fn
        (link)
        (let
          ((href (dom-get-attr link "href")))
          (and
            href
            (not (starts-with? href "#"))
            (not (starts-with? href "javascript:"))
            (not (starts-with? href "mailto:"))
            (browser-same-origin? href)
            (not (dom-has-attr? link "sx-get"))
            (not (dom-has-attr? link "sx-post"))
            (not (dom-has-attr? link "sx-disable"))))))
    (define
      should-boost-form?
      :effects (io)
      (fn
        (form)
        (and
          (not (dom-has-attr? form "sx-get"))
          (not (dom-has-attr? form "sx-post"))
          (not (dom-has-attr? form "sx-disable")))))
    (define
      parse-sse-swap
      :effects (io)
      (fn (el) (or (dom-get-attr el "sx-sse-swap") "message"))))) ;; end define-library

;; Re-export to global namespace for backward compatibility
(import (web engine))
