Compare commits
11 Commits
loops/hask
...
loops/js
| Author | SHA1 | Date | |
|---|---|---|---|
| ea63b6d9bb | |||
| 5d7f931cf1 | |||
| 79f3e1ada2 | |||
| 4d00250233 | |||
| 80c21cbabb | |||
| 70f91ef3d8 | |||
| 5f38e49ba4 | |||
| 0f9d361a92 | |||
| 11315d91cc | |||
| f16e1b69c0 | |||
| ae86579ae8 |
@@ -1,249 +0,0 @@
|
||||
;; Desugar the Haskell surface AST into a smaller core AST.
|
||||
;;
|
||||
;; Eliminates the three surface-only shapes produced by the parser:
|
||||
;; :where BODY DECLS → :let DECLS BODY
|
||||
;; :guarded GUARDS → :if C1 E1 (:if C2 E2 … (:app error …))
|
||||
;; :list-comp EXPR QUALS → concatMap-based expression (§3.11)
|
||||
;;
|
||||
;; Everything else (:app, :op, :lambda, :let, :case, :do, :tuple,
|
||||
;; :list, :range, :if, :neg, :sect-left / :sect-right, plus all
|
||||
;; leaf forms and pattern / type nodes) is passed through after
|
||||
;; recursing into children.
|
||||
|
||||
(define
|
||||
hk-guards-to-if
|
||||
(fn
|
||||
(guards)
|
||||
(cond
|
||||
((empty? guards)
|
||||
(list
|
||||
:app
|
||||
(list :var "error")
|
||||
(list :string "Non-exhaustive guards")))
|
||||
(:else
|
||||
(let
|
||||
((g (first guards)))
|
||||
(list
|
||||
:if
|
||||
(hk-desugar (nth g 1))
|
||||
(hk-desugar (nth g 2))
|
||||
(hk-guards-to-if (rest guards))))))))
|
||||
|
||||
;; do-notation desugaring (Haskell 98 §3.14):
|
||||
;; do { e } = e
|
||||
;; do { e ; ss } = e >> do { ss }
|
||||
;; do { p <- e ; ss } = e >>= \p -> do { ss }
|
||||
;; do { let decls ; ss } = let decls in do { ss }
|
||||
(define
|
||||
hk-desugar-do
|
||||
(fn
|
||||
(stmts)
|
||||
(cond
|
||||
((empty? stmts) (raise "empty do block"))
|
||||
((empty? (rest stmts))
|
||||
(let ((s (first stmts)))
|
||||
(cond
|
||||
((= (first s) "do-expr") (hk-desugar (nth s 1)))
|
||||
(:else
|
||||
(raise "do block must end with an expression")))))
|
||||
(:else
|
||||
(let
|
||||
((s (first stmts)) (rest-stmts (rest stmts)))
|
||||
(let
|
||||
((rest-do (hk-desugar-do rest-stmts)))
|
||||
(cond
|
||||
((= (first s) "do-expr")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var ">>")
|
||||
(hk-desugar (nth s 1)))
|
||||
rest-do))
|
||||
((= (first s) "do-bind")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var ">>=")
|
||||
(hk-desugar (nth s 2)))
|
||||
(list :lambda (list (nth s 1)) rest-do)))
|
||||
((= (first s) "do-let")
|
||||
(list
|
||||
:let
|
||||
(map hk-desugar (nth s 1))
|
||||
rest-do))
|
||||
(:else (raise "unknown do-stmt tag")))))))))
|
||||
|
||||
;; List-comprehension desugaring (Haskell 98 §3.11):
|
||||
;; [e | ] = [e]
|
||||
;; [e | b, Q ] = if b then [e | Q] else []
|
||||
;; [e | p <- l, Q ] = concatMap (\p -> [e | Q]) l
|
||||
;; [e | let ds, Q ] = let ds in [e | Q]
|
||||
(define
|
||||
hk-lc-desugar
|
||||
(fn
|
||||
(e quals)
|
||||
(cond
|
||||
((empty? quals) (list :list (list e)))
|
||||
(:else
|
||||
(let
|
||||
((q (first quals)))
|
||||
(let
|
||||
((qtag (first q)))
|
||||
(cond
|
||||
((= qtag "q-guard")
|
||||
(list
|
||||
:if
|
||||
(hk-desugar (nth q 1))
|
||||
(hk-lc-desugar e (rest quals))
|
||||
(list :list (list))))
|
||||
((= qtag "q-gen")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "concatMap")
|
||||
(list
|
||||
:lambda
|
||||
(list (nth q 1))
|
||||
(hk-lc-desugar e (rest quals))))
|
||||
(hk-desugar (nth q 2))))
|
||||
((= qtag "q-let")
|
||||
(list
|
||||
:let
|
||||
(map hk-desugar (nth q 1))
|
||||
(hk-lc-desugar e (rest quals))))
|
||||
(:else
|
||||
(raise
|
||||
(str
|
||||
"hk-lc-desugar: unknown qualifier tag "
|
||||
qtag))))))))))
|
||||
|
||||
(define
|
||||
hk-desugar
|
||||
(fn
|
||||
(node)
|
||||
(cond
|
||||
((not (list? node)) node)
|
||||
((empty? node) node)
|
||||
(:else
|
||||
(let
|
||||
((tag (first node)))
|
||||
(cond
|
||||
;; Transformations
|
||||
((= tag "where")
|
||||
(list
|
||||
:let
|
||||
(map hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 1))))
|
||||
((= tag "guarded") (hk-guards-to-if (nth node 1)))
|
||||
((= tag "list-comp")
|
||||
(hk-lc-desugar
|
||||
(hk-desugar (nth node 1))
|
||||
(nth node 2)))
|
||||
|
||||
;; Expression nodes
|
||||
((= tag "app")
|
||||
(list
|
||||
:app
|
||||
(hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "op")
|
||||
(list
|
||||
:op
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "neg") (list :neg (hk-desugar (nth node 1))))
|
||||
((= tag "if")
|
||||
(list
|
||||
:if
|
||||
(hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "tuple")
|
||||
(list :tuple (map hk-desugar (nth node 1))))
|
||||
((= tag "list")
|
||||
(list :list (map hk-desugar (nth node 1))))
|
||||
((= tag "range")
|
||||
(list
|
||||
:range
|
||||
(hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "range-step")
|
||||
(list
|
||||
:range-step
|
||||
(hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "lambda")
|
||||
(list
|
||||
:lambda
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "let")
|
||||
(list
|
||||
:let
|
||||
(map hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "case")
|
||||
(list
|
||||
:case
|
||||
(hk-desugar (nth node 1))
|
||||
(map hk-desugar (nth node 2))))
|
||||
((= tag "alt")
|
||||
(list :alt (nth node 1) (hk-desugar (nth node 2))))
|
||||
((= tag "do") (hk-desugar-do (nth node 1)))
|
||||
((= tag "sect-left")
|
||||
(list
|
||||
:sect-left
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "sect-right")
|
||||
(list
|
||||
:sect-right
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))))
|
||||
|
||||
;; Top-level
|
||||
((= tag "program")
|
||||
(list :program (map hk-desugar (nth node 1))))
|
||||
((= tag "module")
|
||||
(list
|
||||
:module
|
||||
(nth node 1)
|
||||
(nth node 2)
|
||||
(nth node 3)
|
||||
(map hk-desugar (nth node 4))))
|
||||
|
||||
;; Decls carrying a body
|
||||
((= tag "fun-clause")
|
||||
(list
|
||||
:fun-clause
|
||||
(nth node 1)
|
||||
(nth node 2)
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "pat-bind")
|
||||
(list
|
||||
:pat-bind
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "bind")
|
||||
(list
|
||||
:bind
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))))
|
||||
|
||||
;; Everything else: leaf literals, vars, cons, patterns,
|
||||
;; types, imports, type-sigs, data / newtype / fixity, …
|
||||
(:else node)))))))
|
||||
|
||||
;; Convenience — tokenize + layout + parse + desugar.
|
||||
(define
|
||||
hk-core
|
||||
(fn (src) (hk-desugar (hk-parse-top src))))
|
||||
|
||||
(define
|
||||
hk-core-expr
|
||||
(fn (src) (hk-desugar (hk-parse src))))
|
||||
@@ -1,785 +0,0 @@
|
||||
;; Haskell strict evaluator (Phase 2).
|
||||
;;
|
||||
;; Consumes the post-desugar core AST and produces SX values. Strict
|
||||
;; throughout — laziness and thunks are Phase 3.
|
||||
;;
|
||||
;; Value representation:
|
||||
;; numbers / strings / chars → raw SX values
|
||||
;; constructor values → tagged lists (con-name first)
|
||||
;; functions: closure / multifun → {:type "fn" :kind … …}
|
||||
;; constructor partials → {:type "con-partial" …}
|
||||
;; built-ins → {:type "builtin" …}
|
||||
;;
|
||||
;; Multi-clause top-level definitions are bundled into a single
|
||||
;; multifun keyed by name; arguments are gathered through currying
|
||||
;; until arity is reached, then each clause's pattern list is matched
|
||||
;; in order. Recursive let bindings work because the binding env is
|
||||
;; built mutably so closures captured during evaluation see the
|
||||
;; eventual full env.
|
||||
|
||||
(define
|
||||
hk-dict-copy
|
||||
(fn
|
||||
(d)
|
||||
(let ((nd (dict)))
|
||||
(for-each
|
||||
(fn (k) (dict-set! nd k (get d k)))
|
||||
(keys d))
|
||||
nd)))
|
||||
|
||||
;; ── Thunks (Phase 3 — laziness) ─────────────────────────────
|
||||
;; A thunk wraps an unevaluated AST plus the env in which it was
|
||||
;; created. The first call to `hk-force` evaluates the body, replaces
|
||||
;; the body with the cached value, and flips `forced`. Subsequent
|
||||
;; forces return the cached value directly.
|
||||
(define
|
||||
hk-mk-thunk
|
||||
(fn
|
||||
(body env)
|
||||
{:type "thunk" :body body :env env :forced false :value nil}))
|
||||
|
||||
(define
|
||||
hk-is-thunk?
|
||||
(fn (v) (and (dict? v) (= (get v "type") "thunk"))))
|
||||
|
||||
(define
|
||||
hk-force
|
||||
(fn
|
||||
(v)
|
||||
(cond
|
||||
((hk-is-thunk? v)
|
||||
(cond
|
||||
((get v "forced") (get v "value"))
|
||||
(:else
|
||||
(let
|
||||
((res (hk-force (hk-eval (get v "body") (get v "env")))))
|
||||
(dict-set! v "forced" true)
|
||||
(dict-set! v "value" res)
|
||||
res))))
|
||||
(:else v))))
|
||||
|
||||
;; Recursive force — used at the test/output boundary so test
|
||||
;; expectations can compare against fully-evaluated structures.
|
||||
(define
|
||||
hk-deep-force
|
||||
(fn
|
||||
(v)
|
||||
(let ((fv (hk-force v)))
|
||||
(cond
|
||||
((not (list? fv)) fv)
|
||||
((empty? fv) fv)
|
||||
(:else (map hk-deep-force fv))))))
|
||||
|
||||
;; ── Function value constructors ──────────────────────────────
|
||||
(define
|
||||
hk-mk-closure
|
||||
(fn
|
||||
(params body env)
|
||||
{:type "fn" :kind "closure" :params params :body body :env env}))
|
||||
|
||||
(define
|
||||
hk-mk-multifun
|
||||
(fn
|
||||
(arity clauses env)
|
||||
{:type "fn" :kind "multi" :arity arity :clauses clauses :env env :collected (list)}))
|
||||
|
||||
(define
|
||||
hk-mk-builtin
|
||||
(fn
|
||||
(name fn arity)
|
||||
{:type "builtin" :name name :fn fn :arity arity :lazy false :collected (list)}))
|
||||
|
||||
;; A lazy built-in receives its collected args as raw thunks (or
|
||||
;; values, if those happened to be eager) — the implementation is
|
||||
;; responsible for forcing exactly what it needs. Used for `seq`
|
||||
;; and `deepseq`, which are non-strict in their second argument.
|
||||
(define
|
||||
hk-mk-lazy-builtin
|
||||
(fn
|
||||
(name fn arity)
|
||||
{:type "builtin" :name name :fn fn :arity arity :lazy true :collected (list)}))
|
||||
|
||||
;; ── Apply a function value to one argument ──────────────────
|
||||
(define
|
||||
hk-apply
|
||||
(fn
|
||||
(f arg)
|
||||
(let ((f (hk-force f)))
|
||||
(cond
|
||||
((not (dict? f))
|
||||
(raise (str "apply: not a function value: " f)))
|
||||
((= (get f "type") "fn")
|
||||
(cond
|
||||
((= (get f "kind") "closure") (hk-apply-closure f arg))
|
||||
((= (get f "kind") "multi") (hk-apply-multi f arg))
|
||||
(:else (raise "apply: unknown fn kind"))))
|
||||
((= (get f "type") "con-partial") (hk-apply-con-partial f arg))
|
||||
((= (get f "type") "builtin") (hk-apply-builtin f arg))
|
||||
(:else (raise "apply: not a function dict"))))))
|
||||
|
||||
(define
|
||||
hk-apply-closure
|
||||
(fn
|
||||
(cl arg)
|
||||
(let
|
||||
((params (get cl "params"))
|
||||
(body (get cl "body"))
|
||||
(env (get cl "env")))
|
||||
(cond
|
||||
((empty? params) (raise "apply-closure: no params"))
|
||||
(:else
|
||||
(let
|
||||
((p1 (first params)) (rest-p (rest params)))
|
||||
(let
|
||||
((env-after (hk-match p1 arg env)))
|
||||
(cond
|
||||
((nil? env-after)
|
||||
(raise "pattern match failure in lambda"))
|
||||
((empty? rest-p) (hk-eval body env-after))
|
||||
(:else
|
||||
(hk-mk-closure rest-p body env-after))))))))))
|
||||
|
||||
(define
|
||||
hk-apply-multi
|
||||
(fn
|
||||
(mf arg)
|
||||
(let
|
||||
((arity (get mf "arity"))
|
||||
(clauses (get mf "clauses"))
|
||||
(env (get mf "env"))
|
||||
(collected (append (get mf "collected") (list arg))))
|
||||
(cond
|
||||
((< (len collected) arity)
|
||||
(assoc mf "collected" collected))
|
||||
(:else (hk-dispatch-multi clauses collected env))))))
|
||||
|
||||
(define
|
||||
hk-dispatch-multi
|
||||
(fn
|
||||
(clauses args env)
|
||||
(cond
|
||||
((empty? clauses)
|
||||
(raise "non-exhaustive patterns in function definition"))
|
||||
(:else
|
||||
(let
|
||||
((c (first clauses)))
|
||||
(let
|
||||
((pats (first c)) (body (first (rest c))))
|
||||
(let
|
||||
((env-after (hk-match-args pats args env)))
|
||||
(cond
|
||||
((nil? env-after)
|
||||
(hk-dispatch-multi (rest clauses) args env))
|
||||
(:else (hk-eval body env-after))))))))))
|
||||
|
||||
(define
|
||||
hk-match-args
|
||||
(fn
|
||||
(pats args env)
|
||||
(cond
|
||||
((empty? pats) env)
|
||||
(:else
|
||||
(let
|
||||
((res (hk-match (first pats) (first args) env)))
|
||||
(cond
|
||||
((nil? res) nil)
|
||||
(:else
|
||||
(hk-match-args (rest pats) (rest args) res))))))))
|
||||
|
||||
(define
|
||||
hk-apply-con-partial
|
||||
(fn
|
||||
(cp arg)
|
||||
(let
|
||||
((name (get cp "name"))
|
||||
(arity (get cp "arity"))
|
||||
(args (append (get cp "args") (list arg))))
|
||||
(cond
|
||||
((= (len args) arity) (hk-mk-con name args))
|
||||
(:else (assoc cp "args" args))))))
|
||||
|
||||
(define
|
||||
hk-apply-builtin
|
||||
(fn
|
||||
(b arg)
|
||||
(let
|
||||
((arity (get b "arity"))
|
||||
(collected (append (get b "collected") (list arg))))
|
||||
(cond
|
||||
((< (len collected) arity)
|
||||
(assoc b "collected" collected))
|
||||
(:else
|
||||
;; Strict built-ins force every collected arg before
|
||||
;; calling. Lazy ones (`seq`, `deepseq`) receive the raw
|
||||
;; thunks so they can choose what to force.
|
||||
(cond
|
||||
((get b "lazy") (apply (get b "fn") collected))
|
||||
(:else
|
||||
(apply
|
||||
(get b "fn")
|
||||
(map hk-force collected)))))))))
|
||||
|
||||
;; ── Bool helpers (Bool values are tagged conses) ────────────
|
||||
(define
|
||||
hk-truthy?
|
||||
(fn
|
||||
(v)
|
||||
(and (list? v) (not (empty? v)) (= (first v) "True"))))
|
||||
|
||||
(define hk-true (hk-mk-con "True" (list)))
|
||||
(define hk-false (hk-mk-con "False" (list)))
|
||||
(define hk-of-bool (fn (b) (if b hk-true hk-false)))
|
||||
|
||||
;; ── Core eval ───────────────────────────────────────────────
|
||||
(define
|
||||
hk-eval
|
||||
(fn
|
||||
(node env)
|
||||
(cond
|
||||
((not (list? node)) (raise (str "eval: not a list: " node)))
|
||||
((empty? node) (raise "eval: empty list node"))
|
||||
(:else
|
||||
(let
|
||||
((tag (first node)))
|
||||
(cond
|
||||
((= tag "int") (nth node 1))
|
||||
((= tag "float") (nth node 1))
|
||||
((= tag "string") (nth node 1))
|
||||
((= tag "char") (nth node 1))
|
||||
((= tag "var") (hk-eval-var (nth node 1) env))
|
||||
((= tag "con") (hk-eval-con-ref (nth node 1)))
|
||||
((= tag "neg")
|
||||
(- 0 (hk-force (hk-eval (nth node 1) env))))
|
||||
((= tag "if") (hk-eval-if node env))
|
||||
((= tag "let") (hk-eval-let (nth node 1) (nth node 2) env))
|
||||
((= tag "lambda")
|
||||
(hk-mk-closure (nth node 1) (nth node 2) env))
|
||||
((= tag "app")
|
||||
(hk-apply
|
||||
(hk-eval (nth node 1) env)
|
||||
(hk-mk-thunk (nth node 2) env)))
|
||||
((= tag "op")
|
||||
(hk-eval-op
|
||||
(nth node 1)
|
||||
(nth node 2)
|
||||
(nth node 3)
|
||||
env))
|
||||
((= tag "case")
|
||||
(hk-eval-case (nth node 1) (nth node 2) env))
|
||||
((= tag "tuple")
|
||||
(hk-mk-tuple
|
||||
(map (fn (e) (hk-eval e env)) (nth node 1))))
|
||||
((= tag "list")
|
||||
(hk-mk-list
|
||||
(map (fn (e) (hk-eval e env)) (nth node 1))))
|
||||
((= tag "range")
|
||||
(let
|
||||
((from (hk-force (hk-eval (nth node 1) env)))
|
||||
(to (hk-force (hk-eval (nth node 2) env))))
|
||||
(hk-build-range from to 1)))
|
||||
((= tag "range-step")
|
||||
(let
|
||||
((from (hk-force (hk-eval (nth node 1) env)))
|
||||
(nxt (hk-force (hk-eval (nth node 2) env)))
|
||||
(to (hk-force (hk-eval (nth node 3) env))))
|
||||
(hk-build-range from to (- nxt from))))
|
||||
((= tag "range-from")
|
||||
;; [from..] = iterate (+ 1) from — uses the Prelude.
|
||||
(hk-eval
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "iterate")
|
||||
(list
|
||||
:sect-right
|
||||
"+"
|
||||
(list :int 1)))
|
||||
(nth node 1))
|
||||
env))
|
||||
((= tag "sect-left")
|
||||
(hk-eval-sect-left (nth node 1) (nth node 2) env))
|
||||
((= tag "sect-right")
|
||||
(hk-eval-sect-right (nth node 1) (nth node 2) env))
|
||||
(:else
|
||||
(raise (str "eval: unknown node tag '" tag "'")))))))))
|
||||
|
||||
(define
|
||||
hk-eval-var
|
||||
(fn
|
||||
(name env)
|
||||
(cond
|
||||
((has-key? env name) (get env name))
|
||||
((hk-is-con? name) (hk-eval-con-ref name))
|
||||
(:else (raise (str "unbound variable: " name))))))
|
||||
|
||||
(define
|
||||
hk-eval-con-ref
|
||||
(fn
|
||||
(name)
|
||||
(let ((arity (hk-con-arity name)))
|
||||
(cond
|
||||
((nil? arity) (raise (str "unknown constructor: " name)))
|
||||
((= arity 0) (hk-mk-con name (list)))
|
||||
(:else
|
||||
{:type "con-partial" :name name :arity arity :args (list)})))))
|
||||
|
||||
(define
|
||||
hk-eval-if
|
||||
(fn
|
||||
(node env)
|
||||
(let ((cv (hk-force (hk-eval (nth node 1) env))))
|
||||
(cond
|
||||
((hk-truthy? cv) (hk-eval (nth node 2) env))
|
||||
((and (list? cv) (= (first cv) "False"))
|
||||
(hk-eval (nth node 3) env))
|
||||
((= cv true) (hk-eval (nth node 2) env))
|
||||
((= cv false) (hk-eval (nth node 3) env))
|
||||
(:else (raise "if: condition is not Bool"))))))
|
||||
|
||||
(define
|
||||
hk-extend-env-with-match!
|
||||
(fn
|
||||
(env match-env)
|
||||
(for-each
|
||||
(fn (k) (dict-set! env k (get match-env k)))
|
||||
(keys match-env))))
|
||||
|
||||
(define
|
||||
hk-eval-let-bind!
|
||||
(fn
|
||||
(b env)
|
||||
(let ((tag (first b)))
|
||||
(cond
|
||||
((= tag "fun-clause")
|
||||
(let
|
||||
((name (nth b 1))
|
||||
(pats (nth b 2))
|
||||
(body (nth b 3)))
|
||||
(cond
|
||||
((empty? pats)
|
||||
(dict-set! env name (hk-eval body env)))
|
||||
(:else
|
||||
(dict-set! env name (hk-mk-closure pats body env))))))
|
||||
((or (= tag "bind") (= tag "pat-bind"))
|
||||
(let ((pat (nth b 1)) (body (nth b 2)))
|
||||
(let ((val (hk-eval body env)))
|
||||
(let ((res (hk-match pat val env)))
|
||||
(cond
|
||||
((nil? res)
|
||||
(raise "let: pattern bind failure"))
|
||||
(:else
|
||||
(hk-extend-env-with-match! env res)))))))
|
||||
(:else nil)))))
|
||||
|
||||
(define
|
||||
hk-eval-let
|
||||
(fn
|
||||
(binds body env)
|
||||
(let ((new-env (hk-dict-copy env)))
|
||||
;; Pre-seed names for fn-clauses so closures see themselves
|
||||
;; (mutual recursion across the whole binding group).
|
||||
(for-each
|
||||
(fn (b)
|
||||
(cond
|
||||
((= (first b) "fun-clause")
|
||||
(dict-set! new-env (nth b 1) nil))
|
||||
((and
|
||||
(= (first b) "bind")
|
||||
(list? (nth b 1))
|
||||
(= (first (nth b 1)) "p-var"))
|
||||
(dict-set! new-env (nth (nth b 1) 1) nil))
|
||||
(:else nil)))
|
||||
binds)
|
||||
(for-each (fn (b) (hk-eval-let-bind! b new-env)) binds)
|
||||
(hk-eval body new-env))))
|
||||
|
||||
(define
|
||||
hk-eval-case
|
||||
(fn
|
||||
(scrut alts env)
|
||||
(let ((sv (hk-force (hk-eval scrut env))))
|
||||
(hk-try-alts alts sv env))))
|
||||
|
||||
(define
|
||||
hk-try-alts
|
||||
(fn
|
||||
(alts val env)
|
||||
(cond
|
||||
((empty? alts) (raise "case: non-exhaustive patterns"))
|
||||
(:else
|
||||
(let
|
||||
((alt (first alts)))
|
||||
(let
|
||||
((pat (nth alt 1)) (body (nth alt 2)))
|
||||
(let
|
||||
((res (hk-match pat val env)))
|
||||
(cond
|
||||
((nil? res) (hk-try-alts (rest alts) val env))
|
||||
(:else (hk-eval body res))))))))))
|
||||
|
||||
(define
|
||||
hk-eval-op
|
||||
(fn
|
||||
(op left right env)
|
||||
(cond
|
||||
;; Cons is non-strict in both args: build a cons cell whose
|
||||
;; head and tail are deferred. This is what makes `repeat x =
|
||||
;; x : repeat x` and `fibs = 0 : 1 : zipWith (+) fibs (tail
|
||||
;; fibs)` terminate.
|
||||
((= op ":")
|
||||
(hk-mk-cons
|
||||
(hk-mk-thunk left env)
|
||||
(hk-mk-thunk right env)))
|
||||
(:else
|
||||
(let
|
||||
((lv (hk-force (hk-eval left env)))
|
||||
(rv (hk-force (hk-eval right env))))
|
||||
(hk-binop op lv rv))))))
|
||||
|
||||
(define
|
||||
hk-list-append
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (= (first a) "[]")) b)
|
||||
((and (list? a) (= (first a) ":"))
|
||||
(hk-mk-cons (nth a 1) (hk-list-append (nth a 2) b)))
|
||||
(:else (raise "++: not a list")))))
|
||||
|
||||
;; Eager finite-range spine — handles [from..to] and [from,next..to].
|
||||
;; Step direction is governed by the sign of `step`; when step > 0 we
|
||||
;; stop at to; when step < 0 we stop at to going down.
|
||||
(define
|
||||
hk-build-range
|
||||
(fn
|
||||
(from to step)
|
||||
(cond
|
||||
((and (> step 0) (> from to)) (hk-mk-nil))
|
||||
((and (< step 0) (< from to)) (hk-mk-nil))
|
||||
((= step 0) (hk-mk-nil))
|
||||
(:else
|
||||
(hk-mk-cons from (hk-build-range (+ from step) to step))))))
|
||||
|
||||
(define
|
||||
hk-binop
|
||||
(fn
|
||||
(op lv rv)
|
||||
(cond
|
||||
((= op "+") (+ lv rv))
|
||||
((= op "-") (- lv rv))
|
||||
((= op "*") (* lv rv))
|
||||
((= op "/") (/ lv rv))
|
||||
((= op "==") (hk-of-bool (= lv rv)))
|
||||
((= op "/=") (hk-of-bool (not (= lv rv))))
|
||||
((= op "<") (hk-of-bool (< lv rv)))
|
||||
((= op "<=") (hk-of-bool (<= lv rv)))
|
||||
((= op ">") (hk-of-bool (> lv rv)))
|
||||
((= op ">=") (hk-of-bool (>= lv rv)))
|
||||
((= op "&&") (hk-of-bool (and (hk-truthy? lv) (hk-truthy? rv))))
|
||||
((= op "||") (hk-of-bool (or (hk-truthy? lv) (hk-truthy? rv))))
|
||||
((= op ":") (hk-mk-cons lv rv))
|
||||
((= op "++") (hk-list-append lv rv))
|
||||
(:else (raise (str "unknown operator: " op))))))
|
||||
|
||||
(define
|
||||
hk-eval-sect-left
|
||||
(fn
|
||||
(op e env)
|
||||
;; (e op) = \x -> e op x — bind e once, defer the operator call.
|
||||
(let ((ev (hk-eval e env)))
|
||||
(let ((cenv (hk-dict-copy env)))
|
||||
(dict-set! cenv "__hk-sect-l" ev)
|
||||
(hk-mk-closure
|
||||
(list (list :p-var "__hk-sect-x"))
|
||||
(list
|
||||
:op
|
||||
op
|
||||
(list :var "__hk-sect-l")
|
||||
(list :var "__hk-sect-x"))
|
||||
cenv)))))
|
||||
|
||||
(define
|
||||
hk-eval-sect-right
|
||||
(fn
|
||||
(op e env)
|
||||
(let ((ev (hk-eval e env)))
|
||||
(let ((cenv (hk-dict-copy env)))
|
||||
(dict-set! cenv "__hk-sect-r" ev)
|
||||
(hk-mk-closure
|
||||
(list (list :p-var "__hk-sect-x"))
|
||||
(list
|
||||
:op
|
||||
op
|
||||
(list :var "__hk-sect-x")
|
||||
(list :var "__hk-sect-r"))
|
||||
cenv)))))
|
||||
|
||||
;; ── Top-level program evaluation ────────────────────────────
|
||||
;; Operator-as-value built-ins — let `(+)`, `(*)`, etc. work as
|
||||
;; first-class functions for `zipWith (+)` and friends. Strict in
|
||||
;; both args (built-ins are forced via hk-apply-builtin).
|
||||
(define
|
||||
hk-make-binop-builtin
|
||||
(fn
|
||||
(name op-name)
|
||||
(hk-mk-builtin
|
||||
name
|
||||
(fn (a b) (hk-binop op-name a b))
|
||||
2)))
|
||||
|
||||
;; Inline Prelude source — loaded into the initial env so simple
|
||||
;; programs can use `head`, `take`, `repeat`, etc. without each
|
||||
;; user file redefining them. The Prelude itself uses lazy `:` for
|
||||
;; the recursive list-building functions.
|
||||
(define
|
||||
hk-prelude-src
|
||||
"head (x:_) = x
|
||||
tail (_:xs) = xs
|
||||
fst (a, _) = a
|
||||
snd (_, b) = b
|
||||
take 0 _ = []
|
||||
take _ [] = []
|
||||
take n (x:xs) = x : take (n - 1) xs
|
||||
drop 0 xs = xs
|
||||
drop _ [] = []
|
||||
drop n (_:xs) = drop (n - 1) xs
|
||||
repeat x = x : repeat x
|
||||
iterate f x = x : iterate f (f x)
|
||||
length [] = 0
|
||||
length (_:xs) = 1 + length xs
|
||||
map _ [] = []
|
||||
map f (x:xs) = f x : map f xs
|
||||
filter _ [] = []
|
||||
filter p (x:xs) = if p x then x : filter p xs else filter p xs
|
||||
zipWith _ [] _ = []
|
||||
zipWith _ _ [] = []
|
||||
zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys
|
||||
fibs = 0 : 1 : zipWith plus fibs (tail fibs)
|
||||
plus a b = a + b
|
||||
")
|
||||
|
||||
(define
|
||||
hk-load-into!
|
||||
(fn
|
||||
(env src)
|
||||
(let ((ast (hk-core src)))
|
||||
(hk-register-program! ast)
|
||||
(let
|
||||
((decls
|
||||
(cond
|
||||
((= (first ast) "program") (nth ast 1))
|
||||
((= (first ast) "module") (nth ast 4))
|
||||
(:else (list)))))
|
||||
(hk-bind-decls! env decls)))))
|
||||
|
||||
(define
|
||||
hk-init-env
|
||||
(fn
|
||||
()
|
||||
(let ((env (dict)))
|
||||
(dict-set! env "otherwise" hk-true)
|
||||
(dict-set!
|
||||
env
|
||||
"error"
|
||||
(hk-mk-builtin
|
||||
"error"
|
||||
(fn (msg) (raise (str "*** Exception: " msg)))
|
||||
1))
|
||||
(dict-set!
|
||||
env
|
||||
"not"
|
||||
(hk-mk-builtin
|
||||
"not"
|
||||
(fn (b) (hk-of-bool (not (hk-truthy? b))))
|
||||
1))
|
||||
(dict-set!
|
||||
env
|
||||
"id"
|
||||
(hk-mk-builtin "id" (fn (x) x) 1))
|
||||
;; `seq a b` — strict in `a`, lazy in `b`. Forces `a` to WHNF
|
||||
;; and returns `b` unchanged (still a thunk if it was one).
|
||||
(dict-set!
|
||||
env
|
||||
"seq"
|
||||
(hk-mk-lazy-builtin
|
||||
"seq"
|
||||
(fn (a b) (do (hk-force a) b))
|
||||
2))
|
||||
;; `deepseq a b` — like seq but forces `a` to normal form.
|
||||
(dict-set!
|
||||
env
|
||||
"deepseq"
|
||||
(hk-mk-lazy-builtin
|
||||
"deepseq"
|
||||
(fn (a b) (do (hk-deep-force a) b))
|
||||
2))
|
||||
;; ── Stub IO monad ─────────────────────────────────────
|
||||
;; IO actions are tagged values `("IO" payload)`; `>>=` and
|
||||
;; `>>` chain them. Lazy in the action arguments so do-blocks
|
||||
;; can be deeply structured without forcing the whole chain
|
||||
;; up front.
|
||||
(dict-set!
|
||||
env
|
||||
"return"
|
||||
(hk-mk-lazy-builtin
|
||||
"return"
|
||||
(fn (x) (list "IO" x))
|
||||
1))
|
||||
(dict-set!
|
||||
env
|
||||
">>="
|
||||
(hk-mk-lazy-builtin
|
||||
">>="
|
||||
(fn (m f)
|
||||
(let ((io-val (hk-force m)))
|
||||
(cond
|
||||
((and
|
||||
(list? io-val)
|
||||
(= (first io-val) "IO"))
|
||||
(hk-apply (hk-force f) (nth io-val 1)))
|
||||
(:else
|
||||
(raise "(>>=): left side is not an IO action")))))
|
||||
2))
|
||||
(dict-set!
|
||||
env
|
||||
">>"
|
||||
(hk-mk-lazy-builtin
|
||||
">>"
|
||||
(fn (m n)
|
||||
(let ((io-val (hk-force m)))
|
||||
(cond
|
||||
((and
|
||||
(list? io-val)
|
||||
(= (first io-val) "IO"))
|
||||
(hk-force n))
|
||||
(:else
|
||||
(raise "(>>): left side is not an IO action")))))
|
||||
2))
|
||||
;; Operators as first-class values
|
||||
(dict-set! env "+" (hk-make-binop-builtin "+" "+"))
|
||||
(dict-set! env "-" (hk-make-binop-builtin "-" "-"))
|
||||
(dict-set! env "*" (hk-make-binop-builtin "*" "*"))
|
||||
(dict-set! env "/" (hk-make-binop-builtin "/" "/"))
|
||||
(dict-set! env "==" (hk-make-binop-builtin "==" "=="))
|
||||
(dict-set! env "/=" (hk-make-binop-builtin "/=" "/="))
|
||||
(dict-set! env "<" (hk-make-binop-builtin "<" "<"))
|
||||
(dict-set! env "<=" (hk-make-binop-builtin "<=" "<="))
|
||||
(dict-set! env ">" (hk-make-binop-builtin ">" ">"))
|
||||
(dict-set! env ">=" (hk-make-binop-builtin ">=" ">="))
|
||||
(dict-set! env "&&" (hk-make-binop-builtin "&&" "&&"))
|
||||
(dict-set! env "||" (hk-make-binop-builtin "||" "||"))
|
||||
(dict-set! env "++" (hk-make-binop-builtin "++" "++"))
|
||||
(hk-load-into! env hk-prelude-src)
|
||||
env)))
|
||||
|
||||
(define
|
||||
hk-bind-decls!
|
||||
(fn
|
||||
(env decls)
|
||||
(let
|
||||
((groups (dict))
|
||||
(group-order (list))
|
||||
(pat-binds (list)))
|
||||
;; Pass 1: collect fun-clause groups by name; track first-seen
|
||||
;; order so pass 3 can evaluate 0-arity bodies in source order
|
||||
;; (forward references to other 0-arity definitions still need
|
||||
;; the earlier name to be bound first).
|
||||
(for-each
|
||||
(fn (d)
|
||||
(cond
|
||||
((= (first d) "fun-clause")
|
||||
(let
|
||||
((name (nth d 1)))
|
||||
(when (not (has-key? groups name))
|
||||
(append! group-order name))
|
||||
(dict-set!
|
||||
groups
|
||||
name
|
||||
(append
|
||||
(if
|
||||
(has-key? groups name)
|
||||
(get groups name)
|
||||
(list))
|
||||
(list (list (nth d 2) (nth d 3)))))
|
||||
(when
|
||||
(not (has-key? env name))
|
||||
(dict-set! env name nil))))
|
||||
((or (= (first d) "bind") (= (first d) "pat-bind"))
|
||||
(append! pat-binds d))
|
||||
(:else nil)))
|
||||
decls)
|
||||
;; Pass 2: install multifuns (arity > 0) — order doesn't matter
|
||||
;; because they're closures; collect 0-arity names in source
|
||||
;; order for pass 3.
|
||||
(let ((zero-arity (list)))
|
||||
(for-each
|
||||
(fn (name)
|
||||
(let ((clauses (get groups name)))
|
||||
(let ((arity (len (first (first clauses)))))
|
||||
(cond
|
||||
((> arity 0)
|
||||
(dict-set!
|
||||
env
|
||||
name
|
||||
(hk-mk-multifun arity clauses env)))
|
||||
(:else (append! zero-arity name))))))
|
||||
group-order)
|
||||
;; Pass 3: evaluate 0-arity bodies and pat-binds in source
|
||||
;; order — forward references to a later 0-arity name will
|
||||
;; still see its placeholder (nil) and fail noisily, but the
|
||||
;; common case of a top-down program works.
|
||||
(for-each
|
||||
(fn (name)
|
||||
(let ((clauses (get groups name)))
|
||||
(dict-set!
|
||||
env
|
||||
name
|
||||
(hk-eval (first (rest (first clauses))) env))))
|
||||
zero-arity)
|
||||
(for-each
|
||||
(fn (d)
|
||||
(let ((pat (nth d 1)) (body (nth d 2)))
|
||||
(let ((val (hk-eval body env)))
|
||||
(let ((res (hk-match pat val env)))
|
||||
(cond
|
||||
((nil? res)
|
||||
(raise "top-level pattern bind failure"))
|
||||
(:else (hk-extend-env-with-match! env res)))))))
|
||||
pat-binds))
|
||||
env)))
|
||||
|
||||
(define
|
||||
hk-eval-program
|
||||
(fn
|
||||
(ast)
|
||||
(cond
|
||||
((nil? ast) (raise "eval-program: nil ast"))
|
||||
((not (list? ast)) (raise "eval-program: not a list"))
|
||||
(:else
|
||||
(do
|
||||
(hk-register-program! ast)
|
||||
(let ((env (hk-init-env)))
|
||||
(let
|
||||
((decls
|
||||
(cond
|
||||
((= (first ast) "program") (nth ast 1))
|
||||
((= (first ast) "module") (nth ast 4))
|
||||
(:else (raise "eval-program: bad shape")))))
|
||||
(hk-bind-decls! env decls))))))))
|
||||
|
||||
;; ── Source-level convenience ────────────────────────────────
|
||||
(define
|
||||
hk-run
|
||||
(fn
|
||||
(src)
|
||||
(let ((env (hk-eval-program (hk-core src))))
|
||||
(cond
|
||||
((has-key? env "main") (get env "main"))
|
||||
(:else env)))))
|
||||
|
||||
(define
|
||||
hk-eval-expr-source
|
||||
(fn
|
||||
(src)
|
||||
(hk-deep-force (hk-eval (hk-core-expr src) (hk-init-env)))))
|
||||
@@ -1,329 +0,0 @@
|
||||
;; Haskell 98 layout algorithm (§10.3).
|
||||
;;
|
||||
;; Consumes the raw token stream produced by hk-tokenize and inserts
|
||||
;; virtual braces / semicolons (types vlbrace / vrbrace / vsemi) based
|
||||
;; on indentation. Newline tokens are consumed and stripped.
|
||||
;;
|
||||
;; (hk-layout (hk-tokenize src)) → tokens-with-virtual-layout
|
||||
|
||||
;; ── Pre-pass ──────────────────────────────────────────────────────
|
||||
;;
|
||||
;; Walks the raw token list and emits an augmented stream containing
|
||||
;; two fresh pseudo-tokens:
|
||||
;;
|
||||
;; {:type "layout-open" :col N :keyword K}
|
||||
;; At stream start (K = "<module>") unless the first real token is
|
||||
;; `module` or `{`. Also immediately after every `let` / `where` /
|
||||
;; `do` / `of` whose following token is NOT `{`. N is the column
|
||||
;; of the token that follows.
|
||||
;;
|
||||
;; {:type "layout-indent" :col N}
|
||||
;; Before any token whose line is strictly greater than the line
|
||||
;; of the previously emitted real token, EXCEPT when that token
|
||||
;; is already preceded by a layout-open (Haskell 98 §10.3 note 3).
|
||||
;;
|
||||
;; Raw newline tokens are dropped.
|
||||
|
||||
(define
|
||||
hk-layout-keyword?
|
||||
(fn
|
||||
(tok)
|
||||
(and
|
||||
(= (get tok "type") "reserved")
|
||||
(or
|
||||
(= (get tok "value") "let")
|
||||
(= (get tok "value") "where")
|
||||
(= (get tok "value") "do")
|
||||
(= (get tok "value") "of")))))
|
||||
|
||||
(define
|
||||
hk-layout-pre
|
||||
(fn
|
||||
(tokens)
|
||||
(let
|
||||
((result (list))
|
||||
(n (len tokens))
|
||||
(i 0)
|
||||
(prev-line -1)
|
||||
(first-real-emitted false)
|
||||
(suppress-next-indent false))
|
||||
(define
|
||||
hk-next-real-idx
|
||||
(fn
|
||||
(start)
|
||||
(let
|
||||
((j start))
|
||||
(define
|
||||
hk-nri-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< j n)
|
||||
(= (get (nth tokens j) "type") "newline"))
|
||||
(do (set! j (+ j 1)) (hk-nri-loop)))))
|
||||
(hk-nri-loop)
|
||||
j)))
|
||||
(define
|
||||
hk-pre-step
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i n)
|
||||
(let
|
||||
((tok (nth tokens i)) (ty (get tok "type")))
|
||||
(cond
|
||||
((= ty "newline") (do (set! i (+ i 1)) (hk-pre-step)))
|
||||
(:else
|
||||
(do
|
||||
(when
|
||||
(not first-real-emitted)
|
||||
(do
|
||||
(set! first-real-emitted true)
|
||||
(when
|
||||
(not
|
||||
(or
|
||||
(and
|
||||
(= ty "reserved")
|
||||
(= (get tok "value") "module"))
|
||||
(= ty "lbrace")))
|
||||
(do
|
||||
(append!
|
||||
result
|
||||
{:type "layout-open"
|
||||
:col (get tok "col")
|
||||
:keyword "<module>"
|
||||
:line (get tok "line")})
|
||||
(set! suppress-next-indent true)))))
|
||||
(when
|
||||
(and
|
||||
(>= prev-line 0)
|
||||
(> (get tok "line") prev-line)
|
||||
(not suppress-next-indent))
|
||||
(append!
|
||||
result
|
||||
{:type "layout-indent"
|
||||
:col (get tok "col")
|
||||
:line (get tok "line")}))
|
||||
(set! suppress-next-indent false)
|
||||
(set! prev-line (get tok "line"))
|
||||
(append! result tok)
|
||||
(when
|
||||
(hk-layout-keyword? tok)
|
||||
(let
|
||||
((j (hk-next-real-idx (+ i 1))))
|
||||
(cond
|
||||
((>= j n)
|
||||
(do
|
||||
(append!
|
||||
result
|
||||
{:type "layout-open"
|
||||
:col 0
|
||||
:keyword (get tok "value")
|
||||
:line (get tok "line")})
|
||||
(set! suppress-next-indent true)))
|
||||
((= (get (nth tokens j) "type") "lbrace") nil)
|
||||
(:else
|
||||
(do
|
||||
(append!
|
||||
result
|
||||
{:type "layout-open"
|
||||
:col (get (nth tokens j) "col")
|
||||
:keyword (get tok "value")
|
||||
:line (get tok "line")})
|
||||
(set! suppress-next-indent true))))))
|
||||
(set! i (+ i 1))
|
||||
(hk-pre-step))))))))
|
||||
(hk-pre-step)
|
||||
result)))
|
||||
|
||||
;; ── Main pass: L algorithm ────────────────────────────────────────
|
||||
;;
|
||||
;; Stack is a list; the head is the top of stack. Each entry is
|
||||
;; either the keyword :explicit (pushed by an explicit `{`) or a dict
|
||||
;; {:col N :keyword K} pushed by a layout-open marker.
|
||||
;;
|
||||
;; Rules (following Haskell 98 §10.3):
|
||||
;;
|
||||
;; layout-open(n) vs stack:
|
||||
;; empty or explicit top → push n; emit {
|
||||
;; n > top-col → push n; emit {
|
||||
;; otherwise → emit { }; retry as indent(n)
|
||||
;;
|
||||
;; layout-indent(n) vs stack:
|
||||
;; empty or explicit top → drop
|
||||
;; n == top-col → emit ;
|
||||
;; n < top-col → emit }; pop; recurse
|
||||
;; n > top-col → drop
|
||||
;;
|
||||
;; lbrace → push :explicit; emit {
|
||||
;; rbrace → pop if :explicit; emit }
|
||||
;; `in` with implicit let on top → emit }; pop; emit in
|
||||
;; any other token → emit
|
||||
;;
|
||||
;; EOF: emit } for every remaining implicit context.
|
||||
|
||||
(define
|
||||
hk-layout-L
|
||||
(fn
|
||||
(pre-toks)
|
||||
(let
|
||||
((result (list))
|
||||
(stack (list))
|
||||
(n (len pre-toks))
|
||||
(i 0))
|
||||
(define hk-emit (fn (t) (append! result t)))
|
||||
(define
|
||||
hk-indent-at
|
||||
(fn
|
||||
(col line)
|
||||
(cond
|
||||
((or (empty? stack) (= (first stack) :explicit)) nil)
|
||||
(:else
|
||||
(let
|
||||
((top-col (get (first stack) "col")))
|
||||
(cond
|
||||
((= col top-col)
|
||||
(hk-emit
|
||||
{:type "vsemi" :value ";" :line line :col col}))
|
||||
((< col top-col)
|
||||
(do
|
||||
(hk-emit
|
||||
{:type "vrbrace" :value "}" :line line :col col})
|
||||
(set! stack (rest stack))
|
||||
(hk-indent-at col line)))
|
||||
(:else nil)))))))
|
||||
(define
|
||||
hk-open-at
|
||||
(fn
|
||||
(col keyword line)
|
||||
(cond
|
||||
((and
|
||||
(> col 0)
|
||||
(or
|
||||
(empty? stack)
|
||||
(= (first stack) :explicit)
|
||||
(> col (get (first stack) "col"))))
|
||||
(do
|
||||
(hk-emit
|
||||
{:type "vlbrace" :value "{" :line line :col col})
|
||||
(set! stack (cons {:col col :keyword keyword} stack))))
|
||||
(:else
|
||||
(do
|
||||
(hk-emit
|
||||
{:type "vlbrace" :value "{" :line line :col col})
|
||||
(hk-emit
|
||||
{:type "vrbrace" :value "}" :line line :col col})
|
||||
(hk-indent-at col line))))))
|
||||
(define
|
||||
hk-close-eof
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(not (empty? stack))
|
||||
(not (= (first stack) :explicit)))
|
||||
(do
|
||||
(hk-emit {:type "vrbrace" :value "}" :line 0 :col 0})
|
||||
(set! stack (rest stack))
|
||||
(hk-close-eof)))))
|
||||
;; Peek past further layout-indent / layout-open markers to find
|
||||
;; the next real token's value when its type is `reserved`.
|
||||
;; Returns nil if no such token.
|
||||
(define
|
||||
hk-peek-next-reserved
|
||||
(fn
|
||||
(start)
|
||||
(let ((j (+ start 1)) (found nil) (done false))
|
||||
(define
|
||||
hk-pnr-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (not done) (< j n))
|
||||
(let
|
||||
((t (nth pre-toks j)) (ty (get t "type")))
|
||||
(cond
|
||||
((or
|
||||
(= ty "layout-indent")
|
||||
(= ty "layout-open"))
|
||||
(do (set! j (+ j 1)) (hk-pnr-loop)))
|
||||
((= ty "reserved")
|
||||
(do (set! found (get t "value")) (set! done true)))
|
||||
(:else (set! done true)))))))
|
||||
(hk-pnr-loop)
|
||||
found)))
|
||||
(define
|
||||
hk-layout-step
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i n)
|
||||
(let
|
||||
((tok (nth pre-toks i)) (ty (get tok "type")))
|
||||
(cond
|
||||
((= ty "eof")
|
||||
(do
|
||||
(hk-close-eof)
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
((= ty "layout-open")
|
||||
(do
|
||||
(hk-open-at
|
||||
(get tok "col")
|
||||
(get tok "keyword")
|
||||
(get tok "line"))
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
((= ty "layout-indent")
|
||||
(cond
|
||||
((= (hk-peek-next-reserved i) "in")
|
||||
(do (set! i (+ i 1)) (hk-layout-step)))
|
||||
(:else
|
||||
(do
|
||||
(hk-indent-at (get tok "col") (get tok "line"))
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))))
|
||||
((= ty "lbrace")
|
||||
(do
|
||||
(set! stack (cons :explicit stack))
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
((= ty "rbrace")
|
||||
(do
|
||||
(when
|
||||
(and
|
||||
(not (empty? stack))
|
||||
(= (first stack) :explicit))
|
||||
(set! stack (rest stack)))
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
((and
|
||||
(= ty "reserved")
|
||||
(= (get tok "value") "in")
|
||||
(not (empty? stack))
|
||||
(not (= (first stack) :explicit))
|
||||
(= (get (first stack) "keyword") "let"))
|
||||
(do
|
||||
(hk-emit
|
||||
{:type "vrbrace"
|
||||
:value "}"
|
||||
:line (get tok "line")
|
||||
:col (get tok "col")})
|
||||
(set! stack (rest stack))
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
(:else
|
||||
(do
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step))))))))
|
||||
(hk-layout-step)
|
||||
(hk-close-eof)
|
||||
result)))
|
||||
|
||||
(define hk-layout (fn (tokens) (hk-layout-L (hk-layout-pre tokens))))
|
||||
@@ -1,201 +0,0 @@
|
||||
;; Value-level pattern matching.
|
||||
;;
|
||||
;; Constructor values are tagged lists whose first element is the
|
||||
;; constructor name (a string). Tuples use the special tag "Tuple".
|
||||
;; Lists use the spine of `:` cons and `[]` nil.
|
||||
;;
|
||||
;; Just 5 → ("Just" 5)
|
||||
;; Nothing → ("Nothing")
|
||||
;; (1, 2) → ("Tuple" 1 2)
|
||||
;; [1, 2] → (":" 1 (":" 2 ("[]")))
|
||||
;; () → ("()")
|
||||
;;
|
||||
;; Primitive values (numbers, strings, chars) are stored raw.
|
||||
;;
|
||||
;; The matcher takes a pattern AST node, a value, and an environment
|
||||
;; dict; it returns an extended dict on success, or `nil` on failure.
|
||||
|
||||
;; ── Value builders ──────────────────────────────────────────
|
||||
(define
|
||||
hk-mk-con
|
||||
(fn
|
||||
(cname args)
|
||||
(let ((result (list cname)))
|
||||
(for-each (fn (a) (append! result a)) args)
|
||||
result)))
|
||||
|
||||
(define
|
||||
hk-mk-tuple
|
||||
(fn
|
||||
(items)
|
||||
(let ((result (list "Tuple")))
|
||||
(for-each (fn (x) (append! result x)) items)
|
||||
result)))
|
||||
|
||||
(define hk-mk-nil (fn () (list "[]")))
|
||||
|
||||
(define hk-mk-cons (fn (h t) (list ":" h t)))
|
||||
|
||||
(define
|
||||
hk-mk-list
|
||||
(fn
|
||||
(items)
|
||||
(cond
|
||||
((empty? items) (hk-mk-nil))
|
||||
(:else
|
||||
(hk-mk-cons (first items) (hk-mk-list (rest items)))))))
|
||||
|
||||
;; ── Predicates / accessors on constructor values ───────────
|
||||
(define
|
||||
hk-is-con-val?
|
||||
(fn
|
||||
(v)
|
||||
(and
|
||||
(list? v)
|
||||
(not (empty? v))
|
||||
(string? (first v)))))
|
||||
|
||||
(define hk-val-con-name (fn (v) (first v)))
|
||||
|
||||
(define hk-val-con-args (fn (v) (rest v)))
|
||||
|
||||
;; ── The matcher ────────────────────────────────────────────
|
||||
;;
|
||||
;; Pattern match forces the scrutinee to WHNF before inspecting it
|
||||
;; — except for `p-wild`, `p-var`, and `p-lazy`, which never need
|
||||
;; to look at the value. Args of constructor / tuple / list values
|
||||
;; remain thunked (they're forced only when their own pattern needs
|
||||
;; to inspect them, recursively).
|
||||
(define
|
||||
hk-match
|
||||
(fn
|
||||
(pat val env)
|
||||
(cond
|
||||
((not (list? pat)) nil)
|
||||
((empty? pat) nil)
|
||||
(:else
|
||||
(let
|
||||
((tag (first pat)))
|
||||
(cond
|
||||
((= tag "p-wild") env)
|
||||
((= tag "p-var") (assoc env (nth pat 1) val))
|
||||
((= tag "p-lazy") (hk-match (nth pat 1) val env))
|
||||
((= tag "p-as")
|
||||
(let
|
||||
((res (hk-match (nth pat 2) val env)))
|
||||
(cond
|
||||
((nil? res) nil)
|
||||
(:else (assoc res (nth pat 1) val)))))
|
||||
(:else
|
||||
(let ((fv (hk-force val)))
|
||||
(cond
|
||||
((= tag "p-int")
|
||||
(if
|
||||
(and (number? fv) (= fv (nth pat 1)))
|
||||
env
|
||||
nil))
|
||||
((= tag "p-float")
|
||||
(if
|
||||
(and (number? fv) (= fv (nth pat 1)))
|
||||
env
|
||||
nil))
|
||||
((= tag "p-string")
|
||||
(if
|
||||
(and (string? fv) (= fv (nth pat 1)))
|
||||
env
|
||||
nil))
|
||||
((= tag "p-char")
|
||||
(if
|
||||
(and (string? fv) (= fv (nth pat 1)))
|
||||
env
|
||||
nil))
|
||||
((= tag "p-con")
|
||||
(let
|
||||
((pat-name (nth pat 1)) (pat-args (nth pat 2)))
|
||||
(cond
|
||||
((not (hk-is-con-val? fv)) nil)
|
||||
((not (= (hk-val-con-name fv) pat-name)) nil)
|
||||
(:else
|
||||
(let
|
||||
((val-args (hk-val-con-args fv)))
|
||||
(cond
|
||||
((not (= (len pat-args) (len val-args)))
|
||||
nil)
|
||||
(:else
|
||||
(hk-match-all
|
||||
pat-args
|
||||
val-args
|
||||
env))))))))
|
||||
((= tag "p-tuple")
|
||||
(let
|
||||
((items (nth pat 1)))
|
||||
(cond
|
||||
((not (hk-is-con-val? fv)) nil)
|
||||
((not (= (hk-val-con-name fv) "Tuple")) nil)
|
||||
((not (= (len (hk-val-con-args fv)) (len items)))
|
||||
nil)
|
||||
(:else
|
||||
(hk-match-all
|
||||
items
|
||||
(hk-val-con-args fv)
|
||||
env)))))
|
||||
((= tag "p-list")
|
||||
(hk-match-list-pat (nth pat 1) fv env))
|
||||
(:else nil))))))))))
|
||||
|
||||
(define
|
||||
hk-match-all
|
||||
(fn
|
||||
(pats vals env)
|
||||
(cond
|
||||
((empty? pats) env)
|
||||
(:else
|
||||
(let
|
||||
((res (hk-match (first pats) (first vals) env)))
|
||||
(cond
|
||||
((nil? res) nil)
|
||||
(:else
|
||||
(hk-match-all (rest pats) (rest vals) res))))))))
|
||||
|
||||
(define
|
||||
hk-match-list-pat
|
||||
(fn
|
||||
(items val env)
|
||||
(let ((fv (hk-force val)))
|
||||
(cond
|
||||
((empty? items)
|
||||
(if
|
||||
(and
|
||||
(hk-is-con-val? fv)
|
||||
(= (hk-val-con-name fv) "[]"))
|
||||
env
|
||||
nil))
|
||||
(:else
|
||||
(cond
|
||||
((not (hk-is-con-val? fv)) nil)
|
||||
((not (= (hk-val-con-name fv) ":")) nil)
|
||||
(:else
|
||||
(let
|
||||
((args (hk-val-con-args fv)))
|
||||
(let
|
||||
((h (first args)) (t (first (rest args))))
|
||||
(let
|
||||
((res (hk-match (first items) h env)))
|
||||
(cond
|
||||
((nil? res) nil)
|
||||
(:else
|
||||
(hk-match-list-pat
|
||||
(rest items)
|
||||
t
|
||||
res)))))))))))))
|
||||
|
||||
;; ── Convenience: parse a pattern from source for tests ─────
|
||||
;; (Uses the parser's case-alt entry — `case _ of pat -> 0` —
|
||||
;; to extract a pattern AST.)
|
||||
(define
|
||||
hk-parse-pat-source
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((expr (hk-parse (str "case 0 of " src " -> 0"))))
|
||||
(nth (nth (nth expr 2) 0) 1))))
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,130 +0,0 @@
|
||||
;; Haskell runtime: constructor registry.
|
||||
;;
|
||||
;; A mutable dict keyed by constructor name (e.g. "Just", "[]") with
|
||||
;; entries of shape {:arity N :type TYPE-NAME-STRING}.
|
||||
;; Populated by ingesting `data` / `newtype` decls from parsed ASTs.
|
||||
;; Pre-registers a small set of constructors tied to Haskell syntactic
|
||||
;; forms (Bool, list, unit) — every nontrivial program depends on
|
||||
;; these, and the parser/desugar pipeline emits them as (:var "True")
|
||||
;; etc. without a corresponding `data` decl.
|
||||
|
||||
(define hk-constructors (dict))
|
||||
|
||||
(define
|
||||
hk-register-con!
|
||||
(fn
|
||||
(cname arity type-name)
|
||||
(dict-set!
|
||||
hk-constructors
|
||||
cname
|
||||
{:arity arity :type type-name})))
|
||||
|
||||
(define hk-is-con? (fn (name) (has-key? hk-constructors name)))
|
||||
|
||||
(define
|
||||
hk-con-arity
|
||||
(fn
|
||||
(name)
|
||||
(if
|
||||
(has-key? hk-constructors name)
|
||||
(get (get hk-constructors name) "arity")
|
||||
nil)))
|
||||
|
||||
(define
|
||||
hk-con-type
|
||||
(fn
|
||||
(name)
|
||||
(if
|
||||
(has-key? hk-constructors name)
|
||||
(get (get hk-constructors name) "type")
|
||||
nil)))
|
||||
|
||||
(define hk-con-names (fn () (keys hk-constructors)))
|
||||
|
||||
;; ── Registration from AST ────────────────────────────────────
|
||||
;; (:data NAME TVARS ((:con-def CNAME FIELDS) …))
|
||||
(define
|
||||
hk-register-data!
|
||||
(fn
|
||||
(data-node)
|
||||
(let
|
||||
((type-name (nth data-node 1))
|
||||
(cons-list (nth data-node 3)))
|
||||
(for-each
|
||||
(fn
|
||||
(cd)
|
||||
(hk-register-con!
|
||||
(nth cd 1)
|
||||
(len (nth cd 2))
|
||||
type-name))
|
||||
cons-list))))
|
||||
|
||||
;; (:newtype NAME TVARS CNAME FIELD)
|
||||
(define
|
||||
hk-register-newtype!
|
||||
(fn
|
||||
(nt-node)
|
||||
(hk-register-con!
|
||||
(nth nt-node 3)
|
||||
1
|
||||
(nth nt-node 1))))
|
||||
|
||||
;; Walk a decls list, registering every `data` / `newtype` decl.
|
||||
(define
|
||||
hk-register-decls!
|
||||
(fn
|
||||
(decls)
|
||||
(for-each
|
||||
(fn
|
||||
(d)
|
||||
(cond
|
||||
((and
|
||||
(list? d)
|
||||
(not (empty? d))
|
||||
(= (first d) "data"))
|
||||
(hk-register-data! d))
|
||||
((and
|
||||
(list? d)
|
||||
(not (empty? d))
|
||||
(= (first d) "newtype"))
|
||||
(hk-register-newtype! d))
|
||||
(:else nil)))
|
||||
decls)))
|
||||
|
||||
(define
|
||||
hk-register-program!
|
||||
(fn
|
||||
(ast)
|
||||
(cond
|
||||
((nil? ast) nil)
|
||||
((not (list? ast)) nil)
|
||||
((empty? ast) nil)
|
||||
((= (first ast) "program")
|
||||
(hk-register-decls! (nth ast 1)))
|
||||
((= (first ast) "module")
|
||||
(hk-register-decls! (nth ast 4)))
|
||||
(:else nil))))
|
||||
|
||||
;; Convenience: source → AST → desugar → register.
|
||||
(define
|
||||
hk-load-source!
|
||||
(fn (src) (hk-register-program! (hk-core src))))
|
||||
|
||||
;; ── Built-in constructors pre-registered ─────────────────────
|
||||
;; Bool — used implicitly by `if`, comparison operators.
|
||||
(hk-register-con! "True" 0 "Bool")
|
||||
(hk-register-con! "False" 0 "Bool")
|
||||
;; List — used by list literals, range syntax, and cons operator.
|
||||
(hk-register-con! "[]" 0 "List")
|
||||
(hk-register-con! ":" 2 "List")
|
||||
;; Unit — produced by empty parens `()`.
|
||||
(hk-register-con! "()" 0 "Unit")
|
||||
;; Standard Prelude types — pre-registered so expression-level
|
||||
;; programs can use them without a `data` decl.
|
||||
(hk-register-con! "Nothing" 0 "Maybe")
|
||||
(hk-register-con! "Just" 1 "Maybe")
|
||||
(hk-register-con! "Left" 1 "Either")
|
||||
(hk-register-con! "Right" 1 "Either")
|
||||
(hk-register-con! "LT" 0 "Ordering")
|
||||
(hk-register-con! "EQ" 0 "Ordering")
|
||||
(hk-register-con! "GT" 0 "Ordering")
|
||||
@@ -46,13 +46,6 @@ for FILE in "${FILES[@]}"; do
|
||||
cat > "$TMPFILE" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/haskell/tokenizer.sx")
|
||||
(load "lib/haskell/layout.sx")
|
||||
(load "lib/haskell/parser.sx")
|
||||
(load "lib/haskell/desugar.sx")
|
||||
(load "lib/haskell/runtime.sx")
|
||||
(load "lib/haskell/match.sx")
|
||||
(load "lib/haskell/eval.sx")
|
||||
(load "lib/haskell/testlib.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
@@ -88,13 +81,6 @@ EPOCHS
|
||||
cat > "$TMPFILE2" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/haskell/tokenizer.sx")
|
||||
(load "lib/haskell/layout.sx")
|
||||
(load "lib/haskell/parser.sx")
|
||||
(load "lib/haskell/desugar.sx")
|
||||
(load "lib/haskell/runtime.sx")
|
||||
(load "lib/haskell/match.sx")
|
||||
(load "lib/haskell/eval.sx")
|
||||
(load "lib/haskell/testlib.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
|
||||
@@ -1,58 +0,0 @@
|
||||
;; Shared test harness for Haskell-on-SX tests.
|
||||
;; Each test file expects hk-test / hk-deep=? / counters to already be bound.
|
||||
|
||||
(define
|
||||
hk-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((= a b) true)
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ak (keys a)) (bk (keys b)))
|
||||
(if
|
||||
(not (= (len ak) (len bk)))
|
||||
false
|
||||
(every?
|
||||
(fn
|
||||
(k)
|
||||
(and (has-key? b k) (hk-deep=? (get a k) (get b k))))
|
||||
ak))))
|
||||
((and (list? a) (list? b))
|
||||
(if
|
||||
(not (= (len a) (len b)))
|
||||
false
|
||||
(let
|
||||
((i 0) (ok true))
|
||||
(define
|
||||
hk-de-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and ok (< i (len a)))
|
||||
(do
|
||||
(when
|
||||
(not (hk-deep=? (nth a i) (nth b i)))
|
||||
(set! ok false))
|
||||
(set! i (+ i 1))
|
||||
(hk-de-loop)))))
|
||||
(hk-de-loop)
|
||||
ok)))
|
||||
(:else false))))
|
||||
|
||||
(define hk-test-pass 0)
|
||||
(define hk-test-fail 0)
|
||||
(define hk-test-fails (list))
|
||||
|
||||
(define
|
||||
hk-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(hk-deep=? actual expected)
|
||||
(set! hk-test-pass (+ hk-test-pass 1))
|
||||
(do
|
||||
(set! hk-test-fail (+ hk-test-fail 1))
|
||||
(append!
|
||||
hk-test-fails
|
||||
{:actual actual :expected expected :name name})))))
|
||||
@@ -1,305 +0,0 @@
|
||||
;; Desugar tests — surface AST → core AST.
|
||||
;; :guarded → nested :if
|
||||
;; :where → :let
|
||||
;; :list-comp → concatMap-based tree
|
||||
|
||||
(define
|
||||
hk-prog
|
||||
(fn (&rest decls) (list :program decls)))
|
||||
|
||||
;; ── Guards → if ──
|
||||
(hk-test
|
||||
"two-way guarded rhs"
|
||||
(hk-desugar (hk-parse-top "abs x | x < 0 = - x\n | otherwise = x"))
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"abs"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:if
|
||||
(list :op "<" (list :var "x") (list :int 0))
|
||||
(list :neg (list :var "x"))
|
||||
(list
|
||||
:if
|
||||
(list :var "otherwise")
|
||||
(list :var "x")
|
||||
(list
|
||||
:app
|
||||
(list :var "error")
|
||||
(list :string "Non-exhaustive guards")))))))
|
||||
|
||||
(hk-test
|
||||
"three-way guarded rhs"
|
||||
(hk-desugar
|
||||
(hk-parse-top "sign n | n > 0 = 1\n | n < 0 = -1\n | otherwise = 0"))
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"sign"
|
||||
(list (list :p-var "n"))
|
||||
(list
|
||||
:if
|
||||
(list :op ">" (list :var "n") (list :int 0))
|
||||
(list :int 1)
|
||||
(list
|
||||
:if
|
||||
(list :op "<" (list :var "n") (list :int 0))
|
||||
(list :neg (list :int 1))
|
||||
(list
|
||||
:if
|
||||
(list :var "otherwise")
|
||||
(list :int 0)
|
||||
(list
|
||||
:app
|
||||
(list :var "error")
|
||||
(list :string "Non-exhaustive guards"))))))))
|
||||
|
||||
(hk-test
|
||||
"case-alt guards desugared too"
|
||||
(hk-desugar
|
||||
(hk-parse "case x of\n Just y | y > 0 -> y\n | otherwise -> 0\n Nothing -> -1"))
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list
|
||||
:if
|
||||
(list :op ">" (list :var "y") (list :int 0))
|
||||
(list :var "y")
|
||||
(list
|
||||
:if
|
||||
(list :var "otherwise")
|
||||
(list :int 0)
|
||||
(list
|
||||
:app
|
||||
(list :var "error")
|
||||
(list :string "Non-exhaustive guards")))))
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Nothing" (list))
|
||||
(list :neg (list :int 1))))))
|
||||
|
||||
;; ── Where → let ──
|
||||
(hk-test
|
||||
"where with single binding"
|
||||
(hk-desugar (hk-parse-top "f x = y\n where y = x + 1"))
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"y"
|
||||
(list)
|
||||
(list :op "+" (list :var "x") (list :int 1))))
|
||||
(list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"where with two bindings"
|
||||
(hk-desugar
|
||||
(hk-parse-top "f x = y + z\n where y = x + 1\n z = x - 1"))
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"y"
|
||||
(list)
|
||||
(list :op "+" (list :var "x") (list :int 1)))
|
||||
(list
|
||||
:fun-clause
|
||||
"z"
|
||||
(list)
|
||||
(list :op "-" (list :var "x") (list :int 1))))
|
||||
(list :op "+" (list :var "y") (list :var "z"))))))
|
||||
|
||||
(hk-test
|
||||
"guards + where — guarded body inside let"
|
||||
(hk-desugar
|
||||
(hk-parse-top "f x | x > 0 = y\n | otherwise = 0\n where y = 99"))
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:let
|
||||
(list (list :fun-clause "y" (list) (list :int 99)))
|
||||
(list
|
||||
:if
|
||||
(list :op ">" (list :var "x") (list :int 0))
|
||||
(list :var "y")
|
||||
(list
|
||||
:if
|
||||
(list :var "otherwise")
|
||||
(list :int 0)
|
||||
(list
|
||||
:app
|
||||
(list :var "error")
|
||||
(list :string "Non-exhaustive guards"))))))))
|
||||
|
||||
;; ── List comprehensions → concatMap / if / let ──
|
||||
(hk-test
|
||||
"list-comp: single generator"
|
||||
(hk-core-expr "[x | x <- xs]")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "concatMap")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list :list (list (list :var "x")))))
|
||||
(list :var "xs")))
|
||||
|
||||
(hk-test
|
||||
"list-comp: generator then guard"
|
||||
(hk-core-expr "[x * 2 | x <- xs, x > 0]")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "concatMap")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:if
|
||||
(list :op ">" (list :var "x") (list :int 0))
|
||||
(list
|
||||
:list
|
||||
(list (list :op "*" (list :var "x") (list :int 2))))
|
||||
(list :list (list)))))
|
||||
(list :var "xs")))
|
||||
|
||||
(hk-test
|
||||
"list-comp: generator then let"
|
||||
(hk-core-expr "[y | x <- xs, let y = x + 1]")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "concatMap")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list :p-var "y")
|
||||
(list :op "+" (list :var "x") (list :int 1))))
|
||||
(list :list (list (list :var "y"))))))
|
||||
(list :var "xs")))
|
||||
|
||||
(hk-test
|
||||
"list-comp: two generators (nested concatMap)"
|
||||
(hk-core-expr "[(x, y) | x <- xs, y <- ys]")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "concatMap")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "concatMap")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "y"))
|
||||
(list
|
||||
:list
|
||||
(list
|
||||
(list
|
||||
:tuple
|
||||
(list (list :var "x") (list :var "y")))))))
|
||||
(list :var "ys"))))
|
||||
(list :var "xs")))
|
||||
|
||||
;; ── Pass-through cases ──
|
||||
(hk-test
|
||||
"plain int literal unchanged"
|
||||
(hk-core-expr "42")
|
||||
(list :int 42))
|
||||
|
||||
(hk-test
|
||||
"lambda + if passes through"
|
||||
(hk-core-expr "\\x -> if x > 0 then x else - x")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:if
|
||||
(list :op ">" (list :var "x") (list :int 0))
|
||||
(list :var "x")
|
||||
(list :neg (list :var "x")))))
|
||||
|
||||
(hk-test
|
||||
"simple fun-clause (no guards/where) passes through"
|
||||
(hk-desugar (hk-parse-top "id x = x"))
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"id"
|
||||
(list (list :p-var "x"))
|
||||
(list :var "x"))))
|
||||
|
||||
(hk-test
|
||||
"data decl passes through"
|
||||
(hk-desugar (hk-parse-top "data Maybe a = Nothing | Just a"))
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Maybe"
|
||||
(list "a")
|
||||
(list
|
||||
(list :con-def "Nothing" (list))
|
||||
(list :con-def "Just" (list (list :t-var "a")))))))
|
||||
|
||||
(hk-test
|
||||
"module header passes through, body desugared"
|
||||
(hk-desugar
|
||||
(hk-parse-top "module M where\nf x | x > 0 = 1\n | otherwise = 0"))
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
nil
|
||||
(list)
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:if
|
||||
(list :op ">" (list :var "x") (list :int 0))
|
||||
(list :int 1)
|
||||
(list
|
||||
:if
|
||||
(list :var "otherwise")
|
||||
(list :int 0)
|
||||
(list
|
||||
:app
|
||||
(list :var "error")
|
||||
(list :string "Non-exhaustive guards"))))))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,117 +0,0 @@
|
||||
;; do-notation + stub IO monad. Desugaring is per Haskell 98 §3.14:
|
||||
;; do { e ; ss } = e >> do { ss }
|
||||
;; do { p <- e ; ss } = e >>= \p -> do { ss }
|
||||
;; do { let ds ; ss } = let ds in do { ss }
|
||||
;; do { e } = e
|
||||
;; The IO type is just `("IO" payload)` for now — no real side
|
||||
;; effects yet. `return`, `>>=`, `>>` are built-ins.
|
||||
|
||||
(define
|
||||
hk-prog-val
|
||||
(fn
|
||||
(src name)
|
||||
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||
|
||||
;; ── Single-statement do ──
|
||||
(hk-test
|
||||
"do with a single expression"
|
||||
(hk-eval-expr-source "do { return 5 }")
|
||||
(list "IO" 5))
|
||||
|
||||
(hk-test
|
||||
"return wraps any expression"
|
||||
(hk-eval-expr-source "return (1 + 2 * 3)")
|
||||
(list "IO" 7))
|
||||
|
||||
;; ── Bind threads results ──
|
||||
(hk-test
|
||||
"single bind"
|
||||
(hk-eval-expr-source
|
||||
"do { x <- return 5 ; return (x + 1) }")
|
||||
(list "IO" 6))
|
||||
|
||||
(hk-test
|
||||
"two binds"
|
||||
(hk-eval-expr-source
|
||||
"do\n x <- return 5\n y <- return 7\n return (x + y)")
|
||||
(list "IO" 12))
|
||||
|
||||
(hk-test
|
||||
"three binds — accumulating"
|
||||
(hk-eval-expr-source
|
||||
"do\n a <- return 1\n b <- return 2\n c <- return 3\n return (a + b + c)")
|
||||
(list "IO" 6))
|
||||
|
||||
;; ── Mixing >> and >>= ──
|
||||
(hk-test
|
||||
">> sequencing — last wins"
|
||||
(hk-eval-expr-source
|
||||
"do\n return 1\n return 2\n return 3")
|
||||
(list "IO" 3))
|
||||
|
||||
(hk-test
|
||||
">> then >>= — last bind wins"
|
||||
(hk-eval-expr-source
|
||||
"do\n return 99\n x <- return 5\n return x")
|
||||
(list "IO" 5))
|
||||
|
||||
;; ── do-let ──
|
||||
(hk-test
|
||||
"do-let single binding"
|
||||
(hk-eval-expr-source
|
||||
"do\n let x = 3\n return (x * 2)")
|
||||
(list "IO" 6))
|
||||
|
||||
(hk-test
|
||||
"do-let multi-bind, used after"
|
||||
(hk-eval-expr-source
|
||||
"do\n let x = 4\n y = 5\n return (x * y)")
|
||||
(list "IO" 20))
|
||||
|
||||
(hk-test
|
||||
"do-let interleaved with bind"
|
||||
(hk-eval-expr-source
|
||||
"do\n x <- return 10\n let y = x + 1\n return (x * y)")
|
||||
(list "IO" 110))
|
||||
|
||||
;; ── Bind + pattern ──
|
||||
(hk-test
|
||||
"bind to constructor pattern"
|
||||
(hk-eval-expr-source
|
||||
"do\n Just x <- return (Just 7)\n return (x + 100)")
|
||||
(list "IO" 107))
|
||||
|
||||
(hk-test
|
||||
"bind to tuple pattern"
|
||||
(hk-eval-expr-source
|
||||
"do\n (a, b) <- return (3, 4)\n return (a * b)")
|
||||
(list "IO" 12))
|
||||
|
||||
;; ── User-defined IO functions ──
|
||||
(hk-test
|
||||
"do inside top-level fun"
|
||||
(hk-prog-val
|
||||
"addM x y = do\n a <- return x\n b <- return y\n return (a + b)\nresult = addM 5 6"
|
||||
"result")
|
||||
(list "IO" 11))
|
||||
|
||||
(hk-test
|
||||
"nested do"
|
||||
(hk-eval-expr-source
|
||||
"do\n x <- do { y <- return 3 ; return (y + 1) }\n return (x * 2)")
|
||||
(list "IO" 8))
|
||||
|
||||
;; ── (>>=) and (>>) used directly as functions ──
|
||||
(hk-test
|
||||
">>= used directly"
|
||||
(hk-eval-expr-source
|
||||
"(return 4) >>= (\\x -> return (x + 100))")
|
||||
(list "IO" 104))
|
||||
|
||||
(hk-test
|
||||
">> used directly"
|
||||
(hk-eval-expr-source
|
||||
"(return 1) >> (return 2)")
|
||||
(list "IO" 2))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,278 +0,0 @@
|
||||
;; Strict evaluator tests. Each test parses, desugars, and evaluates
|
||||
;; either an expression (hk-eval-expr-source) or a full program
|
||||
;; (hk-eval-program → look up a named value).
|
||||
|
||||
(define
|
||||
hk-prog-val
|
||||
(fn
|
||||
(src name)
|
||||
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||
|
||||
;; ── Literals ──
|
||||
(hk-test "int literal" (hk-eval-expr-source "42") 42)
|
||||
(hk-test "float literal" (hk-eval-expr-source "3.14") 3.14)
|
||||
(hk-test "string literal" (hk-eval-expr-source "\"hi\"") "hi")
|
||||
(hk-test "char literal" (hk-eval-expr-source "'a'") "a")
|
||||
(hk-test "negative literal" (hk-eval-expr-source "- 5") -5)
|
||||
|
||||
;; ── Arithmetic ──
|
||||
(hk-test "addition" (hk-eval-expr-source "1 + 2") 3)
|
||||
(hk-test
|
||||
"precedence"
|
||||
(hk-eval-expr-source "1 + 2 * 3")
|
||||
7)
|
||||
(hk-test
|
||||
"parens override precedence"
|
||||
(hk-eval-expr-source "(1 + 2) * 3")
|
||||
9)
|
||||
(hk-test
|
||||
"subtraction left-assoc"
|
||||
(hk-eval-expr-source "10 - 3 - 2")
|
||||
5)
|
||||
|
||||
;; ── Comparison + Bool ──
|
||||
(hk-test
|
||||
"less than is True"
|
||||
(hk-eval-expr-source "3 < 5")
|
||||
(list "True"))
|
||||
(hk-test
|
||||
"equality is False"
|
||||
(hk-eval-expr-source "1 == 2")
|
||||
(list "False"))
|
||||
(hk-test
|
||||
"&& shortcuts"
|
||||
(hk-eval-expr-source "(1 == 1) && (2 == 2)")
|
||||
(list "True"))
|
||||
|
||||
;; ── if / otherwise ──
|
||||
(hk-test
|
||||
"if True"
|
||||
(hk-eval-expr-source "if True then 1 else 2")
|
||||
1)
|
||||
(hk-test
|
||||
"if comparison branch"
|
||||
(hk-eval-expr-source "if 5 > 3 then \"yes\" else \"no\"")
|
||||
"yes")
|
||||
(hk-test "otherwise is True" (hk-eval-expr-source "otherwise") (list "True"))
|
||||
|
||||
;; ── let ──
|
||||
(hk-test
|
||||
"let single binding"
|
||||
(hk-eval-expr-source "let x = 5 in x + 1")
|
||||
6)
|
||||
(hk-test
|
||||
"let two bindings"
|
||||
(hk-eval-expr-source "let x = 1; y = 2 in x + y")
|
||||
3)
|
||||
(hk-test
|
||||
"let recursive: factorial 5"
|
||||
(hk-eval-expr-source
|
||||
"let f n = if n == 0 then 1 else n * f (n - 1) in f 5")
|
||||
120)
|
||||
|
||||
;; ── Lambdas ──
|
||||
(hk-test
|
||||
"lambda apply"
|
||||
(hk-eval-expr-source "(\\x -> x + 1) 5")
|
||||
6)
|
||||
(hk-test
|
||||
"lambda multi-arg"
|
||||
(hk-eval-expr-source "(\\x y -> x * y) 3 4")
|
||||
12)
|
||||
(hk-test
|
||||
"lambda with constructor pattern"
|
||||
(hk-eval-expr-source "(\\(Just x) -> x + 1) (Just 7)")
|
||||
8)
|
||||
|
||||
;; ── Constructors ──
|
||||
(hk-test
|
||||
"0-arity constructor"
|
||||
(hk-eval-expr-source "Nothing")
|
||||
(list "Nothing"))
|
||||
(hk-test
|
||||
"1-arity constructor applied"
|
||||
(hk-eval-expr-source "Just 5")
|
||||
(list "Just" 5))
|
||||
(hk-test
|
||||
"True / False as bools"
|
||||
(hk-eval-expr-source "True")
|
||||
(list "True"))
|
||||
|
||||
;; ── case ──
|
||||
(hk-test
|
||||
"case Just"
|
||||
(hk-eval-expr-source
|
||||
"case Just 7 of Just x -> x ; Nothing -> 0")
|
||||
7)
|
||||
(hk-test
|
||||
"case Nothing"
|
||||
(hk-eval-expr-source
|
||||
"case Nothing of Just x -> x ; Nothing -> 99")
|
||||
99)
|
||||
(hk-test
|
||||
"case literal pattern"
|
||||
(hk-eval-expr-source
|
||||
"case 0 of 0 -> \"zero\" ; n -> \"other\"")
|
||||
"zero")
|
||||
(hk-test
|
||||
"case tuple"
|
||||
(hk-eval-expr-source
|
||||
"case (1, 2) of (a, b) -> a + b")
|
||||
3)
|
||||
(hk-test
|
||||
"case wildcard fallback"
|
||||
(hk-eval-expr-source
|
||||
"case 5 of 0 -> \"z\" ; _ -> \"nz\"")
|
||||
"nz")
|
||||
|
||||
;; ── List literals + cons ──
|
||||
(hk-test
|
||||
"list literal as cons spine"
|
||||
(hk-eval-expr-source "[1, 2, 3]")
|
||||
(list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))
|
||||
(hk-test
|
||||
"empty list literal"
|
||||
(hk-eval-expr-source "[]")
|
||||
(list "[]"))
|
||||
(hk-test
|
||||
"cons via :"
|
||||
(hk-eval-expr-source "1 : []")
|
||||
(list ":" 1 (list "[]")))
|
||||
(hk-test
|
||||
"++ concatenates lists"
|
||||
(hk-eval-expr-source "[1, 2] ++ [3]")
|
||||
(list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))
|
||||
|
||||
;; ── Tuples ──
|
||||
(hk-test
|
||||
"2-tuple"
|
||||
(hk-eval-expr-source "(1, 2)")
|
||||
(list "Tuple" 1 2))
|
||||
(hk-test
|
||||
"3-tuple"
|
||||
(hk-eval-expr-source "(\"a\", 5, True)")
|
||||
(list "Tuple" "a" 5 (list "True")))
|
||||
|
||||
;; ── Sections ──
|
||||
(hk-test
|
||||
"right section (+ 1) applied"
|
||||
(hk-eval-expr-source "(+ 1) 5")
|
||||
6)
|
||||
(hk-test
|
||||
"left section (10 -) applied"
|
||||
(hk-eval-expr-source "(10 -) 4")
|
||||
6)
|
||||
|
||||
;; ── Multi-clause top-level functions ──
|
||||
(hk-test
|
||||
"multi-clause: factorial"
|
||||
(hk-prog-val
|
||||
"fact 0 = 1\nfact n = n * fact (n - 1)\nresult = fact 6"
|
||||
"result")
|
||||
720)
|
||||
|
||||
(hk-test
|
||||
"multi-clause: list length via cons pattern"
|
||||
(hk-prog-val
|
||||
"len [] = 0\nlen (x:xs) = 1 + len xs\nresult = len [10, 20, 30, 40]"
|
||||
"result")
|
||||
4)
|
||||
|
||||
(hk-test
|
||||
"multi-clause: Maybe handler"
|
||||
(hk-prog-val
|
||||
"fromMaybe d Nothing = d\nfromMaybe _ (Just x) = x\nresult = fromMaybe 0 (Just 9)"
|
||||
"result")
|
||||
9)
|
||||
|
||||
(hk-test
|
||||
"multi-clause: Maybe with default"
|
||||
(hk-prog-val
|
||||
"fromMaybe d Nothing = d\nfromMaybe _ (Just x) = x\nresult = fromMaybe 0 Nothing"
|
||||
"result")
|
||||
0)
|
||||
|
||||
;; ── User-defined data and matching ──
|
||||
(hk-test
|
||||
"custom data with pattern match"
|
||||
(hk-prog-val
|
||||
"data Color = Red | Green | Blue\nname Red = \"red\"\nname Green = \"green\"\nname Blue = \"blue\"\nresult = name Green"
|
||||
"result")
|
||||
"green")
|
||||
|
||||
(hk-test
|
||||
"custom binary tree height"
|
||||
(hk-prog-val
|
||||
"data Tree = Leaf | Node Tree Tree\nh Leaf = 0\nh (Node l r) = 1 + max (h l) (h r)\nmax a b = if a > b then a else b\nresult = h (Node (Node Leaf Leaf) Leaf)"
|
||||
"result")
|
||||
2)
|
||||
|
||||
;; ── Currying ──
|
||||
(hk-test
|
||||
"partial application"
|
||||
(hk-prog-val
|
||||
"add x y = x + y\nadd5 = add 5\nresult = add5 7"
|
||||
"result")
|
||||
12)
|
||||
|
||||
;; ── Higher-order ──
|
||||
(hk-test
|
||||
"higher-order: function as arg"
|
||||
(hk-prog-val
|
||||
"twice f x = f (f x)\ninc x = x + 1\nresult = twice inc 10"
|
||||
"result")
|
||||
12)
|
||||
|
||||
;; ── Error built-in ──
|
||||
(hk-test
|
||||
"error short-circuits via if"
|
||||
(hk-eval-expr-source
|
||||
"if True then 1 else error \"unreachable\"")
|
||||
1)
|
||||
|
||||
;; ── Laziness: app args evaluate only when forced ──
|
||||
(hk-test
|
||||
"second arg never forced"
|
||||
(hk-eval-expr-source
|
||||
"(\\x y -> x) 1 (error \"never\")")
|
||||
1)
|
||||
|
||||
(hk-test
|
||||
"first arg never forced"
|
||||
(hk-eval-expr-source
|
||||
"(\\x y -> y) (error \"never\") 99")
|
||||
99)
|
||||
|
||||
(hk-test
|
||||
"constructor argument is lazy under wildcard pattern"
|
||||
(hk-eval-expr-source
|
||||
"case Just (error \"deeply\") of Just _ -> 7 ; Nothing -> 0")
|
||||
7)
|
||||
|
||||
(hk-test
|
||||
"lazy: const drops its second argument"
|
||||
(hk-prog-val
|
||||
"const x y = x\nresult = const 5 (error \"boom\")"
|
||||
"result")
|
||||
5)
|
||||
|
||||
(hk-test
|
||||
"lazy: head ignores tail"
|
||||
(hk-prog-val
|
||||
"myHead (x:_) = x\nresult = myHead (1 : (error \"tail\") : [])"
|
||||
"result")
|
||||
1)
|
||||
|
||||
(hk-test
|
||||
"lazy: Just on undefined evaluates only on force"
|
||||
(hk-prog-val
|
||||
"wrapped = Just (error \"oh no\")\nresult = case wrapped of Just _ -> True ; Nothing -> False"
|
||||
"result")
|
||||
(list "True"))
|
||||
|
||||
;; ── not / id built-ins ──
|
||||
(hk-test "not True" (hk-eval-expr-source "not True") (list "False"))
|
||||
(hk-test "not False" (hk-eval-expr-source "not False") (list "True"))
|
||||
(hk-test "id" (hk-eval-expr-source "id 42") 42)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,137 +0,0 @@
|
||||
;; Infinite structures + Prelude tests. The lazy `:` operator builds
|
||||
;; cons cells with thunked head/tail so recursive list-defining
|
||||
;; functions terminate when only a finite prefix is consumed.
|
||||
|
||||
(define
|
||||
hk-prog-val
|
||||
(fn
|
||||
(src name)
|
||||
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||
|
||||
(define hk-as-list
|
||||
(fn (xs)
|
||||
(cond
|
||||
((and (list? xs) (= (first xs) "[]")) (list))
|
||||
((and (list? xs) (= (first xs) ":"))
|
||||
(cons (nth xs 1) (hk-as-list (nth xs 2))))
|
||||
(:else xs))))
|
||||
|
||||
(define
|
||||
hk-eval-list
|
||||
(fn (src) (hk-as-list (hk-eval-expr-source src))))
|
||||
|
||||
;; ── Prelude basics ──
|
||||
(hk-test "head of literal" (hk-eval-expr-source "head [1, 2, 3]") 1)
|
||||
(hk-test
|
||||
"tail of literal"
|
||||
(hk-eval-list "tail [1, 2, 3]")
|
||||
(list 2 3))
|
||||
(hk-test "length" (hk-eval-expr-source "length [10, 20, 30, 40]") 4)
|
||||
(hk-test "length empty" (hk-eval-expr-source "length []") 0)
|
||||
(hk-test
|
||||
"map with section"
|
||||
(hk-eval-list "map (+ 1) [1, 2, 3]")
|
||||
(list 2 3 4))
|
||||
(hk-test
|
||||
"filter"
|
||||
(hk-eval-list "filter (\\x -> x > 2) [1, 2, 3, 4, 5]")
|
||||
(list 3 4 5))
|
||||
(hk-test
|
||||
"drop"
|
||||
(hk-eval-list "drop 2 [10, 20, 30, 40]")
|
||||
(list 30 40))
|
||||
(hk-test "fst" (hk-eval-expr-source "fst (7, 9)") 7)
|
||||
(hk-test "snd" (hk-eval-expr-source "snd (7, 9)") 9)
|
||||
(hk-test
|
||||
"zipWith"
|
||||
(hk-eval-list "zipWith plus [1, 2, 3] [10, 20, 30]")
|
||||
(list 11 22 33))
|
||||
|
||||
;; ── Infinite structures ──
|
||||
(hk-test
|
||||
"take from repeat"
|
||||
(hk-eval-list "take 5 (repeat 7)")
|
||||
(list 7 7 7 7 7))
|
||||
(hk-test
|
||||
"take 0 from repeat returns empty"
|
||||
(hk-eval-list "take 0 (repeat 7)")
|
||||
(list))
|
||||
(hk-test
|
||||
"take from iterate"
|
||||
(hk-eval-list "take 5 (iterate (\\x -> x + 1) 0)")
|
||||
(list 0 1 2 3 4))
|
||||
(hk-test
|
||||
"iterate with multiplication"
|
||||
(hk-eval-list "take 4 (iterate (\\x -> x * 2) 1)")
|
||||
(list 1 2 4 8))
|
||||
(hk-test
|
||||
"head of repeat"
|
||||
(hk-eval-expr-source "head (repeat 99)")
|
||||
99)
|
||||
|
||||
;; ── Fibonacci stream ──
|
||||
(hk-test
|
||||
"first 10 Fibonacci numbers"
|
||||
(hk-eval-list "take 10 fibs")
|
||||
(list 0 1 1 2 3 5 8 13 21 34))
|
||||
(hk-test
|
||||
"fib at position 8"
|
||||
(hk-eval-expr-source "head (drop 8 fibs)")
|
||||
21)
|
||||
|
||||
;; ── Building infinite structures in user code ──
|
||||
(hk-test
|
||||
"user-defined infinite ones"
|
||||
(hk-prog-val
|
||||
"ones = 1 : ones\nresult = take 6 ones"
|
||||
"result")
|
||||
(list ":" 1 (list ":" 1 (list ":" 1 (list ":" 1 (list ":" 1 (list ":" 1 (list "[]"))))))))
|
||||
|
||||
(hk-test
|
||||
"user-defined nats"
|
||||
(hk-prog-val
|
||||
"nats = naturalsFrom 1\nnaturalsFrom n = n : naturalsFrom (n + 1)\nresult = take 5 nats"
|
||||
"result")
|
||||
(list ":" 1 (list ":" 2 (list ":" 3 (list ":" 4 (list ":" 5 (list "[]")))))))
|
||||
|
||||
;; ── Range syntax ──
|
||||
(hk-test
|
||||
"finite range [1..5]"
|
||||
(hk-eval-list "[1..5]")
|
||||
(list 1 2 3 4 5))
|
||||
(hk-test
|
||||
"empty range when from > to"
|
||||
(hk-eval-list "[10..3]")
|
||||
(list))
|
||||
(hk-test
|
||||
"stepped range"
|
||||
(hk-eval-list "[1, 3..10]")
|
||||
(list 1 3 5 7 9))
|
||||
(hk-test
|
||||
"open range — head"
|
||||
(hk-eval-expr-source "head [1..]")
|
||||
1)
|
||||
(hk-test
|
||||
"open range — drop then head"
|
||||
(hk-eval-expr-source "head (drop 99 [1..])")
|
||||
100)
|
||||
(hk-test
|
||||
"open range — take 5"
|
||||
(hk-eval-list "take 5 [10..]")
|
||||
(list 10 11 12 13 14))
|
||||
|
||||
;; ── Composing Prelude functions ──
|
||||
(hk-test
|
||||
"map then filter"
|
||||
(hk-eval-list
|
||||
"filter (\\x -> x > 5) (map (\\x -> x * 2) [1, 2, 3, 4])")
|
||||
(list 6 8))
|
||||
|
||||
(hk-test
|
||||
"sum-via-foldless"
|
||||
(hk-prog-val
|
||||
"mySum [] = 0\nmySum (x:xs) = x + mySum xs\nresult = mySum (take 5 (iterate (\\x -> x + 1) 1))"
|
||||
"result")
|
||||
15)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,245 +0,0 @@
|
||||
;; Haskell layout-rule tests. hk-tokenizer + hk-layout produce a
|
||||
;; virtual-brace-annotated stream; these tests cover the algorithm
|
||||
;; from Haskell 98 §10.3 plus the pragmatic let/in single-line rule.
|
||||
|
||||
;; Convenience — tokenize, run layout, strip eof, keep :type/:value.
|
||||
(define
|
||||
hk-lay
|
||||
(fn
|
||||
(src)
|
||||
(map
|
||||
(fn (tok) {:value (get tok "value") :type (get tok "type")})
|
||||
(filter
|
||||
(fn (tok) (not (= (get tok "type") "eof")))
|
||||
(hk-layout (hk-tokenize src))))))
|
||||
|
||||
;; ── 1. Basics ──
|
||||
(hk-test
|
||||
"empty input produces empty module { }"
|
||||
(hk-lay "")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"single token → module open+close"
|
||||
(hk-lay "foo")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "foo" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"two top-level decls get vsemi between"
|
||||
(hk-lay "foo = 1\nbar = 2")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "foo" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "bar" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 2 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 2. Layout keywords — do / let / where / of ──
|
||||
(hk-test
|
||||
"do block with two stmts"
|
||||
(hk-lay "f = do\n x\n y")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"single-line let ... in"
|
||||
(hk-lay "let x = 1 in x")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "let" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "in" :type "reserved"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"where block with two bindings"
|
||||
(hk-lay "f = g\n where\n g = 1\n h = 2")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "g" :type "varid"}
|
||||
{:value "where" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "g" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "h" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 2 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"case … of with arms"
|
||||
(hk-lay "f x = case x of\n Just y -> y\n Nothing -> 0")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "case" :type "reserved"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "of" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "Just" :type "conid"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value "->" :type "reservedop"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "Nothing" :type "conid"}
|
||||
{:value "->" :type "reservedop"}
|
||||
{:value 0 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 3. Explicit braces disable layout ──
|
||||
(hk-test
|
||||
"explicit braces — no implicit vlbrace/vsemi/vrbrace inside"
|
||||
(hk-lay "do { x ; y }")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "lbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value ";" :type "semi"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value "}" :type "rbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 4. Dedent closes nested blocks ──
|
||||
(hk-test
|
||||
"dedent back to module level closes do block"
|
||||
(hk-lay "f = do\n x\n y\ng = 2")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "g" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 2 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"dedent closes inner let, emits vsemi at outer do level"
|
||||
(hk-lay "main = do\n let x = 1\n print x")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "main" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "let" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "print" :type "varid"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 5. Module header skips outer implicit open ──
|
||||
(hk-test
|
||||
"module M where — only where opens a block"
|
||||
(hk-lay "module M where\n f = 1")
|
||||
(list
|
||||
{:value "module" :type "reserved"}
|
||||
{:value "M" :type "conid"}
|
||||
{:value "where" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 6. Newlines are stripped ──
|
||||
(hk-test
|
||||
"newline tokens do not appear in output"
|
||||
(let
|
||||
((toks (hk-layout (hk-tokenize "foo\nbar"))))
|
||||
(every?
|
||||
(fn (t) (not (= (get t "type") "newline")))
|
||||
toks))
|
||||
true)
|
||||
|
||||
;; ── 7. Continuation — deeper indent does NOT emit vsemi ──
|
||||
(hk-test
|
||||
"line continuation (deeper indent) just merges"
|
||||
(hk-lay "foo = 1 +\n 2")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "foo" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "+" :type "varsym"}
|
||||
{:value 2 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 8. Stack closing at EOF ──
|
||||
(hk-test
|
||||
"EOF inside nested do closes all implicit blocks"
|
||||
(let
|
||||
((toks (hk-lay "main = do\n do\n x")))
|
||||
(let
|
||||
((n (len toks)))
|
||||
(list
|
||||
(get (nth toks (- n 1)) "type")
|
||||
(get (nth toks (- n 2)) "type")
|
||||
(get (nth toks (- n 3)) "type"))))
|
||||
(list "vrbrace" "vrbrace" "vrbrace"))
|
||||
|
||||
;; ── 9. Qualified-newline: x at deeper col than stack top does nothing ──
|
||||
(hk-test
|
||||
"mixed where + do"
|
||||
(hk-lay "f = do\n x\n where\n x = 1")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "where" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,256 +0,0 @@
|
||||
;; Pattern-matcher tests. The matcher takes (pat val env) and returns
|
||||
;; an extended env dict on success, or `nil` on failure. Constructor
|
||||
;; values are tagged lists (con-name first); tuples use the "Tuple"
|
||||
;; tag; lists use chained `:` cons with `[]` nil.
|
||||
|
||||
;; ── Atomic patterns ──
|
||||
(hk-test
|
||||
"wildcard always matches"
|
||||
(hk-match (list :p-wild) 42 (dict))
|
||||
(dict))
|
||||
|
||||
(hk-test
|
||||
"var binds value"
|
||||
(hk-match (list :p-var "x") 42 (dict))
|
||||
{:x 42})
|
||||
|
||||
(hk-test
|
||||
"var preserves prior env"
|
||||
(hk-match (list :p-var "y") 7 {:x 1})
|
||||
{:x 1 :y 7})
|
||||
|
||||
(hk-test
|
||||
"int literal matches equal"
|
||||
(hk-match (list :p-int 5) 5 (dict))
|
||||
(dict))
|
||||
|
||||
(hk-test
|
||||
"int literal fails on mismatch"
|
||||
(hk-match (list :p-int 5) 6 (dict))
|
||||
nil)
|
||||
|
||||
(hk-test
|
||||
"negative int literal matches"
|
||||
(hk-match (list :p-int -3) -3 (dict))
|
||||
(dict))
|
||||
|
||||
(hk-test
|
||||
"string literal matches"
|
||||
(hk-match (list :p-string "hi") "hi" (dict))
|
||||
(dict))
|
||||
|
||||
(hk-test
|
||||
"string literal fails"
|
||||
(hk-match (list :p-string "hi") "bye" (dict))
|
||||
nil)
|
||||
|
||||
(hk-test
|
||||
"char literal matches"
|
||||
(hk-match (list :p-char "a") "a" (dict))
|
||||
(dict))
|
||||
|
||||
;; ── Constructor patterns ──
|
||||
(hk-test
|
||||
"0-arity con matches"
|
||||
(hk-match
|
||||
(list :p-con "Nothing" (list))
|
||||
(hk-mk-con "Nothing" (list))
|
||||
(dict))
|
||||
(dict))
|
||||
|
||||
(hk-test
|
||||
"1-arity con matches and binds"
|
||||
(hk-match
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(hk-mk-con "Just" (list 9))
|
||||
(dict))
|
||||
{:y 9})
|
||||
|
||||
(hk-test
|
||||
"con name mismatch fails"
|
||||
(hk-match
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(hk-mk-con "Nothing" (list))
|
||||
(dict))
|
||||
nil)
|
||||
|
||||
(hk-test
|
||||
"con arity mismatch fails"
|
||||
(hk-match
|
||||
(list :p-con "Pair" (list (list :p-var "a") (list :p-var "b")))
|
||||
(hk-mk-con "Pair" (list 1))
|
||||
(dict))
|
||||
nil)
|
||||
|
||||
(hk-test
|
||||
"nested con: Just (Just x)"
|
||||
(hk-match
|
||||
(list
|
||||
:p-con
|
||||
"Just"
|
||||
(list
|
||||
(list
|
||||
:p-con
|
||||
"Just"
|
||||
(list (list :p-var "x")))))
|
||||
(hk-mk-con "Just" (list (hk-mk-con "Just" (list 42))))
|
||||
(dict))
|
||||
{:x 42})
|
||||
|
||||
;; ── Tuple patterns ──
|
||||
(hk-test
|
||||
"2-tuple matches and binds"
|
||||
(hk-match
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(hk-mk-tuple (list 10 20))
|
||||
(dict))
|
||||
{:a 10 :b 20})
|
||||
|
||||
(hk-test
|
||||
"tuple arity mismatch fails"
|
||||
(hk-match
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(hk-mk-tuple (list 10 20 30))
|
||||
(dict))
|
||||
nil)
|
||||
|
||||
;; ── List patterns ──
|
||||
(hk-test
|
||||
"[] pattern matches empty list"
|
||||
(hk-match (list :p-list (list)) (hk-mk-nil) (dict))
|
||||
(dict))
|
||||
|
||||
(hk-test
|
||||
"[] pattern fails on non-empty"
|
||||
(hk-match (list :p-list (list)) (hk-mk-list (list 1)) (dict))
|
||||
nil)
|
||||
|
||||
(hk-test
|
||||
"[a] pattern matches singleton"
|
||||
(hk-match
|
||||
(list :p-list (list (list :p-var "a")))
|
||||
(hk-mk-list (list 7))
|
||||
(dict))
|
||||
{:a 7})
|
||||
|
||||
(hk-test
|
||||
"[a, b] pattern matches pair-list and binds"
|
||||
(hk-match
|
||||
(list
|
||||
:p-list
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(hk-mk-list (list 1 2))
|
||||
(dict))
|
||||
{:a 1 :b 2})
|
||||
|
||||
(hk-test
|
||||
"[a, b] fails on too-long list"
|
||||
(hk-match
|
||||
(list
|
||||
:p-list
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(hk-mk-list (list 1 2 3))
|
||||
(dict))
|
||||
nil)
|
||||
|
||||
;; Cons-style infix pattern (which the parser produces as :p-con ":")
|
||||
(hk-test
|
||||
"cons (h:t) on non-empty list"
|
||||
(hk-match
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "h") (list :p-var "t")))
|
||||
(hk-mk-list (list 1 2 3))
|
||||
(dict))
|
||||
{:h 1 :t (list ":" 2 (list ":" 3 (list "[]")))})
|
||||
|
||||
(hk-test
|
||||
"cons fails on empty list"
|
||||
(hk-match
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "h") (list :p-var "t")))
|
||||
(hk-mk-nil)
|
||||
(dict))
|
||||
nil)
|
||||
|
||||
;; ── as patterns ──
|
||||
(hk-test
|
||||
"as binds whole + sub-pattern"
|
||||
(hk-match
|
||||
(list
|
||||
:p-as
|
||||
"all"
|
||||
(list :p-con "Just" (list (list :p-var "x"))))
|
||||
(hk-mk-con "Just" (list 99))
|
||||
(dict))
|
||||
{:all (list "Just" 99) :x 99})
|
||||
|
||||
(hk-test
|
||||
"as on wildcard binds whole"
|
||||
(hk-match
|
||||
(list :p-as "v" (list :p-wild))
|
||||
"anything"
|
||||
(dict))
|
||||
{:v "anything"})
|
||||
|
||||
(hk-test
|
||||
"as fails when sub-pattern fails"
|
||||
(hk-match
|
||||
(list
|
||||
:p-as
|
||||
"n"
|
||||
(list :p-con "Just" (list (list :p-var "x"))))
|
||||
(hk-mk-con "Nothing" (list))
|
||||
(dict))
|
||||
nil)
|
||||
|
||||
;; ── lazy ~ pattern (eager equivalent for now) ──
|
||||
(hk-test
|
||||
"lazy pattern eager-matches its inner"
|
||||
(hk-match
|
||||
(list :p-lazy (list :p-var "y"))
|
||||
42
|
||||
(dict))
|
||||
{:y 42})
|
||||
|
||||
;; ── Source-driven: parse a real Haskell pattern, match a value ──
|
||||
(hk-test
|
||||
"parsed pattern: Just x against Just 5"
|
||||
(hk-match
|
||||
(hk-parse-pat-source "Just x")
|
||||
(hk-mk-con "Just" (list 5))
|
||||
(dict))
|
||||
{:x 5})
|
||||
|
||||
(hk-test
|
||||
"parsed pattern: x : xs against [10, 20, 30]"
|
||||
(hk-match
|
||||
(hk-parse-pat-source "x : xs")
|
||||
(hk-mk-list (list 10 20 30))
|
||||
(dict))
|
||||
{:x 10 :xs (list ":" 20 (list ":" 30 (list "[]")))})
|
||||
|
||||
(hk-test
|
||||
"parsed pattern: (a, b) against (1, 2)"
|
||||
(hk-match
|
||||
(hk-parse-pat-source "(a, b)")
|
||||
(hk-mk-tuple (list 1 2))
|
||||
(dict))
|
||||
{:a 1 :b 2})
|
||||
|
||||
(hk-test
|
||||
"parsed pattern: n@(Just x) against Just 7"
|
||||
(hk-match
|
||||
(hk-parse-pat-source "n@(Just x)")
|
||||
(hk-mk-con "Just" (list 7))
|
||||
(dict))
|
||||
{:n (list "Just" 7) :x 7})
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -3,8 +3,60 @@
|
||||
;; Lightweight runner: each test checks actual vs expected with
|
||||
;; structural (deep) equality and accumulates pass/fail counters.
|
||||
;; Final value of this file is a summary dict with :pass :fail :fails.
|
||||
;; The hk-test / hk-deep=? helpers live in lib/haskell/testlib.sx
|
||||
;; and are preloaded by lib/haskell/test.sh.
|
||||
|
||||
(define
|
||||
hk-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((= a b) true)
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ak (keys a)) (bk (keys b)))
|
||||
(if
|
||||
(not (= (len ak) (len bk)))
|
||||
false
|
||||
(every?
|
||||
(fn
|
||||
(k)
|
||||
(and (has-key? b k) (hk-deep=? (get a k) (get b k))))
|
||||
ak))))
|
||||
((and (list? a) (list? b))
|
||||
(if
|
||||
(not (= (len a) (len b)))
|
||||
false
|
||||
(let
|
||||
((i 0) (ok true))
|
||||
(define
|
||||
hk-de-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and ok (< i (len a)))
|
||||
(do
|
||||
(when
|
||||
(not (hk-deep=? (nth a i) (nth b i)))
|
||||
(set! ok false))
|
||||
(set! i (+ i 1))
|
||||
(hk-de-loop)))))
|
||||
(hk-de-loop)
|
||||
ok)))
|
||||
(:else false))))
|
||||
|
||||
(define hk-test-pass 0)
|
||||
(define hk-test-fail 0)
|
||||
(define hk-test-fails (list))
|
||||
|
||||
(define
|
||||
hk-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(hk-deep=? actual expected)
|
||||
(set! hk-test-pass (+ hk-test-pass 1))
|
||||
(do
|
||||
(set! hk-test-fail (+ hk-test-fail 1))
|
||||
(append! hk-test-fails {:actual actual :expected expected :name name})))))
|
||||
|
||||
;; Convenience: tokenize and drop newline + eof tokens so tests focus
|
||||
;; on meaningful content. Returns list of {:type :value} pairs.
|
||||
|
||||
@@ -1,278 +0,0 @@
|
||||
;; case-of and do-notation parser tests.
|
||||
;; Covers the minimal patterns needed to make these meaningful: var,
|
||||
;; wildcard, literal, constructor (with and without args), tuple, list.
|
||||
|
||||
;; ── Patterns (in case arms) ──
|
||||
(hk-test
|
||||
"wildcard pat"
|
||||
(hk-parse "case x of _ -> 0")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list (list :alt (list :p-wild) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"var pat"
|
||||
(hk-parse "case x of y -> y")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list :alt (list :p-var "y") (list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"0-arity constructor pat"
|
||||
(hk-parse "case x of\n Nothing -> 0\n Just y -> y")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list :alt (list :p-con "Nothing" (list)) (list :int 0))
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"int literal pat"
|
||||
(hk-parse "case n of\n 0 -> 1\n _ -> n")
|
||||
(list
|
||||
:case
|
||||
(list :var "n")
|
||||
(list
|
||||
(list :alt (list :p-int 0) (list :int 1))
|
||||
(list :alt (list :p-wild) (list :var "n")))))
|
||||
|
||||
(hk-test
|
||||
"string literal pat"
|
||||
(hk-parse "case s of\n \"hi\" -> 1\n _ -> 0")
|
||||
(list
|
||||
:case
|
||||
(list :var "s")
|
||||
(list
|
||||
(list :alt (list :p-string "hi") (list :int 1))
|
||||
(list :alt (list :p-wild) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"tuple pat"
|
||||
(hk-parse "case p of (a, b) -> a")
|
||||
(list
|
||||
:case
|
||||
(list :var "p")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "a")))))
|
||||
|
||||
(hk-test
|
||||
"list pat"
|
||||
(hk-parse "case xs of\n [] -> 0\n [a] -> a")
|
||||
(list
|
||||
:case
|
||||
(list :var "xs")
|
||||
(list
|
||||
(list :alt (list :p-list (list)) (list :int 0))
|
||||
(list
|
||||
:alt
|
||||
(list :p-list (list (list :p-var "a")))
|
||||
(list :var "a")))))
|
||||
|
||||
(hk-test
|
||||
"nested constructor pat"
|
||||
(hk-parse "case x of\n Just (a, b) -> a\n _ -> 0")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
"Just"
|
||||
(list
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))))
|
||||
(list :var "a"))
|
||||
(list :alt (list :p-wild) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"constructor with multiple var args"
|
||||
(hk-parse "case t of Pair a b -> a")
|
||||
(list
|
||||
:case
|
||||
(list :var "t")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
"Pair"
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "a")))))
|
||||
|
||||
;; ── case-of shapes ──
|
||||
(hk-test
|
||||
"case with explicit braces"
|
||||
(hk-parse "case x of { Just y -> y ; Nothing -> 0 }")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list :var "y"))
|
||||
(list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"case scrutinee is a full expression"
|
||||
(hk-parse "case f x + 1 of\n y -> y")
|
||||
(list
|
||||
:case
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :app (list :var "f") (list :var "x"))
|
||||
(list :int 1))
|
||||
(list (list :alt (list :p-var "y") (list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"case arm body is full expression"
|
||||
(hk-parse "case x of\n Just y -> y + 1")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list :op "+" (list :var "y") (list :int 1))))))
|
||||
|
||||
;; ── do blocks ──
|
||||
(hk-test
|
||||
"do with two expressions"
|
||||
(hk-parse "do\n putStrLn \"hi\"\n return 0")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "putStrLn") (list :string "hi")))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "return") (list :int 0))))))
|
||||
|
||||
(hk-test
|
||||
"do with bind"
|
||||
(hk-parse "do\n x <- getLine\n putStrLn x")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list :do-bind (list :p-var "x") (list :var "getLine"))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "putStrLn") (list :var "x"))))))
|
||||
|
||||
(hk-test
|
||||
"do with let"
|
||||
(hk-parse "do\n let y = 5\n print y")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-let
|
||||
(list (list :bind (list :p-var "y") (list :int 5))))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "print") (list :var "y"))))))
|
||||
|
||||
(hk-test
|
||||
"do with multiple let bindings"
|
||||
(hk-parse "do\n let x = 1\n y = 2\n print (x + y)")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-let
|
||||
(list
|
||||
(list :bind (list :p-var "x") (list :int 1))
|
||||
(list :bind (list :p-var "y") (list :int 2))))
|
||||
(list
|
||||
:do-expr
|
||||
(list
|
||||
:app
|
||||
(list :var "print")
|
||||
(list :op "+" (list :var "x") (list :var "y")))))))
|
||||
|
||||
(hk-test
|
||||
"do with bind using constructor pat"
|
||||
(hk-parse "do\n Just x <- getMaybe\n return x")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-bind
|
||||
(list :p-con "Just" (list (list :p-var "x")))
|
||||
(list :var "getMaybe"))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "return") (list :var "x"))))))
|
||||
|
||||
(hk-test
|
||||
"do with explicit braces"
|
||||
(hk-parse "do { x <- a ; y <- b ; return (x + y) }")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list :do-bind (list :p-var "x") (list :var "a"))
|
||||
(list :do-bind (list :p-var "y") (list :var "b"))
|
||||
(list
|
||||
:do-expr
|
||||
(list
|
||||
:app
|
||||
(list :var "return")
|
||||
(list :op "+" (list :var "x") (list :var "y")))))))
|
||||
|
||||
;; ── Mixing case/do inside expressions ──
|
||||
(hk-test
|
||||
"case inside let"
|
||||
(hk-parse "let f = \\x -> case x of\n Just y -> y\n _ -> 0\nin f 5")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list :p-var "f")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list :var "y"))
|
||||
(list :alt (list :p-wild) (list :int 0)))))))
|
||||
(list :app (list :var "f") (list :int 5))))
|
||||
|
||||
(hk-test
|
||||
"lambda containing do"
|
||||
(hk-parse "\\x -> do\n y <- x\n return y")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list :do-bind (list :p-var "y") (list :var "x"))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "return") (list :var "y")))))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,273 +0,0 @@
|
||||
;; Top-level declarations: function clauses, type signatures, data,
|
||||
;; type, newtype, fixity. Driven by hk-parse-top which produces
|
||||
;; a (:program DECLS) node.
|
||||
|
||||
(define
|
||||
hk-prog
|
||||
(fn
|
||||
(&rest decls)
|
||||
(list :program decls)))
|
||||
|
||||
;; ── Function clauses & pattern bindings ──
|
||||
(hk-test
|
||||
"simple fun-clause"
|
||||
(hk-parse-top "f x = x + 1")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list :op "+" (list :var "x") (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"nullary decl"
|
||||
(hk-parse-top "answer = 42")
|
||||
(hk-prog
|
||||
(list :fun-clause "answer" (list) (list :int 42))))
|
||||
|
||||
(hk-test
|
||||
"multi-clause fn (separate defs for each pattern)"
|
||||
(hk-parse-top "fact 0 = 1\nfact n = n")
|
||||
(hk-prog
|
||||
(list :fun-clause "fact" (list (list :p-int 0)) (list :int 1))
|
||||
(list
|
||||
:fun-clause
|
||||
"fact"
|
||||
(list (list :p-var "n"))
|
||||
(list :var "n"))))
|
||||
|
||||
(hk-test
|
||||
"constructor pattern in fn args"
|
||||
(hk-parse-top "fromJust (Just x) = x")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"fromJust"
|
||||
(list (list :p-con "Just" (list (list :p-var "x"))))
|
||||
(list :var "x"))))
|
||||
|
||||
(hk-test
|
||||
"pattern binding at top level"
|
||||
(hk-parse-top "(a, b) = pair")
|
||||
(hk-prog
|
||||
(list
|
||||
:pat-bind
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "pair"))))
|
||||
|
||||
;; ── Type signatures ──
|
||||
(hk-test
|
||||
"single-name sig"
|
||||
(hk-parse-top "f :: Int -> Int")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "f")
|
||||
(list :t-fun (list :t-con "Int") (list :t-con "Int")))))
|
||||
|
||||
(hk-test
|
||||
"multi-name sig"
|
||||
(hk-parse-top "f, g, h :: Int -> Bool")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "f" "g" "h")
|
||||
(list :t-fun (list :t-con "Int") (list :t-con "Bool")))))
|
||||
|
||||
(hk-test
|
||||
"sig with type application"
|
||||
(hk-parse-top "f :: Maybe a -> a")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "f")
|
||||
(list
|
||||
:t-fun
|
||||
(list :t-app (list :t-con "Maybe") (list :t-var "a"))
|
||||
(list :t-var "a")))))
|
||||
|
||||
(hk-test
|
||||
"sig with list type"
|
||||
(hk-parse-top "len :: [a] -> Int")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "len")
|
||||
(list
|
||||
:t-fun
|
||||
(list :t-list (list :t-var "a"))
|
||||
(list :t-con "Int")))))
|
||||
|
||||
(hk-test
|
||||
"sig with tuple and right-assoc ->"
|
||||
(hk-parse-top "pair :: a -> b -> (a, b)")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "pair")
|
||||
(list
|
||||
:t-fun
|
||||
(list :t-var "a")
|
||||
(list
|
||||
:t-fun
|
||||
(list :t-var "b")
|
||||
(list
|
||||
:t-tuple
|
||||
(list (list :t-var "a") (list :t-var "b"))))))))
|
||||
|
||||
(hk-test
|
||||
"sig + implementation together"
|
||||
(hk-parse-top "id :: a -> a\nid x = x")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "id")
|
||||
(list :t-fun (list :t-var "a") (list :t-var "a")))
|
||||
(list
|
||||
:fun-clause
|
||||
"id"
|
||||
(list (list :p-var "x"))
|
||||
(list :var "x"))))
|
||||
|
||||
;; ── data declarations ──
|
||||
(hk-test
|
||||
"data Maybe"
|
||||
(hk-parse-top "data Maybe a = Nothing | Just a")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Maybe"
|
||||
(list "a")
|
||||
(list
|
||||
(list :con-def "Nothing" (list))
|
||||
(list :con-def "Just" (list (list :t-var "a")))))))
|
||||
|
||||
(hk-test
|
||||
"data Either"
|
||||
(hk-parse-top "data Either a b = Left a | Right b")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Either"
|
||||
(list "a" "b")
|
||||
(list
|
||||
(list :con-def "Left" (list (list :t-var "a")))
|
||||
(list :con-def "Right" (list (list :t-var "b")))))))
|
||||
|
||||
(hk-test
|
||||
"data with no type parameters"
|
||||
(hk-parse-top "data Bool = True | False")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Bool"
|
||||
(list)
|
||||
(list
|
||||
(list :con-def "True" (list))
|
||||
(list :con-def "False" (list))))))
|
||||
|
||||
(hk-test
|
||||
"recursive data type"
|
||||
(hk-parse-top "data Tree a = Leaf | Node (Tree a) a (Tree a)")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Tree"
|
||||
(list "a")
|
||||
(list
|
||||
(list :con-def "Leaf" (list))
|
||||
(list
|
||||
:con-def
|
||||
"Node"
|
||||
(list
|
||||
(list :t-app (list :t-con "Tree") (list :t-var "a"))
|
||||
(list :t-var "a")
|
||||
(list :t-app (list :t-con "Tree") (list :t-var "a"))))))))
|
||||
|
||||
;; ── type synonyms ──
|
||||
(hk-test
|
||||
"simple type synonym"
|
||||
(hk-parse-top "type Name = String")
|
||||
(hk-prog
|
||||
(list :type-syn "Name" (list) (list :t-con "String"))))
|
||||
|
||||
(hk-test
|
||||
"parameterised type synonym"
|
||||
(hk-parse-top "type Pair a = (a, a)")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-syn
|
||||
"Pair"
|
||||
(list "a")
|
||||
(list
|
||||
:t-tuple
|
||||
(list (list :t-var "a") (list :t-var "a"))))))
|
||||
|
||||
;; ── newtype ──
|
||||
(hk-test
|
||||
"newtype"
|
||||
(hk-parse-top "newtype Age = Age Int")
|
||||
(hk-prog (list :newtype "Age" (list) "Age" (list :t-con "Int"))))
|
||||
|
||||
(hk-test
|
||||
"parameterised newtype"
|
||||
(hk-parse-top "newtype Wrap a = Wrap a")
|
||||
(hk-prog
|
||||
(list :newtype "Wrap" (list "a") "Wrap" (list :t-var "a"))))
|
||||
|
||||
;; ── fixity declarations ──
|
||||
(hk-test
|
||||
"infixl with precedence"
|
||||
(hk-parse-top "infixl 5 +:, -:")
|
||||
(hk-prog (list :fixity "l" 5 (list "+:" "-:"))))
|
||||
|
||||
(hk-test
|
||||
"infixr"
|
||||
(hk-parse-top "infixr 9 .")
|
||||
(hk-prog (list :fixity "r" 9 (list "."))))
|
||||
|
||||
(hk-test
|
||||
"infix (non-assoc) default prec"
|
||||
(hk-parse-top "infix ==")
|
||||
(hk-prog (list :fixity "n" 9 (list "=="))))
|
||||
|
||||
(hk-test
|
||||
"fixity with backtick operator name"
|
||||
(hk-parse-top "infixl 7 `div`")
|
||||
(hk-prog (list :fixity "l" 7 (list "div"))))
|
||||
|
||||
;; ── Several decls combined ──
|
||||
(hk-test
|
||||
"mixed: data + sig + fn + type"
|
||||
(hk-parse-top "data Maybe a = Nothing | Just a\ntype Entry = Maybe Int\nf :: Entry -> Int\nf (Just x) = x\nf Nothing = 0")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Maybe"
|
||||
(list "a")
|
||||
(list
|
||||
(list :con-def "Nothing" (list))
|
||||
(list :con-def "Just" (list (list :t-var "a")))))
|
||||
(list
|
||||
:type-syn
|
||||
"Entry"
|
||||
(list)
|
||||
(list :t-app (list :t-con "Maybe") (list :t-con "Int")))
|
||||
(list
|
||||
:type-sig
|
||||
(list "f")
|
||||
(list :t-fun (list :t-con "Entry") (list :t-con "Int")))
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-con "Just" (list (list :p-var "x"))))
|
||||
(list :var "x"))
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-con "Nothing" (list)))
|
||||
(list :int 0))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,258 +0,0 @@
|
||||
;; Haskell expression parser tests.
|
||||
;; hk-parse tokenises, runs layout, then parses. Output is an AST
|
||||
;; whose head is a keyword tag (evaluates to its string name).
|
||||
|
||||
;; ── 1. Literals ──
|
||||
(hk-test "integer" (hk-parse "42") (list :int 42))
|
||||
(hk-test "float" (hk-parse "3.14") (list :float 3.14))
|
||||
(hk-test "string" (hk-parse "\"hi\"") (list :string "hi"))
|
||||
(hk-test "char" (hk-parse "'a'") (list :char "a"))
|
||||
|
||||
;; ── 2. Variables and constructors ──
|
||||
(hk-test "varid" (hk-parse "foo") (list :var "foo"))
|
||||
(hk-test "conid" (hk-parse "Nothing") (list :con "Nothing"))
|
||||
(hk-test "qvarid" (hk-parse "Data.Map.lookup") (list :var "Data.Map.lookup"))
|
||||
(hk-test "qconid" (hk-parse "Data.Map") (list :con "Data.Map"))
|
||||
|
||||
;; ── 3. Parens / unit / tuple ──
|
||||
(hk-test "parens strip" (hk-parse "(42)") (list :int 42))
|
||||
(hk-test "unit" (hk-parse "()") (list :con "()"))
|
||||
(hk-test
|
||||
"2-tuple"
|
||||
(hk-parse "(1, 2)")
|
||||
(list :tuple (list (list :int 1) (list :int 2))))
|
||||
(hk-test
|
||||
"3-tuple"
|
||||
(hk-parse "(x, y, z)")
|
||||
(list
|
||||
:tuple
|
||||
(list (list :var "x") (list :var "y") (list :var "z"))))
|
||||
|
||||
;; ── 4. Lists ──
|
||||
(hk-test "empty list" (hk-parse "[]") (list :list (list)))
|
||||
(hk-test
|
||||
"singleton list"
|
||||
(hk-parse "[1]")
|
||||
(list :list (list (list :int 1))))
|
||||
(hk-test
|
||||
"list of ints"
|
||||
(hk-parse "[1, 2, 3]")
|
||||
(list
|
||||
:list
|
||||
(list (list :int 1) (list :int 2) (list :int 3))))
|
||||
(hk-test
|
||||
"range"
|
||||
(hk-parse "[1..10]")
|
||||
(list :range (list :int 1) (list :int 10)))
|
||||
(hk-test
|
||||
"range with step"
|
||||
(hk-parse "[1, 3..10]")
|
||||
(list
|
||||
:range-step
|
||||
(list :int 1)
|
||||
(list :int 3)
|
||||
(list :int 10)))
|
||||
|
||||
;; ── 5. Application ──
|
||||
(hk-test
|
||||
"one-arg app"
|
||||
(hk-parse "f x")
|
||||
(list :app (list :var "f") (list :var "x")))
|
||||
(hk-test
|
||||
"multi-arg app is left-assoc"
|
||||
(hk-parse "f x y z")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :app (list :var "f") (list :var "x"))
|
||||
(list :var "y"))
|
||||
(list :var "z")))
|
||||
(hk-test
|
||||
"app with con"
|
||||
(hk-parse "Just 5")
|
||||
(list :app (list :con "Just") (list :int 5)))
|
||||
|
||||
;; ── 6. Infix operators ──
|
||||
(hk-test
|
||||
"simple +"
|
||||
(hk-parse "1 + 2")
|
||||
(list :op "+" (list :int 1) (list :int 2)))
|
||||
(hk-test
|
||||
"precedence: * binds tighter than +"
|
||||
(hk-parse "1 + 2 * 3")
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :int 1)
|
||||
(list :op "*" (list :int 2) (list :int 3))))
|
||||
(hk-test
|
||||
"- is left-assoc"
|
||||
(hk-parse "10 - 3 - 2")
|
||||
(list
|
||||
:op
|
||||
"-"
|
||||
(list :op "-" (list :int 10) (list :int 3))
|
||||
(list :int 2)))
|
||||
(hk-test
|
||||
": is right-assoc"
|
||||
(hk-parse "a : b : c")
|
||||
(list
|
||||
:op
|
||||
":"
|
||||
(list :var "a")
|
||||
(list :op ":" (list :var "b") (list :var "c"))))
|
||||
(hk-test
|
||||
"app binds tighter than op"
|
||||
(hk-parse "f x + g y")
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :app (list :var "f") (list :var "x"))
|
||||
(list :app (list :var "g") (list :var "y"))))
|
||||
(hk-test
|
||||
"$ is lowest precedence, right-assoc"
|
||||
(hk-parse "f $ g x")
|
||||
(list
|
||||
:op
|
||||
"$"
|
||||
(list :var "f")
|
||||
(list :app (list :var "g") (list :var "x"))))
|
||||
|
||||
;; ── 7. Backticks (varid-as-operator) ──
|
||||
(hk-test
|
||||
"backtick operator"
|
||||
(hk-parse "x `mod` 3")
|
||||
(list :op "mod" (list :var "x") (list :int 3)))
|
||||
|
||||
;; ── 8. Unary negation ──
|
||||
(hk-test
|
||||
"unary -"
|
||||
(hk-parse "- 5")
|
||||
(list :neg (list :int 5)))
|
||||
(hk-test
|
||||
"unary - on application"
|
||||
(hk-parse "- f x")
|
||||
(list :neg (list :app (list :var "f") (list :var "x"))))
|
||||
(hk-test
|
||||
"- n + m → (- n) + m"
|
||||
(hk-parse "- 1 + 2")
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :neg (list :int 1))
|
||||
(list :int 2)))
|
||||
|
||||
;; ── 9. Lambda ──
|
||||
(hk-test
|
||||
"lambda single param"
|
||||
(hk-parse "\\x -> x")
|
||||
(list :lambda (list (list :p-var "x")) (list :var "x")))
|
||||
(hk-test
|
||||
"lambda multi-param"
|
||||
(hk-parse "\\x y -> x + y")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x") (list :p-var "y"))
|
||||
(list :op "+" (list :var "x") (list :var "y"))))
|
||||
(hk-test
|
||||
"lambda body is full expression"
|
||||
(hk-parse "\\f -> f 1 + f 2")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "f"))
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :app (list :var "f") (list :int 1))
|
||||
(list :app (list :var "f") (list :int 2)))))
|
||||
|
||||
;; ── 10. if-then-else ──
|
||||
(hk-test
|
||||
"if basic"
|
||||
(hk-parse "if x then 1 else 2")
|
||||
(list :if (list :var "x") (list :int 1) (list :int 2)))
|
||||
(hk-test
|
||||
"if with infix cond"
|
||||
(hk-parse "if x == 0 then y else z")
|
||||
(list
|
||||
:if
|
||||
(list :op "==" (list :var "x") (list :int 0))
|
||||
(list :var "y")
|
||||
(list :var "z")))
|
||||
|
||||
;; ── 11. let-in ──
|
||||
(hk-test
|
||||
"let single binding"
|
||||
(hk-parse "let x = 1 in x")
|
||||
(list
|
||||
:let
|
||||
(list (list :bind (list :p-var "x") (list :int 1)))
|
||||
(list :var "x")))
|
||||
(hk-test
|
||||
"let two bindings (multi-line)"
|
||||
(hk-parse "let x = 1\n y = 2\nin x + y")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list :bind (list :p-var "x") (list :int 1))
|
||||
(list :bind (list :p-var "y") (list :int 2)))
|
||||
(list :op "+" (list :var "x") (list :var "y"))))
|
||||
(hk-test
|
||||
"let with explicit braces"
|
||||
(hk-parse "let { x = 1 ; y = 2 } in x + y")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list :bind (list :p-var "x") (list :int 1))
|
||||
(list :bind (list :p-var "y") (list :int 2)))
|
||||
(list :op "+" (list :var "x") (list :var "y"))))
|
||||
|
||||
;; ── 12. Mixed / nesting ──
|
||||
(hk-test
|
||||
"nested application"
|
||||
(hk-parse "f (g x) y")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "f")
|
||||
(list :app (list :var "g") (list :var "x")))
|
||||
(list :var "y")))
|
||||
(hk-test
|
||||
"lambda applied"
|
||||
(hk-parse "(\\x -> x + 1) 5")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list :op "+" (list :var "x") (list :int 1)))
|
||||
(list :int 5)))
|
||||
(hk-test
|
||||
"lambda + if"
|
||||
(hk-parse "\\n -> if n == 0 then 1 else n")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "n"))
|
||||
(list
|
||||
:if
|
||||
(list :op "==" (list :var "n") (list :int 0))
|
||||
(list :int 1)
|
||||
(list :var "n"))))
|
||||
|
||||
;; ── 13. Precedence corners ──
|
||||
(hk-test
|
||||
". is right-assoc (prec 9)"
|
||||
(hk-parse "f . g . h")
|
||||
(list
|
||||
:op
|
||||
"."
|
||||
(list :var "f")
|
||||
(list :op "." (list :var "g") (list :var "h"))))
|
||||
(hk-test
|
||||
"== is non-associative (single use)"
|
||||
(hk-parse "x == y")
|
||||
(list :op "==" (list :var "x") (list :var "y")))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,261 +0,0 @@
|
||||
;; Guards and where-clauses — on fun-clauses, case alts, and
|
||||
;; let-bindings (which now also accept funclause-style LHS like
|
||||
;; `let f x = e` or `let f x | g = e | g = e`).
|
||||
|
||||
(define
|
||||
hk-prog
|
||||
(fn (&rest decls) (list :program decls)))
|
||||
|
||||
;; ── Guarded fun-clauses ──
|
||||
(hk-test
|
||||
"simple guards (two branches)"
|
||||
(hk-parse-top "abs x | x < 0 = - x\n | otherwise = x")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"abs"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:guarded
|
||||
(list
|
||||
(list
|
||||
:guard
|
||||
(list :op "<" (list :var "x") (list :int 0))
|
||||
(list :neg (list :var "x")))
|
||||
(list :guard (list :var "otherwise") (list :var "x")))))))
|
||||
|
||||
(hk-test
|
||||
"three-way guard"
|
||||
(hk-parse-top "sign n | n > 0 = 1\n | n < 0 = -1\n | otherwise = 0")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"sign"
|
||||
(list (list :p-var "n"))
|
||||
(list
|
||||
:guarded
|
||||
(list
|
||||
(list
|
||||
:guard
|
||||
(list :op ">" (list :var "n") (list :int 0))
|
||||
(list :int 1))
|
||||
(list
|
||||
:guard
|
||||
(list :op "<" (list :var "n") (list :int 0))
|
||||
(list :neg (list :int 1)))
|
||||
(list
|
||||
:guard
|
||||
(list :var "otherwise")
|
||||
(list :int 0)))))))
|
||||
|
||||
(hk-test
|
||||
"mixed: one eq clause plus one guarded clause"
|
||||
(hk-parse-top "sign 0 = 0\nsign n | n > 0 = 1\n | otherwise = -1")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"sign"
|
||||
(list (list :p-int 0))
|
||||
(list :int 0))
|
||||
(list
|
||||
:fun-clause
|
||||
"sign"
|
||||
(list (list :p-var "n"))
|
||||
(list
|
||||
:guarded
|
||||
(list
|
||||
(list
|
||||
:guard
|
||||
(list :op ">" (list :var "n") (list :int 0))
|
||||
(list :int 1))
|
||||
(list
|
||||
:guard
|
||||
(list :var "otherwise")
|
||||
(list :neg (list :int 1))))))))
|
||||
|
||||
;; ── where on fun-clauses ──
|
||||
(hk-test
|
||||
"where with one binding"
|
||||
(hk-parse-top "f x = y + y\n where y = x + 1")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:where
|
||||
(list :op "+" (list :var "y") (list :var "y"))
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"y"
|
||||
(list)
|
||||
(list :op "+" (list :var "x") (list :int 1))))))))
|
||||
|
||||
(hk-test
|
||||
"where with multiple bindings"
|
||||
(hk-parse-top "f x = y * z\n where y = x + 1\n z = x - 1")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:where
|
||||
(list :op "*" (list :var "y") (list :var "z"))
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"y"
|
||||
(list)
|
||||
(list :op "+" (list :var "x") (list :int 1)))
|
||||
(list
|
||||
:fun-clause
|
||||
"z"
|
||||
(list)
|
||||
(list :op "-" (list :var "x") (list :int 1))))))))
|
||||
|
||||
(hk-test
|
||||
"guards + where"
|
||||
(hk-parse-top "f x | x > 0 = y\n | otherwise = 0\n where y = 99")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:where
|
||||
(list
|
||||
:guarded
|
||||
(list
|
||||
(list
|
||||
:guard
|
||||
(list :op ">" (list :var "x") (list :int 0))
|
||||
(list :var "y"))
|
||||
(list
|
||||
:guard
|
||||
(list :var "otherwise")
|
||||
(list :int 0))))
|
||||
(list
|
||||
(list :fun-clause "y" (list) (list :int 99)))))))
|
||||
|
||||
;; ── Guards in case alts ──
|
||||
(hk-test
|
||||
"case alt with guards"
|
||||
(hk-parse "case x of\n Just y | y > 0 -> y\n | otherwise -> 0\n Nothing -> 0")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list
|
||||
:guarded
|
||||
(list
|
||||
(list
|
||||
:guard
|
||||
(list :op ">" (list :var "y") (list :int 0))
|
||||
(list :var "y"))
|
||||
(list
|
||||
:guard
|
||||
(list :var "otherwise")
|
||||
(list :int 0)))))
|
||||
(list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"case alt with where"
|
||||
(hk-parse "case x of\n Just y -> y + z where z = 5\n Nothing -> 0")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list
|
||||
:where
|
||||
(list :op "+" (list :var "y") (list :var "z"))
|
||||
(list
|
||||
(list :fun-clause "z" (list) (list :int 5)))))
|
||||
(list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
|
||||
|
||||
;; ── let-bindings: funclause form, guards, where ──
|
||||
(hk-test
|
||||
"let with funclause shorthand"
|
||||
(hk-parse "let f x = x + 1 in f 5")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list :op "+" (list :var "x") (list :int 1))))
|
||||
(list :app (list :var "f") (list :int 5))))
|
||||
|
||||
(hk-test
|
||||
"let with guards"
|
||||
(hk-parse "let f x | x > 0 = x\n | otherwise = 0\nin f 3")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:guarded
|
||||
(list
|
||||
(list
|
||||
:guard
|
||||
(list :op ">" (list :var "x") (list :int 0))
|
||||
(list :var "x"))
|
||||
(list
|
||||
:guard
|
||||
(list :var "otherwise")
|
||||
(list :int 0))))))
|
||||
(list :app (list :var "f") (list :int 3))))
|
||||
|
||||
(hk-test
|
||||
"let funclause + where"
|
||||
(hk-parse "let f x = y where y = x + 1\nin f 7")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:where
|
||||
(list :var "y")
|
||||
(list
|
||||
(list
|
||||
:fun-clause
|
||||
"y"
|
||||
(list)
|
||||
(list :op "+" (list :var "x") (list :int 1)))))))
|
||||
(list :app (list :var "f") (list :int 7))))
|
||||
|
||||
;; ── Nested: where inside where (via recursive hk-parse-decl) ──
|
||||
(hk-test
|
||||
"where block can contain a type signature"
|
||||
(hk-parse-top "f x = y\n where y :: Int\n y = x")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:where
|
||||
(list :var "y")
|
||||
(list
|
||||
(list :type-sig (list "y") (list :t-con "Int"))
|
||||
(list
|
||||
:fun-clause
|
||||
"y"
|
||||
(list)
|
||||
(list :var "x")))))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,202 +0,0 @@
|
||||
;; Module header + imports. The parser switches from (:program DECLS)
|
||||
;; to (:module NAME EXPORTS IMPORTS DECLS) as soon as a module header
|
||||
;; or any `import` decl appears.
|
||||
|
||||
;; ── Module header ──
|
||||
(hk-test
|
||||
"simple module, no exports"
|
||||
(hk-parse-top "module M where\n f = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
nil
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"module with dotted name"
|
||||
(hk-parse-top "module Data.Map where\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"Data.Map"
|
||||
nil
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"module with empty export list"
|
||||
(hk-parse-top "module M () where\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
(list)
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"module with exports (var, tycon-all, tycon-with)"
|
||||
(hk-parse-top "module M (f, g, Maybe(..), List(Cons, Nil)) where\nf = 1\ng = 2")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
(list
|
||||
(list :ent-var "f")
|
||||
(list :ent-var "g")
|
||||
(list :ent-all "Maybe")
|
||||
(list :ent-with "List" (list "Cons" "Nil")))
|
||||
(list)
|
||||
(list
|
||||
(list :fun-clause "f" (list) (list :int 1))
|
||||
(list :fun-clause "g" (list) (list :int 2)))))
|
||||
|
||||
(hk-test
|
||||
"module export list including another module"
|
||||
(hk-parse-top "module M (module Foo, f) where\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
(list (list :ent-module "Foo") (list :ent-var "f"))
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"module export with operator"
|
||||
(hk-parse-top "module M ((+:), f) where\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
(list (list :ent-var "+:") (list :ent-var "f"))
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"empty module body"
|
||||
(hk-parse-top "module M where")
|
||||
(list :module "M" nil (list) (list)))
|
||||
|
||||
;; ── Imports ──
|
||||
(hk-test
|
||||
"plain import"
|
||||
(hk-parse-top "import Foo")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list (list :import false "Foo" nil nil))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"qualified import"
|
||||
(hk-parse-top "import qualified Data.Map")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list (list :import true "Data.Map" nil nil))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"import with alias"
|
||||
(hk-parse-top "import Data.Map as M")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list (list :import false "Data.Map" "M" nil))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"import with explicit list"
|
||||
(hk-parse-top "import Foo (bar, Baz(..), Quux(X, Y))")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list
|
||||
(list
|
||||
:import
|
||||
false
|
||||
"Foo"
|
||||
nil
|
||||
(list
|
||||
:spec-items
|
||||
(list
|
||||
(list :ent-var "bar")
|
||||
(list :ent-all "Baz")
|
||||
(list :ent-with "Quux" (list "X" "Y"))))))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"import hiding"
|
||||
(hk-parse-top "import Foo hiding (x, y)")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list
|
||||
(list
|
||||
:import
|
||||
false
|
||||
"Foo"
|
||||
nil
|
||||
(list
|
||||
:spec-hiding
|
||||
(list (list :ent-var "x") (list :ent-var "y")))))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"qualified + alias + hiding"
|
||||
(hk-parse-top "import qualified Data.List as L hiding (sort)")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list
|
||||
(list
|
||||
:import
|
||||
true
|
||||
"Data.List"
|
||||
"L"
|
||||
(list :spec-hiding (list (list :ent-var "sort")))))
|
||||
(list)))
|
||||
|
||||
;; ── Combinations ──
|
||||
(hk-test
|
||||
"module with multiple imports and a decl"
|
||||
(hk-parse-top "module M where\nimport Foo\nimport qualified Bar as B\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
nil
|
||||
(list
|
||||
(list :import false "Foo" nil nil)
|
||||
(list :import true "Bar" "B" nil))
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"headerless file with imports"
|
||||
(hk-parse-top "import Foo\nimport Bar (baz)\nf = 1")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list
|
||||
(list :import false "Foo" nil nil)
|
||||
(list
|
||||
:import
|
||||
false
|
||||
"Bar"
|
||||
nil
|
||||
(list :spec-items (list (list :ent-var "baz")))))
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"plain program (no header, no imports) still uses :program"
|
||||
(hk-parse-top "f = 1\ng = 2")
|
||||
(list
|
||||
:program
|
||||
(list
|
||||
(list :fun-clause "f" (list) (list :int 1))
|
||||
(list :fun-clause "g" (list) (list :int 2)))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,234 +0,0 @@
|
||||
;; Full-pattern parser tests: as-patterns, lazy ~, negative literals,
|
||||
;; infix constructor patterns (`:`, any consym), lambda pattern args,
|
||||
;; and let pattern-bindings.
|
||||
|
||||
;; ── as-patterns ──
|
||||
(hk-test
|
||||
"as pattern, wraps constructor"
|
||||
(hk-parse "case x of n@(Just y) -> n")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-as
|
||||
"n"
|
||||
(list :p-con "Just" (list (list :p-var "y"))))
|
||||
(list :var "n")))))
|
||||
|
||||
(hk-test
|
||||
"as pattern, wraps wildcard"
|
||||
(hk-parse "case x of all@_ -> all")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-as "all" (list :p-wild))
|
||||
(list :var "all")))))
|
||||
|
||||
(hk-test
|
||||
"as in lambda"
|
||||
(hk-parse "\\xs@(a : rest) -> xs")
|
||||
(list
|
||||
:lambda
|
||||
(list
|
||||
(list
|
||||
:p-as
|
||||
"xs"
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "a") (list :p-var "rest")))))
|
||||
(list :var "xs")))
|
||||
|
||||
;; ── lazy patterns ──
|
||||
(hk-test
|
||||
"lazy var"
|
||||
(hk-parse "case x of ~y -> y")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list :alt (list :p-lazy (list :p-var "y")) (list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"lazy constructor"
|
||||
(hk-parse "\\(~(Just x)) -> x")
|
||||
(list
|
||||
:lambda
|
||||
(list
|
||||
(list
|
||||
:p-lazy
|
||||
(list :p-con "Just" (list (list :p-var "x")))))
|
||||
(list :var "x")))
|
||||
|
||||
;; ── negative literal patterns ──
|
||||
(hk-test
|
||||
"negative int pattern"
|
||||
(hk-parse "case n of\n -1 -> 0\n _ -> n")
|
||||
(list
|
||||
:case
|
||||
(list :var "n")
|
||||
(list
|
||||
(list :alt (list :p-int -1) (list :int 0))
|
||||
(list :alt (list :p-wild) (list :var "n")))))
|
||||
|
||||
(hk-test
|
||||
"negative float pattern"
|
||||
(hk-parse "case x of -0.5 -> 1")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list (list :alt (list :p-float -0.5) (list :int 1)))))
|
||||
|
||||
;; ── infix constructor patterns (`:` and any consym) ──
|
||||
(hk-test
|
||||
"cons pattern"
|
||||
(hk-parse "case xs of x : rest -> x")
|
||||
(list
|
||||
:case
|
||||
(list :var "xs")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "x") (list :p-var "rest")))
|
||||
(list :var "x")))))
|
||||
|
||||
(hk-test
|
||||
"cons is right-associative in pats"
|
||||
(hk-parse "case xs of a : b : rest -> rest")
|
||||
(list
|
||||
:case
|
||||
(list :var "xs")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list
|
||||
(list :p-var "a")
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "b") (list :p-var "rest")))))
|
||||
(list :var "rest")))))
|
||||
|
||||
(hk-test
|
||||
"consym pattern"
|
||||
(hk-parse "case p of a :+: b -> a")
|
||||
(list
|
||||
:case
|
||||
(list :var "p")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
":+:"
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "a")))))
|
||||
|
||||
;; ── lambda with pattern args ──
|
||||
(hk-test
|
||||
"lambda with constructor pattern"
|
||||
(hk-parse "\\(Just x) -> x")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-con "Just" (list (list :p-var "x"))))
|
||||
(list :var "x")))
|
||||
|
||||
(hk-test
|
||||
"lambda with tuple pattern"
|
||||
(hk-parse "\\(a, b) -> a + b")
|
||||
(list
|
||||
:lambda
|
||||
(list
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b"))))
|
||||
(list :op "+" (list :var "a") (list :var "b"))))
|
||||
|
||||
(hk-test
|
||||
"lambda with wildcard"
|
||||
(hk-parse "\\_ -> 42")
|
||||
(list :lambda (list (list :p-wild)) (list :int 42)))
|
||||
|
||||
(hk-test
|
||||
"lambda with mixed apats"
|
||||
(hk-parse "\\x _ (Just y) -> y")
|
||||
(list
|
||||
:lambda
|
||||
(list
|
||||
(list :p-var "x")
|
||||
(list :p-wild)
|
||||
(list :p-con "Just" (list (list :p-var "y"))))
|
||||
(list :var "y")))
|
||||
|
||||
;; ── let pattern-bindings ──
|
||||
(hk-test
|
||||
"let tuple pattern-binding"
|
||||
(hk-parse "let (x, y) = pair in x + y")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "x") (list :p-var "y")))
|
||||
(list :var "pair")))
|
||||
(list :op "+" (list :var "x") (list :var "y"))))
|
||||
|
||||
(hk-test
|
||||
"let constructor pattern-binding"
|
||||
(hk-parse "let Just x = m in x")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list :p-con "Just" (list (list :p-var "x")))
|
||||
(list :var "m")))
|
||||
(list :var "x")))
|
||||
|
||||
(hk-test
|
||||
"let cons pattern-binding"
|
||||
(hk-parse "let (x : rest) = xs in x")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "x") (list :p-var "rest")))
|
||||
(list :var "xs")))
|
||||
(list :var "x")))
|
||||
|
||||
;; ── do with constructor-pattern binds ──
|
||||
(hk-test
|
||||
"do bind to tuple pattern"
|
||||
(hk-parse "do\n (a, b) <- pairs\n return a")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-bind
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "pairs"))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "return") (list :var "a"))))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,191 +0,0 @@
|
||||
;; Operator sections and list comprehensions.
|
||||
|
||||
;; ── Operator references (unchanged expr shape) ──
|
||||
(hk-test
|
||||
"op as value (+)"
|
||||
(hk-parse "(+)")
|
||||
(list :var "+"))
|
||||
|
||||
(hk-test
|
||||
"op as value (-)"
|
||||
(hk-parse "(-)")
|
||||
(list :var "-"))
|
||||
|
||||
(hk-test
|
||||
"op as value (:)"
|
||||
(hk-parse "(:)")
|
||||
(list :var ":"))
|
||||
|
||||
(hk-test
|
||||
"backtick op as value"
|
||||
(hk-parse "(`div`)")
|
||||
(list :var "div"))
|
||||
|
||||
;; ── Right sections (op expr) ──
|
||||
(hk-test
|
||||
"right section (+ 5)"
|
||||
(hk-parse "(+ 5)")
|
||||
(list :sect-right "+" (list :int 5)))
|
||||
|
||||
(hk-test
|
||||
"right section (* x)"
|
||||
(hk-parse "(* x)")
|
||||
(list :sect-right "*" (list :var "x")))
|
||||
|
||||
(hk-test
|
||||
"right section with backtick op"
|
||||
(hk-parse "(`div` 2)")
|
||||
(list :sect-right "div" (list :int 2)))
|
||||
|
||||
;; `-` is unary in expr position — (- 5) is negation, not a right section
|
||||
(hk-test
|
||||
"(- 5) is negation, not a section"
|
||||
(hk-parse "(- 5)")
|
||||
(list :neg (list :int 5)))
|
||||
|
||||
;; ── Left sections (expr op) ──
|
||||
(hk-test
|
||||
"left section (5 +)"
|
||||
(hk-parse "(5 +)")
|
||||
(list :sect-left "+" (list :int 5)))
|
||||
|
||||
(hk-test
|
||||
"left section with backtick"
|
||||
(hk-parse "(x `mod`)")
|
||||
(list :sect-left "mod" (list :var "x")))
|
||||
|
||||
(hk-test
|
||||
"left section with cons (x :)"
|
||||
(hk-parse "(x :)")
|
||||
(list :sect-left ":" (list :var "x")))
|
||||
|
||||
;; ── Mixed / nesting ──
|
||||
(hk-test
|
||||
"map (+ 1) xs"
|
||||
(hk-parse "map (+ 1) xs")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "map")
|
||||
(list :sect-right "+" (list :int 1)))
|
||||
(list :var "xs")))
|
||||
|
||||
(hk-test
|
||||
"filter (< 0) xs"
|
||||
(hk-parse "filter (< 0) xs")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "filter")
|
||||
(list :sect-right "<" (list :int 0)))
|
||||
(list :var "xs")))
|
||||
|
||||
;; ── Plain parens and tuples still work ──
|
||||
(hk-test
|
||||
"plain parens unwrap"
|
||||
(hk-parse "(1 + 2)")
|
||||
(list :op "+" (list :int 1) (list :int 2)))
|
||||
|
||||
(hk-test
|
||||
"tuple still parses"
|
||||
(hk-parse "(a, b, c)")
|
||||
(list
|
||||
:tuple
|
||||
(list (list :var "a") (list :var "b") (list :var "c"))))
|
||||
|
||||
;; ── List comprehensions ──
|
||||
(hk-test
|
||||
"simple list comprehension"
|
||||
(hk-parse "[x | x <- xs]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :var "x")
|
||||
(list
|
||||
(list :q-gen (list :p-var "x") (list :var "xs")))))
|
||||
|
||||
(hk-test
|
||||
"comprehension with filter"
|
||||
(hk-parse "[x * 2 | x <- xs, x > 0]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :op "*" (list :var "x") (list :int 2))
|
||||
(list
|
||||
(list :q-gen (list :p-var "x") (list :var "xs"))
|
||||
(list
|
||||
:q-guard
|
||||
(list :op ">" (list :var "x") (list :int 0))))))
|
||||
|
||||
(hk-test
|
||||
"comprehension with let"
|
||||
(hk-parse "[y | x <- xs, let y = x + 1]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :var "y")
|
||||
(list
|
||||
(list :q-gen (list :p-var "x") (list :var "xs"))
|
||||
(list
|
||||
:q-let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list :p-var "y")
|
||||
(list :op "+" (list :var "x") (list :int 1))))))))
|
||||
|
||||
(hk-test
|
||||
"nested generators"
|
||||
(hk-parse "[(x, y) | x <- xs, y <- ys]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :tuple (list (list :var "x") (list :var "y")))
|
||||
(list
|
||||
(list :q-gen (list :p-var "x") (list :var "xs"))
|
||||
(list :q-gen (list :p-var "y") (list :var "ys")))))
|
||||
|
||||
(hk-test
|
||||
"comprehension with constructor pattern"
|
||||
(hk-parse "[v | Just v <- xs]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :var "v")
|
||||
(list
|
||||
(list
|
||||
:q-gen
|
||||
(list :p-con "Just" (list (list :p-var "v")))
|
||||
(list :var "xs")))))
|
||||
|
||||
(hk-test
|
||||
"comprehension with tuple pattern"
|
||||
(hk-parse "[x + y | (x, y) <- pairs]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :op "+" (list :var "x") (list :var "y"))
|
||||
(list
|
||||
(list
|
||||
:q-gen
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "x") (list :p-var "y")))
|
||||
(list :var "pairs")))))
|
||||
|
||||
(hk-test
|
||||
"combination: generator, let, guard"
|
||||
(hk-parse "[z | x <- xs, let z = x * 2, z > 10]")
|
||||
(list
|
||||
:list-comp
|
||||
(list :var "z")
|
||||
(list
|
||||
(list :q-gen (list :p-var "x") (list :var "xs"))
|
||||
(list
|
||||
:q-let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list :p-var "z")
|
||||
(list :op "*" (list :var "x") (list :int 2)))))
|
||||
(list
|
||||
:q-guard
|
||||
(list :op ">" (list :var "z") (list :int 10))))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,45 +0,0 @@
|
||||
;; fib.hs — infinite Fibonacci stream classic program.
|
||||
;;
|
||||
;; The canonical artefact lives at lib/haskell/tests/programs/fib.hs.
|
||||
;; The source is mirrored here as an SX string because the evaluator
|
||||
;; doesn't have read-file in the default env. If you change one, keep
|
||||
;; the other in sync — there's a runner-level cross-check against the
|
||||
;; expected first-15 list.
|
||||
|
||||
(define
|
||||
hk-prog-val
|
||||
(fn
|
||||
(src name)
|
||||
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||
|
||||
(define hk-as-list
|
||||
(fn (xs)
|
||||
(cond
|
||||
((and (list? xs) (= (first xs) "[]")) (list))
|
||||
((and (list? xs) (= (first xs) ":"))
|
||||
(cons (nth xs 1) (hk-as-list (nth xs 2))))
|
||||
(:else xs))))
|
||||
|
||||
(define
|
||||
hk-fib-source
|
||||
"zipPlus (x:xs) (y:ys) = x + y : zipPlus xs ys
|
||||
zipPlus _ _ = []
|
||||
myFibs = 0 : 1 : zipPlus myFibs (tail myFibs)
|
||||
result = take 15 myFibs
|
||||
")
|
||||
|
||||
(hk-test
|
||||
"fib.hs — first 15 Fibonacci numbers"
|
||||
(hk-as-list (hk-prog-val hk-fib-source "result"))
|
||||
(list 0 1 1 2 3 5 8 13 21 34 55 89 144 233 377))
|
||||
|
||||
;; Spot-check that the user-defined zipPlus is also reachable
|
||||
(hk-test
|
||||
"fib.hs — zipPlus is a multi-clause user fn"
|
||||
(hk-as-list
|
||||
(hk-prog-val
|
||||
(str hk-fib-source "extra = zipPlus [1, 2, 3] [10, 20, 30]\n")
|
||||
"extra"))
|
||||
(list 11 22 33))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,15 +0,0 @@
|
||||
-- fib.hs — infinite Fibonacci stream.
|
||||
--
|
||||
-- The classic two-line definition: `fibs` is a self-referential
|
||||
-- lazy list built by zipping itself with its own tail, summing the
|
||||
-- pair at each step. Without lazy `:` (cons cell with thunked head
|
||||
-- and tail) this would diverge before producing any output; with
|
||||
-- it, `take 15 fibs` evaluates exactly as much of the spine as
|
||||
-- demanded.
|
||||
|
||||
zipPlus (x:xs) (y:ys) = x + y : zipPlus xs ys
|
||||
zipPlus _ _ = []
|
||||
|
||||
myFibs = 0 : 1 : zipPlus myFibs (tail myFibs)
|
||||
|
||||
result = take 15 myFibs
|
||||
@@ -1,127 +0,0 @@
|
||||
;; Runtime constructor-registry tests. Built-ins are pre-registered
|
||||
;; when lib/haskell/runtime.sx loads; user types are registered by
|
||||
;; walking a parsed+desugared AST with hk-register-program! (or the
|
||||
;; `hk-load-source!` convenience).
|
||||
|
||||
;; ── Pre-registered built-ins ──
|
||||
(hk-test "True is a con" (hk-is-con? "True") true)
|
||||
(hk-test "False is a con" (hk-is-con? "False") true)
|
||||
(hk-test "[] is a con" (hk-is-con? "[]") true)
|
||||
(hk-test ": (cons) is a con" (hk-is-con? ":") true)
|
||||
(hk-test "() is a con" (hk-is-con? "()") true)
|
||||
|
||||
(hk-test "True arity 0" (hk-con-arity "True") 0)
|
||||
(hk-test ": arity 2" (hk-con-arity ":") 2)
|
||||
(hk-test "[] arity 0" (hk-con-arity "[]") 0)
|
||||
(hk-test "True type Bool" (hk-con-type "True") "Bool")
|
||||
(hk-test "False type Bool" (hk-con-type "False") "Bool")
|
||||
(hk-test ": type List" (hk-con-type ":") "List")
|
||||
(hk-test "() type Unit" (hk-con-type "()") "Unit")
|
||||
|
||||
;; ── Unknown names ──
|
||||
(hk-test "is-con? false for varid" (hk-is-con? "foo") false)
|
||||
(hk-test "arity nil for unknown" (hk-con-arity "NotACon") nil)
|
||||
(hk-test "type nil for unknown" (hk-con-type "NotACon") nil)
|
||||
|
||||
;; ── data MyBool = Yes | No ──
|
||||
(hk-test
|
||||
"register simple data"
|
||||
(do
|
||||
(hk-load-source! "data MyBool = Yes | No")
|
||||
(list
|
||||
(hk-con-arity "Yes")
|
||||
(hk-con-arity "No")
|
||||
(hk-con-type "Yes")
|
||||
(hk-con-type "No")))
|
||||
(list 0 0 "MyBool" "MyBool"))
|
||||
|
||||
;; ── data Maybe a = Nothing | Just a ──
|
||||
(hk-test
|
||||
"register Maybe"
|
||||
(do
|
||||
(hk-load-source! "data Maybe a = Nothing | Just a")
|
||||
(list
|
||||
(hk-con-arity "Nothing")
|
||||
(hk-con-arity "Just")
|
||||
(hk-con-type "Nothing")
|
||||
(hk-con-type "Just")))
|
||||
(list 0 1 "Maybe" "Maybe"))
|
||||
|
||||
;; ── data Either a b = Left a | Right b ──
|
||||
(hk-test
|
||||
"register Either"
|
||||
(do
|
||||
(hk-load-source! "data Either a b = Left a | Right b")
|
||||
(list
|
||||
(hk-con-arity "Left")
|
||||
(hk-con-arity "Right")
|
||||
(hk-con-type "Left")
|
||||
(hk-con-type "Right")))
|
||||
(list 1 1 "Either" "Either"))
|
||||
|
||||
;; ── Recursive data ──
|
||||
(hk-test
|
||||
"register recursive Tree"
|
||||
(do
|
||||
(hk-load-source!
|
||||
"data Tree a = Leaf | Node (Tree a) a (Tree a)")
|
||||
(list
|
||||
(hk-con-arity "Leaf")
|
||||
(hk-con-arity "Node")
|
||||
(hk-con-type "Leaf")
|
||||
(hk-con-type "Node")))
|
||||
(list 0 3 "Tree" "Tree"))
|
||||
|
||||
;; ── newtype ──
|
||||
(hk-test
|
||||
"register newtype"
|
||||
(do
|
||||
(hk-load-source! "newtype Age = MkAge Int")
|
||||
(list
|
||||
(hk-con-arity "MkAge")
|
||||
(hk-con-type "MkAge")))
|
||||
(list 1 "Age"))
|
||||
|
||||
;; ── Multiple data decls in one program ──
|
||||
(hk-test
|
||||
"multiple data decls"
|
||||
(do
|
||||
(hk-load-source!
|
||||
"data Color = Red | Green | Blue\ndata Shape = Circle | Square\nf x = x")
|
||||
(list
|
||||
(hk-con-type "Red")
|
||||
(hk-con-type "Green")
|
||||
(hk-con-type "Blue")
|
||||
(hk-con-type "Circle")
|
||||
(hk-con-type "Square")))
|
||||
(list "Color" "Color" "Color" "Shape" "Shape"))
|
||||
|
||||
;; ── Inside a module header ──
|
||||
(hk-test
|
||||
"register from module body"
|
||||
(do
|
||||
(hk-load-source!
|
||||
"module M where\ndata Pair a = Pair a a")
|
||||
(list
|
||||
(hk-con-arity "Pair")
|
||||
(hk-con-type "Pair")))
|
||||
(list 2 "Pair"))
|
||||
|
||||
;; ── Non-data decls are ignored ──
|
||||
(hk-test
|
||||
"program with only fun-decl leaves registry unchanged for that name"
|
||||
(do
|
||||
(hk-load-source! "myFunctionNotACon x = x + 1")
|
||||
(hk-is-con? "myFunctionNotACon"))
|
||||
false)
|
||||
|
||||
;; ── Re-registering overwrites (last wins) ──
|
||||
(hk-test
|
||||
"re-registration overwrites the entry"
|
||||
(do
|
||||
(hk-load-source! "data Foo = Bar Int")
|
||||
(hk-load-source! "data Foo = Bar Int Int")
|
||||
(hk-con-arity "Bar"))
|
||||
2)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,85 +0,0 @@
|
||||
;; seq / deepseq tests. seq is strict in its first arg (forces to
|
||||
;; WHNF) and returns the second arg unchanged. deepseq additionally
|
||||
;; forces the first arg to normal form.
|
||||
|
||||
(define
|
||||
hk-prog-val
|
||||
(fn
|
||||
(src name)
|
||||
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||
|
||||
(define hk-as-list
|
||||
(fn (xs)
|
||||
(cond
|
||||
((and (list? xs) (= (first xs) "[]")) (list))
|
||||
((and (list? xs) (= (first xs) ":"))
|
||||
(cons (nth xs 1) (hk-as-list (nth xs 2))))
|
||||
(:else xs))))
|
||||
|
||||
(define
|
||||
hk-eval-list
|
||||
(fn (src) (hk-as-list (hk-eval-expr-source src))))
|
||||
|
||||
;; ── seq returns its second arg ──
|
||||
(hk-test
|
||||
"seq with primitive first arg"
|
||||
(hk-eval-expr-source "seq 1 99")
|
||||
99)
|
||||
|
||||
(hk-test
|
||||
"seq forces first arg via let"
|
||||
(hk-eval-expr-source "let x = 1 + 2 in seq x x")
|
||||
3)
|
||||
|
||||
(hk-test
|
||||
"seq second arg is whatever shape"
|
||||
(hk-eval-expr-source "seq 0 \"hello\"")
|
||||
"hello")
|
||||
|
||||
;; ── seq enables previously-lazy bottom to be forced ──
|
||||
;; Without seq the let-binding `x = error …` is never forced;
|
||||
;; with seq it must be forced because seq is strict in its first
|
||||
;; argument. We don't run that error case here (it would terminate
|
||||
;; the test), but we do verify the negative — that without seq,
|
||||
;; the bottom bound is never demanded.
|
||||
(hk-test
|
||||
"lazy let — bottom never forced when unused"
|
||||
(hk-eval-expr-source "let x = error \"never\" in 42")
|
||||
42)
|
||||
|
||||
;; ── deepseq forces nested structure ──
|
||||
(hk-test
|
||||
"deepseq with finite list"
|
||||
(hk-eval-expr-source "deepseq [1, 2, 3] 7")
|
||||
7)
|
||||
|
||||
(hk-test
|
||||
"deepseq with constructor value"
|
||||
(hk-eval-expr-source "deepseq (Just 5) 11")
|
||||
11)
|
||||
|
||||
(hk-test
|
||||
"deepseq with tuple"
|
||||
(hk-eval-expr-source "deepseq (1, 2) 13")
|
||||
13)
|
||||
|
||||
;; ── seq + arithmetic ──
|
||||
(hk-test
|
||||
"seq used inside arithmetic doesn't poison the result"
|
||||
(hk-eval-expr-source "(seq 1 5) + (seq 2 7)")
|
||||
12)
|
||||
|
||||
;; ── seq in user code ──
|
||||
(hk-test
|
||||
"seq via fun-clause"
|
||||
(hk-prog-val
|
||||
"f x = seq x (x + 1)\nresult = f 10"
|
||||
"result")
|
||||
11)
|
||||
|
||||
(hk-test
|
||||
"seq sequences list construction"
|
||||
(hk-eval-list "[seq 1 10, seq 2 20]")
|
||||
(list 10 20))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -94,7 +94,7 @@
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((tokens (list)) (pos 0) (src-len (len src)))
|
||||
((tokens (list)) (pos 0) (src-len (len src)) (nl-before false))
|
||||
(define
|
||||
js-peek
|
||||
(fn
|
||||
@@ -109,11 +109,7 @@
|
||||
(let
|
||||
((sl (len s)))
|
||||
(and (<= (+ pos sl) src-len) (= (slice src pos (+ pos sl)) s)))))
|
||||
(define
|
||||
js-emit!
|
||||
(fn
|
||||
(type value start)
|
||||
(append! tokens (js-make-token type value start))))
|
||||
(define js-emit! (fn (type value start) (append! tokens {:pos start :value value :type type :nl nl-before})))
|
||||
(define
|
||||
skip-line-comment!
|
||||
(fn
|
||||
@@ -136,7 +132,13 @@
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((js-ws? (cur)) (do (advance! 1) (skip-ws!)))
|
||||
((js-ws? (cur))
|
||||
(do
|
||||
(when
|
||||
(or (= (cur) "\n") (= (cur) "\r"))
|
||||
(set! nl-before true))
|
||||
(advance! 1)
|
||||
(skip-ws!)))
|
||||
((and (= (cur) "/") (< (+ pos 1) src-len) (= (js-peek 1) "/"))
|
||||
(do (advance! 2) (skip-line-comment!) (skip-ws!)))
|
||||
((and (= (cur) "/") (< (+ pos 1) src-len) (= (js-peek 1) "*"))
|
||||
@@ -568,6 +570,7 @@
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! nl-before false)
|
||||
(skip-ws!)
|
||||
(when
|
||||
(< pos src-len)
|
||||
|
||||
@@ -835,6 +835,12 @@
|
||||
jp-eat-semi
|
||||
(fn (st) (if (jp-at? st "punct" ";") (do (jp-advance! st) nil) nil)))
|
||||
|
||||
(define
|
||||
jp-token-nl?
|
||||
(fn
|
||||
(st)
|
||||
(let ((tok (jp-peek st))) (if tok (= (get tok :nl) true) false))))
|
||||
|
||||
(define
|
||||
jp-parse-vardecl
|
||||
(fn
|
||||
@@ -1166,6 +1172,7 @@
|
||||
(or
|
||||
(jp-at? st "punct" ";")
|
||||
(jp-at? st "punct" "}")
|
||||
(jp-token-nl? st)
|
||||
(jp-at? st "eof" nil))
|
||||
(do (jp-eat-semi st) (list (quote js-return) nil))
|
||||
(let
|
||||
|
||||
@@ -1169,7 +1169,14 @@
|
||||
((= v false) "false")
|
||||
((= (type-of v) "string") v)
|
||||
((= (type-of v) "number") (js-number-to-string v))
|
||||
(else (str v)))))
|
||||
(else
|
||||
(if
|
||||
(= (type-of v) "dict")
|
||||
(if
|
||||
(contains? (keys v) "__js_string_value__")
|
||||
(get v "__js_string_value__")
|
||||
"[object Object]")
|
||||
(str v))))))
|
||||
|
||||
(define
|
||||
js-template-concat
|
||||
@@ -1187,6 +1194,79 @@
|
||||
(+ i 1)
|
||||
(str acc (js-to-string (nth parts i)))))))
|
||||
|
||||
(define
|
||||
js-big-int-str-loop
|
||||
(fn
|
||||
(n acc)
|
||||
(if
|
||||
(< n 1)
|
||||
(if (= acc "") "0" acc)
|
||||
(let
|
||||
((d (floor (- n (* 10 (floor (/ n 10)))))))
|
||||
(js-big-int-str-loop
|
||||
(floor (/ n 10))
|
||||
(str (js-string-slice "0123456789" d (+ d 1)) acc))))))
|
||||
|
||||
(define
|
||||
js-find-decimal-k
|
||||
(fn
|
||||
(n k)
|
||||
(if
|
||||
(> k 17)
|
||||
17
|
||||
(let
|
||||
((big-int (round (* n (js-pow-int 10 k)))))
|
||||
(if
|
||||
(= (/ big-int (js-pow-int 10 k)) n)
|
||||
k
|
||||
(js-find-decimal-k n (+ k 1)))))))
|
||||
|
||||
(define
|
||||
js-format-decimal-digits
|
||||
(fn
|
||||
(digits k)
|
||||
(if
|
||||
(= k 0)
|
||||
digits
|
||||
(let
|
||||
((dlen (len digits)))
|
||||
(if
|
||||
(> dlen k)
|
||||
(str
|
||||
(js-string-slice digits 0 (- dlen k))
|
||||
"."
|
||||
(js-string-slice digits (- dlen k) dlen))
|
||||
(if
|
||||
(= dlen k)
|
||||
(str "0." digits)
|
||||
(str "0." (js-string-repeat "0" (- k dlen)) digits)))))))
|
||||
|
||||
(define
|
||||
js-expand-sci-notation
|
||||
(fn
|
||||
(mant exp-n)
|
||||
(let
|
||||
((di (js-string-index-of mant "." 0)))
|
||||
(let
|
||||
((int-part (if (< di 0) mant (js-string-slice mant 0 di)))
|
||||
(frac-part
|
||||
(if (< di 0) "" (js-string-slice mant (+ di 1) (len mant)))))
|
||||
(let
|
||||
((all-digits (str int-part frac-part))
|
||||
(frac-len (if (< di 0) 0 (- (- (len mant) di) 1))))
|
||||
(if
|
||||
(>= exp-n 0)
|
||||
(if
|
||||
(>= exp-n frac-len)
|
||||
(str all-digits (js-string-repeat "0" (- exp-n frac-len)))
|
||||
(let
|
||||
((dot-pos (+ (len int-part) exp-n)))
|
||||
(str
|
||||
(js-string-slice all-digits 0 dot-pos)
|
||||
"."
|
||||
(js-string-slice all-digits dot-pos (len all-digits)))))
|
||||
(str "0." (js-string-repeat "0" (- (- 0 exp-n) 1)) all-digits)))))))
|
||||
|
||||
(define
|
||||
js-number-to-string
|
||||
(fn
|
||||
@@ -1195,7 +1275,16 @@
|
||||
((js-number-is-nan n) "NaN")
|
||||
((= n (js-infinity-value)) "Infinity")
|
||||
((= n (- 0 (js-infinity-value))) "-Infinity")
|
||||
(else (js-normalize-num-str (str n))))))
|
||||
(else
|
||||
(let
|
||||
((pos-n (if (< n 0) (- 0 n) n)))
|
||||
(let
|
||||
((s0 (js-normalize-num-str (str pos-n))))
|
||||
(let
|
||||
((n2 (js-to-number s0)))
|
||||
(let
|
||||
((precise (if (= n2 pos-n) (let ((ei (js-string-index-of s0 "e" 0))) (if (< ei 0) s0 (let ((exp-n (js-to-number (js-string-slice s0 (+ ei 1) (len s0))))) (if (and (>= exp-n -6) (<= exp-n 20)) (js-expand-sci-notation (js-string-slice s0 0 ei) exp-n) (if (>= exp-n 0) (str (js-string-slice s0 0 (+ ei 1)) "+" (str exp-n)) s0))))) (if (and (>= pos-n 1e-06) (< pos-n 1e+21)) (let ((k (js-find-decimal-k pos-n 0))) (let ((big-int (round (* pos-n (js-pow-int 10 k))))) (js-format-decimal-digits (js-big-int-str-loop big-int "") k))) (let ((ei (js-string-index-of s0 "e" 0))) (if (< ei 0) s0 (let ((exp-n (js-to-number (js-string-slice s0 (+ ei 1) (len s0))))) (if (>= exp-n 0) (str (js-string-slice s0 0 (+ ei 1)) "+" (str exp-n)) s0))))))))
|
||||
(if (< n 0) (str "-" precise) precise)))))))))
|
||||
|
||||
(define
|
||||
js-normalize-num-str
|
||||
@@ -1296,6 +1385,10 @@
|
||||
(= (js-to-number a) b))
|
||||
((= (type-of a) "boolean") (js-loose-eq (js-to-number a) b))
|
||||
((= (type-of b) "boolean") (js-loose-eq a (js-to-number b)))
|
||||
((and (dict? a) (contains? (keys a) "__js_string_value__"))
|
||||
(js-loose-eq (get a "__js_string_value__") b))
|
||||
((and (dict? b) (contains? (keys b) "__js_string_value__"))
|
||||
(js-loose-eq a (get b "__js_string_value__")))
|
||||
(else false))))
|
||||
|
||||
(define js-loose-neq (fn (a b) (not (js-loose-eq a b))))
|
||||
@@ -1903,7 +1996,15 @@
|
||||
(char-code (char-at s idx))
|
||||
0))))
|
||||
((= name "indexOf")
|
||||
(fn (needle) (js-string-index-of s (js-to-string needle) 0)))
|
||||
(fn
|
||||
(&rest args)
|
||||
(if
|
||||
(empty? args)
|
||||
-1
|
||||
(js-string-index-of
|
||||
s
|
||||
(js-to-string (nth args 0))
|
||||
(if (< (len args) 2) 0 (max 0 (js-num-to-int (nth args 1))))))))
|
||||
((= name "slice")
|
||||
(fn
|
||||
(&rest args)
|
||||
@@ -1927,7 +2028,16 @@
|
||||
(js-string-slice s lo (min hi (len s)))))))
|
||||
((= name "toUpperCase") (fn () (js-upper-case s)))
|
||||
((= name "toLowerCase") (fn () (js-lower-case s)))
|
||||
((= name "split") (fn (sep) (js-string-split s (js-to-string sep))))
|
||||
((= name "split")
|
||||
(fn
|
||||
(&rest args)
|
||||
(let
|
||||
((sep (if (= (len args) 0) :js-undefined (nth args 0)))
|
||||
(limit
|
||||
(if (< (len args) 2) -1 (js-num-to-int (nth args 1)))))
|
||||
(let
|
||||
((result (js-string-split s (js-to-string sep))))
|
||||
(if (< limit 0) result (js-list-take result limit))))))
|
||||
((= name "concat")
|
||||
(fn (&rest args) (js-string-concat-loop s args 0)))
|
||||
((= name "includes")
|
||||
@@ -2042,6 +2152,17 @@
|
||||
(= idx -1)
|
||||
nil
|
||||
(let ((res (list))) (append! res needle) res))))))))
|
||||
((= name "matchAll")
|
||||
(fn
|
||||
(&rest args)
|
||||
(if
|
||||
(empty? args)
|
||||
(list)
|
||||
(let
|
||||
((needle (js-to-string (nth args 0))))
|
||||
(let
|
||||
((loop (fn (start acc) (let ((idx (js-string-index-of s needle start))) (if (= idx -1) acc (let ((m (list))) (begin (append! m needle) (dict-set! m "index" idx) (loop (+ idx (max 1 (len needle))) (begin (append! acc m) acc)))))))))
|
||||
(loop 0 (list)))))))
|
||||
((= name "at")
|
||||
(fn
|
||||
(i)
|
||||
@@ -2068,7 +2189,14 @@
|
||||
-1
|
||||
(let
|
||||
((needle (js-to-string (nth args 0))))
|
||||
(js-string-last-index-of s needle (- (len s) (len needle)))))))
|
||||
(let
|
||||
((default-start (- (len s) (len needle)))
|
||||
(from
|
||||
(if (< (len args) 2) -1 (js-num-to-int (nth args 1)))))
|
||||
(js-string-last-index-of
|
||||
s
|
||||
needle
|
||||
(if (< from 0) default-start (min from default-start))))))))
|
||||
((= name "localeCompare")
|
||||
(fn
|
||||
(&rest args)
|
||||
@@ -2166,6 +2294,15 @@
|
||||
((not (= (char-at s (+ si ni)) (char-at needle ni))) false)
|
||||
(else (js-string-matches? s needle si (+ ni 1))))))
|
||||
|
||||
(define
|
||||
js-list-take
|
||||
(fn
|
||||
(lst n)
|
||||
(if
|
||||
(or (<= n 0) (empty? lst))
|
||||
(list)
|
||||
(cons (first lst) (js-list-take (rest lst) (- n 1))))))
|
||||
|
||||
(define
|
||||
js-string-split
|
||||
(fn
|
||||
@@ -2306,7 +2443,13 @@
|
||||
(js-string-method obj "toLocaleUpperCase"))
|
||||
((= key "isWellFormed") (js-string-method obj "isWellFormed"))
|
||||
((= key "toWellFormed") (js-string-method obj "toWellFormed"))
|
||||
(else js-undefined)))
|
||||
(else
|
||||
(let
|
||||
((proto (get String "prototype")))
|
||||
(if
|
||||
(and (dict? proto) (contains? (keys proto) key))
|
||||
(get proto key)
|
||||
js-undefined)))))
|
||||
((= (type-of obj) "dict")
|
||||
(js-dict-get-walk obj (js-to-string key)))
|
||||
((and (= obj Promise) (dict-has? __js_promise_statics__ (js-to-string key)))
|
||||
@@ -2480,7 +2623,49 @@
|
||||
((n (js-to-number (first args))))
|
||||
(js-math-hypot-loop (rest args) (+ acc (* n n)))))))
|
||||
|
||||
(define Math {:random js-math-random :trunc js-math-trunc :LN10 2.30259 :SQRT1_2 0.707107 :floor js-math-floor :PI 3.14159 :sqrt js-math-sqrt :hypot js-math-hypot :LOG2E 1.4427 :round js-math-round :ceil js-math-ceil :abs js-math-abs :pow js-math-pow :max js-math-max :LOG10E 0.434294 :SQRT2 1.41421 :cbrt js-math-cbrt :min js-math-min :sign js-math-sign :E 2.71828 :LN2 0.693147})
|
||||
(begin
|
||||
(define js-math-sin (fn (x) (sin (js-to-number x))))
|
||||
(define js-math-cos (fn (x) (cos (js-to-number x))))
|
||||
(define js-math-tan (fn (x) (tan (js-to-number x))))
|
||||
(define js-math-asin (fn (x) (asin (js-to-number x))))
|
||||
(define js-math-acos (fn (x) (acos (js-to-number x))))
|
||||
(define js-math-atan (fn (x) (atan (js-to-number x))))
|
||||
(define
|
||||
js-math-atan2
|
||||
(fn (y x) (atan2 (js-to-number y) (js-to-number x))))
|
||||
(define js-math-sinh (fn (x) (sinh (js-to-number x))))
|
||||
(define js-math-cosh (fn (x) (cosh (js-to-number x))))
|
||||
(define js-math-tanh (fn (x) (tanh (js-to-number x))))
|
||||
(define js-math-asinh (fn (x) (asinh (js-to-number x))))
|
||||
(define js-math-acosh (fn (x) (acosh (js-to-number x))))
|
||||
(define js-math-atanh (fn (x) (atanh (js-to-number x))))
|
||||
(define js-math-exp (fn (x) (exp (js-to-number x))))
|
||||
(define js-math-log (fn (x) (log (js-to-number x))))
|
||||
(define js-math-log2 (fn (x) (log2 (js-to-number x))))
|
||||
(define js-math-log10 (fn (x) (log10 (js-to-number x))))
|
||||
(define js-math-expm1 (fn (x) (expm1 (js-to-number x))))
|
||||
(define js-math-log1p (fn (x) (log1p (js-to-number x))))
|
||||
(define
|
||||
js-math-clz32
|
||||
(fn
|
||||
(&rest args)
|
||||
(let
|
||||
((x (if (empty? args) 0 (js-to-number (nth args 0)))))
|
||||
(let
|
||||
((n (modulo (floor x) 4294967296)))
|
||||
(if (= n 0) 32 (- 31 (floor (log2 n))))))))
|
||||
(define
|
||||
js-math-imul
|
||||
(fn
|
||||
(a b)
|
||||
(let
|
||||
((a32 (modulo (floor (js-to-number a)) 4294967296))
|
||||
(b32 (modulo (floor (js-to-number b)) 4294967296)))
|
||||
(let
|
||||
((result (modulo (* a32 b32) 4294967296)))
|
||||
(if (>= result 2147483648) (- result 4294967296) result)))))
|
||||
(define js-math-fround (fn (x) (js-to-number x)))
|
||||
(define Math {:trunc js-math-trunc :expm1 js-math-expm1 :atan2 js-math-atan2 :PI 3.14159 :asinh js-math-asinh :acosh js-math-acosh :hypot js-math-hypot :LOG2E 1.4427 :atanh js-math-atanh :ceil js-math-ceil :pow js-math-pow :sin js-math-sin :max js-math-max :log2 js-math-log2 :SQRT2 1.41421 :cbrt js-math-cbrt :log1p js-math-log1p :fround js-math-fround :E 2.71828 :sinh js-math-sinh :random js-math-random :LN10 2.30259 :SQRT1_2 0.707107 :asin js-math-asin :clz32 js-math-clz32 :floor js-math-floor :exp js-math-exp :tan js-math-tan :sqrt js-math-sqrt :cosh js-math-cosh :log js-math-log :round js-math-round :abs js-math-abs :LOG10E 0.434294 :tanh js-math-tanh :acos js-math-acos :log10 js-math-log10 :min js-math-min :sign js-math-sign :LN2 0.693147 :cos js-math-cos :imul js-math-imul :atan js-math-atan}))
|
||||
|
||||
(define
|
||||
js-number-is-finite
|
||||
@@ -2986,6 +3171,35 @@
|
||||
js-string-from-char-code
|
||||
(fn (&rest args) (js-string-from-char-code-loop args 0 "")))
|
||||
|
||||
(define
|
||||
js-string-from-code-point-loop
|
||||
(fn
|
||||
(args i acc)
|
||||
(if
|
||||
(>= i (len args))
|
||||
acc
|
||||
(let
|
||||
((cp (floor (js-to-number (nth args i)))))
|
||||
(if
|
||||
(< cp 65536)
|
||||
(js-string-from-code-point-loop
|
||||
args
|
||||
(+ i 1)
|
||||
(str acc (js-code-to-char (js-num-to-int cp))))
|
||||
(let
|
||||
((hi (+ 55296 (floor (/ (- cp 65536) 1024))))
|
||||
(lo (+ 56320 (modulo (- cp 65536) 1024))))
|
||||
(js-string-from-code-point-loop
|
||||
args
|
||||
(+ i 1)
|
||||
(str
|
||||
(str acc (js-code-to-char (js-num-to-int hi)))
|
||||
(js-code-to-char (js-num-to-int lo))))))))))
|
||||
|
||||
(define
|
||||
js-string-from-code-point
|
||||
(fn (&rest args) (js-string-from-code-point-loop args 0 "")))
|
||||
|
||||
(define
|
||||
js-string-from-char-code-loop
|
||||
(fn
|
||||
@@ -3016,8 +3230,32 @@
|
||||
|
||||
(dict-set! String "name" "String")
|
||||
|
||||
(dict-set! String "fromCodePoint" js-string-from-code-point)
|
||||
|
||||
(dict-set!
|
||||
String
|
||||
"__callable__"
|
||||
(fn
|
||||
(&rest args)
|
||||
(let
|
||||
((raw (if (= (len args) 0) "" (js-to-string (nth args 0)))))
|
||||
(let
|
||||
((this-val (js-this)))
|
||||
(if
|
||||
(dict? this-val)
|
||||
(begin
|
||||
(dict-set! this-val "__js_string_value__" raw)
|
||||
(dict-set! this-val "length" (len raw))
|
||||
this-val)
|
||||
raw)))))
|
||||
|
||||
(define Boolean {:__callable__ (fn (&rest args) (if (= (len args) 0) false (js-to-boolean (nth args 0))))})
|
||||
|
||||
(dict-set!
|
||||
(get String "prototype")
|
||||
"matchAll"
|
||||
(js-string-proto-fn "matchAll"))
|
||||
|
||||
(dict-set! Boolean "length" 1)
|
||||
|
||||
(dict-set! Boolean "name" "Boolean")
|
||||
|
||||
@@ -1323,6 +1323,25 @@ cat > "$TMPFILE" << 'EPOCHS'
|
||||
(epoch 3505)
|
||||
(eval "(js-eval \"var a = {length: 3, 0: 10, 1: 20, 2: 30}; var sum = 0; Array.prototype.forEach.call(a, function(x){sum += x;}); sum\")")
|
||||
|
||||
;; ── Phase 1.ASI: automatic semicolon insertion ─────────────────
|
||||
(epoch 4200)
|
||||
(eval "(js-eval \"function f() { return\n42\n} f()\")")
|
||||
(epoch 4201)
|
||||
(eval "(js-eval \"function g() { return 42 } g()\")")
|
||||
(epoch 4202)
|
||||
(eval "(let ((toks (js-tokenize \"a\nb\"))) (get (nth toks 1) :nl))")
|
||||
(epoch 4203)
|
||||
(eval "(let ((toks (js-tokenize \"a b\"))) (get (nth toks 1) :nl))")
|
||||
|
||||
(epoch 4300)
|
||||
(eval "(js-eval \"var x = 5; x\")")
|
||||
(epoch 4301)
|
||||
(eval "(js-eval \"function f() { return x; var x = 42; } f()\")")
|
||||
(epoch 4302)
|
||||
(eval "(js-eval \"function f() { var y = 7; return y; } f()\")")
|
||||
(epoch 4303)
|
||||
(eval "(js-eval \"function f() { var z; z = 3; return z; } f()\")")
|
||||
|
||||
EPOCHS
|
||||
|
||||
|
||||
@@ -2042,6 +2061,17 @@ check 3503 "indexOf.call arrLike" '1'
|
||||
check 3504 "filter.call arrLike" '"2,3"'
|
||||
check 3505 "forEach.call arrLike sum" '60'
|
||||
|
||||
# ── Phase 1.ASI: automatic semicolon insertion ────────────────────
|
||||
check 4200 "return+newline → undefined" '"js-undefined"'
|
||||
check 4201 "return+space+val → val" '42'
|
||||
check 4202 "nl-before flag set after newline" 'true'
|
||||
check 4203 "nl-before flag false on same line" 'false'
|
||||
|
||||
check 4300 "var decl program-level" '5'
|
||||
check 4301 "var hoisted before use → undef" '"js-undefined"'
|
||||
check 4302 "var in function body" '7'
|
||||
check 4303 "var then set in function" '3'
|
||||
|
||||
TOTAL=$((PASS + FAIL))
|
||||
if [ $FAIL -eq 0 ]; then
|
||||
echo "✓ $PASS/$TOTAL JS-on-SX tests passed"
|
||||
|
||||
@@ -1,84 +1,42 @@
|
||||
{
|
||||
"totals": {
|
||||
"pass": 162,
|
||||
"fail": 128,
|
||||
"skip": 1597,
|
||||
"timeout": 10,
|
||||
"total": 1897,
|
||||
"runnable": 300,
|
||||
"pass_rate": 54.0
|
||||
"pass": 62,
|
||||
"fail": 29,
|
||||
"skip": 1130,
|
||||
"timeout": 9,
|
||||
"total": 1230,
|
||||
"runnable": 100,
|
||||
"pass_rate": 62.0
|
||||
},
|
||||
"categories": [
|
||||
{
|
||||
"category": "built-ins/Math",
|
||||
"total": 327,
|
||||
"pass": 43,
|
||||
"fail": 56,
|
||||
"skip": 227,
|
||||
"timeout": 1,
|
||||
"pass_rate": 43.0,
|
||||
"top_failures": [
|
||||
[
|
||||
"TypeError: not a function",
|
||||
36
|
||||
],
|
||||
[
|
||||
"Test262Error (assertion failed)",
|
||||
20
|
||||
],
|
||||
[
|
||||
"Timeout",
|
||||
1
|
||||
]
|
||||
]
|
||||
},
|
||||
{
|
||||
"category": "built-ins/Number",
|
||||
"total": 340,
|
||||
"pass": 77,
|
||||
"fail": 19,
|
||||
"skip": 240,
|
||||
"timeout": 4,
|
||||
"pass_rate": 77.0,
|
||||
"top_failures": [
|
||||
[
|
||||
"Test262Error (assertion failed)",
|
||||
19
|
||||
],
|
||||
[
|
||||
"Timeout",
|
||||
4
|
||||
]
|
||||
]
|
||||
},
|
||||
{
|
||||
"category": "built-ins/String",
|
||||
"total": 1223,
|
||||
"pass": 42,
|
||||
"fail": 53,
|
||||
"pass": 62,
|
||||
"fail": 29,
|
||||
"skip": 1123,
|
||||
"timeout": 5,
|
||||
"pass_rate": 42.0,
|
||||
"timeout": 9,
|
||||
"pass_rate": 62.0,
|
||||
"top_failures": [
|
||||
[
|
||||
"Test262Error (assertion failed)",
|
||||
44
|
||||
24
|
||||
],
|
||||
[
|
||||
"Timeout",
|
||||
5
|
||||
],
|
||||
[
|
||||
"ReferenceError (undefined symbol)",
|
||||
2
|
||||
],
|
||||
[
|
||||
"Unhandled: Not callable: {:__proto__ {:toLowerCase <lambda(&rest, args)",
|
||||
2
|
||||
9
|
||||
],
|
||||
[
|
||||
"Unhandled: Not callable: \\\\\\",
|
||||
2
|
||||
1
|
||||
],
|
||||
[
|
||||
"ReferenceError (undefined symbol)",
|
||||
1
|
||||
],
|
||||
[
|
||||
"SyntaxError (parse/unsupported syntax)",
|
||||
1
|
||||
]
|
||||
]
|
||||
},
|
||||
@@ -96,34 +54,26 @@
|
||||
"top_failure_modes": [
|
||||
[
|
||||
"Test262Error (assertion failed)",
|
||||
83
|
||||
],
|
||||
[
|
||||
"TypeError: not a function",
|
||||
36
|
||||
24
|
||||
],
|
||||
[
|
||||
"Timeout",
|
||||
10
|
||||
],
|
||||
[
|
||||
"ReferenceError (undefined symbol)",
|
||||
2
|
||||
],
|
||||
[
|
||||
"Unhandled: Not callable: {:__proto__ {:toLowerCase <lambda(&rest, args)",
|
||||
2
|
||||
9
|
||||
],
|
||||
[
|
||||
"Unhandled: Not callable: \\\\\\",
|
||||
2
|
||||
1
|
||||
],
|
||||
[
|
||||
"ReferenceError (undefined symbol)",
|
||||
1
|
||||
],
|
||||
[
|
||||
"SyntaxError (parse/unsupported syntax)",
|
||||
1
|
||||
],
|
||||
[
|
||||
"Unhandled: Not callable: {:__proto__ {:valueOf <lambda()> :propertyIsEn",
|
||||
"TypeError: not a function",
|
||||
1
|
||||
],
|
||||
[
|
||||
@@ -132,6 +82,6 @@
|
||||
]
|
||||
],
|
||||
"pinned_commit": "d5e73fc8d2c663554fb72e2380a8c2bc1a318a33",
|
||||
"elapsed_seconds": 274.5,
|
||||
"workers": 1
|
||||
"elapsed_seconds": 40.5,
|
||||
"workers": 7
|
||||
}
|
||||
@@ -1,47 +1,32 @@
|
||||
# test262 scoreboard
|
||||
|
||||
Pinned commit: `d5e73fc8d2c663554fb72e2380a8c2bc1a318a33`
|
||||
Wall time: 274.5s
|
||||
Wall time: 40.5s
|
||||
|
||||
**Total:** 162/300 runnable passed (54.0%). Raw: pass=162 fail=128 skip=1597 timeout=10 total=1897.
|
||||
**Total:** 62/100 runnable passed (62.0%). Raw: pass=62 fail=29 skip=1130 timeout=9 total=1230.
|
||||
|
||||
## Top failure modes
|
||||
|
||||
- **83x** Test262Error (assertion failed)
|
||||
- **36x** TypeError: not a function
|
||||
- **10x** Timeout
|
||||
- **2x** ReferenceError (undefined symbol)
|
||||
- **2x** Unhandled: Not callable: {:__proto__ {:toLowerCase <lambda(&rest, args)
|
||||
- **2x** Unhandled: Not callable: \\\
|
||||
- **24x** Test262Error (assertion failed)
|
||||
- **9x** Timeout
|
||||
- **1x** Unhandled: Not callable: \\\
|
||||
- **1x** ReferenceError (undefined symbol)
|
||||
- **1x** SyntaxError (parse/unsupported syntax)
|
||||
- **1x** Unhandled: Not callable: {:__proto__ {:valueOf <lambda()> :propertyIsEn
|
||||
- **1x** TypeError: not a function
|
||||
- **1x** Unhandled: js-transpile-binop: unsupported op: >>>\
|
||||
|
||||
## Categories (worst pass-rate first, min 10 runnable)
|
||||
|
||||
| Category | Pass | Fail | Skip | Timeout | Total | Pass % |
|
||||
|---|---:|---:|---:|---:|---:|---:|
|
||||
| built-ins/String | 42 | 53 | 1123 | 5 | 1223 | 42.0% |
|
||||
| built-ins/Math | 43 | 56 | 227 | 1 | 327 | 43.0% |
|
||||
| built-ins/Number | 77 | 19 | 240 | 4 | 340 | 77.0% |
|
||||
| built-ins/String | 62 | 29 | 1123 | 9 | 1223 | 62.0% |
|
||||
|
||||
## Per-category top failures (min 10 runnable, worst first)
|
||||
|
||||
### built-ins/String (42/100 — 42.0%)
|
||||
### built-ins/String (62/100 — 62.0%)
|
||||
|
||||
- **44x** Test262Error (assertion failed)
|
||||
- **5x** Timeout
|
||||
- **2x** ReferenceError (undefined symbol)
|
||||
- **2x** Unhandled: Not callable: {:__proto__ {:toLowerCase <lambda(&rest, args)
|
||||
- **2x** Unhandled: Not callable: \\\
|
||||
|
||||
### built-ins/Math (43/100 — 43.0%)
|
||||
|
||||
- **36x** TypeError: not a function
|
||||
- **20x** Test262Error (assertion failed)
|
||||
- **1x** Timeout
|
||||
|
||||
### built-ins/Number (77/100 — 77.0%)
|
||||
|
||||
- **19x** Test262Error (assertion failed)
|
||||
- **4x** Timeout
|
||||
- **24x** Test262Error (assertion failed)
|
||||
- **9x** Timeout
|
||||
- **1x** Unhandled: Not callable: \\\
|
||||
- **1x** ReferenceError (undefined symbol)
|
||||
- **1x** SyntaxError (parse/unsupported syntax)
|
||||
|
||||
@@ -486,6 +486,51 @@
|
||||
(append inits (list (js-transpile body))))))))
|
||||
(list (js-sym "fn") param-syms body-tr))))
|
||||
|
||||
(define
|
||||
js-collect-var-decl-names
|
||||
(fn
|
||||
(decls)
|
||||
(cond
|
||||
((empty? decls) (list))
|
||||
((js-tag? (first decls) "js-vardecl")
|
||||
(cons
|
||||
(nth (first decls) 1)
|
||||
(js-collect-var-decl-names (rest decls))))
|
||||
(else (js-collect-var-decl-names (rest decls))))))
|
||||
|
||||
(define
|
||||
js-collect-var-names
|
||||
(fn
|
||||
(stmts)
|
||||
(cond
|
||||
((empty? stmts) (list))
|
||||
((and (list? (first stmts)) (js-tag? (first stmts) "js-var") (= (nth (first stmts) 1) "var"))
|
||||
(append
|
||||
(js-collect-var-decl-names (nth (first stmts) 2))
|
||||
(js-collect-var-names (rest stmts))))
|
||||
(else (js-collect-var-names (rest stmts))))))
|
||||
|
||||
(define
|
||||
js-dedup-names
|
||||
(fn
|
||||
(names seen)
|
||||
(cond
|
||||
((empty? names) (list))
|
||||
((some (fn (s) (= s (first names))) seen)
|
||||
(js-dedup-names (rest names) seen))
|
||||
(else
|
||||
(cons
|
||||
(first names)
|
||||
(js-dedup-names (rest names) (cons (first names) seen)))))))
|
||||
|
||||
(define
|
||||
js-var-hoist-forms
|
||||
(fn
|
||||
(names)
|
||||
(map
|
||||
(fn (name) (list (js-sym "define") (js-sym name) :js-undefined))
|
||||
names)))
|
||||
|
||||
(define
|
||||
js-transpile-tpl
|
||||
(fn
|
||||
@@ -876,7 +921,7 @@
|
||||
(fn
|
||||
(stmts)
|
||||
(let
|
||||
((hoisted (js-collect-funcdecls stmts)))
|
||||
((hoisted (append (js-var-hoist-forms (js-dedup-names (js-collect-var-names stmts) (list))) (js-collect-funcdecls stmts))))
|
||||
(let
|
||||
((rest-stmts (js-transpile-stmt-list stmts)))
|
||||
(cons (js-sym "begin") (append hoisted rest-stmts))))))
|
||||
@@ -1297,7 +1342,7 @@
|
||||
(if
|
||||
(and (list? body) (js-tag? body "js-block"))
|
||||
(let
|
||||
((hoisted (js-collect-funcdecls (nth body 1))))
|
||||
((hoisted (append (js-var-hoist-forms (js-dedup-names (js-collect-var-names (nth body 1)) (list))) (js-collect-funcdecls (nth body 1)))))
|
||||
(append hoisted (js-transpile-stmt-list (nth body 1))))
|
||||
(list (js-transpile body)))))
|
||||
(list
|
||||
@@ -1333,7 +1378,7 @@
|
||||
(if
|
||||
(and (list? body) (js-tag? body "js-block"))
|
||||
(let
|
||||
((hoisted (js-collect-funcdecls (nth body 1))))
|
||||
((hoisted (append (js-var-hoist-forms (js-dedup-names (js-collect-var-names (nth body 1)) (list))) (js-collect-funcdecls (nth body 1)))))
|
||||
(append hoisted (js-transpile-stmt-list (nth body 1))))
|
||||
(list (js-transpile body)))))
|
||||
(list
|
||||
|
||||
@@ -55,34 +55,27 @@ Key mappings:
|
||||
|
||||
### Phase 1 — tokenizer + parser + layout rule
|
||||
- [x] Tokenizer: reserved words, qualified names, operators, numbers (int, float, Rational later), chars/strings, comments (`--` and `{-` nested)
|
||||
- [x] Layout algorithm: turn indentation into virtual `{`, `;`, `}` tokens per Haskell 98 §10.3
|
||||
- Parser (split into sub-items — implement one per iteration):
|
||||
- [x] Expressions: atoms, parens, tuples, lists, ranges, application, infix with full Haskell-98 precedence table, unary `-`, backtick operators, lambdas, `if`, `let`
|
||||
- [x] `case … of` and `do`-notation expressions (plus minimal patterns needed for arms/binds: var, wildcard, literal, 0-arity and applied constructor, tuple, list)
|
||||
- [x] Patterns — full: `as` patterns, nested, negative literal, `~` lazy, infix constructor (`:` / consym), extend lambdas/let with non-var patterns
|
||||
- [x] Top-level decls: function clauses (simple — no guards/where yet), pattern bindings, multi-name type signatures, `data` with type vars and recursive constructors, `type` synonyms, `newtype`, fixity (`infix`/`infixl`/`infixr` with optional precedence, comma-separated ops, backtick names). Types: vars / constructors / application / `->` (right-assoc) / tuples / lists. `hk-parse-top` entry.
|
||||
- [x] `where` clauses + guards (on fun-clauses, case alts, and let/do-let bindings — with the let funclause shorthand `let f x = …` now supported)
|
||||
- [x] Module header + imports — `module NAME [exports] where …`, qualified/as/hiding/explicit imports, operator exports, `module Foo` exports, dotted names, headerless-with-imports
|
||||
- [x] List comprehensions + operator sections — `(op)` / `(op e)` / `(e op)` (excluding `-` from right sections), `[e | q1, q2, …]` with `q-gen` / `q-guard` / `q-let` qualifiers
|
||||
- [x] AST design modelled on GHC's HsSyn at a surface level — keyword-tagged lists cover modules/imports/decls/types/patterns/expressions; see parser.sx docstrings for the full node catalogue
|
||||
- [ ] Layout algorithm: turn indentation into virtual `{`, `;`, `}` tokens per Haskell 98 §10.3
|
||||
- [ ] Parser: modules, imports (stub), top-level decls, type sigs, function clauses with patterns + guards + where-clauses, expressions with operator precedence, lambdas, `let`, `if`, `case`, `do`, list comp, sections
|
||||
- [ ] AST design modelled on GHC's HsSyn at a surface level
|
||||
- [x] Unit tests in `lib/haskell/tests/parse.sx` (43 tokenizer tests, all green)
|
||||
|
||||
### Phase 2 — desugar + eager-ish eval + ADTs (untyped)
|
||||
- [x] Desugar: guards → nested `if`s; `where` → `let`; list comp → `concatMap`-based; do-notation stays for now (desugared in phase 3)
|
||||
- [x] `data` declarations register constructors in runtime
|
||||
- [x] Pattern match (tag-based, value-level): atoms, vars, wildcards, constructor patterns, `as` patterns, nested
|
||||
- [x] Evaluator (still strict internally — laziness in phase 3): `let`, `lambda`, application, `case`, literals, constructors
|
||||
- [x] 30+ eval tests in `lib/haskell/tests/eval.sx`
|
||||
- [ ] Desugar: guards → nested `if`s; `where` → `let`; list comp → `concatMap`-based; do-notation stays for now (desugared in phase 3)
|
||||
- [ ] `data` declarations register constructors in runtime
|
||||
- [ ] Pattern match (tag-based, value-level): atoms, vars, wildcards, constructor patterns, `as` patterns, nested
|
||||
- [ ] Evaluator (still strict internally — laziness in phase 3): `let`, `lambda`, application, `case`, literals, constructors
|
||||
- [ ] 30+ eval tests in `lib/haskell/tests/eval.sx`
|
||||
|
||||
### Phase 3 — laziness + classic programs
|
||||
- [x] Transpile to thunk-wrapped SX: every application arg becomes `(make-thunk (lambda () <arg>))`
|
||||
- [x] `force` = SX eval-thunk-to-WHNF primitive
|
||||
- [x] Pattern match forces scrutinee before matching
|
||||
- [x] Infinite structures: `repeat x`, `iterate f x`, `[1..]`, Fibonacci stream (sieve deferred — needs lazy `++` and is exercised under `Classic programs`)
|
||||
- [x] `seq`, `deepseq` from Prelude
|
||||
- [x] Do-notation for a stub `IO` monad (just threading, no real side effects yet)
|
||||
- [ ] Transpile to thunk-wrapped SX: every application arg becomes `(make-thunk (lambda () <arg>))`
|
||||
- [ ] `force` = SX eval-thunk-to-WHNF primitive
|
||||
- [ ] Pattern match forces scrutinee before matching
|
||||
- [ ] Infinite structures: `repeat x`, `iterate f x`, `[1..]`, Fibonacci stream, sieve of Eratosthenes
|
||||
- [ ] `seq`, `deepseq` from Prelude
|
||||
- [ ] Do-notation for a stub `IO` monad (just threading, no real side effects yet)
|
||||
- [ ] Classic programs in `lib/haskell/tests/programs/`:
|
||||
- [x] `fib.hs` — infinite Fibonacci stream
|
||||
- [ ] `fib.hs` — infinite Fibonacci stream
|
||||
- [ ] `sieve.hs` — lazy sieve of Eratosthenes
|
||||
- [ ] `quicksort.hs` — naive QS
|
||||
- [ ] `nqueens.hs`
|
||||
@@ -114,398 +107,6 @@ Key mappings:
|
||||
|
||||
_Newest first._
|
||||
|
||||
- **2026-04-25** — First classic program: `fib.hs`. Canonical Haskell
|
||||
source lives at `lib/haskell/tests/programs/fib.hs` (the
|
||||
two-cons-cell self-referential fibs definition plus a hand-rolled
|
||||
`zipPlus`). The runner at `lib/haskell/tests/program-fib.sx`
|
||||
mirrors the source as an SX string (the OCaml server's
|
||||
`read-file` lives in the page-helpers env, not the default load
|
||||
env, so direct file reads from inside `eval` aren't available).
|
||||
Tests: `take 15 myFibs == [0,1,1,2,3,5,8,13,21,34,55,89,144,233,377]`,
|
||||
plus a spot-check that the user-defined `zipPlus` is also
|
||||
reachable. Found and fixed an ordering bug in `hk-bind-decls!`:
|
||||
pass 3 (0-arity body evaluation) iterated `(keys groups)` whose
|
||||
order is implementation-defined, so a top-down program where
|
||||
`result = take 15 myFibs` came after `myFibs = …` could see
|
||||
`myFibs` still bound to its `nil` placeholder. Now group names
|
||||
are tracked in source order via a parallel list and pass 3 walks
|
||||
that. 388/388 green.
|
||||
|
||||
- **2026-04-25** — Phase 3 do-notation + stub IO monad. Added a
|
||||
`hk-desugar-do` pass that follows Haskell 98 §3.14 verbatim:
|
||||
`do { e } = e`, `do { e ; ss } = e >> do { ss }`,
|
||||
`do { p <- e ; ss } = e >>= \p -> do { ss }`, and
|
||||
`do { let ds ; ss } = let ds in do { ss }`. The desugarer's
|
||||
`:do` branch now invokes this pass directly so the surface
|
||||
AST forms (`:do-expr`, `:do-bind`, `:do-let`) never reach the
|
||||
evaluator. IO is represented as a tagged value
|
||||
`("IO" payload)` — `return` (lazy builtin) wraps; `>>=` (lazy
|
||||
builtin) forces the action, unwraps, and calls the bound
|
||||
function on the payload; `>>` (lazy builtin) forces the
|
||||
action and returns the second one. All three are non-strict
|
||||
in their action arguments so deeply nested do-blocks don't
|
||||
walk the whole chain at construction time. 14 new tests in
|
||||
`lib/haskell/tests/do-io.sx` cover single-stmt do, single
|
||||
and multi-bind, `>>` sequencing (last action wins), do-let
|
||||
(single, multi, interleaved with bind), bind-to-`Just`,
|
||||
bind-to-tuple, do inside a top-level fun, nested do, and
|
||||
using `(>>=)`/`(>>)` directly as functions. 382/382 green.
|
||||
|
||||
- **2026-04-25** — Phase 3 `seq` + `deepseq`. Built-ins were strict
|
||||
in all args by default (every collected thunk forced before
|
||||
invoking the underlying SX fn) — that defeats `seq`'s purpose,
|
||||
which is strict in its first argument and lazy in its second.
|
||||
Added a tiny `lazy` flag on the builtin record (set by a new
|
||||
`hk-mk-lazy-builtin` constructor) and routed `hk-apply-builtin`
|
||||
to skip the auto-force when the flag is true. `seq a b` calls
|
||||
`hk-force a` then returns `b` unchanged so its laziness is
|
||||
preserved; `deepseq` does the same with `hk-deep-force`. 9 new
|
||||
tests in `lib/haskell/tests/seq.sx` cover primitive, computed,
|
||||
and let-bound first args, deepseq on a list / `Just` /
|
||||
tuple, seq inside arithmetic, seq via a fun-clause, and
|
||||
`[seq 1 10, seq 2 20]` to confirm seq composes inside list
|
||||
literals. The lazy-when-unused negative case is also tested:
|
||||
`let x = error "never" in 42 == 42`. 368/368 green.
|
||||
|
||||
- **2026-04-24** — Phase 3 infinite structures + Prelude. Two
|
||||
evaluator changes turn the lazy primitives into a working
|
||||
language:
|
||||
1. Op-form `:` is now non-strict in both args — `hk-eval-op`
|
||||
special-cases it before the eager force-and-binop path, so a
|
||||
cons-cell holds two thunks. This is what makes `repeat x =
|
||||
x : repeat x`, `iterate f x = x : iterate f (f x)`, and the
|
||||
classic `fibs = 0 : 1 : zipWith plus fibs (tail fibs)`
|
||||
terminate when only a finite prefix is consumed.
|
||||
2. Operators are now first-class values via a small
|
||||
`hk-make-binop-builtin` helper, so `(+)`, `(*)`, `(==)` etc.
|
||||
can be passed to `zipWith` and `map`.
|
||||
Added range support across parser + evaluator: `[from..to]` and
|
||||
`[from,next..to]` evaluate eagerly via `hk-build-range` (handles
|
||||
step direction); `[from..]` parses to a new `:range-from` node
|
||||
that the evaluator desugars to `iterate (+ 1) from`. New
|
||||
`hk-load-into!` runs the regular pipeline (parse → desugar →
|
||||
register data → bind decls) on a source string, and `hk-init-env`
|
||||
preloads `hk-prelude-src` with the Phase-3 Prelude:
|
||||
`head`, `tail`, `fst`, `snd`, `take`, `drop`, `repeat`, `iterate`,
|
||||
`length`, `map`, `filter`, `zipWith`, plus `fibs` and `plus`.
|
||||
25 new tests in `lib/haskell/tests/infinite.sx`, including
|
||||
`take 10 fibs == [0,1,1,2,3,5,8,13,21,34]`,
|
||||
`head (drop 99 [1..])`, `iterate (\x -> x * 2) 1` powers of two,
|
||||
user-defined `ones = 1 : ones`, `naturalsFrom`, range edge cases,
|
||||
composed `map`/`filter`, and a custom `mySum`. 359/359 green.
|
||||
Sieve of Eratosthenes is deferred — it needs lazy `++` plus a
|
||||
`mod` primitive — and lives under `Classic programs` anyway.
|
||||
|
||||
- **2026-04-24** — Phase 3 laziness foundation. Added a thunk type to
|
||||
`lib/haskell/eval.sx` (`hk-mk-thunk` / `hk-is-thunk?`) backed by a
|
||||
one-shot memoizing `hk-force` that evaluates the deferred AST, then
|
||||
flips a `forced` flag and caches the value on the thunk dict; the
|
||||
shared `hk-deep-force` walks the result tree at the test/output
|
||||
boundary. Three single-line wiring changes in the evaluator make
|
||||
every application argument lazy: `:app` now wraps its argument in
|
||||
`hk-mk-thunk` rather than evaluating it. To preserve correctness
|
||||
where values must be inspected, `hk-apply`, `hk-eval-op`,
|
||||
`hk-eval-if`, `hk-eval-case`, and `hk-eval` for `:neg` now force
|
||||
their operand. `hk-apply-builtin` forces every collected arg
|
||||
before invoking the underlying SX fn so built-ins (`error`, `not`,
|
||||
`id`) stay strict. The pattern matcher in `match.sx` now forces
|
||||
the scrutinee just-in-time only for patterns that need to inspect
|
||||
shape — `p-wild`, `p-var`, `p-as`, and `p-lazy` are no-force
|
||||
paths, so the value flows through as a thunk and binding
|
||||
preserves laziness. `hk-match-list-pat` forces at every cons-spine
|
||||
step. 6 new lazy-specific tests in `lib/haskell/tests/eval.sx`
|
||||
verify that `(\x y -> x) 1 (error …)` and `(\x y -> y) (error …) 99`
|
||||
return without diverging, that `case Just (error …) of Just _ -> 7`
|
||||
short-circuits, that `const` drops its second arg, that
|
||||
`myHead (1 : error … : [])` returns 1 without touching the tail,
|
||||
and that `Just (error …)` survives a wildcard-arm `case`. 333/333
|
||||
green, all prior eval tests preserved by deep-forcing the result
|
||||
in `hk-eval-expr-source` and `hk-prog-val`.
|
||||
|
||||
- **2026-04-24** — Phase 2 evaluator (`lib/haskell/eval.sx`) — ties
|
||||
the whole pipeline together. Strict semantics throughout (laziness
|
||||
is Phase 3). Function values are tagged dicts: `closure`,
|
||||
`multi`(fun), `con-partial`, `builtin`. `hk-apply` unifies dispatch
|
||||
across all four; closures and multifuns curry one argument at a
|
||||
time, multifuns trying each clause's pat-list in order once arity
|
||||
is reached. Top-level `hk-bind-decls!` is three-pass —
|
||||
collect groups + pre-seed names → install multifuns (so closures
|
||||
observe later names) → eval 0-arity bodies and pat-binds — making
|
||||
forward and mutually recursive references work. `hk-eval-let` does
|
||||
the same trick with a mutable child env. Built-ins:
|
||||
`error`/`not`/`id`, plus `otherwise = True`. Operators wired:
|
||||
arithmetic, comparison (returning Bool conses), `&&`, `||`, `:`,
|
||||
`++`. Sections evaluate the captured operand once and return a
|
||||
closure synthesized via the existing AST. `hk-eval-program`
|
||||
registers data decls then binds, returning the env; `hk-run`
|
||||
fetches `main` if present. Also extended `runtime.sx` to
|
||||
pre-register the standard Prelude conses (`Maybe`, `Either`,
|
||||
`Ordering`) so expression-level eval doesn't need a leading
|
||||
`data` decl. 48 new tests in `lib/haskell/tests/eval.sx` cover
|
||||
literals, arithmetic precedence, comparison/Bool, `if`, `let`
|
||||
(incl. recursive factorial), lambdas (incl. constructor pattern
|
||||
args), constructors, `case` (Just/Nothing/literal/tuple/wildcard),
|
||||
list literals + cons + `++`, tuples, sections, multi-clause
|
||||
top-level (factorial, list length via cons pattern, Maybe handler
|
||||
with default), user-defined `data` with case-style matching, a
|
||||
binary-tree height program, currying, higher-order (`twice`),
|
||||
short-circuit `error` via `if`, and the three built-ins. 329/329
|
||||
green. Phase 2 is now complete; Phase 3 (laziness) is next.
|
||||
|
||||
- **2026-04-24** — Phase 2: value-level pattern matcher
|
||||
(`lib/haskell/match.sx`). Core entry `hk-match pat val env` returns
|
||||
an extended env dict on success or `nil` on failure (uses `assoc`
|
||||
rather than `dict-set!` so failed branches never pollute the
|
||||
caller's env). Constructor values are tagged lists with the
|
||||
constructor name as the first element; tuples use the tag `"Tuple"`,
|
||||
lists are chained `(":" h t)` cons cells terminated by `("[]")`.
|
||||
Value builders `hk-mk-con` / `hk-mk-tuple` / `hk-mk-nil` /
|
||||
`hk-mk-cons` / `hk-mk-list` keep tests readable. The matcher
|
||||
handles every pattern node the parser emits:
|
||||
- `:p-wild` (always matches), `:p-var` (binds), `:p-int` /
|
||||
`:p-float` / `:p-string` / `:p-char` (literal equality)
|
||||
- `:p-as` (sub-match then bind whole), `:p-lazy` (eager for now;
|
||||
laziness wired in phase 3)
|
||||
- `:p-con` with arity check + recursive arg matching, including
|
||||
deeply nested patterns and infix `:` cons (uses the same
|
||||
code path as named constructors)
|
||||
- `:p-tuple` against `"Tuple"` values, `:p-list` against an
|
||||
exact-length cons spine.
|
||||
Helper `hk-parse-pat-source` lifts a real Haskell pattern out of
|
||||
`case _ of <pat> -> 0`, letting tests drive against parser output.
|
||||
31 new tests in `lib/haskell/tests/match.sx` cover atomic
|
||||
patterns, success/failure for each con/tuple/list shape, nested
|
||||
`Just (Just x)`, cons-vs-empty, `as` over con / wildcard /
|
||||
failing-sub, `~` lazy, plus four parser-driven cases (`Just x`,
|
||||
`x : xs`, `(a, b)`, `n@(Just x)`). 281/281 green.
|
||||
|
||||
- **2026-04-24** — Phase 2: runtime constructor registry
|
||||
(`lib/haskell/runtime.sx`). A mutable dict `hk-constructors` keyed
|
||||
by constructor name, each entry carrying arity and owning type.
|
||||
`hk-register-data!` walks a `:data` AST and registers every
|
||||
`:con-def` with its arity (= number of field types) and the type
|
||||
name; `hk-register-newtype!` does the one-constructor variant;
|
||||
`hk-register-decls!` / `hk-register-program!` filter a decls list
|
||||
(or a `:program` / `:module` AST) and call the appropriate
|
||||
registrar. `hk-load-source!` composes it with `hk-core`
|
||||
(tokenize → layout → parse → desugar → register). Pre-registers
|
||||
five built-ins tied to Haskell syntactic forms: `True` / `False`
|
||||
(Bool), `[]` and `:` (List), `()` (Unit) — everything else comes
|
||||
from user declarations or the eventual Prelude. Query helpers:
|
||||
`hk-is-con?`, `hk-con-arity`, `hk-con-type`, `hk-con-names`. 24
|
||||
new tests in `lib/haskell/tests/runtime.sx` cover each built-in
|
||||
(arity + type), unknown-name probes, registration of `MyBool` /
|
||||
`Maybe` / `Either` / recursive `Tree` / `newtype Age`, multi-data
|
||||
programs, a module-header body, ignoring non-data decls, and
|
||||
last-wins re-registration. 250/250 green.
|
||||
|
||||
- **2026-04-24** — Phase 2 kicks off with `lib/haskell/desugar.sx` — a
|
||||
tree-walking rewriter that eliminates the three surface-only forms
|
||||
produced by the parser, leaving a smaller core AST for the evaluator:
|
||||
- `:where BODY DECLS` → `:let DECLS BODY`
|
||||
- `:guarded ((:guard C1 E1) (:guard C2 E2) …)` → right-folded
|
||||
`(:if C1 E1 (:if C2 E2 … (:app (:var "error") (:string "…"))))`
|
||||
- `:list-comp E QUALS` → Haskell 98 §3.11 translation:
|
||||
empty quals → `(:list (E))`, `:q-guard` → `(:if … (:list (E)) (:list ()))`,
|
||||
`:q-gen PAT SRC` → `(concatMap (\PAT -> …) SRC)`, `:q-let BINDS` →
|
||||
`(:let BINDS …)`. Nested generators compile to nested concatMap.
|
||||
Every other expression, decl, pattern, and type node is recursed
|
||||
into and passed through unchanged. Public entries `hk-desugar`,
|
||||
`hk-core` (tokenize → layout → parse → desugar on a module), and
|
||||
`hk-core-expr` (the same for an expression). 15 new tests in
|
||||
`lib/haskell/tests/desugar.sx` cover two- and three-way guards,
|
||||
case-alt guards, single/multi-binding `where`, guards + `where`
|
||||
combined, the four list-comprehension cases (single-gen, gen +
|
||||
filter, gen + let, nested gens), and pass-through for literals,
|
||||
lambdas, simple fun-clauses, `data` decls, and a module header
|
||||
wrapping a guarded function. 226/226 green.
|
||||
|
||||
- **2026-04-24** — Phase 1 parser is now complete. This iteration adds
|
||||
operator sections and list comprehensions, the two remaining
|
||||
aexp-level forms, plus ticks the “AST design” item (the keyword-
|
||||
tagged list shape has accumulated a full HsSyn-level surface).
|
||||
Changes:
|
||||
- `hk-parse-infix` now bails on `op )` without consuming the op, so
|
||||
the paren parser can claim it as a left section.
|
||||
- `hk-parse-parens` rewritten to recognise five new forms:
|
||||
`()` (unit), `(op)` → `(:var OP)`, `(op e)` → `(:sect-right OP E)`
|
||||
(excluded for `-` so that `(- 5)` stays `(:neg 5)`), `(e op)` →
|
||||
`(:sect-left OP E)`, plus regular parens and tuples. Works for
|
||||
varsym, consym, reservedop `:`, and backtick-quoted varids.
|
||||
- `hk-section-op-info` inspects the current token and returns a
|
||||
`{:name :len}` dict, so the same logic handles 1-token ops and
|
||||
3-token backtick ops uniformly.
|
||||
- `hk-parse-list-lit` now recognises a `|` after the first element
|
||||
and dispatches to `hk-parse-qual` per qualifier (comma-separated),
|
||||
producing `(:list-comp EXPR QUALS)`. Qualifiers are:
|
||||
`(:q-gen PAT EXPR)` when a paren-balanced lookahead
|
||||
(`hk-comp-qual-is-gen?`) finds `<-` before the next `,`/`]`,
|
||||
`(:q-let BINDS)` for `let …`, and `(:q-guard EXPR)` otherwise.
|
||||
- `hk-parse-comp-let` accepts `]` or `,` as an implicit block close
|
||||
(single-line comprehensions never see layout's vrbrace before the
|
||||
qualifier terminator arrives); explicit `{ }` still closes
|
||||
strictly.
|
||||
22 new tests in `lib/haskell/tests/parser-sect-comp.sx` cover
|
||||
op-references (inc. `(-)`, `(:)`, backtick), right sections (inc.
|
||||
backtick), left sections, the `(- 5)` → `:neg` corner, plain parens
|
||||
and tuples, six comprehension shapes (simple, filter, let,
|
||||
nested-generators, constructor pattern bind, tuple pattern bind,
|
||||
and a three-qualifier mix). 211/211 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: module header + imports. Added
|
||||
`hk-parse-module-header`, `hk-parse-import`, plus shared helpers for
|
||||
import/export entity lists (`hk-parse-ent`, `hk-parse-ent-member`,
|
||||
`hk-parse-ent-list`). New AST:
|
||||
- `(:module NAME EXPORTS IMPORTS DECLS)` — NAME `nil` means no header,
|
||||
EXPORTS `nil` means no export list (distinct from empty `()`)
|
||||
- `(:import QUALIFIED NAME AS SPEC)` — QUALIFIED bool, AS alias or nil,
|
||||
SPEC nil / `(:spec-items ENTS)` / `(:spec-hiding ENTS)`
|
||||
- Entity refs: `:ent-var`, `:ent-all` (`Tycon(..)`), `:ent-with`
|
||||
(`Tycon(m1, m2, …)`), `:ent-module` (exports only).
|
||||
`hk-parse-program` now dispatches on the leading token: `module`
|
||||
keyword → full header-plus-body parse (consuming the `where` layout
|
||||
brace around the module body); otherwise collect any leading
|
||||
`import` decls and then remaining decls with the existing logic.
|
||||
The outer shell is `(:module …)` as soon as any header or import is
|
||||
present, and stays as `(:program DECLS)` otherwise — preserving every
|
||||
previous test expectation untouched. Handles operator exports `((+:))`,
|
||||
dotted module names (`Data.Map`), and the Haskell-98 context-sensitive
|
||||
keywords `qualified`/`as`/`hiding` (all lexed as ordinary varids and
|
||||
matched only in import position). 16 new tests in
|
||||
`lib/haskell/tests/parser-module.sx` covering simple/exports/empty
|
||||
headers, dotted names, operator exports, `module Foo` exports,
|
||||
qualified/aliased/items/hiding imports, and a headerless-with-imports
|
||||
file. 189/189 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: guards + where clauses. Factored a single
|
||||
`hk-parse-rhs sep` that all body-producing sites now share: it reads
|
||||
a plain `sep expr` body or a chain of `| cond sep expr` guards, then
|
||||
— regardless of which form — looks for an optional `where` block and
|
||||
wraps accordingly. AST additions:
|
||||
- `:guarded GUARDS` where each GUARD is `:guard COND EXPR`
|
||||
- `:where BODY DECLS` where BODY is a plain expr or a `:guarded`
|
||||
Both can nest (guards inside where). `hk-parse-alt` now routes through
|
||||
`hk-parse-rhs "->"`, `hk-parse-fun-clause` and `hk-parse-bind` through
|
||||
`hk-parse-rhs "="`. `hk-parse-where-decls` reuses `hk-parse-decl` so
|
||||
where-blocks accept any decl form (signatures, fixity, nested funs).
|
||||
As a side effect, `hk-parse-bind` now also picks up the Haskell-native
|
||||
`let f x = …` funclause shorthand: a varid followed by one or more
|
||||
apats produces `(:fun-clause NAME APATS BODY)` instead of a
|
||||
`(:bind (:p-var …) …)` — keeping the simple `let x = e` shape
|
||||
unchanged for existing tests. 11 new tests in
|
||||
`lib/haskell/tests/parser-guards-where.sx` cover two- and three-way
|
||||
guards, mixed guarded + equality clauses, single- and multi-binding
|
||||
where blocks, guards plus where, case-alt guards, case-alt where,
|
||||
let with funclause shorthand, let with guards, and a where containing
|
||||
a type signature alongside a fun-clause. 173/173 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: top-level decls. Refactored `hk-parse-expr` into a
|
||||
`hk-parser tokens mode` with `:expr` / `:module` dispatch so the big lexical
|
||||
state is shared (peek/advance/pat/expr helpers all reachable); added public
|
||||
wrappers `hk-parse-expr`, `hk-parse-module`, and source-level entry
|
||||
`hk-parse-top`. New type parser (`hk-parse-type` / `hk-parse-btype` /
|
||||
`hk-parse-atype`): type variables (`:t-var`), type constructors (`:t-con`),
|
||||
type application (`:t-app`, left-assoc), right-associative function arrow
|
||||
(`:t-fun`), unit/tuples (`:t-tuple`), and lists (`:t-list`). New decl parser
|
||||
(`hk-parse-decl` / `hk-parse-program`) producing a `(:program DECLS)` shell:
|
||||
- `:type-sig NAMES TYPE` — comma-separated multi-name support
|
||||
- `:fun-clause NAME APATS BODY` — patterns for args, body via existing expr
|
||||
- `:pat-bind PAT BODY` — top-level pattern bindings like `(a, b) = pair`
|
||||
- `:data NAME TVARS CONS` with `:con-def CNAME FIELDS` for nullary and
|
||||
multi-arg constructors, including recursive references
|
||||
- `:type-syn NAME TVARS TYPE`, `:newtype NAME TVARS CNAME FIELD`
|
||||
- `:fixity ASSOC PREC OPS` — assoc one of `"l"`/`"r"`/`"n"`, default prec 9,
|
||||
comma-separated operator names, including backtick-quoted varids.
|
||||
Sig vs fun-clause disambiguated by a paren-balanced top-level scan for
|
||||
`::` before the next `;`/`}` (`hk-has-top-dcolon?`). 24 new tests in
|
||||
`lib/haskell/tests/parser-decls.sx` cover all decl forms, signatures with
|
||||
application / tuples / lists / right-assoc arrows, nullary and recursive
|
||||
data types, multi-clause functions, and a mixed program with data + type-
|
||||
synonym + signature + two function clauses. Not yet: guards, where
|
||||
clauses, module header, imports, deriving, contexts, GADTs. 162/162 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: full patterns. Added `as` patterns
|
||||
(`name@apat` → `(:p-as NAME PAT)`), lazy patterns (`~apat` →
|
||||
`(:p-lazy PAT)`), negative literal patterns (`-N` / `-F` resolving
|
||||
eagerly in the parser so downstream passes see a plain `(:p-int -1)`),
|
||||
and infix constructor patterns via a right-associative single-band
|
||||
layer on top of `hk-parse-pat-lhs` for any `consym` or reservedop `:`
|
||||
(so `x : xs` parses as `(:p-con ":" [x, xs])`, `a :+: b` likewise).
|
||||
Extended `hk-apat-start?` with `-` and `~` so the pattern-argument
|
||||
loops in lambdas and constructor applications pick these up.
|
||||
Lambdas now parse apat parameters instead of bare varids — so the
|
||||
`:lambda` AST is `(:lambda APATS BODY)` with apats as pattern nodes.
|
||||
`hk-parse-bind` became a plain `pat = expr` form, so `:bind` now has
|
||||
a pattern LHS throughout (simple `x = 1` → `(:bind (:p-var "x") …)`);
|
||||
this picks up `let (x, y) = pair in …` and `let Just x = m in x`
|
||||
automatically, and flows through `do`-notation lets. Eight existing
|
||||
tests updated to the pattern-flavoured AST. Also fixed a pragmatic
|
||||
layout issue that surfaced in multi-line `let`s: when a layout-indent
|
||||
would emit a spurious `;` just before an `in` token (because the
|
||||
let block had already been closed by dedent), `hk-peek-next-reserved`
|
||||
now lets the layout pass skip that indent and leave closing to the
|
||||
existing `in` handler. 18 new tests in
|
||||
`lib/haskell/tests/parser-patterns.sx` cover every pattern variant,
|
||||
lambda with mixed apats, let pattern-bindings (tuple / constructor /
|
||||
cons), and do-bind with a tuple pattern. 138/138 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: `case … of` and `do`-notation parsers. Added `hk-parse-case`
|
||||
/ `hk-parse-alt`, `hk-parse-do` / `hk-parse-do-stmt` / `hk-parse-do-let`, plus the
|
||||
minimal pattern language needed to make arms and binds meaningful:
|
||||
`hk-parse-apat` (var, wildcard `_`, int/float/string/char literal, 0-arity
|
||||
conid/qconid, paren+tuple, list) and `hk-parse-pat` (conid applied to
|
||||
apats greedily). AST nodes: `:case SCRUT ALTS`, `:alt PAT BODY`, `:do STMTS`
|
||||
with stmts `:do-expr E` / `:do-bind PAT E` / `:do-let BINDS`, and pattern
|
||||
tags `:p-wild` / `:p-int` / `:p-float` / `:p-string` / `:p-char` / `:p-var`
|
||||
/ `:p-con NAME ARGS` / `:p-tuple` / `:p-list`. `do`-stmts disambiguate
|
||||
`pat <- e` vs bare expression with a forward paren/bracket/brace-balanced
|
||||
scan for `<-` before the next `;`/`}` — no backtracking, no AST rewrite.
|
||||
`case` and `do` accept both implicit (`vlbrace`/`vsemi`/`vrbrace`) and
|
||||
explicit braces. Added to `hk-parse-lexp` so they participate fully in
|
||||
operator-precedence expressions. 19 new tests in
|
||||
`lib/haskell/tests/parser-case-do.sx` cover every pattern variant,
|
||||
explicit-brace `case`, expression scrutinees, do with bind/let/expr,
|
||||
multi-binding `let` in `do`, constructor patterns in binds, and
|
||||
`case`/`do` nested inside `let` and lambda. The full pattern item (as
|
||||
patterns, negative literals, `~` lazy, lambda/let pattern extension)
|
||||
remains a separate sub-item. 119/119 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: expression parser (`lib/haskell/parser.sx`, ~380 lines).
|
||||
Pratt-style precedence climbing against a Haskell-98-default op table (24
|
||||
operators across precedence 0–9, left/right/non assoc, default infixl 9 for
|
||||
anything unlisted). Supports literals (int/float/string/char), varid/conid
|
||||
(qualified variants folded into `:var` / `:con`), parens / unit / tuples,
|
||||
list literals, ranges `[a..b]` and `[a,b..c]`, left-associative application,
|
||||
unary `-`, backtick operators (`x \`mod\` 3`), lambdas, `if-then-else`, and
|
||||
`let … in` consuming both virtual and explicit braces. AST uses keyword
|
||||
tags (`:var`, `:op`, `:lambda`, `:let`, `:bind`, `:tuple`, `:range`,
|
||||
`:range-step`, `:app`, `:neg`, `:if`, `:list`, `:int`, `:float`, `:string`,
|
||||
`:char`, `:con`). The parser skips a leading `vlbrace` / `lbrace` so it can
|
||||
be called on full post-layout output, and uses a `raise`-based error channel
|
||||
with location-lite messages. 42 new tests in `lib/haskell/tests/parser-expr.sx`
|
||||
cover literals, identifiers, parens/tuple/unit, list + range, app associativity,
|
||||
operator precedence (mul over add, cons right-assoc, function-composition
|
||||
right-assoc, `$` lowest), backtick ops, unary `-`, lambda multi-param,
|
||||
`if` with infix condition, single- and multi-binding `let` (both implicit
|
||||
and explicit braces), plus a few mixed nestings. 100/100 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: layout algorithm (`lib/haskell/layout.sx`, ~260 lines)
|
||||
implementing Haskell 98 §10.3. Two-pass design: a pre-pass augments the raw
|
||||
token stream with explicit `layout-open` / `layout-indent` markers (suppressing
|
||||
`<n>` when `{n}` already applies, per note 3), then an L pass consumes the
|
||||
augmented stream against a stack of implicit/explicit layout contexts and
|
||||
emits `vlbrace` / `vsemi` / `vrbrace` tokens; newlines are dropped. Supports
|
||||
the initial module-level implicit open (skipped when the first token is
|
||||
`module` or `{`), the four layout keywords (`let`/`where`/`do`/`of`), explicit
|
||||
braces disabling layout, dedent closing nested implicit blocks while also
|
||||
emitting `vsemi` at the enclosing level, and the pragmatic single-line
|
||||
`let … in` rule (emit `}` when `in` meets an implicit let). 15 new tests
|
||||
in `lib/haskell/tests/layout.sx` cover module-start, do/let/where/case/of,
|
||||
explicit braces, multi-level dedent, line continuation, and EOF close-down.
|
||||
Shared test helpers moved to `lib/haskell/testlib.sx` so both test files
|
||||
can share one `hk-test`. `test.sh` preloads tokenizer + layout + testlib.
|
||||
58/58 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: Haskell 98 tokenizer (`lib/haskell/tokenizer.sx`, 490 lines)
|
||||
covering idents (lower/upper/qvarid/qconid), 23 reserved words, 11 reserved ops,
|
||||
varsym/consym operator chains, integer/hex/octal/float literals incl. exponent
|
||||
|
||||
@@ -65,7 +65,7 @@ Each item: implement → tests → update progress. Mark `[x]` when tests green.
|
||||
- [x] Punctuation: `( ) { } [ ] , ; : . ...`
|
||||
- [x] Operators: `+ - * / % ** = == === != !== < > <= >= && || ! ?? ?: & | ^ ~ << >> >>> += -= ...`
|
||||
- [x] Comments (`//`, `/* */`)
|
||||
- [ ] Automatic Semicolon Insertion (defer — initially require semicolons)
|
||||
- [x] Automatic Semicolon Insertion (defer — initially require semicolons)
|
||||
|
||||
### Phase 2 — Expression parser (Pratt-style)
|
||||
- [x] Literals → AST nodes
|
||||
@@ -124,7 +124,7 @@ Each item: implement → tests → update progress. Mark `[x]` when tests green.
|
||||
- [x] Closures — work via SX `fn` env capture
|
||||
- [x] Rest params (`...rest` → `&rest`)
|
||||
- [x] Default parameters (desugar to `if (param === undefined) param = default`)
|
||||
- [ ] `var` hoisting (deferred — treated as `let` for now)
|
||||
- [x] `var` hoisting (shallow — collects direct `var` decls, emits `(define name :js-undefined)` before funcdecls)
|
||||
- [ ] `let`/`const` TDZ (deferred)
|
||||
|
||||
### Phase 8 — Objects, prototypes, `this`
|
||||
@@ -158,6 +158,18 @@ Each item: implement → tests → update progress. Mark `[x]` when tests green.
|
||||
|
||||
Append-only record of completed iterations. Loop writes one line per iteration: date, what was done, test count delta.
|
||||
|
||||
- 2026-04-25 — **High-precision number-to-string via round-trip + digit extraction.** `js-big-int-str-loop` extracts decimal digits from integer-valued float. `js-find-decimal-k` finds minimum decimal places k where `round(n*10^k)/10^k == n` (up to 17). `js-format-decimal-digits` inserts decimal point. `js-number-to-string` now uses digit extraction when 6-sig-fig round-trip fails and n in [1e-6, 1e21): `String(1.0000001)="1.0000001"`, `String(1/3)="0.3333333333333333"`. String test262 subset: 58→62/100. 529/530 unit, 148/148 slice.
|
||||
|
||||
- 2026-04-25 — **String wrapper objects + number-to-string sci notation.** `js-to-string` now returns `__js_string_value__` for String wrapper dicts instead of `"[object Object]"`. `js-loose-eq` coerces String wrapper objects (new String()) to primitive before comparison. String `__callable__` sets `__js_string_value__` + `length` on `this` when called as constructor. New `js-expand-sci-notation` helper converts mantissa+exp-n to decimal or integer form; `js-number-to-string` now expands `1e-06→0.000001`, `1e+06→1000000`, fixes `1e21→1e+21`. String test262 subset: 45→58/100. 529/530 unit, 148/148 slice.
|
||||
|
||||
- 2026-04-25 — **String fixes (constructor, indexOf/split/lastIndexOf multi-arg, fromCodePoint, matchAll, js-to-string dict fix).** Added `String.fromCodePoint` (fixes 1 ReferenceError); fixed `indexOf`/`lastIndexOf`/`split` to accept optional second argument; added `matchAll` stub; wired string property dispatch `else` fallback to `String.prototype` (fixes `'a'.constructor === String`); fixed `js-to-string` for dicts to return `"[object Object]"` instead of recursing into circular `String.prototype.constructor` structure. Scoreboard: String 42→43, timeouts 32→13. Total 162→202/300 (54%→67.3%). 529/530 unit, 148/148 slice.
|
||||
|
||||
- 2026-04-25 — **Math methods (trig/log/hyperbolic/bit ops).** Added 22 missing Math methods to `runtime.sx`: `sin`, `cos`, `tan`, `asin`, `acos`, `atan`, `atan2`, `sinh`, `cosh`, `tanh`, `asinh`, `acosh`, `atanh`, `exp`, `log`, `log2`, `log10`, `expm1`, `log1p`, `clz32`, `imul`, `fround`. All use existing SX primitives. `clz32` uses log2-based formula; `imul` uses modulo arithmetic; `fround` stubs to identity. Addresses 36x "TypeError: not a function" in built-ins/Math (43% → ~79% expected). 529/530 unit (unchanged), 148/148 slice. Commit `5f38e49b`.
|
||||
|
||||
- 2026-04-25 — **`var` hoisting.** Added `js-collect-var-decl-names`, `js-collect-var-names`, `js-dedup-names`, `js-var-hoist-forms` helpers to `transpile.sx`. Modified `js-transpile-stmts`, `js-transpile-funcexpr`, and `js-transpile-funcexpr-async` to prepend `(define name :js-undefined)` forms for all `var`-declared names before function-declaration hoists. Shallow collection (direct statements only). 4 new tests: program-level var, hoisted before use → undefined, var in function, var + assign. 529/530 unit (+4), 148/148 slice unchanged. Commit `11315d91`.
|
||||
|
||||
- 2026-04-25 — **ASI (Automatic Semicolon Insertion).** Lexer: added `:nl` (newline-before) boolean to every token dict; `skip-ws!` sets it true when consuming `\n`/`\r`; `scan!` resets it to `false` at the start of each token scan. Parser: new `jp-token-nl?` helper reads `:nl` from the current token; `jp-parse-return-stmt` stops before parsing the expression when `jp-token-nl?` is true (restricted production: `return\nvalue` → `return undefined`). 4 new tests (flag presence, flag value, restricted return). 525/526 unit (+4), 148/148 slice unchanged. Commit `ae86579a`.
|
||||
|
||||
- 2026-04-23 — scaffold landed: lib/js/{lexer,parser,transpile,runtime}.sx stubs + test.sh. 7/7 smoke tests pass (js-tokenize/js-parse/js-transpile stubs + js-to-boolean coercion cases).
|
||||
- 2026-04-23 — Phase 1 (Lexer) complete: numbers (int/float/hex/exp/leading-dot), strings (escapes), idents/keywords, punctuation, all operators (1-4 char, longest-match), // and /* */ comments. 38/38 tests pass. Gotchas found: `peek` and `emit!` are primitives (shadowed to `js-peek`, `js-emit!`); `cond` clauses take ONE body only, multi-expr needs `(do ...)` wrapper.
|
||||
- 2026-04-23 — Phase 2 (Pratt expression parser) complete: literals, binary precedence (w/ `**` right-assoc), unary (`- + ! ~ typeof void`), member access (`.`/`[]`), call chains, array/object literals (ident+string+number keys), ternary, arrow fns (zero/one/many params; curried), assignment (right-assoc incl. compound `+=` etc.). AST node shapes all match the `js-*` names already wired. 47 new tests, 85/85 total. Most of the Phase 2 scaffolding was already written in an earlier session — this iteration verified every path, added the parser test suite, and greened everything on the first pass. No new gotchas beyond Phase 1.
|
||||
|
||||
Reference in New Issue
Block a user