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

HS parser/compiler/mock: fix put positions, add CSS properties

Browse Source 
Parser:
- Skip optional "the" in "at the start/end of" put targets
- Handle "style" token type in parse-add-cmd for *prop:value syntax

Compiler:
- Add set-style dispatch → dom-set-style for CSS property additions

Mock DOM:
- Position-aware insertAdjacentHTML: afterbegin prepends, beforeend appends
- Sync textContent after insertAdjacentHTML mutations

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-18 20:55:58 +00:00
parent be84246961
commit 5a0740d3ce
3 changed files with 87 additions and 53 deletions
Download Patch File Download Diff File Expand all files Collapse all files

20
hosts/ocaml/bin/run_tests.ml
View File

@@ -1985,12 +1985,26 @@ let run_spec_tests env test_files =
Hashtbl.replace r "right" (Number 100.0); Hashtbl.replace r "bottom" (Number 100.0);
Dict r
| "insertAdjacentHTML" ->
(* Simplified: coerce value to string and append to innerHTML *)
(* Position-aware insertion, coerce value to string *)
(match rest with
| [String _pos; value] ->
| [String pos; value] ->
let html = match dom_stringify value with String s -> s | _ -> "" in
let cur = match Hashtbl.find_opt d "innerHTML" with Some (String s) -> s | _ -> "" in
Hashtbl.replace d "innerHTML" (String (cur ^ html)); Nil
let new_html = match pos with
| "afterbegin" -> html ^ cur (* prepend *)
| _ -> cur ^ html (* beforeend / default: append *)
in
Hashtbl.replace d "innerHTML" (String new_html);
(* Sync textContent *)
let buf = Buffer.create (String.length new_html) in
let in_tag = ref false in
String.iter (fun c ->
if c = '<' then in_tag := true
else if c = '>' then in_tag := false
else if not !in_tag then Buffer.add_char buf c
) new_html;
Hashtbl.replace d "textContent" (String (Buffer.contents buf));
Nil
| _ -> Nil)
| "showModal" | "show" ->
Hashtbl.replace d "open" (Bool true);

6
lib/hyperscript/compiler.sx
View File

@@ -856,6 +856,12 @@
(quote dom-add-class)
(hs-to-sx raw-tgt)
(nth ast 1)))))
((= head (quote set-style))
(list
(quote dom-set-style)
(hs-to-sx (nth ast 3))
(nth ast 1)
(nth ast 2)))
((= head (quote multi-add-class))
(let
((target (hs-to-sx (nth ast 1)))

114
lib/hyperscript/parser.sx
View File

@@ -775,50 +775,62 @@
parse-add-cmd
(fn
()
(if
(= (tp-type) "class")
(let
((cls (get (adv!) "value")) (extra-classes (list)))
(define
collect-classes!
(fn
()
(when
(= (tp-type) "class")
(set!
extra-classes
(append extra-classes (list (get (adv!) "value"))))
(collect-classes!))))
(collect-classes!)
(cond
((= (tp-type) "class")
(let
((tgt (parse-tgt-kw "to" (list (quote me)))))
((cls (get (adv!) "value")) (extra-classes (list)))
(define
collect-classes!
(fn
()
(when
(= (tp-type) "class")
(set!
extra-classes
(append extra-classes (list (get (adv!) "value"))))
(collect-classes!))))
(collect-classes!)
(let
((when-clause (if (match-kw "when") (parse-expr) nil)))
(if
(empty? extra-classes)
((tgt (if (match-kw "to") (parse-expr) (list (quote me)))))
(let
((when-clause (if (match-kw "when") (parse-expr) nil)))
(if
when-clause
(list (quote add-class-when) cls tgt when-clause)
(list (quote add-class) cls tgt))
(if
when-clause
(list
(quote multi-add-class-when)
tgt
(empty? extra-classes)
(if
when-clause
cls
extra-classes)
(cons
(quote multi-add-class)
(cons tgt (cons cls extra-classes))))))))
(let
((value (parse-expr)))
(if
(match-kw "to")
(list (quote add-class-when) cls tgt when-clause)
(list (quote add-class) cls tgt))
(if
when-clause
(list
(quote multi-add-class-when)
tgt
when-clause
cls
extra-classes)
(cons
(quote multi-add-class)
(cons tgt (cons cls extra-classes)))))))))
((= (tp-type) "style")
(let
((prop (get (adv!) "value"))
(value
(if
(= (tp-type) "local")
(get (adv!) "value")
(parse-expr))))
(let
((tgt (parse-expr)))
(list (quote add-value) value tgt))
nil)))))
((tgt (if (match-kw "to") (parse-expr) (list (quote me)))))
(list (quote set-style) prop value tgt))))
(true
(let
((value (parse-expr)))
(if
(match-kw "to")
(let
((tgt (parse-expr)))
(list (quote add-value) value tgt))
nil))))))
(define
parse-remove-cmd
(fn
@@ -1050,17 +1062,19 @@
((match-kw "after")
(list (quote put!) value "after" (parse-expr)))
((match-kw "at")
(cond
((match-kw "start")
(do
(expect-kw! "of")
(list (quote put!) value "start" (parse-expr))))
((match-kw "end")
(do
(expect-kw! "of")
(list (quote put!) value "end" (parse-expr))))
(true
(error (str "Expected start/end after at, position " p)))))
(do
(match-kw "the")
(cond
((match-kw "start")
(do
(expect-kw! "of")
(list (quote put!) value "start" (parse-expr))))
((match-kw "end")
(do
(expect-kw! "of")
(list (quote put!) value "end" (parse-expr))))
(true
(error (str "Expected start/end after at, position " p))))))
(true
(error (str "Expected into/before/after/at at position " p)))))))
(define