diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index 81e88a8e..01e33e69 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -1311,6 +1311,7 @@ let run_spec_tests env test_files = let hs_dir = Filename.concat lib_dir "hyperscript" in load_module "tokenizer.sx" hs_dir; load_module "parser.sx" hs_dir; + load_module "compiler.sx" hs_dir; load_module "types.sx" lib_dir; load_module "sx-swap.sx" lib_dir; (* Shared templates: TW styling engine *) diff --git a/lib/hyperscript/compiler.sx b/lib/hyperscript/compiler.sx new file mode 100644 index 00000000..3a423a5e --- /dev/null +++ b/lib/hyperscript/compiler.sx @@ -0,0 +1,530 @@ +;; _hyperscript compiler — AST → SX expressions +;; +;; Input: AST from hs-parse (list structures) +;; Output: SX expressions targeting web/lib/dom.sx primitives +;; +;; Usage: +;; (hs-to-sx (hs-compile "on click add .active to me")) +;; → (hs-on me "click" (fn (event) (dom-add-class me "active"))) + +(define + hs-to-sx + (let + ((dot-sym (make-symbol ".")) (pct-sym (make-symbol "%"))) + (define emit-target (fn (ast) (hs-to-sx ast))) + (define + emit-set + (fn + (target value) + (if + (not (list? target)) + (list (quote set!) target value) + (let + ((th (first target))) + (cond + ((= th dot-sym) + (list + (quote dom-set-prop) + (hs-to-sx (nth target 1)) + (nth target 2) + value)) + ((= th (quote attr)) + (list + (quote dom-set-attr) + (hs-to-sx (nth target 2)) + (nth target 1) + value)) + ((= th (quote style)) + (list + (quote dom-set-style) + (hs-to-sx (nth target 2)) + (nth target 1) + value)) + ((= th (quote ref)) + (list (quote set!) (make-symbol (nth target 1)) value)) + ((= th (quote local)) + (list (quote set!) (make-symbol (nth target 1)) value)) + ((= th (quote me)) + (list (quote dom-set-inner-html) (quote me) value)) + ((= th (quote it)) (list (quote set!) (quote it) value)) + (true (list (quote set!) (hs-to-sx target) value))))))) + (define + emit-on + (fn + (ast) + (let + ((parts (rest ast))) + (let + ((event-name (first parts))) + (define + scan-on + (fn + (items source filter every?) + (cond + ((<= (len items) 1) + (let + ((body (if (> (len items) 0) (first items) nil))) + (let + ((target (if source (hs-to-sx source) (quote me)))) + (let + ((handler (list (quote fn) (list (quote event)) (hs-to-sx body)))) + (if + every? + (list + (quote hs-on-every) + target + event-name + handler) + (list (quote hs-on) target event-name handler)))))) + ((= (first items) :from) + (scan-on + (rest (rest items)) + (nth items 1) + filter + every?)) + ((= (first items) :filter) + (scan-on + (rest (rest items)) + source + (nth items 1) + every?)) + ((= (first items) :every) + (scan-on (rest (rest items)) source filter true)) + (true (scan-on (rest items) source filter every?))))) + (scan-on (rest parts) nil nil false))))) + (define + emit-send + (fn + (ast) + (let + ((name (nth ast 1)) (rest-parts (rest (rest ast)))) + (cond + ((and (= (len ast) 4) (list? (nth ast 2)) (= (first (nth ast 2)) (quote dict))) + (list + (quote dom-dispatch) + (hs-to-sx (nth ast 3)) + name + (hs-to-sx (nth ast 2)))) + ((= (len ast) 3) + (list (quote dom-dispatch) (hs-to-sx (nth ast 2)) name nil)) + (true (list (quote dom-dispatch) (quote me) name nil)))))) + (define + emit-repeat + (fn + (ast) + (let + ((mode (nth ast 1)) (body (hs-to-sx (nth ast 2)))) + (cond + ((and (list? mode) (= (first mode) (quote forever))) + (list + (quote hs-repeat-forever) + (list (quote fn) (list) body))) + ((and (list? mode) (= (first mode) (quote times))) + (list + (quote hs-repeat-times) + (hs-to-sx (nth mode 1)) + (list (quote fn) (list) body))) + ((number? mode) + (list + (quote hs-repeat-times) + mode + (list (quote fn) (list) body))) + (true + (list + (quote hs-repeat-times) + (hs-to-sx mode) + (list (quote fn) (list) body))))))) + (define + emit-for + (fn + (ast) + (let + ((var-name (nth ast 1)) + (collection (hs-to-sx (nth ast 2))) + (body (hs-to-sx (nth ast 3)))) + (if + (and (> (len ast) 4) (= (nth ast 4) :index)) + (list + (quote for-each) + (list + (quote fn) + (list (make-symbol var-name) (make-symbol (nth ast 5))) + body) + collection) + (list + (quote for-each) + (list (quote fn) (list (make-symbol var-name)) body) + collection))))) + (define + emit-wait-for + (fn + (ast) + (let + ((event-name (nth ast 1))) + (if + (and (> (len ast) 2) (= (nth ast 2) :from)) + (list (quote hs-wait-for) (hs-to-sx (nth ast 3)) event-name) + (list (quote hs-wait-for) (quote me) event-name))))) + (define + emit-transition + (fn + (ast) + (let + ((prop (nth ast 1)) (value (hs-to-sx (nth ast 2)))) + (if + (= (len ast) 5) + (list + (quote hs-transition) + (hs-to-sx (nth ast 4)) + prop + value + (nth ast 3)) + (list + (quote hs-transition) + (hs-to-sx (nth ast 3)) + prop + value + nil))))) + (define + emit-make + (fn + (ast) + (if + (= (len ast) 3) + (list + (quote let) + (list + (list + (make-symbol (nth ast 2)) + (list (quote hs-make) (nth ast 1)))) + (make-symbol (nth ast 2))) + (list (quote hs-make) (nth ast 1))))) + (define + emit-inc + (fn + (target) + (let + ((t (hs-to-sx target))) + (if + (and (list? target) (= (first target) (quote attr))) + (list + (quote dom-set-attr) + (hs-to-sx (nth target 2)) + (nth target 1) + (list + (quote +) + (list + (quote dom-get-attr) + (hs-to-sx (nth target 2)) + (nth target 1)) + 1)) + (list (quote set!) t (list (quote +) t 1)))))) + (define + emit-dec + (fn + (target) + (let + ((t (hs-to-sx target))) + (if + (and (list? target) (= (first target) (quote attr))) + (list + (quote dom-set-attr) + (hs-to-sx (nth target 2)) + (nth target 1) + (list + (quote -) + (list + (quote dom-get-attr) + (hs-to-sx (nth target 2)) + (nth target 1)) + 1)) + (list (quote set!) t (list (quote -) t 1)))))) + (define + emit-behavior + (fn + (ast) + (let + ((name (nth ast 1)) (params (nth ast 2)) (body (nth ast 3))) + (list + (quote define) + (make-symbol name) + (list + (quote fn) + (cons (quote me) (map make-symbol params)) + (cons (quote do) (map hs-to-sx body))))))) + (fn + (ast) + (cond + ((nil? ast) nil) + ((number? ast) ast) + ((string? ast) ast) + ((boolean? ast) ast) + ((not (list? ast)) ast) + (true + (let + ((head (first ast))) + (cond + ((= head (quote me)) (quote me)) + ((= head (quote it)) (quote it)) + ((= head (quote event)) (quote event)) + ((= head dot-sym) + (list (quote get) (hs-to-sx (nth ast 1)) (nth ast 2))) + ((= head (quote ref)) (make-symbol (nth ast 1))) + ((= head (quote query)) + (list (quote dom-query) (nth ast 1))) + ((= head (quote attr)) + (list + (quote dom-get-attr) + (hs-to-sx (nth ast 2)) + (nth ast 1))) + ((= head (quote style)) + (list + (quote dom-get-style) + (hs-to-sx (nth ast 2)) + (nth ast 1))) + ((= head (quote local)) (make-symbol (nth ast 1))) + ((= head (quote array)) + (cons (quote list) (map hs-to-sx (rest ast)))) + ((= head (quote not)) + (list (quote not) (hs-to-sx (nth ast 1)))) + ((= head (quote no)) + (list (quote not) (hs-to-sx (nth ast 1)))) + ((= head (quote and)) + (list + (quote and) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote or)) + (list + (quote or) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote =)) + (list + (quote =) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote +)) + (list + (quote +) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote -)) + (list + (quote -) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote *)) + (list + (quote *) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote /)) + (list + (quote /) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head pct-sym) + (list + pct-sym + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote empty?)) + (list (quote empty?) (hs-to-sx (nth ast 1)))) + ((= head (quote exists?)) + (list + (quote not) + (list (quote nil?) (hs-to-sx (nth ast 1))))) + ((= head (quote matches?)) + (list + (quote dom-matches?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote contains?)) + (list + (quote contains?) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote as)) + (list (quote hs-coerce) (hs-to-sx (nth ast 1)) (nth ast 2))) + ((= head (quote in?)) + (list + (quote contains?) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 1)))) + ((= head (quote of)) + (list + (quote get) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 1)))) + ((= head "!=") + (list + (quote not) + (list + (quote =) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2))))) + ((= head "<") + (list + (quote <) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head ">") + (list + (quote >) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head "<=") + (list + (quote <=) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head ">=") + (list + (quote >=) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote closest)) + (list + (quote dom-closest) + (hs-to-sx (nth ast 2)) + (nth ast 1))) + ((= head (quote next)) + (list (quote hs-next) (hs-to-sx (nth ast 2)) (nth ast 1))) + ((= head (quote previous)) + (list + (quote hs-previous) + (hs-to-sx (nth ast 2)) + (nth ast 1))) + ((= head (quote first)) + (if + (> (len ast) 2) + (list + (quote hs-first) + (hs-to-sx (nth ast 2)) + (nth ast 1)) + (list (quote hs-query-first) (nth ast 1)))) + ((= head (quote last)) + (if + (> (len ast) 2) + (list (quote hs-last) (hs-to-sx (nth ast 2)) (nth ast 1)) + (list (quote hs-query-last) (nth ast 1)))) + ((= head (quote add-class)) + (list + (quote dom-add-class) + (hs-to-sx (nth ast 2)) + (nth ast 1))) + ((= head (quote remove-class)) + (list + (quote dom-remove-class) + (hs-to-sx (nth ast 2)) + (nth ast 1))) + ((= head (quote toggle-class)) + (list + (quote hs-toggle-class!) + (hs-to-sx (nth ast 2)) + (nth ast 1))) + ((= head (quote toggle-between)) + (list + (quote hs-toggle-between!) + (hs-to-sx (nth ast 3)) + (nth ast 1) + (nth ast 2))) + ((= head (quote set!)) + (emit-set (nth ast 1) (hs-to-sx (nth ast 2)))) + ((= head (quote put!)) + (list + (quote hs-put!) + (hs-to-sx (nth ast 1)) + (nth ast 2) + (hs-to-sx (nth ast 3)))) + ((= head (quote if)) + (if + (> (len ast) 3) + (list + (quote if) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 3))) + (list + (quote when) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2))))) + ((= head (quote do)) + (cons (quote do) (map hs-to-sx (rest ast)))) + ((= head (quote wait)) (list (quote hs-wait) (nth ast 1))) + ((= head (quote wait-for)) (emit-wait-for ast)) + ((= head (quote log)) + (list (quote log) (hs-to-sx (nth ast 1)))) + ((= head (quote send)) (emit-send ast)) + ((= head (quote trigger)) + (list + (quote dom-dispatch) + (hs-to-sx (nth ast 2)) + (nth ast 1) + nil)) + ((= head (quote hide)) + (list + (quote dom-set-style) + (hs-to-sx (nth ast 1)) + "display" + "none")) + ((= head (quote show)) + (list + (quote dom-set-style) + (hs-to-sx (nth ast 1)) + "display" + "")) + ((= head (quote transition)) (emit-transition ast)) + ((= head (quote repeat)) (emit-repeat ast)) + ((= head (quote fetch)) + (list (quote hs-fetch) (hs-to-sx (nth ast 1)) (nth ast 2))) + ((= head (quote call)) + (cons + (make-symbol (nth ast 1)) + (map hs-to-sx (rest (rest ast))))) + ((= head (quote return)) (hs-to-sx (nth ast 1))) + ((= head (quote throw)) + (list (quote raise) (hs-to-sx (nth ast 1)))) + ((= head (quote settle)) + (list (quote hs-settle) (quote me))) + ((= head (quote go)) + (list (quote hs-navigate!) (hs-to-sx (nth ast 1)))) + ((= head (quote append!)) + (list + (quote dom-append) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 1)))) + ((= head (quote tell)) + (list + (quote let) + (list (list (quote me) (hs-to-sx (nth ast 1)))) + (hs-to-sx (nth ast 2)))) + ((= head (quote for)) (emit-for ast)) + ((= head (quote take)) + (list (quote hs-take!) (hs-to-sx (nth ast 2)) (nth ast 1))) + ((= head (quote make)) (emit-make ast)) + ((= head (quote install)) + (cons (quote hs-install) (map hs-to-sx (rest ast)))) + ((= head (quote measure)) + (list (quote hs-measure) (hs-to-sx (nth ast 1)))) + ((= head (quote increment!)) (emit-inc (nth ast 1))) + ((= head (quote decrement!)) (emit-dec (nth ast 1))) + ((= head (quote on)) (emit-on ast)) + ((= head (quote init)) + (list + (quote hs-init) + (list (quote fn) (list) (hs-to-sx (nth ast 1))))) + ((= head (quote def)) + (list + (quote define) + (make-symbol (nth ast 1)) + (list + (quote fn) + (map make-symbol (nth ast 2)) + (hs-to-sx (nth ast 3))))) + ((= head (quote behavior)) (emit-behavior ast)) + (true ast)))))))) + +;; ── Convenience: source → SX ───────────────────────────────── +(define hs-to-sx-from-source (fn (src) (hs-to-sx (hs-compile src)))) \ No newline at end of file diff --git a/spec/tests/test-hyperscript-compiler.sx b/spec/tests/test-hyperscript-compiler.sx new file mode 100644 index 00000000..dd68e34c --- /dev/null +++ b/spec/tests/test-hyperscript-compiler.sx @@ -0,0 +1,242 @@ +;; _hyperscript compiler tests +;; Tests that hs-to-sx (AST → SX) produces correct output +;; Uses hs-to-sx-from-source for end-to-end source→SX tests + +;; ── Class commands ──────────────────────────────────────────── +(defsuite + "hs-emit-classes" + (deftest + "add class to me" + (let + ((sx (hs-to-sx-from-source "add .active to me"))) + (assert= (quote dom-add-class) (first sx)) + (assert= (quote me) (nth sx 1)) + (assert= "active" (nth sx 2)))) + (deftest + "remove class from target" + (let + ((sx (hs-to-sx-from-source "remove .old from #box"))) + (assert= (quote dom-remove-class) (first sx)) + (assert= (quote dom-query) (first (nth sx 1))) + (assert= "old" (nth sx 2)))) + (deftest + "toggle class" + (let + ((sx (hs-to-sx-from-source "toggle .visible on me"))) + (assert= (quote hs-toggle-class!) (first sx)) + (assert= (quote me) (nth sx 1))))) + +;; ── Set command ─────────────────────────────────────────────── +(defsuite + "hs-emit-set" + (deftest + "set variable to value" + (let + ((sx (hs-to-sx-from-source "set x to 42"))) + (assert= (quote set!) (first sx)) + (assert= (quote x) (nth sx 1)) + (assert= 42 (nth sx 2)))) + (deftest + "set attribute" + (let + ((sx (hs-to-sx-from-source "set @title to 'hello'"))) + (assert= (quote dom-set-attr) (first sx)) + (assert= "title" (nth sx 2)) + (assert= "hello" (nth sx 3)))) + (deftest + "set style" + (let + ((sx (hs-to-sx-from-source "set *color to 'red'"))) + (assert= (quote dom-set-style) (first sx)) + (assert= "color" (nth sx 2)) + (assert= "red" (nth sx 3))))) + +;; ── Arithmetic ──────────────────────────────────────────────── +(defsuite + "hs-emit-arithmetic" + (deftest + "addition passes through" + (let + ((sx (hs-to-sx-from-source "set x to 1 + 2"))) + (let + ((val (nth sx 2))) + (assert= (quote +) (first val)) + (assert= 1 (nth val 1)) + (assert= 2 (nth val 2))))) + (deftest + "comparison emits correctly" + (let + ((sx (hs-to-sx-from-source "if x == 5 log x end"))) + (let ((cnd (nth sx 1))) (assert= (quote =) (first cnd)))))) + +;; ── Control flow ────────────────────────────────────────────── +(defsuite + "hs-emit-control-flow" + (deftest + "if-then becomes when" + (let + ((sx (hs-to-sx-from-source "if true log 1 end"))) + (assert= (quote when) (first sx)))) + (deftest + "if-else becomes if" + (let + ((sx (hs-to-sx-from-source "if true log 1 else log 2 end"))) + (assert= (quote if) (first sx)))) + (deftest + "for becomes for-each" + (let + ((sx (hs-to-sx-from-source "for item in items log item end"))) + (assert= (quote for-each) (first sx)) + (assert= (quote fn) (first (nth sx 1))))) + (deftest + "tell rebinds me" + (let + ((sx (hs-to-sx-from-source "tell
add .active end"))) + (assert= (quote let) (first sx)) + (assert= (quote me) (first (first (nth sx 1))))))) + +;; ── DOM commands ────────────────────────────────────────────── +(defsuite + "hs-emit-dom-commands" + (deftest + "hide sets display none" + (let + ((sx (hs-to-sx-from-source "hide"))) + (assert= (quote dom-set-style) (first sx)) + (assert= (quote me) (nth sx 1)) + (assert= "display" (nth sx 2)) + (assert= "none" (nth sx 3)))) + (deftest + "show clears display" + (let + ((sx (hs-to-sx-from-source "show"))) + (assert= (quote dom-set-style) (first sx)) + (assert= (quote me) (nth sx 1)) + (assert= "" (nth sx 3)))) + (deftest + "log passes through" + (let + ((sx (hs-to-sx-from-source "log 'hello'"))) + (assert= (quote log) (first sx)) + (assert= "hello" (nth sx 1)))) + (deftest + "append becomes dom-append" + (let + ((sx (hs-to-sx-from-source "append 'text' to me"))) + (assert= (quote dom-append) (first sx))))) + +;; ── Expressions ─────────────────────────────────────────────── +(defsuite + "hs-emit-expressions" + (deftest + "me emits as symbol" + (let ((sx (hs-to-sx (list (quote me))))) (assert= (quote me) sx))) + (deftest + "ref emits as symbol" + (let + ((sx (hs-to-sx (list (quote ref) "myVar")))) + (assert= (quote myVar) sx))) + (deftest + "query emits dom-query" + (let + ((sx (hs-to-sx (list (quote query) ".foo")))) + (assert= (quote dom-query) (first sx)) + (assert= ".foo" (nth sx 1)))) + (deftest + "attr emits dom-get-attr" + (let + ((sx (hs-to-sx (list (quote attr) "href" (list (quote me)))))) + (assert= (quote dom-get-attr) (first sx)) + (assert= "href" (nth sx 2)))) + (deftest + "exists becomes not nil?" + (let + ((sx (hs-to-sx (list (quote exists?) (list (quote ref) "x"))))) + (assert= (quote not) (first sx)) + (assert= (quote nil?) (first (nth sx 1))))) + (deftest + "array becomes list" + (let + ((sx (hs-to-sx (list (quote array) 1 2 3)))) + (assert= (quote list) (first sx)) + (assert= 1 (nth sx 1)) + (assert= 3 (nth sx 3))))) + +;; ── On feature ──────────────────────────────────────────────── +(defsuite + "hs-emit-on" + (deftest + "on click add class" + (let + ((sx (hs-to-sx-from-source "on click add .active end"))) + (assert= (quote hs-on) (first sx)) + (assert= (quote me) (nth sx 1)) + (assert= "click" (nth sx 2)) + (assert= (quote fn) (first (nth sx 3))))) + (deftest + "on click from target" + (let + ((sx (hs-to-sx-from-source "on click from #btn add .clicked end"))) + (assert= (quote hs-on) (first sx)) + (assert= (quote dom-query) (first (nth sx 1))))) + (deftest + "on every click" + (let + ((sx (hs-to-sx-from-source "on every click add .pulse end"))) + (assert= (quote hs-on-every) (first sx))))) + +;; ── Def and behavior ───────────────────────────────────────── +(defsuite + "hs-emit-def-behavior" + (deftest + "def becomes define" + (let + ((sx (hs-to-sx-from-source "def greet(name) log name end"))) + (assert= (quote define) (first sx)) + (assert= (quote greet) (nth sx 1)) + (assert= (quote fn) (first (nth sx 2))))) + (deftest + "init wraps in hs-init" + (let + ((sx (hs-to-sx-from-source "init log 'ready' end"))) + (assert= (quote hs-init) (first sx)) + (assert= (quote fn) (first (nth sx 1)))))) + +;; ── Return and throw ───────────────────────────────────────── +(defsuite + "hs-emit-return-throw" + (deftest + "return unwraps to value" + (let ((sx (hs-to-sx-from-source "return 42"))) (assert= 42 sx))) + (deftest + "throw becomes raise" + (let + ((sx (hs-to-sx-from-source "throw 'oops'"))) + (assert= (quote raise) (first sx)) + (assert= "oops" (nth sx 1)))) + (deftest + "wait emits hs-wait" + (let + ((sx (hs-to-sx-from-source "wait 100ms"))) + (assert= (quote hs-wait) (first sx)) + (assert= 100 (nth sx 1)))) + (deftest + "wait for emits hs-wait-for" + (let + ((sx (hs-to-sx-from-source "wait for transitionend"))) + (assert= (quote hs-wait-for) (first sx)) + (assert= "transitionend" (nth sx 2))))) + +;; ── Increment / decrement ──────────────────────────────────── +(defsuite + "hs-emit-inc-dec" + (deftest + "increment attribute" + (let + ((sx (hs-to-sx-from-source "increment @count"))) + (assert= (quote dom-set-attr) (first sx)))) + (deftest + "decrement attribute" + (let + ((sx (hs-to-sx-from-source "decrement @count"))) + (assert= (quote dom-set-attr) (first sx))))) \ No newline at end of file