diff --git a/lib/hyperscript/compiler.sx b/lib/hyperscript/compiler.sx index 4d19ce05..5e76d4d7 100644 --- a/lib/hyperscript/compiler.sx +++ b/lib/hyperscript/compiler.sx @@ -1207,6 +1207,8 @@ ((= head (quote continue)) (list (quote raise) "hs-continue")) ((= head (quote exit)) nil) + ((= head (quote live-no-op)) nil) + ((= head (quote when-feat-no-op)) nil) ((= head (quote on)) (emit-on ast)) ((= head (quote init)) (list diff --git a/lib/hyperscript/parser.sx b/lib/hyperscript/parser.sx index 4f8fa5af..5d192d08 100644 --- a/lib/hyperscript/parser.sx +++ b/lib/hyperscript/parser.sx @@ -1370,11 +1370,13 @@ (fn () (if - (and (= (tp-type) "keyword") (= (tp-val) "gql")) + (and + (or (= (tp-type) "keyword") (= (tp-type) "ident")) + (= (tp-val) "gql")) (do (adv!) (let - ((gql-source (if (= (tp-type) "brace-open") (do (adv!) (define collect-gql (fn (acc depth) (cond ((at-end?) (join " " acc)) ((= (tp-type) "brace-open") (do (adv!) (collect-gql (append acc (list "{")) (+ depth 1)))) ((= (tp-type) "brace-close") (if (= depth 0) (do (adv!) (join " " acc)) (do (adv!) (collect-gql (append acc (list "}")) (- depth 1))))) (true (let ((v (tp-val))) (adv!) (collect-gql (append acc (list (if v v ""))) depth)))))) (str "{ " (collect-gql (list) 0) " }")) (if (or (and (= (tp-type) "keyword") (= (tp-val) "query")) (and (= (tp-type) "keyword") (= (tp-val) "mutation")) (and (= (tp-type) "keyword") (= (tp-val) "subscription"))) (let ((op-word (tp-val))) (adv!) (if (= (tp-type) "brace-open") (do (adv!) (define collect-gql2 (fn (acc depth) (cond ((at-end?) (join " " acc)) ((= (tp-type) "brace-open") (do (adv!) (collect-gql2 (append acc (list "{")) (+ depth 1)))) ((= (tp-type) "brace-close") (if (= depth 0) (do (adv!) (join " " acc)) (do (adv!) (collect-gql2 (append acc (list "}")) (- depth 1))))) (true (let ((v (tp-val))) (adv!) (collect-gql2 (append acc (list (if v v ""))) depth)))))) (str op-word " { " (collect-gql2 (list) 0) " }")) (str op-word ""))) "")))) + ((gql-source (if (= (tp-type) "brace-open") (do (adv!) (define collect-gql (fn (acc depth) (cond ((at-end?) (join " " acc)) ((= (tp-type) "brace-open") (do (adv!) (collect-gql (append acc (list "{")) (+ depth 1)))) ((= (tp-type) "brace-close") (if (= depth 0) (do (adv!) (join " " acc)) (do (adv!) (collect-gql (append acc (list "}")) (- depth 1))))) (true (let ((v (tp-val))) (adv!) (collect-gql (append acc (list (if v v ""))) depth)))))) (str "{ " (collect-gql (list) 0) " }")) (if (or (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "query")) (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "mutation")) (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "subscription"))) (let ((op-word (tp-val))) (adv!) (if (= (tp-type) "brace-open") (do (adv!) (define collect-gql2 (fn (acc depth) (cond ((at-end?) (join " " acc)) ((= (tp-type) "brace-open") (do (adv!) (collect-gql2 (append acc (list "{")) (+ depth 1)))) ((= (tp-type) "brace-close") (if (= depth 0) (do (adv!) (join " " acc)) (do (adv!) (collect-gql2 (append acc (list "}")) (- depth 1))))) (true (let ((v (tp-val))) (adv!) (collect-gql2 (append acc (list (if v v ""))) depth)))))) (str op-word " { " (collect-gql2 (list) 0) " }")) (str op-word ""))) "")))) (let ((url (if (and (= (tp-type) "keyword") (= (tp-val) "from")) (do (adv!) (parse-arith (parse-poss (parse-atom)))) nil))) (list (quote fetch-gql) gql-source url)))) @@ -2047,6 +2049,38 @@ ((body (parse-cmd-list))) (match-kw "end") (list (quote init) body)))) + (define + parse-live-feat + (fn + () + (define + plf-skip + (fn + () + (cond + ((at-end?) nil) + ((and (= (tp-type) "keyword") (or (= (tp-val) "end") (= (tp-val) "on") (= (tp-val) "init") (= (tp-val) "def") (= (tp-val) "behavior") (= (tp-val) "live") (= (tp-val) "when"))) + nil) + (true (do (adv!) (plf-skip)))))) + (plf-skip) + (match-kw "end") + (list (quote live-no-op)))) + (define + parse-when-feat + (fn + () + (define + pwf-skip + (fn + () + (cond + ((at-end?) nil) + ((and (= (tp-type) "keyword") (or (= (tp-val) "end") (= (tp-val) "on") (= (tp-val) "init") (= (tp-val) "def") (= (tp-val) "behavior") (= (tp-val) "live") (= (tp-val) "when"))) + nil) + (true (do (adv!) (pwf-skip)))))) + (pwf-skip) + (match-kw "end") + (list (quote when-feat-no-op)))) (define parse-feat (fn @@ -2058,6 +2092,8 @@ ((= val "init") (do (adv!) (parse-init-feat))) ((= val "def") (do (adv!) (parse-def-feat))) ((= val "behavior") (do (adv!) (parse-behavior-feat))) + ((= val "live") (do (adv!) (parse-live-feat))) + ((= val "when") (do (adv!) (parse-when-feat))) (true (parse-cmd-list)))))) (define coll-feats diff --git a/spec/tests/test-hyperscript-behavioral.sx b/spec/tests/test-hyperscript-behavioral.sx index 207550f5..bd612c41 100644 --- a/spec/tests/test-hyperscript-behavioral.sx +++ b/spec/tests/test-hyperscript-behavioral.sx @@ -18,20 +18,60 @@ ;; Evaluate a hyperscript expression and return its result. ;; Compiles the expression, wraps in a thunk, evaluates, returns result. -(define eval-hs - (fn (src) - (let ((sx (hs-to-sx (hs-compile src)))) - (let ((handler (eval-expr-cek - (list (quote fn) (list (quote me)) (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx))))) - (handler nil))))) +(define + eval-hs + (fn + (src &rest opts) + (let + ((ctx (if (> (len opts) 0) (first opts) nil)) + (sx (hs-to-sx (hs-compile src)))) + (let + ((me-val (if ctx (get ctx "me") nil)) + (locals (if ctx (get ctx "locals") nil))) + (let + ((bindings (list (list (quote it) nil) (list (quote event) nil)))) + (do + (when + locals + (for-each + (fn + (k) + (set! + bindings + (cons + (list + (make-symbol k) + (list (quote quote) (get locals k))) + bindings))) + (keys locals))) + (let + ((handler (eval-expr-cek (list (quote fn) (list (quote me)) (list (quote let) bindings sx))))) + (guard + (_e + (true + (if + (and (list? _e) (= (first _e) "hs-return")) + (nth _e 1) + (raise _e)))) + (handler me-val))))))))) ;; Evaluate with a specific me value (for "I am between" etc.) -(define eval-hs-with-me - (fn (src me-val) - (let ((sx (hs-to-sx (hs-compile src)))) - (let ((handler (eval-expr-cek - (list (quote fn) (list (quote me)) (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx))))) - (handler me-val))))) +(define + eval-hs-with-me + (fn + (src me-val) + (let + ((sx (hs-to-sx (hs-compile src)))) + (let + ((handler (eval-expr-cek (list (quote fn) (list (quote me)) (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx))))) + (guard + (_e + (true + (if + (and (list? _e) (= (first _e) "hs-return")) + (nth _e 1) + (raise _e)))) + (handler me-val)))))) ;; ── add (19 tests) ── (defsuite "hs-upstream-add"