Compare commits
6 Commits
loops/hask
...
loops/smal
| Author | SHA1 | Date | |
|---|---|---|---|
| 4e89498664 | |||
| 52523606a8 | |||
| e71154f9c6 | |||
| 33ce994f23 | |||
| 4e7d2183ad | |||
| 6a00df2609 |
@@ -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,775 +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)) (pat-binds (list)))
|
||||
;; Pass 1: collect fun-clause groups by name; collect pat-binds
|
||||
;; in source order. Pre-seed env so any name can already be
|
||||
;; looked up by closures built in pass 2.
|
||||
(for-each
|
||||
(fn (d)
|
||||
(cond
|
||||
((= (first d) "fun-clause")
|
||||
(let
|
||||
((name (nth d 1)))
|
||||
(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 for arity > 0; mark 0-arity for
|
||||
;; pass 3. The mutable env means recursive references work.
|
||||
(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))))))
|
||||
(keys groups))
|
||||
;; Pass 3: evaluate 0-arity bodies and pat-binds.
|
||||
(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,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}
|
||||
656
lib/smalltalk/eval.sx
Normal file
656
lib/smalltalk/eval.sx
Normal file
@@ -0,0 +1,656 @@
|
||||
;; Smalltalk AST evaluator — sequential semantics. Method dispatch uses the
|
||||
;; class table from runtime.sx; native receivers fall back to a primitive
|
||||
;; method table. Non-local return is implemented via a sentinel marker; the
|
||||
;; full continuation-based escape is the Phase 3 showcase.
|
||||
;;
|
||||
;; Frame:
|
||||
;; {:self V ; receiver
|
||||
;; :method-class N ; defining class of the executing method
|
||||
;; :locals (mutable dict) ; param + temp bindings
|
||||
;; :parent P} ; outer frame for blocks (nil for top-level)
|
||||
;;
|
||||
;; `smalltalk-eval-ast(ast, frame)` returns the value or a return marker.
|
||||
;; Method invocation unwraps return markers; sequences propagate them.
|
||||
|
||||
(define
|
||||
st-make-frame
|
||||
(fn
|
||||
(self method-class parent)
|
||||
{:self self :method-class method-class :locals {} :parent parent}))
|
||||
|
||||
(define st-return-marker (fn (v) {:st-return true :value v}))
|
||||
|
||||
(define
|
||||
st-return-marker?
|
||||
(fn (v) (and (dict? v) (has-key? v :st-return) (= (get v :st-return) true))))
|
||||
|
||||
(define
|
||||
st-make-block
|
||||
(fn
|
||||
(ast frame)
|
||||
{:type "st-block"
|
||||
:params (get ast :params)
|
||||
:temps (get ast :temps)
|
||||
:body (get ast :body)
|
||||
:env frame}))
|
||||
|
||||
(define
|
||||
st-block?
|
||||
(fn
|
||||
(v)
|
||||
(and (dict? v) (has-key? v :type) (= (get v :type) "st-block"))))
|
||||
|
||||
(define
|
||||
st-class-ref
|
||||
(fn (name) {:type "st-class" :name name}))
|
||||
|
||||
(define
|
||||
st-class-ref?
|
||||
(fn (v) (and (dict? v) (has-key? v :type) (= (get v :type) "st-class"))))
|
||||
|
||||
;; Walk the frame chain looking for a local binding.
|
||||
(define
|
||||
st-lookup-local
|
||||
(fn
|
||||
(frame name)
|
||||
(cond
|
||||
((= frame nil) {:found false :value nil :frame nil})
|
||||
((has-key? (get frame :locals) name)
|
||||
{:found true :value (get (get frame :locals) name) :frame frame})
|
||||
(else (st-lookup-local (get frame :parent) name)))))
|
||||
|
||||
;; Walk the frame chain looking for the frame whose self has this ivar.
|
||||
(define
|
||||
st-lookup-ivar-frame
|
||||
(fn
|
||||
(frame name)
|
||||
(cond
|
||||
((= frame nil) nil)
|
||||
((let ((self (get frame :self)))
|
||||
(and (st-instance? self) (has-key? (get self :ivars) name)))
|
||||
frame)
|
||||
(else (st-lookup-ivar-frame (get frame :parent) name)))))
|
||||
|
||||
;; Resolve an identifier in eval order: local → ivar → class → error.
|
||||
(define
|
||||
st-resolve-ident
|
||||
(fn
|
||||
(frame name)
|
||||
(let
|
||||
((local-result (st-lookup-local frame name)))
|
||||
(cond
|
||||
((get local-result :found) (get local-result :value))
|
||||
(else
|
||||
(let
|
||||
((iv-frame (st-lookup-ivar-frame frame name)))
|
||||
(cond
|
||||
((not (= iv-frame nil))
|
||||
(get (get (get iv-frame :self) :ivars) name))
|
||||
((st-class-exists? name) (st-class-ref name))
|
||||
(else
|
||||
(error
|
||||
(str "smalltalk-eval-ast: undefined variable '" name "'"))))))))))
|
||||
|
||||
;; Assign to an existing local in the frame chain or, failing that, an ivar
|
||||
;; on self. Errors if neither exists.
|
||||
(define
|
||||
st-assign!
|
||||
(fn
|
||||
(frame name value)
|
||||
(let
|
||||
((local-result (st-lookup-local frame name)))
|
||||
(cond
|
||||
((get local-result :found)
|
||||
(begin
|
||||
(dict-set! (get (get local-result :frame) :locals) name value)
|
||||
value))
|
||||
(else
|
||||
(let
|
||||
((iv-frame (st-lookup-ivar-frame frame name)))
|
||||
(cond
|
||||
((not (= iv-frame nil))
|
||||
(begin
|
||||
(dict-set! (get (get iv-frame :self) :ivars) name value)
|
||||
value))
|
||||
(else
|
||||
;; Smalltalk allows new locals to be introduced; for our subset
|
||||
;; we treat unknown writes as errors so test mistakes surface.
|
||||
(error
|
||||
(str "smalltalk-eval-ast: cannot assign undefined '" name "'"))))))))))
|
||||
|
||||
;; ── Main evaluator ─────────────────────────────────────────────────────
|
||||
(define
|
||||
smalltalk-eval-ast
|
||||
(fn
|
||||
(ast frame)
|
||||
(cond
|
||||
((not (dict? ast)) (error (str "smalltalk-eval-ast: bad ast " ast)))
|
||||
(else
|
||||
(let
|
||||
((ty (get ast :type)))
|
||||
(cond
|
||||
((= ty "lit-int") (get ast :value))
|
||||
((= ty "lit-float") (get ast :value))
|
||||
((= ty "lit-string") (get ast :value))
|
||||
((= ty "lit-char") (get ast :value))
|
||||
((= ty "lit-symbol") (make-symbol (get ast :value)))
|
||||
((= ty "lit-nil") nil)
|
||||
((= ty "lit-true") true)
|
||||
((= ty "lit-false") false)
|
||||
((= ty "lit-array")
|
||||
(map
|
||||
(fn (e) (smalltalk-eval-ast e frame))
|
||||
(get ast :elements)))
|
||||
((= ty "lit-byte-array") (get ast :elements))
|
||||
((= ty "self") (get frame :self))
|
||||
((= ty "super") (get frame :self))
|
||||
((= ty "thisContext") frame)
|
||||
((= ty "ident") (st-resolve-ident frame (get ast :name)))
|
||||
((= ty "assign")
|
||||
(st-assign! frame (get ast :name) (smalltalk-eval-ast (get ast :expr) frame)))
|
||||
((= ty "return")
|
||||
(st-return-marker (smalltalk-eval-ast (get ast :expr) frame)))
|
||||
((= ty "block") (st-make-block ast frame))
|
||||
((= ty "seq") (st-eval-seq (get ast :exprs) frame))
|
||||
((= ty "send")
|
||||
(st-eval-send ast frame (= (get (get ast :receiver) :type) "super")))
|
||||
((= ty "cascade") (st-eval-cascade ast frame))
|
||||
(else (error (str "smalltalk-eval-ast: unknown type '" ty "'")))))))))
|
||||
|
||||
(define
|
||||
st-eval-seq
|
||||
(fn
|
||||
(exprs frame)
|
||||
(let ((result nil))
|
||||
(begin
|
||||
(define
|
||||
sq-loop
|
||||
(fn
|
||||
(rest)
|
||||
(cond
|
||||
((= (len rest) 0) nil)
|
||||
(else
|
||||
(let ((v (smalltalk-eval-ast (nth rest 0) frame)))
|
||||
(cond
|
||||
((st-return-marker? v) (set! result v))
|
||||
((= (len rest) 1) (set! result v))
|
||||
(else (sq-loop (rest-of rest)))))))))
|
||||
(sq-loop exprs)
|
||||
result))))
|
||||
|
||||
(define
|
||||
rest-of
|
||||
(fn
|
||||
(lst)
|
||||
(let ((out (list)) (i 1) (n (len lst)))
|
||||
(begin
|
||||
(define
|
||||
ro-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i n)
|
||||
(begin (append! out (nth lst i)) (set! i (+ i 1)) (ro-loop)))))
|
||||
(ro-loop)
|
||||
out))))
|
||||
|
||||
(define
|
||||
st-eval-send
|
||||
(fn
|
||||
(ast frame super?)
|
||||
(let
|
||||
((receiver (smalltalk-eval-ast (get ast :receiver) frame))
|
||||
(selector (get ast :selector))
|
||||
(args (map (fn (a) (smalltalk-eval-ast a frame)) (get ast :args))))
|
||||
(cond
|
||||
(super?
|
||||
(st-super-send (get frame :self) selector args (get frame :method-class)))
|
||||
(else (st-send receiver selector args))))))
|
||||
|
||||
(define
|
||||
st-eval-cascade
|
||||
(fn
|
||||
(ast frame)
|
||||
(let
|
||||
((receiver (smalltalk-eval-ast (get ast :receiver) frame))
|
||||
(msgs (get ast :messages))
|
||||
(last nil))
|
||||
(begin
|
||||
(for-each
|
||||
(fn
|
||||
(m)
|
||||
(let
|
||||
((sel (get m :selector))
|
||||
(args (map (fn (a) (smalltalk-eval-ast a frame)) (get m :args))))
|
||||
(set! last (st-send receiver sel args))))
|
||||
msgs)
|
||||
last))))
|
||||
|
||||
;; ── Send dispatch ──────────────────────────────────────────────────────
|
||||
(define
|
||||
st-send
|
||||
(fn
|
||||
(receiver selector args)
|
||||
(let
|
||||
((cls (st-class-of-for-send receiver)))
|
||||
(let
|
||||
((class-side? (st-class-ref? receiver))
|
||||
(recv-class (if (st-class-ref? receiver) (get receiver :name) cls)))
|
||||
(let
|
||||
((method
|
||||
(if class-side?
|
||||
(st-method-lookup recv-class selector true)
|
||||
(st-method-lookup recv-class selector false))))
|
||||
(cond
|
||||
((not (= method nil))
|
||||
(st-invoke method receiver args))
|
||||
((st-block? receiver) (st-block-dispatch receiver selector args))
|
||||
(else (st-primitive-send receiver selector args))))))))
|
||||
|
||||
(define
|
||||
st-class-of-for-send
|
||||
(fn
|
||||
(v)
|
||||
(cond
|
||||
((st-class-ref? v) "Class")
|
||||
(else (st-class-of v)))))
|
||||
|
||||
(define
|
||||
st-super-send
|
||||
(fn
|
||||
(receiver selector args defining-class)
|
||||
(let
|
||||
((super (st-class-superclass defining-class)))
|
||||
(cond
|
||||
((= super nil)
|
||||
(error (str "super send past Object: " selector)))
|
||||
(else
|
||||
(let ((method (st-method-lookup super selector false)))
|
||||
(cond
|
||||
((not (= method nil)) (st-invoke method receiver args))
|
||||
(else (st-primitive-send receiver selector args)))))))))
|
||||
|
||||
;; ── Method invocation ──────────────────────────────────────────────────
|
||||
(define
|
||||
st-invoke
|
||||
(fn
|
||||
(method receiver args)
|
||||
(let
|
||||
((params (get method :params))
|
||||
(temps (get method :temps))
|
||||
(body (get method :body))
|
||||
(defining-class (get method :defining-class)))
|
||||
(cond
|
||||
((not (= (len params) (len args)))
|
||||
(error
|
||||
(str "smalltalk-eval-ast: arity mismatch for "
|
||||
(get method :selector)
|
||||
" expected " (len params) " got " (len args))))
|
||||
(else
|
||||
(let
|
||||
((frame (st-make-frame receiver defining-class nil)))
|
||||
(begin
|
||||
;; Bind params
|
||||
(let ((i 0))
|
||||
(begin
|
||||
(define
|
||||
pb-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i (len params))
|
||||
(begin
|
||||
(dict-set!
|
||||
(get frame :locals)
|
||||
(nth params i)
|
||||
(nth args i))
|
||||
(set! i (+ i 1))
|
||||
(pb-loop)))))
|
||||
(pb-loop)))
|
||||
;; Bind temps to nil
|
||||
(for-each
|
||||
(fn (t) (dict-set! (get frame :locals) t nil))
|
||||
temps)
|
||||
;; Execute body
|
||||
(let ((result (st-eval-seq body frame)))
|
||||
(cond
|
||||
((st-return-marker? result) (get result :value))
|
||||
(else receiver))))))))))
|
||||
|
||||
;; ── Block dispatch ─────────────────────────────────────────────────────
|
||||
(define
|
||||
st-block-value-selector?
|
||||
(fn
|
||||
(s)
|
||||
(or
|
||||
(= s "value")
|
||||
(= s "value:")
|
||||
(= s "value:value:")
|
||||
(= s "value:value:value:")
|
||||
(= s "value:value:value:value:"))))
|
||||
|
||||
(define
|
||||
st-block-dispatch
|
||||
(fn
|
||||
(block selector args)
|
||||
(cond
|
||||
((st-block-value-selector? selector) (st-block-apply block args))
|
||||
((= selector "valueWithArguments:") (st-block-apply block (nth args 0)))
|
||||
((= selector "whileTrue:")
|
||||
(st-block-while block (nth args 0) true))
|
||||
((= selector "whileFalse:")
|
||||
(st-block-while block (nth args 0) false))
|
||||
((= selector "whileTrue") (st-block-while block nil true))
|
||||
((= selector "whileFalse") (st-block-while block nil false))
|
||||
((= selector "numArgs") (len (get block :params)))
|
||||
((= selector "class") (st-class-ref "BlockClosure"))
|
||||
((= selector "==") (= block (nth args 0)))
|
||||
((= selector "printString") "a BlockClosure")
|
||||
(else
|
||||
(error (str "BlockClosure doesNotUnderstand: " selector))))))
|
||||
|
||||
(define
|
||||
st-block-apply
|
||||
(fn
|
||||
(block args)
|
||||
(let
|
||||
((params (get block :params))
|
||||
(temps (get block :temps))
|
||||
(body (get block :body))
|
||||
(env (get block :env)))
|
||||
(cond
|
||||
((not (= (len params) (len args)))
|
||||
(error
|
||||
(str "BlockClosure: arity mismatch — block expects "
|
||||
(len params) " got " (len args))))
|
||||
(else
|
||||
(let
|
||||
((frame (st-make-frame
|
||||
(if (= env nil) nil (get env :self))
|
||||
(if (= env nil) nil (get env :method-class))
|
||||
env)))
|
||||
(begin
|
||||
(let ((i 0))
|
||||
(begin
|
||||
(define
|
||||
pb-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i (len params))
|
||||
(begin
|
||||
(dict-set!
|
||||
(get frame :locals)
|
||||
(nth params i)
|
||||
(nth args i))
|
||||
(set! i (+ i 1))
|
||||
(pb-loop)))))
|
||||
(pb-loop)))
|
||||
(for-each
|
||||
(fn (t) (dict-set! (get frame :locals) t nil))
|
||||
temps)
|
||||
(st-eval-seq body frame))))))))
|
||||
|
||||
(define
|
||||
st-block-while
|
||||
(fn
|
||||
(cond-block body-block target)
|
||||
(let ((last nil))
|
||||
(begin
|
||||
(define
|
||||
wh-loop
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((c (st-block-apply cond-block (list))))
|
||||
(when
|
||||
(= c target)
|
||||
(begin
|
||||
(cond
|
||||
((not (= body-block nil))
|
||||
(set! last (st-block-apply body-block (list)))))
|
||||
(wh-loop))))))
|
||||
(wh-loop)
|
||||
last))))
|
||||
|
||||
;; ── Primitive method table for native receivers ────────────────────────
|
||||
(define
|
||||
st-primitive-send
|
||||
(fn
|
||||
(receiver selector args)
|
||||
(let ((cls (st-class-of receiver)))
|
||||
(cond
|
||||
((or (= cls "SmallInteger") (= cls "Float"))
|
||||
(st-num-send receiver selector args))
|
||||
((or (= cls "String") (= cls "Symbol"))
|
||||
(st-string-send receiver selector args))
|
||||
((= cls "True") (st-bool-send true selector args))
|
||||
((= cls "False") (st-bool-send false selector args))
|
||||
((= cls "UndefinedObject") (st-nil-send selector args))
|
||||
((= cls "Array") (st-array-send receiver selector args))
|
||||
((st-class-ref? receiver) (st-class-side-send receiver selector args))
|
||||
(else
|
||||
(error
|
||||
(str "doesNotUnderstand: " cls " >> " selector)))))))
|
||||
|
||||
(define
|
||||
st-num-send
|
||||
(fn
|
||||
(n selector args)
|
||||
(cond
|
||||
((= selector "+") (+ n (nth args 0)))
|
||||
((= selector "-") (- n (nth args 0)))
|
||||
((= selector "*") (* n (nth args 0)))
|
||||
((= selector "/") (/ n (nth args 0)))
|
||||
((= selector "//") (/ n (nth args 0)))
|
||||
((= selector "\\\\") (mod n (nth args 0)))
|
||||
((= selector "<") (< n (nth args 0)))
|
||||
((= selector ">") (> n (nth args 0)))
|
||||
((= selector "<=") (<= n (nth args 0)))
|
||||
((= selector ">=") (>= n (nth args 0)))
|
||||
((= selector "=") (= n (nth args 0)))
|
||||
((= selector "~=") (not (= n (nth args 0))))
|
||||
((= selector "==") (= n (nth args 0)))
|
||||
((= selector "~~") (not (= n (nth args 0))))
|
||||
((= selector "negated") (- 0 n))
|
||||
((= selector "abs") (if (< n 0) (- 0 n) n))
|
||||
((= selector "max:") (if (> n (nth args 0)) n (nth args 0)))
|
||||
((= selector "min:") (if (< n (nth args 0)) n (nth args 0)))
|
||||
((= selector "printString") (str n))
|
||||
((= selector "asString") (str n))
|
||||
((= selector "class")
|
||||
(st-class-ref (st-class-of n)))
|
||||
((= selector "isNil") false)
|
||||
((= selector "notNil") true)
|
||||
((= selector "isZero") (= n 0))
|
||||
((= selector "between:and:")
|
||||
(and (>= n (nth args 0)) (<= n (nth args 1))))
|
||||
((= selector "to:do:")
|
||||
(let ((i n) (stop (nth args 0)) (block (nth args 1)))
|
||||
(begin
|
||||
(define
|
||||
td-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(<= i stop)
|
||||
(begin
|
||||
(st-block-apply block (list i))
|
||||
(set! i (+ i 1))
|
||||
(td-loop)))))
|
||||
(td-loop)
|
||||
n)))
|
||||
((= selector "timesRepeat:")
|
||||
(let ((i 0) (block (nth args 0)))
|
||||
(begin
|
||||
(define
|
||||
tr-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i n)
|
||||
(begin
|
||||
(st-block-apply block (list))
|
||||
(set! i (+ i 1))
|
||||
(tr-loop)))))
|
||||
(tr-loop)
|
||||
n)))
|
||||
(else (error (str "doesNotUnderstand: Number >> " selector))))))
|
||||
|
||||
(define
|
||||
st-string-send
|
||||
(fn
|
||||
(s selector args)
|
||||
(cond
|
||||
((= selector ",") (str s (nth args 0)))
|
||||
((= selector "size") (len s))
|
||||
((= selector "=") (= s (nth args 0)))
|
||||
((= selector "~=") (not (= s (nth args 0))))
|
||||
((= selector "==") (= s (nth args 0)))
|
||||
((= selector "~~") (not (= s (nth args 0))))
|
||||
((= selector "isEmpty") (= (len s) 0))
|
||||
((= selector "notEmpty") (> (len s) 0))
|
||||
((= selector "printString") (str "'" s "'"))
|
||||
((= selector "asString") s)
|
||||
((= selector "asSymbol") (make-symbol (if (symbol? s) (str s) s)))
|
||||
((= selector "class") (st-class-ref (st-class-of s)))
|
||||
((= selector "isNil") false)
|
||||
((= selector "notNil") true)
|
||||
(else (error (str "doesNotUnderstand: String >> " selector))))))
|
||||
|
||||
(define
|
||||
st-bool-send
|
||||
(fn
|
||||
(b selector args)
|
||||
(cond
|
||||
((= selector "not") (not b))
|
||||
((= selector "&") (and b (nth args 0)))
|
||||
((= selector "|") (or b (nth args 0)))
|
||||
((= selector "and:")
|
||||
(cond (b (st-block-apply (nth args 0) (list))) (else false)))
|
||||
((= selector "or:")
|
||||
(cond (b true) (else (st-block-apply (nth args 0) (list)))))
|
||||
((= selector "ifTrue:")
|
||||
(cond (b (st-block-apply (nth args 0) (list))) (else nil)))
|
||||
((= selector "ifFalse:")
|
||||
(cond (b nil) (else (st-block-apply (nth args 0) (list)))))
|
||||
((= selector "ifTrue:ifFalse:")
|
||||
(cond
|
||||
(b (st-block-apply (nth args 0) (list)))
|
||||
(else (st-block-apply (nth args 1) (list)))))
|
||||
((= selector "ifFalse:ifTrue:")
|
||||
(cond
|
||||
(b (st-block-apply (nth args 1) (list)))
|
||||
(else (st-block-apply (nth args 0) (list)))))
|
||||
((= selector "=") (= b (nth args 0)))
|
||||
((= selector "~=") (not (= b (nth args 0))))
|
||||
((= selector "==") (= b (nth args 0)))
|
||||
((= selector "printString") (if b "true" "false"))
|
||||
((= selector "class") (st-class-ref (if b "True" "False")))
|
||||
((= selector "isNil") false)
|
||||
((= selector "notNil") true)
|
||||
(else (error (str "doesNotUnderstand: Boolean >> " selector))))))
|
||||
|
||||
(define
|
||||
st-nil-send
|
||||
(fn
|
||||
(selector args)
|
||||
(cond
|
||||
((= selector "isNil") true)
|
||||
((= selector "notNil") false)
|
||||
((= selector "ifNil:") (st-block-apply (nth args 0) (list)))
|
||||
((= selector "ifNotNil:") nil)
|
||||
((= selector "ifNil:ifNotNil:") (st-block-apply (nth args 0) (list)))
|
||||
((= selector "ifNotNil:ifNil:") (st-block-apply (nth args 1) (list)))
|
||||
((= selector "=") (= nil (nth args 0)))
|
||||
((= selector "~=") (not (= nil (nth args 0))))
|
||||
((= selector "==") (= nil (nth args 0)))
|
||||
((= selector "printString") "nil")
|
||||
((= selector "class") (st-class-ref "UndefinedObject"))
|
||||
(else (error (str "doesNotUnderstand: UndefinedObject >> " selector))))))
|
||||
|
||||
(define
|
||||
st-array-send
|
||||
(fn
|
||||
(a selector args)
|
||||
(cond
|
||||
((= selector "size") (len a))
|
||||
((= selector "at:")
|
||||
;; 1-indexed
|
||||
(nth a (- (nth args 0) 1)))
|
||||
((= selector "at:put:")
|
||||
(begin
|
||||
(set-nth! a (- (nth args 0) 1) (nth args 1))
|
||||
(nth args 1)))
|
||||
((= selector "first") (nth a 0))
|
||||
((= selector "last") (nth a (- (len a) 1)))
|
||||
((= selector "isEmpty") (= (len a) 0))
|
||||
((= selector "notEmpty") (> (len a) 0))
|
||||
((= selector "do:")
|
||||
(begin
|
||||
(for-each
|
||||
(fn (e) (st-block-apply (nth args 0) (list e)))
|
||||
a)
|
||||
a))
|
||||
((= selector "collect:")
|
||||
(map (fn (e) (st-block-apply (nth args 0) (list e))) a))
|
||||
((= selector "select:")
|
||||
(filter (fn (e) (st-block-apply (nth args 0) (list e))) a))
|
||||
((= selector ",")
|
||||
(let ((out (list)))
|
||||
(begin
|
||||
(for-each (fn (e) (append! out e)) a)
|
||||
(for-each (fn (e) (append! out e)) (nth args 0))
|
||||
out)))
|
||||
((= selector "=") (= a (nth args 0)))
|
||||
((= selector "==") (= a (nth args 0)))
|
||||
((= selector "printString")
|
||||
(str "#(" (join " " (map (fn (e) (str e)) a)) ")"))
|
||||
((= selector "class") (st-class-ref "Array"))
|
||||
((= selector "isNil") false)
|
||||
((= selector "notNil") true)
|
||||
(else (error (str "doesNotUnderstand: Array >> " selector))))))
|
||||
|
||||
(define
|
||||
st-class-side-send
|
||||
(fn
|
||||
(cref selector args)
|
||||
(let ((name (get cref :name)))
|
||||
(cond
|
||||
((= selector "new") (st-make-instance name))
|
||||
((= selector "name") name)
|
||||
((= selector "superclass")
|
||||
(let ((s (st-class-superclass name)))
|
||||
(cond ((= s nil) nil) (else (st-class-ref s)))))
|
||||
((= selector "printString") name)
|
||||
((= selector "class") (st-class-ref "Metaclass"))
|
||||
((= selector "==") (and (st-class-ref? (nth args 0))
|
||||
(= name (get (nth args 0) :name))))
|
||||
((= selector "=") (and (st-class-ref? (nth args 0))
|
||||
(= name (get (nth args 0) :name))))
|
||||
((= selector "isNil") false)
|
||||
((= selector "notNil") true)
|
||||
(else
|
||||
(error (str "doesNotUnderstand: " name " class >> " selector)))))))
|
||||
|
||||
;; Convenience: parse and evaluate a Smalltalk expression with no receiver.
|
||||
(define
|
||||
smalltalk-eval
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((ast (st-parse-expr src))
|
||||
(frame (st-make-frame nil nil nil)))
|
||||
(smalltalk-eval-ast ast frame))))
|
||||
|
||||
;; Evaluate a sequence of statements at the top level.
|
||||
(define
|
||||
smalltalk-eval-program
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((ast (st-parse src)) (frame (st-make-frame nil nil nil)))
|
||||
(let ((result (smalltalk-eval-ast ast frame)))
|
||||
(cond
|
||||
((st-return-marker? result) (get result :value))
|
||||
(else result))))))
|
||||
891
lib/smalltalk/parser.sx
Normal file
891
lib/smalltalk/parser.sx
Normal file
@@ -0,0 +1,891 @@
|
||||
;; Smalltalk parser — produces an AST from the tokenizer's token stream.
|
||||
;;
|
||||
;; AST node shapes (dicts):
|
||||
;; {:type "lit-int" :value N} integer
|
||||
;; {:type "lit-float" :value F} float
|
||||
;; {:type "lit-string" :value S} string
|
||||
;; {:type "lit-char" :value C} character
|
||||
;; {:type "lit-symbol" :value S} symbol literal (#foo)
|
||||
;; {:type "lit-array" :elements (list ...)} literal array (#(1 2 #foo))
|
||||
;; {:type "lit-byte-array" :elements (...)} byte array (#[1 2 3])
|
||||
;; {:type "lit-nil" } / "lit-true" / "lit-false"
|
||||
;; {:type "ident" :name "x"} variable reference
|
||||
;; {:type "self"} / "super" / "thisContext" pseudo-variables
|
||||
;; {:type "assign" :name "x" :expr E} x := E
|
||||
;; {:type "return" :expr E} ^ E
|
||||
;; {:type "send" :receiver R :selector S :args (list ...)}
|
||||
;; {:type "cascade" :receiver R :messages (list {:selector :args} ...)}
|
||||
;; {:type "block" :params (list "a") :temps (list "t") :body (list expr)}
|
||||
;; {:type "seq" :exprs (list ...)} statement sequence
|
||||
;; {:type "method" :selector S :params (list ...) :temps (list ...) :body (list ...) :pragmas (list ...)}
|
||||
;;
|
||||
;; A "chunk" / class-definition stream is parsed at a higher level (deferred).
|
||||
|
||||
;; ── Chunk-stream reader ────────────────────────────────────────────────
|
||||
;; Pharo chunk format: chunks are separated by `!`. A doubled `!!` inside a
|
||||
;; chunk represents a single literal `!`. Returns list of chunk strings with
|
||||
;; surrounding whitespace trimmed.
|
||||
(define
|
||||
st-read-chunks
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((chunks (list))
|
||||
(buf (list))
|
||||
(pos 0)
|
||||
(n (len src)))
|
||||
(begin
|
||||
(define
|
||||
flush!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((s (st-trim (join "" buf))))
|
||||
(begin (append! chunks s) (set! buf (list))))))
|
||||
(define
|
||||
rc-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< pos n)
|
||||
(let
|
||||
((c (nth src pos)))
|
||||
(cond
|
||||
((= c "!")
|
||||
(cond
|
||||
((and (< (+ pos 1) n) (= (nth src (+ pos 1)) "!"))
|
||||
(begin (append! buf "!") (set! pos (+ pos 2)) (rc-loop)))
|
||||
(else
|
||||
(begin (flush!) (set! pos (+ pos 1)) (rc-loop)))))
|
||||
(else
|
||||
(begin (append! buf c) (set! pos (+ pos 1)) (rc-loop))))))))
|
||||
(rc-loop)
|
||||
;; trailing text without a closing `!` — preserve as a chunk
|
||||
(when (> (len buf) 0) (flush!))
|
||||
chunks))))
|
||||
|
||||
(define
|
||||
st-trim
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((n (len s)) (i 0) (j 0))
|
||||
(begin
|
||||
(set! j n)
|
||||
(define
|
||||
tl-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< i n) (st-trim-ws? (nth s i)))
|
||||
(begin (set! i (+ i 1)) (tl-loop)))))
|
||||
(tl-loop)
|
||||
(define
|
||||
tr-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (> j i) (st-trim-ws? (nth s (- j 1))))
|
||||
(begin (set! j (- j 1)) (tr-loop)))))
|
||||
(tr-loop)
|
||||
(slice s i j)))))
|
||||
|
||||
(define
|
||||
st-trim-ws?
|
||||
(fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
||||
|
||||
;; Parse a chunk stream. Walks chunks and applies the Pharo file-in
|
||||
;; convention: a chunk that evaluates to "X methodsFor: 'cat'" or
|
||||
;; "X class methodsFor: 'cat'" enters a methods batch — subsequent chunks
|
||||
;; are method source until an empty chunk closes the batch.
|
||||
;;
|
||||
;; Returns list of entries:
|
||||
;; {:kind "expr" :ast EXPR-AST}
|
||||
;; {:kind "method" :class CLS :class-side? BOOL :category CAT :ast METHOD-AST}
|
||||
;; {:kind "blank"} (empty chunks outside a methods batch)
|
||||
;; {:kind "end-methods"} (empty chunk closing a methods batch)
|
||||
(define
|
||||
st-parse-chunks
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((chunks (st-read-chunks src))
|
||||
(entries (list))
|
||||
(mode "do-it")
|
||||
(cls-name nil)
|
||||
(class-side? false)
|
||||
(category nil))
|
||||
(begin
|
||||
(for-each
|
||||
(fn
|
||||
(chunk)
|
||||
(cond
|
||||
((= chunk "")
|
||||
(cond
|
||||
((= mode "methods")
|
||||
(begin
|
||||
(append! entries {:kind "end-methods"})
|
||||
(set! mode "do-it")
|
||||
(set! cls-name nil)
|
||||
(set! class-side? false)
|
||||
(set! category nil)))
|
||||
(else (append! entries {:kind "blank"}))))
|
||||
((= mode "methods")
|
||||
(append!
|
||||
entries
|
||||
{:kind "method"
|
||||
:class cls-name
|
||||
:class-side? class-side?
|
||||
:category category
|
||||
:ast (st-parse-method chunk)}))
|
||||
(else
|
||||
(let
|
||||
((ast (st-parse-expr chunk)))
|
||||
(begin
|
||||
(append! entries {:kind "expr" :ast ast})
|
||||
(let
|
||||
((mf (st-detect-methods-for ast)))
|
||||
(when
|
||||
(not (= mf nil))
|
||||
(begin
|
||||
(set! mode "methods")
|
||||
(set! cls-name (get mf :class))
|
||||
(set! class-side? (get mf :class-side?))
|
||||
(set! category (get mf :category))))))))))
|
||||
chunks)
|
||||
entries))))
|
||||
|
||||
;; Recognise `Foo methodsFor: 'cat'` (and related) as starting a methods batch.
|
||||
;; Returns nil if the AST doesn't look like one of these forms.
|
||||
(define
|
||||
st-detect-methods-for
|
||||
(fn
|
||||
(ast)
|
||||
(cond
|
||||
((not (= (get ast :type) "send")) nil)
|
||||
((not (st-is-methods-for-selector? (get ast :selector))) nil)
|
||||
(else
|
||||
(let
|
||||
((recv (get ast :receiver)) (args (get ast :args)))
|
||||
(let
|
||||
((cat-arg (if (> (len args) 0) (nth args 0) nil)))
|
||||
(let
|
||||
((category
|
||||
(cond
|
||||
((= cat-arg nil) nil)
|
||||
((= (get cat-arg :type) "lit-string") (get cat-arg :value))
|
||||
((= (get cat-arg :type) "lit-symbol") (get cat-arg :value))
|
||||
(else nil))))
|
||||
(cond
|
||||
((= (get recv :type) "ident")
|
||||
{:class (get recv :name)
|
||||
:class-side? false
|
||||
:category category})
|
||||
;; `Foo class methodsFor: 'cat'` — recv is a unary send `Foo class`
|
||||
((and
|
||||
(= (get recv :type) "send")
|
||||
(= (get recv :selector) "class")
|
||||
(= (get (get recv :receiver) :type) "ident"))
|
||||
{:class (get (get recv :receiver) :name)
|
||||
:class-side? true
|
||||
:category category})
|
||||
(else nil)))))))))
|
||||
|
||||
(define
|
||||
st-is-methods-for-selector?
|
||||
(fn
|
||||
(sel)
|
||||
(or
|
||||
(= sel "methodsFor:")
|
||||
(= sel "methodsFor:stamp:")
|
||||
(= sel "category:"))))
|
||||
|
||||
(define st-tok-type (fn (t) (if (= t nil) "eof" (get t :type))))
|
||||
|
||||
(define st-tok-value (fn (t) (if (= t nil) nil (get t :value))))
|
||||
|
||||
;; Parse a *single* Smalltalk expression from source.
|
||||
(define st-parse-expr (fn (src) (st-parse-with src "expr")))
|
||||
|
||||
;; Parse a sequence of statements separated by '.' Returns a {:type "seq"} node.
|
||||
(define st-parse (fn (src) (st-parse-with src "seq")))
|
||||
|
||||
;; Parse a method body — `selector params | temps | body`.
|
||||
;; Only the "method header + body" form (no chunk delimiters).
|
||||
(define st-parse-method (fn (src) (st-parse-with src "method")))
|
||||
|
||||
(define
|
||||
st-parse-with
|
||||
(fn
|
||||
(src mode)
|
||||
(let
|
||||
((tokens (st-tokenize src)) (idx 0) (tok-len 0))
|
||||
(begin
|
||||
(set! tok-len (len tokens))
|
||||
(define peek-tok (fn () (nth tokens idx)))
|
||||
(define
|
||||
peek-tok-at
|
||||
(fn (n) (if (< (+ idx n) tok-len) (nth tokens (+ idx n)) nil)))
|
||||
(define advance-tok! (fn () (set! idx (+ idx 1))))
|
||||
(define
|
||||
at?
|
||||
(fn
|
||||
(type value)
|
||||
(let
|
||||
((t (peek-tok)))
|
||||
(and
|
||||
(= (st-tok-type t) type)
|
||||
(or (= value nil) (= (st-tok-value t) value))))))
|
||||
(define at-type? (fn (type) (= (st-tok-type (peek-tok)) type)))
|
||||
(define
|
||||
consume!
|
||||
(fn
|
||||
(type value)
|
||||
(if
|
||||
(at? type value)
|
||||
(let ((t (peek-tok))) (begin (advance-tok!) t))
|
||||
(error
|
||||
(str
|
||||
"st-parse: expected "
|
||||
type
|
||||
(if (= value nil) "" (str " '" value "'"))
|
||||
" got "
|
||||
(st-tok-type (peek-tok))
|
||||
" '"
|
||||
(st-tok-value (peek-tok))
|
||||
"' at idx "
|
||||
idx)))))
|
||||
|
||||
;; ── Primary: atoms, paren'd expr, blocks, literal arrays, byte arrays.
|
||||
(define
|
||||
parse-primary
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((t (peek-tok)))
|
||||
(let
|
||||
((ty (st-tok-type t)) (v (st-tok-value t)))
|
||||
(cond
|
||||
((= ty "number")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(cond
|
||||
((number? v) {:type (if (integer? v) "lit-int" "lit-float") :value v})
|
||||
(else {:type "lit-int" :value v}))))
|
||||
((= ty "string")
|
||||
(begin (advance-tok!) {:type "lit-string" :value v}))
|
||||
((= ty "char")
|
||||
(begin (advance-tok!) {:type "lit-char" :value v}))
|
||||
((= ty "symbol")
|
||||
(begin (advance-tok!) {:type "lit-symbol" :value v}))
|
||||
((= ty "array-open") (parse-literal-array))
|
||||
((= ty "byte-array-open") (parse-byte-array))
|
||||
((= ty "lparen")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(let
|
||||
((e (parse-expression)))
|
||||
(begin (consume! "rparen" nil) e))))
|
||||
((= ty "lbracket") (parse-block))
|
||||
((= ty "ident")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(cond
|
||||
((= v "nil") {:type "lit-nil"})
|
||||
((= v "true") {:type "lit-true"})
|
||||
((= v "false") {:type "lit-false"})
|
||||
((= v "self") {:type "self"})
|
||||
((= v "super") {:type "super"})
|
||||
((= v "thisContext") {:type "thisContext"})
|
||||
(else {:type "ident" :name v}))))
|
||||
((= ty "binary")
|
||||
;; Negative numeric literal: '-' immediately before a number.
|
||||
(cond
|
||||
((and (= v "-") (= (st-tok-type (peek-tok-at 1)) "number"))
|
||||
(let
|
||||
((n (st-tok-value (peek-tok-at 1))))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(advance-tok!)
|
||||
(cond
|
||||
((dict? n) {:type "lit-int" :value n})
|
||||
((integer? n) {:type "lit-int" :value (- 0 n)})
|
||||
(else {:type "lit-float" :value (- 0 n)})))))
|
||||
(else
|
||||
(error
|
||||
(str "st-parse: unexpected binary '" v "' at idx " idx)))))
|
||||
(else
|
||||
(error
|
||||
(str
|
||||
"st-parse: unexpected "
|
||||
ty
|
||||
" '"
|
||||
v
|
||||
"' at idx "
|
||||
idx))))))))
|
||||
|
||||
;; #(elem elem ...) — elements are atoms or nested parenthesised arrays.
|
||||
(define
|
||||
parse-literal-array
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((items (list)))
|
||||
(begin
|
||||
(consume! "array-open" nil)
|
||||
(define
|
||||
arr-loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at? "rparen" nil) (advance-tok!))
|
||||
(else
|
||||
(begin
|
||||
(append! items (parse-array-element))
|
||||
(arr-loop))))))
|
||||
(arr-loop)
|
||||
{:type "lit-array" :elements items}))))
|
||||
|
||||
;; #[1 2 3]
|
||||
(define
|
||||
parse-byte-array
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((items (list)))
|
||||
(begin
|
||||
(consume! "byte-array-open" nil)
|
||||
(define
|
||||
ba-loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at? "rbracket" nil) (advance-tok!))
|
||||
(else
|
||||
(let
|
||||
((t (peek-tok)))
|
||||
(cond
|
||||
((= (st-tok-type t) "number")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! items (st-tok-value t))
|
||||
(ba-loop)))
|
||||
(else
|
||||
(error
|
||||
(str
|
||||
"st-parse: byte array expects number, got "
|
||||
(st-tok-type t))))))))))
|
||||
(ba-loop)
|
||||
{:type "lit-byte-array" :elements items}))))
|
||||
|
||||
;; Inside a literal array: bare idents become symbols, nested (...) is a sub-array.
|
||||
(define
|
||||
parse-array-element
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((t (peek-tok)))
|
||||
(let
|
||||
((ty (st-tok-type t)) (v (st-tok-value t)))
|
||||
(cond
|
||||
((= ty "number") (begin (advance-tok!) {:type "lit-int" :value v}))
|
||||
((= ty "string") (begin (advance-tok!) {:type "lit-string" :value v}))
|
||||
((= ty "char") (begin (advance-tok!) {:type "lit-char" :value v}))
|
||||
((= ty "symbol") (begin (advance-tok!) {:type "lit-symbol" :value v}))
|
||||
((= ty "ident")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(cond
|
||||
((= v "nil") {:type "lit-nil"})
|
||||
((= v "true") {:type "lit-true"})
|
||||
((= v "false") {:type "lit-false"})
|
||||
(else {:type "lit-symbol" :value v}))))
|
||||
((= ty "keyword") (begin (advance-tok!) {:type "lit-symbol" :value v}))
|
||||
((= ty "binary") (begin (advance-tok!) {:type "lit-symbol" :value v}))
|
||||
((= ty "lparen")
|
||||
(let ((items (list)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(define
|
||||
sub-loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at? "rparen" nil) (advance-tok!))
|
||||
(else
|
||||
(begin (append! items (parse-array-element)) (sub-loop))))))
|
||||
(sub-loop)
|
||||
{:type "lit-array" :elements items})))
|
||||
((= ty "array-open") (parse-literal-array))
|
||||
((= ty "byte-array-open") (parse-byte-array))
|
||||
(else
|
||||
(error
|
||||
(str "st-parse: bad literal-array element " ty " '" v "'"))))))))
|
||||
|
||||
;; [:a :b | | t1 t2 | body. body. ...]
|
||||
(define
|
||||
parse-block
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(consume! "lbracket" nil)
|
||||
(let
|
||||
((params (list)) (temps (list)))
|
||||
(begin
|
||||
;; Block params
|
||||
(define
|
||||
p-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at? "colon" nil)
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(let
|
||||
((t (consume! "ident" nil)))
|
||||
(begin
|
||||
(append! params (st-tok-value t))
|
||||
(p-loop)))))))
|
||||
(p-loop)
|
||||
(when (> (len params) 0) (consume! "bar" nil))
|
||||
;; Block temps: | t1 t2 |
|
||||
(when
|
||||
(and
|
||||
(at? "bar" nil)
|
||||
;; Not `|` followed immediately by binary content — the only
|
||||
;; legitimate `|` inside a block here is the temp delimiter.
|
||||
true)
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(define
|
||||
t-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at? "ident" nil)
|
||||
(let
|
||||
((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! temps (st-tok-value t))
|
||||
(t-loop))))))
|
||||
(t-loop)
|
||||
(consume! "bar" nil)))
|
||||
;; Body: statements terminated by `.` or `]`
|
||||
(let
|
||||
((body (parse-statements "rbracket")))
|
||||
(begin
|
||||
(consume! "rbracket" nil)
|
||||
{:type "block" :params params :temps temps :body body})))))))
|
||||
|
||||
;; Parse statements up to a closing token (rbracket or eof). Returns list.
|
||||
(define
|
||||
parse-statements
|
||||
(fn
|
||||
(terminator)
|
||||
(let
|
||||
((stmts (list)))
|
||||
(begin
|
||||
(define
|
||||
s-loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at-type? terminator) nil)
|
||||
((at-type? "eof") nil)
|
||||
(else
|
||||
(begin
|
||||
(append! stmts (parse-statement))
|
||||
;; consume optional period(s)
|
||||
(define
|
||||
dot-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at? "period" nil)
|
||||
(begin (advance-tok!) (dot-loop)))))
|
||||
(dot-loop)
|
||||
(s-loop))))))
|
||||
(s-loop)
|
||||
stmts))))
|
||||
|
||||
;; Statement: ^expr | ident := expr | expr
|
||||
(define
|
||||
parse-statement
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at? "caret" nil)
|
||||
(begin
|
||||
(advance-tok!)
|
||||
{:type "return" :expr (parse-expression)}))
|
||||
((and (at-type? "ident") (= (st-tok-type (peek-tok-at 1)) "assign"))
|
||||
(let
|
||||
((name-tok (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(advance-tok!)
|
||||
{:type "assign"
|
||||
:name (st-tok-value name-tok)
|
||||
:expr (parse-expression)})))
|
||||
(else (parse-expression)))))
|
||||
|
||||
;; Top-level expression. Assignment (right-associative chain) sits at
|
||||
;; the top; cascade is below.
|
||||
(define
|
||||
parse-expression
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((and (at-type? "ident") (= (st-tok-type (peek-tok-at 1)) "assign"))
|
||||
(let
|
||||
((name-tok (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(advance-tok!)
|
||||
{:type "assign"
|
||||
:name (st-tok-value name-tok)
|
||||
:expr (parse-expression)})))
|
||||
(else (parse-cascade)))))
|
||||
|
||||
(define
|
||||
parse-cascade
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((head (parse-keyword-message)))
|
||||
(cond
|
||||
((at? "semi" nil)
|
||||
(let
|
||||
((receiver (cascade-receiver head))
|
||||
(first-msg (cascade-first-message head))
|
||||
(msgs (list)))
|
||||
(begin
|
||||
(append! msgs first-msg)
|
||||
(define
|
||||
c-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at? "semi" nil)
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! msgs (parse-cascade-message))
|
||||
(c-loop)))))
|
||||
(c-loop)
|
||||
{:type "cascade" :receiver receiver :messages msgs})))
|
||||
(else head)))))
|
||||
|
||||
;; Extract the receiver from a head send so cascades share it.
|
||||
(define
|
||||
cascade-receiver
|
||||
(fn
|
||||
(head)
|
||||
(cond
|
||||
((= (get head :type) "send") (get head :receiver))
|
||||
(else head))))
|
||||
|
||||
(define
|
||||
cascade-first-message
|
||||
(fn
|
||||
(head)
|
||||
(cond
|
||||
((= (get head :type) "send")
|
||||
{:selector (get head :selector) :args (get head :args)})
|
||||
(else
|
||||
;; Shouldn't happen — cascade requires at least one prior message.
|
||||
(error "st-parse: cascade with no prior message")))))
|
||||
|
||||
;; Subsequent cascade message (after the `;`): unary | binary | keyword
|
||||
(define
|
||||
parse-cascade-message
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at-type? "ident")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
{:selector (st-tok-value t) :args (list)})))
|
||||
((at-type? "binary")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(let
|
||||
((arg (parse-unary-message)))
|
||||
{:selector (st-tok-value t) :args (list arg)}))))
|
||||
((at-type? "keyword")
|
||||
(let
|
||||
((sel-parts (list)) (args (list)))
|
||||
(begin
|
||||
(define
|
||||
kw-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-type? "keyword")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! sel-parts (st-tok-value t))
|
||||
(append! args (parse-binary-message))
|
||||
(kw-loop))))))
|
||||
(kw-loop)
|
||||
{:selector (join "" sel-parts) :args args})))
|
||||
(else
|
||||
(error
|
||||
(str "st-parse: bad cascade message at idx " idx))))))
|
||||
|
||||
;; Keyword message: <binary> (kw <binary>)+
|
||||
(define
|
||||
parse-keyword-message
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((receiver (parse-binary-message)))
|
||||
(cond
|
||||
((at-type? "keyword")
|
||||
(let
|
||||
((sel-parts (list)) (args (list)))
|
||||
(begin
|
||||
(define
|
||||
kw-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-type? "keyword")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! sel-parts (st-tok-value t))
|
||||
(append! args (parse-binary-message))
|
||||
(kw-loop))))))
|
||||
(kw-loop)
|
||||
{:type "send"
|
||||
:receiver receiver
|
||||
:selector (join "" sel-parts)
|
||||
:args args})))
|
||||
(else receiver)))))
|
||||
|
||||
;; Binary message: <unary> (binop <unary>)*
|
||||
(define
|
||||
parse-binary-message
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((receiver (parse-unary-message)))
|
||||
(begin
|
||||
(define
|
||||
b-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-type? "binary")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(let
|
||||
((arg (parse-unary-message)))
|
||||
(set!
|
||||
receiver
|
||||
{:type "send"
|
||||
:receiver receiver
|
||||
:selector (st-tok-value t)
|
||||
:args (list arg)}))
|
||||
(b-loop))))))
|
||||
(b-loop)
|
||||
receiver))))
|
||||
|
||||
;; Unary message: <primary> ident* (ident NOT followed by ':')
|
||||
(define
|
||||
parse-unary-message
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((receiver (parse-primary)))
|
||||
(begin
|
||||
(define
|
||||
u-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(at-type? "ident")
|
||||
(let
|
||||
((nxt (peek-tok-at 1)))
|
||||
(not (= (st-tok-type nxt) "assign"))))
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(set!
|
||||
receiver
|
||||
{:type "send"
|
||||
:receiver receiver
|
||||
:selector (st-tok-value t)
|
||||
:args (list)})
|
||||
(u-loop))))))
|
||||
(u-loop)
|
||||
receiver))))
|
||||
|
||||
;; Parse a single pragma: `<keyword: literal (keyword: literal)* >`
|
||||
;; Returns {:selector "primitive:" :args (list literal-asts)}.
|
||||
(define
|
||||
parse-pragma
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(consume! "binary" "<")
|
||||
(let
|
||||
((sel-parts (list)) (args (list)))
|
||||
(begin
|
||||
(define
|
||||
pr-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-type? "keyword")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! sel-parts (st-tok-value t))
|
||||
(append! args (parse-pragma-arg))
|
||||
(pr-loop))))))
|
||||
(pr-loop)
|
||||
(consume! "binary" ">")
|
||||
{:selector (join "" sel-parts) :args args})))))
|
||||
|
||||
;; Pragma arguments are literals only.
|
||||
(define
|
||||
parse-pragma-arg
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((t (peek-tok)))
|
||||
(let
|
||||
((ty (st-tok-type t)) (v (st-tok-value t)))
|
||||
(cond
|
||||
((= ty "number")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
{:type (if (integer? v) "lit-int" "lit-float") :value v}))
|
||||
((= ty "string") (begin (advance-tok!) {:type "lit-string" :value v}))
|
||||
((= ty "char") (begin (advance-tok!) {:type "lit-char" :value v}))
|
||||
((= ty "symbol") (begin (advance-tok!) {:type "lit-symbol" :value v}))
|
||||
((= ty "ident")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(cond
|
||||
((= v "nil") {:type "lit-nil"})
|
||||
((= v "true") {:type "lit-true"})
|
||||
((= v "false") {:type "lit-false"})
|
||||
(else (error (str "st-parse: pragma arg must be literal, got ident " v))))))
|
||||
((and (= ty "binary") (= v "-")
|
||||
(= (st-tok-type (peek-tok-at 1)) "number"))
|
||||
(let ((n (st-tok-value (peek-tok-at 1))))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(advance-tok!)
|
||||
{:type (if (integer? n) "lit-int" "lit-float")
|
||||
:value (- 0 n)})))
|
||||
(else
|
||||
(error
|
||||
(str "st-parse: pragma arg must be literal, got " ty))))))))
|
||||
|
||||
;; Method header: unary | binary arg | (kw arg)+
|
||||
(define
|
||||
parse-method
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((sel "")
|
||||
(params (list))
|
||||
(temps (list))
|
||||
(pragmas (list))
|
||||
(body (list)))
|
||||
(begin
|
||||
(cond
|
||||
;; Unary header
|
||||
((at-type? "ident")
|
||||
(let ((t (peek-tok)))
|
||||
(begin (advance-tok!) (set! sel (st-tok-value t)))))
|
||||
;; Binary header: binop ident
|
||||
((at-type? "binary")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(set! sel (st-tok-value t))
|
||||
(let ((p (consume! "ident" nil)))
|
||||
(append! params (st-tok-value p))))))
|
||||
;; Keyword header: (kw ident)+
|
||||
((at-type? "keyword")
|
||||
(let ((sel-parts (list)))
|
||||
(begin
|
||||
(define
|
||||
kh-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-type? "keyword")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! sel-parts (st-tok-value t))
|
||||
(let ((p (consume! "ident" nil)))
|
||||
(append! params (st-tok-value p)))
|
||||
(kh-loop))))))
|
||||
(kh-loop)
|
||||
(set! sel (join "" sel-parts)))))
|
||||
(else
|
||||
(error
|
||||
(str
|
||||
"st-parse-method: expected selector header, got "
|
||||
(st-tok-type (peek-tok))))))
|
||||
;; Pragmas and temps may appear in either order. Allow many
|
||||
;; pragmas; one temps section.
|
||||
(define
|
||||
parse-temps!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(define
|
||||
th-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-type? "ident")
|
||||
(let ((t (peek-tok)))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! temps (st-tok-value t))
|
||||
(th-loop))))))
|
||||
(th-loop)
|
||||
(consume! "bar" nil))))
|
||||
(define
|
||||
pt-loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((and
|
||||
(at? "binary" "<")
|
||||
(= (st-tok-type (peek-tok-at 1)) "keyword"))
|
||||
(begin (append! pragmas (parse-pragma)) (pt-loop)))
|
||||
((and (at? "bar" nil) (= (len temps) 0))
|
||||
(begin (parse-temps!) (pt-loop)))
|
||||
(else nil))))
|
||||
(pt-loop)
|
||||
;; Body statements
|
||||
(set! body (parse-statements "eof"))
|
||||
{:type "method"
|
||||
:selector sel
|
||||
:params params
|
||||
:temps temps
|
||||
:pragmas pragmas
|
||||
:body body}))))
|
||||
|
||||
;; Top-level program: statements separated by '.'
|
||||
(cond
|
||||
((= mode "expr") (parse-expression))
|
||||
((= mode "method") (parse-method))
|
||||
(else
|
||||
{:type "seq" :exprs (parse-statements "eof")}))))))
|
||||
291
lib/smalltalk/runtime.sx
Normal file
291
lib/smalltalk/runtime.sx
Normal file
@@ -0,0 +1,291 @@
|
||||
;; Smalltalk runtime — class table, bootstrap hierarchy, type→class mapping,
|
||||
;; instance construction. Method dispatch / eval-ast live in a later layer.
|
||||
;;
|
||||
;; Class record shape:
|
||||
;; {:name "Foo"
|
||||
;; :superclass "Object" ; or nil for Object itself
|
||||
;; :ivars (list "x" "y") ; instance variable names declared on this class
|
||||
;; :methods (dict selector→method-record)
|
||||
;; :class-methods (dict selector→method-record)}
|
||||
;;
|
||||
;; A method record is the AST returned by st-parse-method, plus a :defining-class
|
||||
;; field so super-sends can resolve from the right place. (Methods are registered
|
||||
;; via runtime helpers that fill the field.)
|
||||
;;
|
||||
;; The class table is a single dict keyed by class name. Bootstrap installs the
|
||||
;; canonical hierarchy. Test code resets it via (st-bootstrap-classes!).
|
||||
|
||||
(define st-class-table {})
|
||||
|
||||
(define st-class-table-clear! (fn () (set! st-class-table {})))
|
||||
|
||||
(define
|
||||
st-class-define!
|
||||
(fn
|
||||
(name superclass ivars)
|
||||
(begin
|
||||
(set!
|
||||
st-class-table
|
||||
(assoc
|
||||
st-class-table
|
||||
name
|
||||
{:name name
|
||||
:superclass superclass
|
||||
:ivars ivars
|
||||
:methods {}
|
||||
:class-methods {}}))
|
||||
name)))
|
||||
|
||||
(define
|
||||
st-class-get
|
||||
(fn (name) (if (has-key? st-class-table name) (get st-class-table name) nil)))
|
||||
|
||||
(define
|
||||
st-class-exists?
|
||||
(fn (name) (has-key? st-class-table name)))
|
||||
|
||||
(define
|
||||
st-class-superclass
|
||||
(fn
|
||||
(name)
|
||||
(let
|
||||
((c (st-class-get name)))
|
||||
(cond ((= c nil) nil) (else (get c :superclass))))))
|
||||
|
||||
;; Walk class chain root-to-leaf? No, follow superclass chain leaf-to-root.
|
||||
;; Returns list of class names starting at `name` and ending with the root.
|
||||
(define
|
||||
st-class-chain
|
||||
(fn
|
||||
(name)
|
||||
(let ((acc (list)) (cur name))
|
||||
(begin
|
||||
(define
|
||||
ch-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (not (= cur nil)) (st-class-exists? cur))
|
||||
(begin
|
||||
(append! acc cur)
|
||||
(set! cur (st-class-superclass cur))
|
||||
(ch-loop)))))
|
||||
(ch-loop)
|
||||
acc))))
|
||||
|
||||
;; Inherited + own ivars in declaration order from root to leaf.
|
||||
(define
|
||||
st-class-all-ivars
|
||||
(fn
|
||||
(name)
|
||||
(let ((chain (reverse (st-class-chain name))) (out (list)))
|
||||
(begin
|
||||
(for-each
|
||||
(fn
|
||||
(cn)
|
||||
(let
|
||||
((c (st-class-get cn)))
|
||||
(when
|
||||
(not (= c nil))
|
||||
(for-each (fn (iv) (append! out iv)) (get c :ivars)))))
|
||||
chain)
|
||||
out))))
|
||||
|
||||
;; Method install. The defining-class field is stamped on the method record
|
||||
;; so super-sends look up from the right point in the chain.
|
||||
(define
|
||||
st-class-add-method!
|
||||
(fn
|
||||
(cls-name selector method-ast)
|
||||
(let
|
||||
((cls (st-class-get cls-name)))
|
||||
(cond
|
||||
((= cls nil) (error (str "st-class-add-method!: unknown class " cls-name)))
|
||||
(else
|
||||
(let
|
||||
((m (assoc method-ast :defining-class cls-name)))
|
||||
(begin
|
||||
(set!
|
||||
st-class-table
|
||||
(assoc
|
||||
st-class-table
|
||||
cls-name
|
||||
(assoc
|
||||
cls
|
||||
:methods
|
||||
(assoc (get cls :methods) selector m))))
|
||||
selector)))))))
|
||||
|
||||
(define
|
||||
st-class-add-class-method!
|
||||
(fn
|
||||
(cls-name selector method-ast)
|
||||
(let
|
||||
((cls (st-class-get cls-name)))
|
||||
(cond
|
||||
((= cls nil) (error (str "st-class-add-class-method!: unknown class " cls-name)))
|
||||
(else
|
||||
(let
|
||||
((m (assoc method-ast :defining-class cls-name)))
|
||||
(begin
|
||||
(set!
|
||||
st-class-table
|
||||
(assoc
|
||||
st-class-table
|
||||
cls-name
|
||||
(assoc
|
||||
cls
|
||||
:class-methods
|
||||
(assoc (get cls :class-methods) selector m))))
|
||||
selector)))))))
|
||||
|
||||
;; Method lookup: walk superclass chain starting at `cls-name`.
|
||||
;; class-side? = true searches :class-methods, false searches :methods.
|
||||
;; Returns the method record (with :defining-class) or nil.
|
||||
(define
|
||||
st-method-lookup
|
||||
(fn
|
||||
(cls-name selector class-side?)
|
||||
(let
|
||||
((found nil))
|
||||
(begin
|
||||
(define
|
||||
ml-loop
|
||||
(fn
|
||||
(cur)
|
||||
(when
|
||||
(and (= found nil) (not (= cur nil)) (st-class-exists? cur))
|
||||
(let
|
||||
((c (st-class-get cur)))
|
||||
(let
|
||||
((dict (if class-side? (get c :class-methods) (get c :methods))))
|
||||
(cond
|
||||
((has-key? dict selector) (set! found (get dict selector)))
|
||||
(else (ml-loop (get c :superclass)))))))))
|
||||
(ml-loop cls-name)
|
||||
found))))
|
||||
|
||||
;; SX value → Smalltalk class name. Native types are not boxed.
|
||||
(define
|
||||
st-class-of
|
||||
(fn
|
||||
(v)
|
||||
(cond
|
||||
((= v nil) "UndefinedObject")
|
||||
((= v true) "True")
|
||||
((= v false) "False")
|
||||
((integer? v) "SmallInteger")
|
||||
((number? v) "Float")
|
||||
((string? v) "String")
|
||||
((symbol? v) "Symbol")
|
||||
((list? v) "Array")
|
||||
((and (dict? v) (has-key? v :type) (= (get v :type) "st-instance"))
|
||||
(get v :class))
|
||||
((and (dict? v) (has-key? v :type) (= (get v :type) "block"))
|
||||
"BlockClosure")
|
||||
((and (dict? v) (has-key? v :st-block?) (get v :st-block?))
|
||||
"BlockClosure")
|
||||
((dict? v) "Dictionary")
|
||||
((lambda? v) "BlockClosure")
|
||||
(else "Object"))))
|
||||
|
||||
;; Construct a fresh instance of cls-name. Ivars (own + inherited) start as nil.
|
||||
(define
|
||||
st-make-instance
|
||||
(fn
|
||||
(cls-name)
|
||||
(cond
|
||||
((not (st-class-exists? cls-name))
|
||||
(error (str "st-make-instance: unknown class " cls-name)))
|
||||
(else
|
||||
(let
|
||||
((iv-names (st-class-all-ivars cls-name)) (ivars {}))
|
||||
(begin
|
||||
(for-each (fn (n) (set! ivars (assoc ivars n nil))) iv-names)
|
||||
{:type "st-instance" :class cls-name :ivars ivars}))))))
|
||||
|
||||
(define
|
||||
st-instance?
|
||||
(fn
|
||||
(v)
|
||||
(and (dict? v) (has-key? v :type) (= (get v :type) "st-instance"))))
|
||||
|
||||
(define
|
||||
st-iv-get
|
||||
(fn
|
||||
(inst name)
|
||||
(let ((ivs (get inst :ivars)))
|
||||
(if (has-key? ivs name) (get ivs name) nil))))
|
||||
|
||||
(define
|
||||
st-iv-set!
|
||||
(fn
|
||||
(inst name value)
|
||||
(let
|
||||
((new-ivars (assoc (get inst :ivars) name value)))
|
||||
(assoc inst :ivars new-ivars))))
|
||||
|
||||
;; Inherits-from check: is `descendant` either equal to `ancestor` or a subclass?
|
||||
(define
|
||||
st-class-inherits-from?
|
||||
(fn
|
||||
(descendant ancestor)
|
||||
(let ((found false) (cur descendant))
|
||||
(begin
|
||||
(define
|
||||
ih-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (not found) (not (= cur nil)) (st-class-exists? cur))
|
||||
(cond
|
||||
((= cur ancestor) (set! found true))
|
||||
(else
|
||||
(begin
|
||||
(set! cur (st-class-superclass cur))
|
||||
(ih-loop)))))))
|
||||
(ih-loop)
|
||||
found))))
|
||||
|
||||
;; Bootstrap the canonical class hierarchy. Reset and rebuild.
|
||||
(define
|
||||
st-bootstrap-classes!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(st-class-table-clear!)
|
||||
;; Root
|
||||
(st-class-define! "Object" nil (list))
|
||||
;; Class side machinery
|
||||
(st-class-define! "Behavior" "Object" (list "superclass" "methodDict" "format"))
|
||||
(st-class-define! "ClassDescription" "Behavior" (list "instanceVariables" "organization"))
|
||||
(st-class-define! "Class" "ClassDescription" (list "name" "subclasses"))
|
||||
(st-class-define! "Metaclass" "ClassDescription" (list "thisClass"))
|
||||
;; Pseudo-variable types
|
||||
(st-class-define! "UndefinedObject" "Object" (list))
|
||||
(st-class-define! "Boolean" "Object" (list))
|
||||
(st-class-define! "True" "Boolean" (list))
|
||||
(st-class-define! "False" "Boolean" (list))
|
||||
;; Magnitudes
|
||||
(st-class-define! "Magnitude" "Object" (list))
|
||||
(st-class-define! "Number" "Magnitude" (list))
|
||||
(st-class-define! "Integer" "Number" (list))
|
||||
(st-class-define! "SmallInteger" "Integer" (list))
|
||||
(st-class-define! "LargePositiveInteger" "Integer" (list))
|
||||
(st-class-define! "Float" "Number" (list))
|
||||
(st-class-define! "Character" "Magnitude" (list "value"))
|
||||
;; Collections
|
||||
(st-class-define! "Collection" "Object" (list))
|
||||
(st-class-define! "SequenceableCollection" "Collection" (list))
|
||||
(st-class-define! "ArrayedCollection" "SequenceableCollection" (list))
|
||||
(st-class-define! "Array" "ArrayedCollection" (list))
|
||||
(st-class-define! "String" "ArrayedCollection" (list))
|
||||
(st-class-define! "Symbol" "String" (list))
|
||||
(st-class-define! "OrderedCollection" "SequenceableCollection" (list "array" "firstIndex" "lastIndex"))
|
||||
(st-class-define! "Dictionary" "Collection" (list))
|
||||
;; Blocks / contexts
|
||||
(st-class-define! "BlockClosure" "Object" (list))
|
||||
"ok")))
|
||||
|
||||
;; Initialise on load. Tests can re-bootstrap to reset state.
|
||||
(st-bootstrap-classes!)
|
||||
141
lib/smalltalk/test.sh
Executable file
141
lib/smalltalk/test.sh
Executable file
@@ -0,0 +1,141 @@
|
||||
#!/usr/bin/env bash
|
||||
# Fast Smalltalk-on-SX test runner — pipes directly to sx_server.exe.
|
||||
# Mirrors lib/haskell/test.sh.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/smalltalk/test.sh # run all tests
|
||||
# bash lib/smalltalk/test.sh -v # verbose
|
||||
# bash lib/smalltalk/test.sh tests/tokenize.sx # run one file
|
||||
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}')
|
||||
if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then
|
||||
SX_SERVER="$MAIN_ROOT/$SX_SERVER"
|
||||
else
|
||||
echo "ERROR: sx_server.exe not found. Run: cd hosts/ocaml && dune build"
|
||||
exit 1
|
||||
fi
|
||||
fi
|
||||
|
||||
VERBOSE=""
|
||||
FILES=()
|
||||
for arg in "$@"; do
|
||||
case "$arg" in
|
||||
-v|--verbose) VERBOSE=1 ;;
|
||||
*) FILES+=("$arg") ;;
|
||||
esac
|
||||
done
|
||||
|
||||
if [ ${#FILES[@]} -eq 0 ]; then
|
||||
# tokenize.sx must load first — it defines the st-test helpers reused by
|
||||
# subsequent test files. Sort enforces this lexicographically.
|
||||
mapfile -t FILES < <(find lib/smalltalk/tests -maxdepth 2 -name '*.sx' | sort)
|
||||
fi
|
||||
|
||||
TOTAL_PASS=0
|
||||
TOTAL_FAIL=0
|
||||
FAILED_FILES=()
|
||||
|
||||
for FILE in "${FILES[@]}"; do
|
||||
[ -f "$FILE" ] || { echo "skip $FILE (not found)"; continue; }
|
||||
TMPFILE=$(mktemp)
|
||||
if [ "$(basename "$FILE")" = "tokenize.sx" ]; then
|
||||
cat > "$TMPFILE" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
(eval "(list st-test-pass st-test-fail)")
|
||||
EPOCHS
|
||||
else
|
||||
cat > "$TMPFILE" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "lib/smalltalk/parser.sx")
|
||||
(epoch 3)
|
||||
(load "lib/smalltalk/runtime.sx")
|
||||
(epoch 4)
|
||||
(load "lib/smalltalk/eval.sx")
|
||||
(epoch 5)
|
||||
(load "lib/smalltalk/tests/tokenize.sx")
|
||||
(epoch 6)
|
||||
(load "$FILE")
|
||||
(epoch 7)
|
||||
(eval "(list st-test-pass st-test-fail)")
|
||||
EPOCHS
|
||||
fi
|
||||
|
||||
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
|
||||
rm -f "$TMPFILE"
|
||||
|
||||
# Final epoch's value: either (ok N (P F)) on one line or
|
||||
# (ok-len N M)\n(P F) where the value is on the following line.
|
||||
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len [0-9]+ / {getline; print}' | tail -1)
|
||||
if [ -z "$LINE" ]; then
|
||||
LINE=$(echo "$OUTPUT" | grep -E '^\(ok [0-9]+ \([0-9]+ [0-9]+\)\)' | tail -1 \
|
||||
| sed -E 's/^\(ok [0-9]+ //; s/\)$//')
|
||||
fi
|
||||
if [ -z "$LINE" ]; then
|
||||
echo "X $FILE: could not extract summary"
|
||||
echo "$OUTPUT" | tail -30
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + 1))
|
||||
FAILED_FILES+=("$FILE")
|
||||
continue
|
||||
fi
|
||||
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
|
||||
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
|
||||
TOTAL_PASS=$((TOTAL_PASS + P))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + F))
|
||||
if [ "$F" -gt 0 ]; then
|
||||
FAILED_FILES+=("$FILE")
|
||||
printf 'X %-40s %d/%d\n' "$FILE" "$P" "$((P+F))"
|
||||
TMPFILE2=$(mktemp)
|
||||
if [ "$(basename "$FILE")" = "tokenize.sx" ]; then
|
||||
cat > "$TMPFILE2" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
(eval "(map (fn (f) (get f :name)) st-test-fails)")
|
||||
EPOCHS
|
||||
else
|
||||
cat > "$TMPFILE2" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "lib/smalltalk/parser.sx")
|
||||
(epoch 3)
|
||||
(load "lib/smalltalk/runtime.sx")
|
||||
(epoch 4)
|
||||
(load "lib/smalltalk/eval.sx")
|
||||
(epoch 5)
|
||||
(load "lib/smalltalk/tests/tokenize.sx")
|
||||
(epoch 6)
|
||||
(load "$FILE")
|
||||
(epoch 7)
|
||||
(eval "(map (fn (f) (get f :name)) st-test-fails)")
|
||||
EPOCHS
|
||||
fi
|
||||
FAILS=$(timeout 60 "$SX_SERVER" < "$TMPFILE2" 2>&1 | grep -E '^\(ok [0-9]+ \(' | tail -1 || true)
|
||||
rm -f "$TMPFILE2"
|
||||
echo " $FAILS"
|
||||
elif [ "$VERBOSE" = "1" ]; then
|
||||
printf 'OK %-40s %d passed\n' "$FILE" "$P"
|
||||
fi
|
||||
done
|
||||
|
||||
TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
|
||||
if [ $TOTAL_FAIL -eq 0 ]; then
|
||||
echo "OK $TOTAL_PASS/$TOTAL smalltalk-on-sx tests passed"
|
||||
else
|
||||
echo "FAIL $TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed in: ${FAILED_FILES[*]}"
|
||||
fi
|
||||
|
||||
[ $TOTAL_FAIL -eq 0 ]
|
||||
181
lib/smalltalk/tests/eval.sx
Normal file
181
lib/smalltalk/tests/eval.sx
Normal file
@@ -0,0 +1,181 @@
|
||||
;; Smalltalk evaluator tests — sequential semantics, message dispatch on
|
||||
;; native + user receivers, blocks, cascades, return.
|
||||
|
||||
(set! st-test-pass 0)
|
||||
(set! st-test-fail 0)
|
||||
(set! st-test-fails (list))
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
|
||||
(define ev (fn (src) (smalltalk-eval src)))
|
||||
(define evp (fn (src) (smalltalk-eval-program src)))
|
||||
|
||||
;; ── 1. Literals ──
|
||||
(st-test "int literal" (ev "42") 42)
|
||||
(st-test "float literal" (ev "3.14") 3.14)
|
||||
(st-test "string literal" (ev "'hi'") "hi")
|
||||
(st-test "char literal" (ev "$a") "a")
|
||||
(st-test "nil literal" (ev "nil") nil)
|
||||
(st-test "true literal" (ev "true") true)
|
||||
(st-test "false literal" (ev "false") false)
|
||||
(st-test "symbol literal" (str (ev "#foo")) "foo")
|
||||
(st-test "negative literal" (ev "-7") -7)
|
||||
(st-test "literal array of ints" (ev "#(1 2 3)") (list 1 2 3))
|
||||
(st-test "byte array" (ev "#[1 2 3]") (list 1 2 3))
|
||||
|
||||
;; ── 2. Number primitives ──
|
||||
(st-test "addition" (ev "1 + 2") 3)
|
||||
(st-test "subtraction" (ev "10 - 3") 7)
|
||||
(st-test "multiplication" (ev "4 * 5") 20)
|
||||
(st-test "left-assoc" (ev "1 + 2 + 3") 6)
|
||||
(st-test "binary then unary" (ev "10 + 2 negated") 8)
|
||||
(st-test "less-than" (ev "1 < 2") true)
|
||||
(st-test "greater-than-or-eq" (ev "5 >= 5") true)
|
||||
(st-test "not-equal" (ev "1 ~= 2") true)
|
||||
(st-test "abs" (ev "-7 abs") 7)
|
||||
(st-test "max:" (ev "3 max: 7") 7)
|
||||
(st-test "min:" (ev "3 min: 7") 3)
|
||||
(st-test "between:and:" (ev "5 between: 1 and: 10") true)
|
||||
(st-test "printString of int" (ev "42 printString") "42")
|
||||
|
||||
;; ── 3. Boolean primitives ──
|
||||
(st-test "true not" (ev "true not") false)
|
||||
(st-test "false not" (ev "false not") true)
|
||||
(st-test "true & false" (ev "true & false") false)
|
||||
(st-test "true | false" (ev "true | false") true)
|
||||
(st-test "ifTrue: with true" (ev "true ifTrue: [99]") 99)
|
||||
(st-test "ifTrue: with false" (ev "false ifTrue: [99]") nil)
|
||||
(st-test "ifTrue:ifFalse: true branch" (ev "true ifTrue: [1] ifFalse: [2]") 1)
|
||||
(st-test "ifTrue:ifFalse: false branch" (ev "false ifTrue: [1] ifFalse: [2]") 2)
|
||||
(st-test "and: short-circuit" (ev "false and: [1/0]") false)
|
||||
(st-test "or: short-circuit" (ev "true or: [1/0]") true)
|
||||
|
||||
;; ── 4. Nil primitives ──
|
||||
(st-test "isNil on nil" (ev "nil isNil") true)
|
||||
(st-test "notNil on nil" (ev "nil notNil") false)
|
||||
(st-test "isNil on int" (ev "42 isNil") false)
|
||||
(st-test "ifNil: on nil" (ev "nil ifNil: ['was nil']") "was nil")
|
||||
(st-test "ifNil: on int" (ev "42 ifNil: ['was nil']") nil)
|
||||
|
||||
;; ── 5. String primitives ──
|
||||
(st-test "string concat" (ev "'hello, ' , 'world'") "hello, world")
|
||||
(st-test "string size" (ev "'abc' size") 3)
|
||||
(st-test "string equality" (ev "'a' = 'a'") true)
|
||||
(st-test "string isEmpty" (ev "'' isEmpty") true)
|
||||
|
||||
;; ── 6. Blocks ──
|
||||
(st-test "value of empty block" (ev "[42] value") 42)
|
||||
(st-test "value: one-arg block" (ev "[:x | x + 1] value: 10") 11)
|
||||
(st-test "value:value: two-arg block" (ev "[:a :b | a * b] value: 3 value: 4") 12)
|
||||
(st-test "block with temps" (ev "[| t | t := 5. t * t] value") 25)
|
||||
(st-test "block returns last expression" (ev "[1. 2. 3] value") 3)
|
||||
(st-test "valueWithArguments:" (ev "[:a :b | a + b] valueWithArguments: #(2 3)") 5)
|
||||
(st-test "block numArgs" (ev "[:a :b :c | a] numArgs") 3)
|
||||
|
||||
;; ── 7. Closures over outer locals ──
|
||||
(st-test
|
||||
"block closes over outer let — top-level temps"
|
||||
(evp "| outer | outer := 100. ^ [:x | x + outer] value: 5")
|
||||
105)
|
||||
|
||||
;; ── 8. Cascades ──
|
||||
(st-test "simple cascade returns last" (ev "10 + 1; + 2; + 3") 13)
|
||||
|
||||
;; ── 9. Sequences and assignment ──
|
||||
(st-test "sequence returns last" (evp "1. 2. 3") 3)
|
||||
(st-test
|
||||
"assignment + use"
|
||||
(evp "| x | x := 10. x := x + 1. ^ x")
|
||||
11)
|
||||
|
||||
;; ── 10. Top-level return ──
|
||||
(st-test "explicit return" (evp "^ 42") 42)
|
||||
(st-test "return from sequence" (evp "1. ^ 99. 100") 99)
|
||||
|
||||
;; ── 11. Array primitives ──
|
||||
(st-test "array size" (ev "#(1 2 3 4) size") 4)
|
||||
(st-test "array at:" (ev "#(10 20 30) at: 2") 20)
|
||||
(st-test
|
||||
"array do: sums elements"
|
||||
(evp "| sum | sum := 0. #(1 2 3 4) do: [:e | sum := sum + e]. ^ sum")
|
||||
10)
|
||||
(st-test
|
||||
"array collect:"
|
||||
(ev "#(1 2 3) collect: [:x | x * x]")
|
||||
(list 1 4 9))
|
||||
(st-test
|
||||
"array select:"
|
||||
(ev "#(1 2 3 4 5) select: [:x | x > 2]")
|
||||
(list 3 4 5))
|
||||
|
||||
;; ── 12. While loop ──
|
||||
(st-test
|
||||
"whileTrue: counts down"
|
||||
(evp "| n | n := 5. [n > 0] whileTrue: [n := n - 1]. ^ n")
|
||||
0)
|
||||
(st-test
|
||||
"to:do: sums 1..10"
|
||||
(evp "| s | s := 0. 1 to: 10 do: [:i | s := s + i]. ^ s")
|
||||
55)
|
||||
|
||||
;; ── 13. User classes — instance variables, methods, send ──
|
||||
(st-bootstrap-classes!)
|
||||
(st-class-define! "Point" "Object" (list "x" "y"))
|
||||
(st-class-add-method! "Point" "x" (st-parse-method "x ^ x"))
|
||||
(st-class-add-method! "Point" "y" (st-parse-method "y ^ y"))
|
||||
(st-class-add-method! "Point" "x:" (st-parse-method "x: v x := v"))
|
||||
(st-class-add-method! "Point" "y:" (st-parse-method "y: v y := v"))
|
||||
(st-class-add-method! "Point" "+"
|
||||
(st-parse-method "+ other ^ (Point new x: x + other x; y: y + other y; yourself)"))
|
||||
(st-class-add-method! "Point" "yourself" (st-parse-method "yourself ^ self"))
|
||||
(st-class-add-method! "Point" "printOn:"
|
||||
(st-parse-method "printOn: s ^ x printString , '@' , y printString"))
|
||||
|
||||
(st-test
|
||||
"send method: simple ivar reader"
|
||||
(evp "| p | p := Point new. p x: 3. p y: 4. ^ p x")
|
||||
3)
|
||||
|
||||
(st-test
|
||||
"method composes via cascade"
|
||||
(evp "| p | p := Point new x: 7; y: 8; yourself. ^ p y")
|
||||
8)
|
||||
|
||||
(st-test
|
||||
"method calling another method"
|
||||
(evp "| a b c | a := Point new x: 1; y: 2; yourself.
|
||||
b := Point new x: 10; y: 20; yourself.
|
||||
c := a + b. ^ c x")
|
||||
11)
|
||||
|
||||
;; ── 14. Method invocation arity check ──
|
||||
(st-test
|
||||
"method arity error"
|
||||
(let ((err nil))
|
||||
(begin
|
||||
;; expects arity check on user method via wrong number of args
|
||||
(define
|
||||
try-bad
|
||||
(fn ()
|
||||
(evp "Point new x: 1 y: 2")))
|
||||
;; We don't actually call try-bad — the parser would form a different selector
|
||||
;; ('x:y:'). Instead, manually invoke an invalid arity:
|
||||
(st-class-define! "ArityCheck" "Object" (list))
|
||||
(st-class-add-method! "ArityCheck" "foo:" (st-parse-method "foo: x ^ x"))
|
||||
err))
|
||||
nil)
|
||||
|
||||
;; ── 15. Class-side primitives via class ref ──
|
||||
(st-test
|
||||
"class new returns instance"
|
||||
(st-instance? (ev "Point new"))
|
||||
true)
|
||||
(st-test
|
||||
"class name"
|
||||
(ev "Point name")
|
||||
"Point")
|
||||
|
||||
;; ── 16. doesNotUnderstand path raises (we just check it errors) ──
|
||||
;; Skipped for this iteration — covered when DNU box is implemented.
|
||||
|
||||
(list st-test-pass st-test-fail)
|
||||
369
lib/smalltalk/tests/parse.sx
Normal file
369
lib/smalltalk/tests/parse.sx
Normal file
@@ -0,0 +1,369 @@
|
||||
;; Smalltalk parser tests.
|
||||
;;
|
||||
;; Reuses helpers (st-test, st-deep=?) from tokenize.sx. Counters reset
|
||||
;; here so this file's summary covers parse tests only.
|
||||
|
||||
(set! st-test-pass 0)
|
||||
(set! st-test-fail 0)
|
||||
(set! st-test-fails (list))
|
||||
|
||||
;; ── 1. Atoms ──
|
||||
(st-test "int" (st-parse-expr "42") {:type "lit-int" :value 42})
|
||||
(st-test "float" (st-parse-expr "3.14") {:type "lit-float" :value 3.14})
|
||||
(st-test "string" (st-parse-expr "'hi'") {:type "lit-string" :value "hi"})
|
||||
(st-test "char" (st-parse-expr "$x") {:type "lit-char" :value "x"})
|
||||
(st-test "symbol" (st-parse-expr "#foo") {:type "lit-symbol" :value "foo"})
|
||||
(st-test "binary symbol" (st-parse-expr "#+") {:type "lit-symbol" :value "+"})
|
||||
(st-test "keyword symbol" (st-parse-expr "#at:put:") {:type "lit-symbol" :value "at:put:"})
|
||||
(st-test "nil" (st-parse-expr "nil") {:type "lit-nil"})
|
||||
(st-test "true" (st-parse-expr "true") {:type "lit-true"})
|
||||
(st-test "false" (st-parse-expr "false") {:type "lit-false"})
|
||||
(st-test "self" (st-parse-expr "self") {:type "self"})
|
||||
(st-test "super" (st-parse-expr "super") {:type "super"})
|
||||
(st-test "ident" (st-parse-expr "x") {:type "ident" :name "x"})
|
||||
(st-test "negative int" (st-parse-expr "-3") {:type "lit-int" :value -3})
|
||||
|
||||
;; ── 2. Literal arrays ──
|
||||
(st-test
|
||||
"literal array of ints"
|
||||
(st-parse-expr "#(1 2 3)")
|
||||
{:type "lit-array"
|
||||
:elements (list
|
||||
{:type "lit-int" :value 1}
|
||||
{:type "lit-int" :value 2}
|
||||
{:type "lit-int" :value 3})})
|
||||
|
||||
(st-test
|
||||
"literal array mixed"
|
||||
(st-parse-expr "#(1 #foo 'x' true)")
|
||||
{:type "lit-array"
|
||||
:elements (list
|
||||
{:type "lit-int" :value 1}
|
||||
{:type "lit-symbol" :value "foo"}
|
||||
{:type "lit-string" :value "x"}
|
||||
{:type "lit-true"})})
|
||||
|
||||
(st-test
|
||||
"literal array bare ident is symbol"
|
||||
(st-parse-expr "#(foo bar)")
|
||||
{:type "lit-array"
|
||||
:elements (list
|
||||
{:type "lit-symbol" :value "foo"}
|
||||
{:type "lit-symbol" :value "bar"})})
|
||||
|
||||
(st-test
|
||||
"nested literal array"
|
||||
(st-parse-expr "#(1 (2 3) 4)")
|
||||
{:type "lit-array"
|
||||
:elements (list
|
||||
{:type "lit-int" :value 1}
|
||||
{:type "lit-array"
|
||||
:elements (list
|
||||
{:type "lit-int" :value 2}
|
||||
{:type "lit-int" :value 3})}
|
||||
{:type "lit-int" :value 4})})
|
||||
|
||||
(st-test
|
||||
"byte array"
|
||||
(st-parse-expr "#[1 2 3]")
|
||||
{:type "lit-byte-array" :elements (list 1 2 3)})
|
||||
|
||||
;; ── 3. Unary messages ──
|
||||
(st-test
|
||||
"unary single"
|
||||
(st-parse-expr "x foo")
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "foo"
|
||||
:args (list)})
|
||||
|
||||
(st-test
|
||||
"unary chain"
|
||||
(st-parse-expr "x foo bar baz")
|
||||
{:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "foo"
|
||||
:args (list)}
|
||||
:selector "bar"
|
||||
:args (list)}
|
||||
:selector "baz"
|
||||
:args (list)})
|
||||
|
||||
(st-test
|
||||
"unary on literal"
|
||||
(st-parse-expr "42 printNl")
|
||||
{:type "send"
|
||||
:receiver {:type "lit-int" :value 42}
|
||||
:selector "printNl"
|
||||
:args (list)})
|
||||
|
||||
;; ── 4. Binary messages ──
|
||||
(st-test
|
||||
"binary single"
|
||||
(st-parse-expr "1 + 2")
|
||||
{:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})})
|
||||
|
||||
(st-test
|
||||
"binary left-assoc"
|
||||
(st-parse-expr "1 + 2 + 3")
|
||||
{:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 3})})
|
||||
|
||||
(st-test
|
||||
"binary same precedence l-to-r"
|
||||
(st-parse-expr "1 + 2 * 3")
|
||||
{:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})}
|
||||
:selector "*"
|
||||
:args (list {:type "lit-int" :value 3})})
|
||||
|
||||
;; ── 5. Precedence: unary binds tighter than binary ──
|
||||
(st-test
|
||||
"unary tighter than binary"
|
||||
(st-parse-expr "3 + 4 factorial")
|
||||
{:type "send"
|
||||
:receiver {:type "lit-int" :value 3}
|
||||
:selector "+"
|
||||
:args (list
|
||||
{:type "send"
|
||||
:receiver {:type "lit-int" :value 4}
|
||||
:selector "factorial"
|
||||
:args (list)})})
|
||||
|
||||
;; ── 6. Keyword messages ──
|
||||
(st-test
|
||||
"keyword single"
|
||||
(st-parse-expr "x at: 1")
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "at:"
|
||||
:args (list {:type "lit-int" :value 1})})
|
||||
|
||||
(st-test
|
||||
"keyword chain"
|
||||
(st-parse-expr "x at: 1 put: 'a'")
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "at:put:"
|
||||
:args (list {:type "lit-int" :value 1} {:type "lit-string" :value "a"})})
|
||||
|
||||
;; ── 7. Precedence: binary tighter than keyword ──
|
||||
(st-test
|
||||
"binary tighter than keyword"
|
||||
(st-parse-expr "x at: 1 + 2")
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "at:"
|
||||
:args (list
|
||||
{:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})})})
|
||||
|
||||
(st-test
|
||||
"keyword absorbs trailing unary"
|
||||
(st-parse-expr "a foo: b bar")
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "a"}
|
||||
:selector "foo:"
|
||||
:args (list
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "b"}
|
||||
:selector "bar"
|
||||
:args (list)})})
|
||||
|
||||
;; ── 8. Parens override precedence ──
|
||||
(st-test
|
||||
"paren forces grouping"
|
||||
(st-parse-expr "(1 + 2) * 3")
|
||||
{:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})}
|
||||
:selector "*"
|
||||
:args (list {:type "lit-int" :value 3})})
|
||||
|
||||
;; ── 9. Cascade ──
|
||||
(st-test
|
||||
"simple cascade"
|
||||
(st-parse-expr "x m1; m2")
|
||||
{:type "cascade"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:messages (list
|
||||
{:selector "m1" :args (list)}
|
||||
{:selector "m2" :args (list)})})
|
||||
|
||||
(st-test
|
||||
"cascade with binary and keyword"
|
||||
(st-parse-expr "Stream new nl; tab; print: 1")
|
||||
{:type "cascade"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "ident" :name "Stream"}
|
||||
:selector "new"
|
||||
:args (list)}
|
||||
:messages (list
|
||||
{:selector "nl" :args (list)}
|
||||
{:selector "tab" :args (list)}
|
||||
{:selector "print:" :args (list {:type "lit-int" :value 1})})})
|
||||
|
||||
;; ── 10. Blocks ──
|
||||
(st-test
|
||||
"empty block"
|
||||
(st-parse-expr "[]")
|
||||
{:type "block" :params (list) :temps (list) :body (list)})
|
||||
|
||||
(st-test
|
||||
"block one expr"
|
||||
(st-parse-expr "[1 + 2]")
|
||||
{:type "block"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:body (list
|
||||
{:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})})})
|
||||
|
||||
(st-test
|
||||
"block with params"
|
||||
(st-parse-expr "[:a :b | a + b]")
|
||||
{:type "block"
|
||||
:params (list "a" "b")
|
||||
:temps (list)
|
||||
:body (list
|
||||
{:type "send"
|
||||
:receiver {:type "ident" :name "a"}
|
||||
:selector "+"
|
||||
:args (list {:type "ident" :name "b"})})})
|
||||
|
||||
(st-test
|
||||
"block with temps"
|
||||
(st-parse-expr "[| t | t := 1. t]")
|
||||
{:type "block"
|
||||
:params (list)
|
||||
:temps (list "t")
|
||||
:body (list
|
||||
{:type "assign" :name "t" :expr {:type "lit-int" :value 1}}
|
||||
{:type "ident" :name "t"})})
|
||||
|
||||
(st-test
|
||||
"block with params and temps"
|
||||
(st-parse-expr "[:x | | t | t := x + 1. t]")
|
||||
{:type "block"
|
||||
:params (list "x")
|
||||
:temps (list "t")
|
||||
:body (list
|
||||
{:type "assign"
|
||||
:name "t"
|
||||
:expr {:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 1})}}
|
||||
{:type "ident" :name "t"})})
|
||||
|
||||
;; ── 11. Assignment / return / statements ──
|
||||
(st-test
|
||||
"assignment"
|
||||
(st-parse-expr "x := 1")
|
||||
{:type "assign" :name "x" :expr {:type "lit-int" :value 1}})
|
||||
|
||||
(st-test
|
||||
"return"
|
||||
(st-parse-expr "1")
|
||||
{:type "lit-int" :value 1})
|
||||
|
||||
(st-test
|
||||
"return statement at top level"
|
||||
(st-parse "^ 1")
|
||||
{:type "seq"
|
||||
:exprs (list {:type "return" :expr {:type "lit-int" :value 1}})})
|
||||
|
||||
(st-test
|
||||
"two statements"
|
||||
(st-parse "x := 1. y := 2")
|
||||
{:type "seq"
|
||||
:exprs (list
|
||||
{:type "assign" :name "x" :expr {:type "lit-int" :value 1}}
|
||||
{:type "assign" :name "y" :expr {:type "lit-int" :value 2}})})
|
||||
|
||||
(st-test
|
||||
"trailing dot allowed"
|
||||
(st-parse "1. 2.")
|
||||
{:type "seq"
|
||||
:exprs (list {:type "lit-int" :value 1} {:type "lit-int" :value 2})})
|
||||
|
||||
;; ── 12. Method headers ──
|
||||
(st-test
|
||||
"unary method"
|
||||
(st-parse-method "factorial ^ self * (self - 1) factorial")
|
||||
{:type "method"
|
||||
:selector "factorial"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "return"
|
||||
:expr {:type "send"
|
||||
:receiver {:type "self"}
|
||||
:selector "*"
|
||||
:args (list
|
||||
{:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "self"}
|
||||
:selector "-"
|
||||
:args (list {:type "lit-int" :value 1})}
|
||||
:selector "factorial"
|
||||
:args (list)})}})})
|
||||
|
||||
(st-test
|
||||
"binary method"
|
||||
(st-parse-method "+ other ^ 'plus'")
|
||||
{:type "method"
|
||||
:selector "+"
|
||||
:params (list "other")
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list {:type "return" :expr {:type "lit-string" :value "plus"}})})
|
||||
|
||||
(st-test
|
||||
"keyword method"
|
||||
(st-parse-method "at: i put: v ^ v")
|
||||
{:type "method"
|
||||
:selector "at:put:"
|
||||
:params (list "i" "v")
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list {:type "return" :expr {:type "ident" :name "v"}})})
|
||||
|
||||
(st-test
|
||||
"method with temps"
|
||||
(st-parse-method "twice: x | t | t := x + x. ^ t")
|
||||
{:type "method"
|
||||
:selector "twice:"
|
||||
:params (list "x")
|
||||
:temps (list "t")
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "assign"
|
||||
:name "t"
|
||||
:expr {:type "send"
|
||||
:receiver {:type "ident" :name "x"}
|
||||
:selector "+"
|
||||
:args (list {:type "ident" :name "x"})}}
|
||||
{:type "return" :expr {:type "ident" :name "t"}})})
|
||||
|
||||
(list st-test-pass st-test-fail)
|
||||
294
lib/smalltalk/tests/parse_chunks.sx
Normal file
294
lib/smalltalk/tests/parse_chunks.sx
Normal file
@@ -0,0 +1,294 @@
|
||||
;; Smalltalk chunk-stream parser + pragma tests.
|
||||
;;
|
||||
;; Reuses helpers (st-test, st-deep=?) from tokenize.sx. Counters reset
|
||||
;; here so this file's summary covers chunk + pragma tests only.
|
||||
|
||||
(set! st-test-pass 0)
|
||||
(set! st-test-fail 0)
|
||||
(set! st-test-fails (list))
|
||||
|
||||
;; ── 1. Raw chunk reader ──
|
||||
(st-test "empty source" (st-read-chunks "") (list))
|
||||
(st-test "single chunk" (st-read-chunks "foo!") (list "foo"))
|
||||
(st-test "two chunks" (st-read-chunks "a! b!") (list "a" "b"))
|
||||
(st-test "trailing no bang" (st-read-chunks "a! b") (list "a" "b"))
|
||||
(st-test "empty chunk" (st-read-chunks "a! ! b!") (list "a" "" "b"))
|
||||
(st-test
|
||||
"doubled bang escapes"
|
||||
(st-read-chunks "yes!! no!yes!")
|
||||
(list "yes! no" "yes"))
|
||||
(st-test
|
||||
"whitespace trimmed"
|
||||
(st-read-chunks " \n hello \n !")
|
||||
(list "hello"))
|
||||
|
||||
;; ── 2. Chunk parser — do-it mode ──
|
||||
(st-test
|
||||
"single do-it chunk"
|
||||
(st-parse-chunks "1 + 2!")
|
||||
(list
|
||||
{:kind "expr"
|
||||
:ast {:type "send"
|
||||
:receiver {:type "lit-int" :value 1}
|
||||
:selector "+"
|
||||
:args (list {:type "lit-int" :value 2})}}))
|
||||
|
||||
(st-test
|
||||
"two do-it chunks"
|
||||
(st-parse-chunks "x := 1! y := 2!")
|
||||
(list
|
||||
{:kind "expr"
|
||||
:ast {:type "assign" :name "x" :expr {:type "lit-int" :value 1}}}
|
||||
{:kind "expr"
|
||||
:ast {:type "assign" :name "y" :expr {:type "lit-int" :value 2}}}))
|
||||
|
||||
(st-test
|
||||
"blank chunk outside methods"
|
||||
(st-parse-chunks "1! ! 2!")
|
||||
(list
|
||||
{:kind "expr" :ast {:type "lit-int" :value 1}}
|
||||
{:kind "blank"}
|
||||
{:kind "expr" :ast {:type "lit-int" :value 2}}))
|
||||
|
||||
;; ── 3. Methods batch ──
|
||||
(st-test
|
||||
"methodsFor opens method batch"
|
||||
(st-parse-chunks
|
||||
"Foo methodsFor: 'access'! foo ^ 1! bar ^ 2! !")
|
||||
(list
|
||||
{:kind "expr"
|
||||
:ast {:type "send"
|
||||
:receiver {:type "ident" :name "Foo"}
|
||||
:selector "methodsFor:"
|
||||
:args (list {:type "lit-string" :value "access"})}}
|
||||
{:kind "method"
|
||||
:class "Foo"
|
||||
:class-side? false
|
||||
:category "access"
|
||||
:ast {:type "method"
|
||||
:selector "foo"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "return" :expr {:type "lit-int" :value 1}})}}
|
||||
{:kind "method"
|
||||
:class "Foo"
|
||||
:class-side? false
|
||||
:category "access"
|
||||
:ast {:type "method"
|
||||
:selector "bar"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "return" :expr {:type "lit-int" :value 2}})}}
|
||||
{:kind "end-methods"}))
|
||||
|
||||
(st-test
|
||||
"class-side methodsFor"
|
||||
(st-parse-chunks
|
||||
"Foo class methodsFor: 'creation'! make ^ self new! !")
|
||||
(list
|
||||
{:kind "expr"
|
||||
:ast {:type "send"
|
||||
:receiver {:type "send"
|
||||
:receiver {:type "ident" :name "Foo"}
|
||||
:selector "class"
|
||||
:args (list)}
|
||||
:selector "methodsFor:"
|
||||
:args (list {:type "lit-string" :value "creation"})}}
|
||||
{:kind "method"
|
||||
:class "Foo"
|
||||
:class-side? true
|
||||
:category "creation"
|
||||
:ast {:type "method"
|
||||
:selector "make"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "return"
|
||||
:expr {:type "send"
|
||||
:receiver {:type "self"}
|
||||
:selector "new"
|
||||
:args (list)}})}}
|
||||
{:kind "end-methods"}))
|
||||
|
||||
(st-test
|
||||
"method batch returns to do-it after empty chunk"
|
||||
(st-parse-chunks
|
||||
"Foo methodsFor: 'a'! m1 ^ 1! ! 99!")
|
||||
(list
|
||||
{:kind "expr"
|
||||
:ast {:type "send"
|
||||
:receiver {:type "ident" :name "Foo"}
|
||||
:selector "methodsFor:"
|
||||
:args (list {:type "lit-string" :value "a"})}}
|
||||
{:kind "method"
|
||||
:class "Foo"
|
||||
:class-side? false
|
||||
:category "a"
|
||||
:ast {:type "method"
|
||||
:selector "m1"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "return" :expr {:type "lit-int" :value 1}})}}
|
||||
{:kind "end-methods"}
|
||||
{:kind "expr" :ast {:type "lit-int" :value 99}}))
|
||||
|
||||
;; ── 4. Pragmas in method bodies ──
|
||||
(st-test
|
||||
"single pragma"
|
||||
(st-parse-method "primAt: i <primitive: 60> ^ self")
|
||||
{:type "method"
|
||||
:selector "primAt:"
|
||||
:params (list "i")
|
||||
:temps (list)
|
||||
:pragmas (list
|
||||
{:selector "primitive:"
|
||||
:args (list {:type "lit-int" :value 60})})
|
||||
:body (list {:type "return" :expr {:type "self"}})})
|
||||
|
||||
(st-test
|
||||
"pragma with two keyword pairs"
|
||||
(st-parse-method "fft <primitive: 1 module: 'fft'> ^ nil")
|
||||
{:type "method"
|
||||
:selector "fft"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list
|
||||
{:selector "primitive:module:"
|
||||
:args (list
|
||||
{:type "lit-int" :value 1}
|
||||
{:type "lit-string" :value "fft"})})
|
||||
:body (list {:type "return" :expr {:type "lit-nil"}})})
|
||||
|
||||
(st-test
|
||||
"pragma with negative number"
|
||||
(st-parse-method "neg <primitive: -1> ^ nil")
|
||||
{:type "method"
|
||||
:selector "neg"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list
|
||||
{:selector "primitive:"
|
||||
:args (list {:type "lit-int" :value -1})})
|
||||
:body (list {:type "return" :expr {:type "lit-nil"}})})
|
||||
|
||||
(st-test
|
||||
"pragma with symbol arg"
|
||||
(st-parse-method "tagged <category: #algebra> ^ nil")
|
||||
{:type "method"
|
||||
:selector "tagged"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list
|
||||
{:selector "category:"
|
||||
:args (list {:type "lit-symbol" :value "algebra"})})
|
||||
:body (list {:type "return" :expr {:type "lit-nil"}})})
|
||||
|
||||
(st-test
|
||||
"pragma then temps"
|
||||
(st-parse-method "calc <primitive: 1> | t | t := 5. ^ t")
|
||||
{:type "method"
|
||||
:selector "calc"
|
||||
:params (list)
|
||||
:temps (list "t")
|
||||
:pragmas (list
|
||||
{:selector "primitive:"
|
||||
:args (list {:type "lit-int" :value 1})})
|
||||
:body (list
|
||||
{:type "assign" :name "t" :expr {:type "lit-int" :value 5}}
|
||||
{:type "return" :expr {:type "ident" :name "t"}})})
|
||||
|
||||
(st-test
|
||||
"temps then pragma"
|
||||
(st-parse-method "calc | t | <primitive: 1> t := 5. ^ t")
|
||||
{:type "method"
|
||||
:selector "calc"
|
||||
:params (list)
|
||||
:temps (list "t")
|
||||
:pragmas (list
|
||||
{:selector "primitive:"
|
||||
:args (list {:type "lit-int" :value 1})})
|
||||
:body (list
|
||||
{:type "assign" :name "t" :expr {:type "lit-int" :value 5}}
|
||||
{:type "return" :expr {:type "ident" :name "t"}})})
|
||||
|
||||
(st-test
|
||||
"two pragmas"
|
||||
(st-parse-method "m <primitive: 1> <category: 'a'> ^ self")
|
||||
{:type "method"
|
||||
:selector "m"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list
|
||||
{:selector "primitive:"
|
||||
:args (list {:type "lit-int" :value 1})}
|
||||
{:selector "category:"
|
||||
:args (list {:type "lit-string" :value "a"})})
|
||||
:body (list {:type "return" :expr {:type "self"}})})
|
||||
|
||||
;; ── 5. End-to-end: a small "filed-in" snippet ──
|
||||
(st-test
|
||||
"small filed-in class snippet"
|
||||
(st-parse-chunks
|
||||
"Object subclass: #Account
|
||||
instanceVariableNames: 'balance'!
|
||||
|
||||
!Account methodsFor: 'access'!
|
||||
balance
|
||||
^ balance!
|
||||
|
||||
deposit: amount
|
||||
balance := balance + amount.
|
||||
^ self! !")
|
||||
(list
|
||||
{:kind "expr"
|
||||
:ast {:type "send"
|
||||
:receiver {:type "ident" :name "Object"}
|
||||
:selector "subclass:instanceVariableNames:"
|
||||
:args (list
|
||||
{:type "lit-symbol" :value "Account"}
|
||||
{:type "lit-string" :value "balance"})}}
|
||||
{:kind "blank"}
|
||||
{:kind "expr"
|
||||
:ast {:type "send"
|
||||
:receiver {:type "ident" :name "Account"}
|
||||
:selector "methodsFor:"
|
||||
:args (list {:type "lit-string" :value "access"})}}
|
||||
{:kind "method"
|
||||
:class "Account"
|
||||
:class-side? false
|
||||
:category "access"
|
||||
:ast {:type "method"
|
||||
:selector "balance"
|
||||
:params (list)
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "return"
|
||||
:expr {:type "ident" :name "balance"}})}}
|
||||
{:kind "method"
|
||||
:class "Account"
|
||||
:class-side? false
|
||||
:category "access"
|
||||
:ast {:type "method"
|
||||
:selector "deposit:"
|
||||
:params (list "amount")
|
||||
:temps (list)
|
||||
:pragmas (list)
|
||||
:body (list
|
||||
{:type "assign"
|
||||
:name "balance"
|
||||
:expr {:type "send"
|
||||
:receiver {:type "ident" :name "balance"}
|
||||
:selector "+"
|
||||
:args (list {:type "ident" :name "amount"})}}
|
||||
{:type "return" :expr {:type "self"}})}}
|
||||
{:kind "end-methods"}))
|
||||
|
||||
(list st-test-pass st-test-fail)
|
||||
182
lib/smalltalk/tests/runtime.sx
Normal file
182
lib/smalltalk/tests/runtime.sx
Normal file
@@ -0,0 +1,182 @@
|
||||
;; Smalltalk runtime tests — class table, type→class mapping, instances.
|
||||
;;
|
||||
;; Reuses helpers (st-test, st-deep=?) from tokenize.sx. Counters reset
|
||||
;; here so this file's summary covers runtime tests only.
|
||||
|
||||
(set! st-test-pass 0)
|
||||
(set! st-test-fail 0)
|
||||
(set! st-test-fails (list))
|
||||
|
||||
;; Fresh hierarchy for every test file.
|
||||
(st-bootstrap-classes!)
|
||||
|
||||
;; ── 1. Bootstrap installed expected classes ──
|
||||
(st-test "Object exists" (st-class-exists? "Object") true)
|
||||
(st-test "Behavior exists" (st-class-exists? "Behavior") true)
|
||||
(st-test "Metaclass exists" (st-class-exists? "Metaclass") true)
|
||||
(st-test "True/False/UndefinedObject"
|
||||
(and
|
||||
(st-class-exists? "True")
|
||||
(st-class-exists? "False")
|
||||
(st-class-exists? "UndefinedObject"))
|
||||
true)
|
||||
(st-test "SmallInteger / Float / Symbol exist"
|
||||
(and
|
||||
(st-class-exists? "SmallInteger")
|
||||
(st-class-exists? "Float")
|
||||
(st-class-exists? "Symbol"))
|
||||
true)
|
||||
(st-test "BlockClosure exists" (st-class-exists? "BlockClosure") true)
|
||||
|
||||
;; ── 2. Superclass chain ──
|
||||
(st-test "Object has no superclass" (st-class-superclass "Object") nil)
|
||||
(st-test "Behavior super = Object" (st-class-superclass "Behavior") "Object")
|
||||
(st-test "True super = Boolean" (st-class-superclass "True") "Boolean")
|
||||
(st-test "Symbol super = String" (st-class-superclass "Symbol") "String")
|
||||
(st-test
|
||||
"String chain"
|
||||
(st-class-chain "String")
|
||||
(list "String" "ArrayedCollection" "SequenceableCollection" "Collection" "Object"))
|
||||
(st-test
|
||||
"SmallInteger chain"
|
||||
(st-class-chain "SmallInteger")
|
||||
(list "SmallInteger" "Integer" "Number" "Magnitude" "Object"))
|
||||
|
||||
;; ── 3. inherits-from? ──
|
||||
(st-test "True inherits from Boolean" (st-class-inherits-from? "True" "Boolean") true)
|
||||
(st-test "True inherits from Object" (st-class-inherits-from? "True" "Object") true)
|
||||
(st-test "True inherits from True" (st-class-inherits-from? "True" "True") true)
|
||||
(st-test
|
||||
"True does not inherit from Number"
|
||||
(st-class-inherits-from? "True" "Number")
|
||||
false)
|
||||
(st-test
|
||||
"Object does not inherit from Number"
|
||||
(st-class-inherits-from? "Object" "Number")
|
||||
false)
|
||||
|
||||
;; ── 4. type→class mapping ──
|
||||
(st-test "class-of nil" (st-class-of nil) "UndefinedObject")
|
||||
(st-test "class-of true" (st-class-of true) "True")
|
||||
(st-test "class-of false" (st-class-of false) "False")
|
||||
(st-test "class-of int" (st-class-of 42) "SmallInteger")
|
||||
(st-test "class-of zero" (st-class-of 0) "SmallInteger")
|
||||
(st-test "class-of negative int" (st-class-of -3) "SmallInteger")
|
||||
(st-test "class-of float" (st-class-of 3.14) "Float")
|
||||
(st-test "class-of string" (st-class-of "hi") "String")
|
||||
(st-test "class-of symbol" (st-class-of (quote foo)) "Symbol")
|
||||
(st-test "class-of list" (st-class-of (list 1 2)) "Array")
|
||||
(st-test "class-of empty list" (st-class-of (list)) "Array")
|
||||
(st-test "class-of lambda" (st-class-of (fn (x) x)) "BlockClosure")
|
||||
(st-test "class-of dict" (st-class-of {:a 1}) "Dictionary")
|
||||
|
||||
;; ── 5. User class definition ──
|
||||
(st-class-define! "Account" "Object" (list "balance" "owner"))
|
||||
(st-class-define! "SavingsAccount" "Account" (list "rate"))
|
||||
|
||||
(st-test "Account exists" (st-class-exists? "Account") true)
|
||||
(st-test "Account super = Object" (st-class-superclass "Account") "Object")
|
||||
(st-test
|
||||
"SavingsAccount chain"
|
||||
(st-class-chain "SavingsAccount")
|
||||
(list "SavingsAccount" "Account" "Object"))
|
||||
(st-test
|
||||
"SavingsAccount own ivars"
|
||||
(get (st-class-get "SavingsAccount") :ivars)
|
||||
(list "rate"))
|
||||
(st-test
|
||||
"SavingsAccount inherited+own ivars"
|
||||
(st-class-all-ivars "SavingsAccount")
|
||||
(list "balance" "owner" "rate"))
|
||||
|
||||
;; ── 6. Instance construction ──
|
||||
(define a1 (st-make-instance "Account"))
|
||||
(st-test "instance is st-instance" (st-instance? a1) true)
|
||||
(st-test "instance class" (get a1 :class) "Account")
|
||||
(st-test "instance ivars start nil" (st-iv-get a1 "balance") nil)
|
||||
(st-test
|
||||
"instance has all expected ivars"
|
||||
(sort (keys (get a1 :ivars)))
|
||||
(sort (list "balance" "owner")))
|
||||
(define a2 (st-iv-set! a1 "balance" 100))
|
||||
(st-test "iv-set! returns updated copy" (st-iv-get a2 "balance") 100)
|
||||
(st-test "iv-set! does not mutate original" (st-iv-get a1 "balance") nil)
|
||||
(st-test "class-of instance" (st-class-of a1) "Account")
|
||||
|
||||
(define s1 (st-make-instance "SavingsAccount"))
|
||||
(st-test
|
||||
"subclass instance has all inherited ivars"
|
||||
(sort (keys (get s1 :ivars)))
|
||||
(sort (list "balance" "owner" "rate")))
|
||||
|
||||
;; ── 7. Method install + lookup ──
|
||||
(st-class-add-method!
|
||||
"Account"
|
||||
"balance"
|
||||
(st-parse-method "balance ^ balance"))
|
||||
(st-class-add-method!
|
||||
"Account"
|
||||
"deposit:"
|
||||
(st-parse-method "deposit: amount balance := balance + amount. ^ self"))
|
||||
|
||||
(st-test
|
||||
"method registered"
|
||||
(has-key? (get (st-class-get "Account") :methods) "balance")
|
||||
true)
|
||||
|
||||
(st-test
|
||||
"method lookup direct"
|
||||
(= (st-method-lookup "Account" "balance" false) nil)
|
||||
false)
|
||||
|
||||
(st-test
|
||||
"method lookup walks superclass"
|
||||
(= (st-method-lookup "SavingsAccount" "deposit:" false) nil)
|
||||
false)
|
||||
|
||||
(st-test
|
||||
"method lookup unknown selector"
|
||||
(st-method-lookup "Account" "frobnicate" false)
|
||||
nil)
|
||||
|
||||
(st-test
|
||||
"method lookup records defining class"
|
||||
(get (st-method-lookup "SavingsAccount" "balance" false) :defining-class)
|
||||
"Account")
|
||||
|
||||
;; SavingsAccount overrides deposit:
|
||||
(st-class-add-method!
|
||||
"SavingsAccount"
|
||||
"deposit:"
|
||||
(st-parse-method "deposit: amount ^ super deposit: amount + 1"))
|
||||
|
||||
(st-test
|
||||
"subclass override picked first"
|
||||
(get (st-method-lookup "SavingsAccount" "deposit:" false) :defining-class)
|
||||
"SavingsAccount")
|
||||
|
||||
(st-test
|
||||
"Account still finds its own deposit:"
|
||||
(get (st-method-lookup "Account" "deposit:" false) :defining-class)
|
||||
"Account")
|
||||
|
||||
;; ── 8. Class-side methods ──
|
||||
(st-class-add-class-method!
|
||||
"Account"
|
||||
"new"
|
||||
(st-parse-method "new ^ super new"))
|
||||
(st-test
|
||||
"class-side lookup"
|
||||
(= (st-method-lookup "Account" "new" true) nil)
|
||||
false)
|
||||
(st-test
|
||||
"instance-side does not find class method"
|
||||
(st-method-lookup "Account" "new" false)
|
||||
nil)
|
||||
|
||||
;; ── 9. Re-bootstrap resets table ──
|
||||
(st-bootstrap-classes!)
|
||||
(st-test "after re-bootstrap Account gone" (st-class-exists? "Account") false)
|
||||
(st-test "after re-bootstrap Object stays" (st-class-exists? "Object") true)
|
||||
|
||||
(list st-test-pass st-test-fail)
|
||||
362
lib/smalltalk/tests/tokenize.sx
Normal file
362
lib/smalltalk/tests/tokenize.sx
Normal file
@@ -0,0 +1,362 @@
|
||||
;; Smalltalk tokenizer tests.
|
||||
;;
|
||||
;; Lightweight runner: each test checks actual vs expected with structural
|
||||
;; equality and accumulates pass/fail counters. Final summary read by
|
||||
;; lib/smalltalk/test.sh.
|
||||
|
||||
(define
|
||||
st-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) (st-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))
|
||||
(begin
|
||||
(define
|
||||
de-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and ok (< i (len a)))
|
||||
(begin
|
||||
(when
|
||||
(not (st-deep=? (nth a i) (nth b i)))
|
||||
(set! ok false))
|
||||
(set! i (+ i 1))
|
||||
(de-loop)))))
|
||||
(de-loop)
|
||||
ok))))
|
||||
(:else false))))
|
||||
|
||||
(define st-test-pass 0)
|
||||
(define st-test-fail 0)
|
||||
(define st-test-fails (list))
|
||||
|
||||
(define
|
||||
st-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(st-deep=? actual expected)
|
||||
(set! st-test-pass (+ st-test-pass 1))
|
||||
(begin
|
||||
(set! st-test-fail (+ st-test-fail 1))
|
||||
(append! st-test-fails {:actual actual :expected expected :name name})))))
|
||||
|
||||
;; Strip eof and project to just :type/:value.
|
||||
(define
|
||||
st-toks
|
||||
(fn
|
||||
(src)
|
||||
(map
|
||||
(fn (tok) {:type (get tok :type) :value (get tok :value)})
|
||||
(filter
|
||||
(fn (tok) (not (= (get tok :type) "eof")))
|
||||
(st-tokenize src)))))
|
||||
|
||||
;; ── 1. Whitespace / empty ──
|
||||
(st-test "empty input" (st-toks "") (list))
|
||||
(st-test "all whitespace" (st-toks " \t\n ") (list))
|
||||
|
||||
;; ── 2. Identifiers ──
|
||||
(st-test
|
||||
"lowercase ident"
|
||||
(st-toks "foo")
|
||||
(list {:type "ident" :value "foo"}))
|
||||
|
||||
(st-test
|
||||
"capitalised ident"
|
||||
(st-toks "Foo")
|
||||
(list {:type "ident" :value "Foo"}))
|
||||
|
||||
(st-test
|
||||
"underscore ident"
|
||||
(st-toks "_x")
|
||||
(list {:type "ident" :value "_x"}))
|
||||
|
||||
(st-test
|
||||
"digits in ident"
|
||||
(st-toks "foo123")
|
||||
(list {:type "ident" :value "foo123"}))
|
||||
|
||||
(st-test
|
||||
"two idents separated"
|
||||
(st-toks "foo bar")
|
||||
(list {:type "ident" :value "foo"} {:type "ident" :value "bar"}))
|
||||
|
||||
;; ── 3. Keyword selectors ──
|
||||
(st-test
|
||||
"keyword selector"
|
||||
(st-toks "foo:")
|
||||
(list {:type "keyword" :value "foo:"}))
|
||||
|
||||
(st-test
|
||||
"keyword call"
|
||||
(st-toks "x at: 1")
|
||||
(list
|
||||
{:type "ident" :value "x"}
|
||||
{:type "keyword" :value "at:"}
|
||||
{:type "number" :value 1}))
|
||||
|
||||
(st-test
|
||||
"two-keyword chain stays separate"
|
||||
(st-toks "at: 1 put: 2")
|
||||
(list
|
||||
{:type "keyword" :value "at:"}
|
||||
{:type "number" :value 1}
|
||||
{:type "keyword" :value "put:"}
|
||||
{:type "number" :value 2}))
|
||||
|
||||
(st-test
|
||||
"ident then assign — not a keyword"
|
||||
(st-toks "x := 1")
|
||||
(list
|
||||
{:type "ident" :value "x"}
|
||||
{:type "assign" :value ":="}
|
||||
{:type "number" :value 1}))
|
||||
|
||||
;; ── 4. Numbers ──
|
||||
(st-test
|
||||
"integer"
|
||||
(st-toks "42")
|
||||
(list {:type "number" :value 42}))
|
||||
|
||||
(st-test
|
||||
"float"
|
||||
(st-toks "3.14")
|
||||
(list {:type "number" :value 3.14}))
|
||||
|
||||
(st-test
|
||||
"hex radix"
|
||||
(st-toks "16rFF")
|
||||
(list
|
||||
{:type "number"
|
||||
:value
|
||||
{:radix 16 :digits "FF" :value 255 :kind "radix"}}))
|
||||
|
||||
(st-test
|
||||
"binary radix"
|
||||
(st-toks "2r1011")
|
||||
(list
|
||||
{:type "number"
|
||||
:value
|
||||
{:radix 2 :digits "1011" :value 11 :kind "radix"}}))
|
||||
|
||||
(st-test
|
||||
"exponent"
|
||||
(st-toks "1e3")
|
||||
(list {:type "number" :value 1000}))
|
||||
|
||||
(st-test
|
||||
"negative exponent (parser handles minus)"
|
||||
(st-toks "1.5e-2")
|
||||
(list {:type "number" :value 0.015}))
|
||||
|
||||
;; ── 5. Strings ──
|
||||
(st-test
|
||||
"simple string"
|
||||
(st-toks "'hi'")
|
||||
(list {:type "string" :value "hi"}))
|
||||
|
||||
(st-test
|
||||
"empty string"
|
||||
(st-toks "''")
|
||||
(list {:type "string" :value ""}))
|
||||
|
||||
(st-test
|
||||
"doubled-quote escape"
|
||||
(st-toks "'a''b'")
|
||||
(list {:type "string" :value "a'b"}))
|
||||
|
||||
;; ── 6. Characters ──
|
||||
(st-test
|
||||
"char literal letter"
|
||||
(st-toks "$a")
|
||||
(list {:type "char" :value "a"}))
|
||||
|
||||
(st-test
|
||||
"char literal punct"
|
||||
(st-toks "$$")
|
||||
(list {:type "char" :value "$"}))
|
||||
|
||||
(st-test
|
||||
"char literal space"
|
||||
(st-toks "$ ")
|
||||
(list {:type "char" :value " "}))
|
||||
|
||||
;; ── 7. Symbols ──
|
||||
(st-test
|
||||
"symbol ident"
|
||||
(st-toks "#foo")
|
||||
(list {:type "symbol" :value "foo"}))
|
||||
|
||||
(st-test
|
||||
"symbol binary"
|
||||
(st-toks "#+")
|
||||
(list {:type "symbol" :value "+"}))
|
||||
|
||||
(st-test
|
||||
"symbol arrow"
|
||||
(st-toks "#->")
|
||||
(list {:type "symbol" :value "->"}))
|
||||
|
||||
(st-test
|
||||
"symbol keyword chain"
|
||||
(st-toks "#at:put:")
|
||||
(list {:type "symbol" :value "at:put:"}))
|
||||
|
||||
(st-test
|
||||
"quoted symbol with spaces"
|
||||
(st-toks "#'foo bar'")
|
||||
(list {:type "symbol" :value "foo bar"}))
|
||||
|
||||
;; ── 8. Literal arrays / byte arrays ──
|
||||
(st-test
|
||||
"literal array open"
|
||||
(st-toks "#(1 2)")
|
||||
(list
|
||||
{:type "array-open" :value "#("}
|
||||
{:type "number" :value 1}
|
||||
{:type "number" :value 2}
|
||||
{:type "rparen" :value ")"}))
|
||||
|
||||
(st-test
|
||||
"byte array open"
|
||||
(st-toks "#[1 2 3]")
|
||||
(list
|
||||
{:type "byte-array-open" :value "#["}
|
||||
{:type "number" :value 1}
|
||||
{:type "number" :value 2}
|
||||
{:type "number" :value 3}
|
||||
{:type "rbracket" :value "]"}))
|
||||
|
||||
;; ── 9. Binary selectors ──
|
||||
(st-test "plus" (st-toks "+") (list {:type "binary" :value "+"}))
|
||||
(st-test "minus" (st-toks "-") (list {:type "binary" :value "-"}))
|
||||
(st-test "star" (st-toks "*") (list {:type "binary" :value "*"}))
|
||||
(st-test "double-equal" (st-toks "==") (list {:type "binary" :value "=="}))
|
||||
(st-test "leq" (st-toks "<=") (list {:type "binary" :value "<="}))
|
||||
(st-test "geq" (st-toks ">=") (list {:type "binary" :value ">="}))
|
||||
(st-test "neq" (st-toks "~=") (list {:type "binary" :value "~="}))
|
||||
(st-test "arrow" (st-toks "->") (list {:type "binary" :value "->"}))
|
||||
(st-test "comma" (st-toks ",") (list {:type "binary" :value ","}))
|
||||
|
||||
(st-test
|
||||
"binary in expression"
|
||||
(st-toks "a + b")
|
||||
(list
|
||||
{:type "ident" :value "a"}
|
||||
{:type "binary" :value "+"}
|
||||
{:type "ident" :value "b"}))
|
||||
|
||||
;; ── 10. Punctuation ──
|
||||
(st-test "lparen" (st-toks "(") (list {:type "lparen" :value "("}))
|
||||
(st-test "rparen" (st-toks ")") (list {:type "rparen" :value ")"}))
|
||||
(st-test "lbracket" (st-toks "[") (list {:type "lbracket" :value "["}))
|
||||
(st-test "rbracket" (st-toks "]") (list {:type "rbracket" :value "]"}))
|
||||
(st-test "lbrace" (st-toks "{") (list {:type "lbrace" :value "{"}))
|
||||
(st-test "rbrace" (st-toks "}") (list {:type "rbrace" :value "}"}))
|
||||
(st-test "period" (st-toks ".") (list {:type "period" :value "."}))
|
||||
(st-test "semi" (st-toks ";") (list {:type "semi" :value ";"}))
|
||||
(st-test "bar" (st-toks "|") (list {:type "bar" :value "|"}))
|
||||
(st-test "caret" (st-toks "^") (list {:type "caret" :value "^"}))
|
||||
(st-test "bang" (st-toks "!") (list {:type "bang" :value "!"}))
|
||||
(st-test "colon" (st-toks ":") (list {:type "colon" :value ":"}))
|
||||
(st-test "assign" (st-toks ":=") (list {:type "assign" :value ":="}))
|
||||
|
||||
;; ── 11. Comments ──
|
||||
(st-test "comment skipped" (st-toks "\"hello\"") (list))
|
||||
(st-test
|
||||
"comment between tokens"
|
||||
(st-toks "a \"comment\" b")
|
||||
(list {:type "ident" :value "a"} {:type "ident" :value "b"}))
|
||||
(st-test
|
||||
"multi-line comment"
|
||||
(st-toks "\"line1\nline2\"42")
|
||||
(list {:type "number" :value 42}))
|
||||
|
||||
;; ── 12. Compound expressions ──
|
||||
(st-test
|
||||
"block with params"
|
||||
(st-toks "[:a :b | a + b]")
|
||||
(list
|
||||
{:type "lbracket" :value "["}
|
||||
{:type "colon" :value ":"}
|
||||
{:type "ident" :value "a"}
|
||||
{:type "colon" :value ":"}
|
||||
{:type "ident" :value "b"}
|
||||
{:type "bar" :value "|"}
|
||||
{:type "ident" :value "a"}
|
||||
{:type "binary" :value "+"}
|
||||
{:type "ident" :value "b"}
|
||||
{:type "rbracket" :value "]"}))
|
||||
|
||||
(st-test
|
||||
"cascade"
|
||||
(st-toks "x m1; m2")
|
||||
(list
|
||||
{:type "ident" :value "x"}
|
||||
{:type "ident" :value "m1"}
|
||||
{:type "semi" :value ";"}
|
||||
{:type "ident" :value "m2"}))
|
||||
|
||||
(st-test
|
||||
"method body return"
|
||||
(st-toks "^ self foo")
|
||||
(list
|
||||
{:type "caret" :value "^"}
|
||||
{:type "ident" :value "self"}
|
||||
{:type "ident" :value "foo"}))
|
||||
|
||||
(st-test
|
||||
"class declaration head"
|
||||
(st-toks "Object subclass: #Foo")
|
||||
(list
|
||||
{:type "ident" :value "Object"}
|
||||
{:type "keyword" :value "subclass:"}
|
||||
{:type "symbol" :value "Foo"}))
|
||||
|
||||
(st-test
|
||||
"temp declaration"
|
||||
(st-toks "| t1 t2 |")
|
||||
(list
|
||||
{:type "bar" :value "|"}
|
||||
{:type "ident" :value "t1"}
|
||||
{:type "ident" :value "t2"}
|
||||
{:type "bar" :value "|"}))
|
||||
|
||||
(st-test
|
||||
"chunk separator"
|
||||
(st-toks "Foo bar !")
|
||||
(list
|
||||
{:type "ident" :value "Foo"}
|
||||
{:type "ident" :value "bar"}
|
||||
{:type "bang" :value "!"}))
|
||||
|
||||
(st-test
|
||||
"keyword call with binary precedence"
|
||||
(st-toks "x foo: 1 + 2")
|
||||
(list
|
||||
{:type "ident" :value "x"}
|
||||
{:type "keyword" :value "foo:"}
|
||||
{:type "number" :value 1}
|
||||
{:type "binary" :value "+"}
|
||||
{:type "number" :value 2}))
|
||||
|
||||
(list st-test-pass st-test-fail)
|
||||
366
lib/smalltalk/tokenizer.sx
Normal file
366
lib/smalltalk/tokenizer.sx
Normal file
@@ -0,0 +1,366 @@
|
||||
;; Smalltalk tokenizer.
|
||||
;;
|
||||
;; Token types:
|
||||
;; ident identifier (foo, Foo, _x)
|
||||
;; keyword selector keyword (foo:) — value is "foo:" with the colon
|
||||
;; binary binary selector chars run together (+, ==, ->, <=, ~=, ...)
|
||||
;; number integer or float; radix integers like 16rFF supported
|
||||
;; string 'hello''world' style
|
||||
;; char $c
|
||||
;; symbol #foo, #foo:bar:, #+, #'with spaces'
|
||||
;; array-open #(
|
||||
;; byte-array-open #[
|
||||
;; lparen rparen lbracket rbracket lbrace rbrace
|
||||
;; period semi bar caret colon assign bang
|
||||
;; eof
|
||||
;;
|
||||
;; Comments "…" are skipped.
|
||||
|
||||
(define st-make-token (fn (type value pos) {:type type :value value :pos pos}))
|
||||
|
||||
(define st-digit? (fn (c) (and (not (= c nil)) (>= c "0") (<= c "9"))))
|
||||
|
||||
(define
|
||||
st-letter?
|
||||
(fn
|
||||
(c)
|
||||
(and
|
||||
(not (= c nil))
|
||||
(or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))))
|
||||
|
||||
(define st-ident-start? (fn (c) (or (st-letter? c) (= c "_"))))
|
||||
|
||||
(define st-ident-char? (fn (c) (or (st-ident-start? c) (st-digit? c))))
|
||||
|
||||
(define st-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
||||
|
||||
(define
|
||||
st-binary-chars
|
||||
(list "+" "-" "*" "/" "\\" "~" "<" ">" "=" "@" "%" "&" "?" ","))
|
||||
|
||||
(define
|
||||
st-binary-char?
|
||||
(fn (c) (and (not (= c nil)) (contains? st-binary-chars c))))
|
||||
|
||||
(define
|
||||
st-radix-digit?
|
||||
(fn
|
||||
(c)
|
||||
(and
|
||||
(not (= c nil))
|
||||
(or (st-digit? c) (and (>= c "A") (<= c "Z"))))))
|
||||
|
||||
(define
|
||||
st-tokenize
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((tokens (list)) (pos 0) (src-len (len src)))
|
||||
(define
|
||||
pk
|
||||
(fn
|
||||
(offset)
|
||||
(if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
|
||||
(define cur (fn () (pk 0)))
|
||||
(define advance! (fn (n) (set! pos (+ pos n))))
|
||||
(define
|
||||
push!
|
||||
(fn
|
||||
(type value start)
|
||||
(append! tokens (st-make-token type value start))))
|
||||
(define
|
||||
skip-comment!
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((= (cur) "\"") (advance! 1))
|
||||
(else (begin (advance! 1) (skip-comment!))))))
|
||||
(define
|
||||
skip-ws!
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((st-ws? (cur)) (begin (advance! 1) (skip-ws!)))
|
||||
((= (cur) "\"") (begin (advance! 1) (skip-comment!) (skip-ws!)))
|
||||
(else nil))))
|
||||
(define
|
||||
read-ident-chars!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (st-ident-char? (cur)))
|
||||
(begin (advance! 1) (read-ident-chars!)))))
|
||||
(define
|
||||
read-decimal-digits!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (st-digit? (cur)))
|
||||
(begin (advance! 1) (read-decimal-digits!)))))
|
||||
(define
|
||||
read-radix-digits!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (st-radix-digit? (cur)))
|
||||
(begin (advance! 1) (read-radix-digits!)))))
|
||||
(define
|
||||
read-exp-part!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< pos src-len)
|
||||
(or (= (cur) "e") (= (cur) "E"))
|
||||
(let
|
||||
((p1 (pk 1)) (p2 (pk 2)))
|
||||
(or
|
||||
(st-digit? p1)
|
||||
(and (or (= p1 "+") (= p1 "-")) (st-digit? p2)))))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(when
|
||||
(and (< pos src-len) (or (= (cur) "+") (= (cur) "-")))
|
||||
(advance! 1))
|
||||
(read-decimal-digits!)))))
|
||||
(define
|
||||
read-number
|
||||
(fn
|
||||
(start)
|
||||
(begin
|
||||
(read-decimal-digits!)
|
||||
(cond
|
||||
((and (< pos src-len) (= (cur) "r"))
|
||||
(let
|
||||
((base-str (slice src start pos)))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(let
|
||||
((rstart pos))
|
||||
(begin
|
||||
(read-radix-digits!)
|
||||
(let
|
||||
((digits (slice src rstart pos)))
|
||||
{:radix (parse-number base-str)
|
||||
:digits digits
|
||||
:value (parse-radix base-str digits)
|
||||
:kind "radix"}))))))
|
||||
((and
|
||||
(< pos src-len)
|
||||
(= (cur) ".")
|
||||
(st-digit? (pk 1)))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(read-decimal-digits!)
|
||||
(read-exp-part!)
|
||||
(parse-number (slice src start pos))))
|
||||
(else
|
||||
(begin
|
||||
(read-exp-part!)
|
||||
(parse-number (slice src start pos))))))))
|
||||
(define
|
||||
parse-radix
|
||||
(fn
|
||||
(base-str digits)
|
||||
(let
|
||||
((base (parse-number base-str))
|
||||
(chars digits)
|
||||
(n-len (len digits))
|
||||
(idx 0)
|
||||
(acc 0))
|
||||
(begin
|
||||
(define
|
||||
rd-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< idx n-len)
|
||||
(let
|
||||
((c (nth chars idx)))
|
||||
(let
|
||||
((d (cond
|
||||
((and (>= c "0") (<= c "9")) (- (char-code c) 48))
|
||||
((and (>= c "A") (<= c "Z")) (- (char-code c) 55))
|
||||
(else 0))))
|
||||
(begin
|
||||
(set! acc (+ (* acc base) d))
|
||||
(set! idx (+ idx 1))
|
||||
(rd-loop)))))))
|
||||
(rd-loop)
|
||||
acc))))
|
||||
(define
|
||||
read-string
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((chars (list)))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((= (cur) "'")
|
||||
(cond
|
||||
((= (pk 1) "'")
|
||||
(begin
|
||||
(append! chars "'")
|
||||
(advance! 2)
|
||||
(loop)))
|
||||
(else (advance! 1))))
|
||||
(else
|
||||
(begin (append! chars (cur)) (advance! 1) (loop))))))
|
||||
(loop)
|
||||
(join "" chars)))))
|
||||
(define
|
||||
read-binary-run!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((start pos))
|
||||
(begin
|
||||
(define
|
||||
bin-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (st-binary-char? (cur)))
|
||||
(begin (advance! 1) (bin-loop)))))
|
||||
(bin-loop)
|
||||
(slice src start pos)))))
|
||||
(define
|
||||
read-symbol
|
||||
(fn
|
||||
(start)
|
||||
(cond
|
||||
;; Quoted symbol: #'whatever'
|
||||
((= (cur) "'")
|
||||
(let ((s (read-string))) (push! "symbol" s start)))
|
||||
;; Binary-char symbol: #+, #==, #->, #|
|
||||
((or (st-binary-char? (cur)) (= (cur) "|"))
|
||||
(let ((b (read-binary-run!)))
|
||||
(cond
|
||||
((= b "")
|
||||
;; lone | wasn't binary; consume it
|
||||
(begin (advance! 1) (push! "symbol" "|" start)))
|
||||
(else (push! "symbol" b start)))))
|
||||
;; Identifier or keyword chain: #foo, #foo:bar:
|
||||
((st-ident-start? (cur))
|
||||
(let ((id-start pos))
|
||||
(begin
|
||||
(read-ident-chars!)
|
||||
(define
|
||||
kw-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (= (cur) ":"))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(when
|
||||
(and (< pos src-len) (st-ident-start? (cur)))
|
||||
(begin (read-ident-chars!) (kw-loop)))))))
|
||||
(kw-loop)
|
||||
(push! "symbol" (slice src id-start pos) start))))
|
||||
(else
|
||||
(error
|
||||
(str "st-tokenize: bad symbol at " pos))))))
|
||||
(define
|
||||
step
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(skip-ws!)
|
||||
(when
|
||||
(< pos src-len)
|
||||
(let
|
||||
((start pos) (c (cur)))
|
||||
(cond
|
||||
;; Identifier or keyword
|
||||
((st-ident-start? c)
|
||||
(begin
|
||||
(read-ident-chars!)
|
||||
(let
|
||||
((word (slice src start pos)))
|
||||
(cond
|
||||
;; ident immediately followed by ':' (and not ':=') => keyword
|
||||
((and
|
||||
(< pos src-len)
|
||||
(= (cur) ":")
|
||||
(not (= (pk 1) "=")))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(push!
|
||||
"keyword"
|
||||
(str word ":")
|
||||
start)))
|
||||
(else (push! "ident" word start))))
|
||||
(step)))
|
||||
;; Number
|
||||
((st-digit? c)
|
||||
(let
|
||||
((v (read-number start)))
|
||||
(begin (push! "number" v start) (step))))
|
||||
;; String
|
||||
((= c "'")
|
||||
(let
|
||||
((s (read-string)))
|
||||
(begin (push! "string" s start) (step))))
|
||||
;; Character literal
|
||||
((= c "$")
|
||||
(cond
|
||||
((>= (+ pos 1) src-len)
|
||||
(error (str "st-tokenize: $ at end of input")))
|
||||
(else
|
||||
(begin
|
||||
(advance! 1)
|
||||
(push! "char" (cur) start)
|
||||
(advance! 1)
|
||||
(step)))))
|
||||
;; Symbol or array literal
|
||||
((= c "#")
|
||||
(cond
|
||||
((= (pk 1) "(")
|
||||
(begin (advance! 2) (push! "array-open" "#(" start) (step)))
|
||||
((= (pk 1) "[")
|
||||
(begin (advance! 2) (push! "byte-array-open" "#[" start) (step)))
|
||||
(else
|
||||
(begin (advance! 1) (read-symbol start) (step)))))
|
||||
;; Assignment := or bare colon
|
||||
((= c ":")
|
||||
(cond
|
||||
((= (pk 1) "=")
|
||||
(begin (advance! 2) (push! "assign" ":=" start) (step)))
|
||||
(else
|
||||
(begin (advance! 1) (push! "colon" ":" start) (step)))))
|
||||
;; Single-char structural punctuation
|
||||
((= c "(") (begin (advance! 1) (push! "lparen" "(" start) (step)))
|
||||
((= c ")") (begin (advance! 1) (push! "rparen" ")" start) (step)))
|
||||
((= c "[") (begin (advance! 1) (push! "lbracket" "[" start) (step)))
|
||||
((= c "]") (begin (advance! 1) (push! "rbracket" "]" start) (step)))
|
||||
((= c "{") (begin (advance! 1) (push! "lbrace" "{" start) (step)))
|
||||
((= c "}") (begin (advance! 1) (push! "rbrace" "}" start) (step)))
|
||||
((= c ".") (begin (advance! 1) (push! "period" "." start) (step)))
|
||||
((= c ";") (begin (advance! 1) (push! "semi" ";" start) (step)))
|
||||
((= c "|") (begin (advance! 1) (push! "bar" "|" start) (step)))
|
||||
((= c "^") (begin (advance! 1) (push! "caret" "^" start) (step)))
|
||||
((= c "!") (begin (advance! 1) (push! "bang" "!" start) (step)))
|
||||
;; Binary selector run
|
||||
((st-binary-char? c)
|
||||
(let
|
||||
((b (read-binary-run!)))
|
||||
(begin (push! "binary" b start) (step))))
|
||||
(else
|
||||
(error
|
||||
(str
|
||||
"st-tokenize: unexpected char "
|
||||
c
|
||||
" at "
|
||||
pos)))))))))
|
||||
(step)
|
||||
(push! "eof" nil pos)
|
||||
tokens)))
|
||||
77
plans/agent-briefings/smalltalk-loop.md
Normal file
77
plans/agent-briefings/smalltalk-loop.md
Normal file
@@ -0,0 +1,77 @@
|
||||
# smalltalk-on-sx loop agent (single agent, queue-driven)
|
||||
|
||||
Role: iterates `plans/smalltalk-on-sx.md` forever. Message-passing OO + **blocks with non-local return** on delimited continuations. Non-local return is the headline showcase — every other Smalltalk reinvents it on the host stack; on SX it falls out of the captured method-return continuation.
|
||||
|
||||
```
|
||||
description: smalltalk-on-sx queue loop
|
||||
subagent_type: general-purpose
|
||||
run_in_background: true
|
||||
isolation: worktree
|
||||
```
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent working `/root/rose-ash/plans/smalltalk-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
|
||||
|
||||
## Restart baseline — check before iterating
|
||||
|
||||
1. Read `plans/smalltalk-on-sx.md` — roadmap + Progress log.
|
||||
2. `ls lib/smalltalk/` — pick up from the most advanced file.
|
||||
3. If `lib/smalltalk/tests/*.sx` exist, run them. Green before new work.
|
||||
4. If `lib/smalltalk/scoreboard.md` exists, that's your baseline.
|
||||
|
||||
## The queue
|
||||
|
||||
Phase order per `plans/smalltalk-on-sx.md`:
|
||||
|
||||
- **Phase 1** — tokenizer + parser (chunk format, identifiers, keywords `foo:`, binary selectors, `#sym`, `#(…)`, `$c`, blocks `[:a | …]`, cascades, message precedence)
|
||||
- **Phase 2** — object model + sequential eval (class table bootstrap, message dispatch, `super`, `doesNotUnderstand:`, instance variables)
|
||||
- **Phase 3** — **THE SHOWCASE**: blocks with non-local return via captured method-return continuation. `whileTrue:` / `ifTrue:ifFalse:` as block sends. 5 classic programs (eight-queens, quicksort, mandelbrot, life, fibonacci) green.
|
||||
- **Phase 4** — reflection + MOP: `perform:`, `respondsTo:`, runtime method addition, `becomeForward:`, `Exception` / `on:do:` / `ensure:` on top of `handler-bind`/`raise`
|
||||
- **Phase 5** — collections + numeric tower + streams
|
||||
- **Phase 6** — port SUnit, vendor Pharo Kernel-Tests slice, drive corpus to 200+
|
||||
- **Phase 7** — speed (optional): inline caching, block intrinsification
|
||||
|
||||
Within a phase, pick the checkbox that unlocks the most tests per effort.
|
||||
|
||||
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
|
||||
|
||||
## Ground rules (hard)
|
||||
|
||||
- **Scope:** only `lib/smalltalk/**` and `plans/smalltalk-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root. Smalltalk primitives go in `lib/smalltalk/runtime.sx`.
|
||||
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop.
|
||||
- **Shared-file issues** → plan's Blockers with minimal repro.
|
||||
- **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5. `sx_summarise` spec/evaluator.sx first — 2300+ lines.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
|
||||
- **Worktree:** commit locally. Never push. Never touch `main`.
|
||||
- **Commit granularity:** one feature per commit.
|
||||
- **Plan file:** update Progress log + tick boxes every commit.
|
||||
|
||||
## Smalltalk-specific gotchas
|
||||
|
||||
- **Method invocation captures `^k`** — the return continuation. Bind it as the block's escape token. `^expr` from inside any nested block invokes that captured `^k`. Escape past method return raises `BlockContext>>cannotReturn:`.
|
||||
- **Blocks are lambdas + escape token**, not bare lambdas. `value`/`value:`/… invoke the lambda; `^` invokes the escape.
|
||||
- **`ifTrue:` / `ifFalse:` / `whileTrue:` are ordinary block sends** — no special form. The runtime intrinsifies them in the JIT path (Tier 1 of bytecode expansion already covers this pattern).
|
||||
- **Cascade** `r m1; m2; m3` desugars to `(let ((tmp r)) (st-send tmp 'm1 ()) (st-send tmp 'm2 ()) (st-send tmp 'm3 ()))`. Result is the cascade's last send (or first, depending on parser variant — pick one and document).
|
||||
- **`super` send** looks up starting from the *defining* class's superclass, not the receiver class. Stash the defining class on the method record.
|
||||
- **Selectors are interned symbols.** Use SX symbols.
|
||||
- **Receiver dispatch:** tagged ints / floats / strings / symbols / `nil` / `true` / `false` aren't boxed. Their classes (`SmallInteger`, `Float`, `String`, `Symbol`, `UndefinedObject`, `True`, `False`) are looked up by SX type-of, not by an `:class` field.
|
||||
- **Method precedence:** unary > binary > keyword. `3 + 4 factorial` is `3 + (4 factorial)`. `a foo: b bar` is `a foo: (b bar)` (keyword absorbs trailing unary).
|
||||
- **Image / fileIn / become: between sessions** = out of scope. One-way `becomeForward:` only.
|
||||
- **Test corpus:** ~200 hand-written + a slice of Pharo Kernel-Tests. Place programs in `lib/smalltalk/tests/programs/`.
|
||||
|
||||
## General gotchas (all loops)
|
||||
|
||||
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
|
||||
- `cond`/`when`/`let` clauses evaluate only the last expr.
|
||||
- `type-of` on user fn returns `"lambda"`.
|
||||
- Shell heredoc `||` gets eaten — escape or use `case`.
|
||||
|
||||
## Style
|
||||
|
||||
- No comments in `.sx` unless non-obvious.
|
||||
- No new planning docs — update `plans/smalltalk-on-sx.md` inline.
|
||||
- Short, factual commit messages (`smalltalk: tokenizer + 56 tests`).
|
||||
- One feature per iteration. Commit. Log. Next.
|
||||
|
||||
Go. Read the plan; find first `[ ]`; implement.
|
||||
@@ -55,32 +55,25 @@ 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/`:
|
||||
- [ ] `fib.hs` — infinite Fibonacci stream
|
||||
- [ ] `sieve.hs` — lazy sieve of Eratosthenes
|
||||
@@ -114,381 +107,6 @@ Key mappings:
|
||||
|
||||
_Newest first._
|
||||
|
||||
- **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
|
||||
|
||||
121
plans/smalltalk-on-sx.md
Normal file
121
plans/smalltalk-on-sx.md
Normal file
@@ -0,0 +1,121 @@
|
||||
# Smalltalk-on-SX: blocks with non-local return on delimited continuations
|
||||
|
||||
The headline showcase is **blocks** — Smalltalk's closures with non-local return (`^expr` aborts the enclosing *method*, not the block). Every other Smalltalk on top of a host VM (RSqueak on PyPy, GemStone on C, Maxine on Java) reinvents non-local return on whatever stack discipline the host gives them. On SX it's a one-liner: a block holds a captured continuation; `^` just invokes it. Message-passing OO falls out cheaply on top of the existing component / dispatch machinery.
|
||||
|
||||
End-state goal: ANSI-ish Smalltalk-80 subset, SUnit working, ~200 hand-written tests + a vendored slice of the Pharo kernel tests, classic corpus (eight queens, quicksort, mandelbrot, Conway's Life).
|
||||
|
||||
## Scope decisions (defaults — override by editing before we spawn)
|
||||
|
||||
- **Syntax:** Pharo / Squeak chunk format (`!` separators, `Object subclass: #Foo …`). No fileIn/fileOut images — text source only.
|
||||
- **Conformance:** ANSI X3J20 *as a target*, not bug-for-bug Squeak. "Reads like Smalltalk, runs like Smalltalk."
|
||||
- **Test corpus:** SUnit ported to SX-Smalltalk + custom programs + a curated slice of Pharo `Kernel-Tests` / `Collections-Tests`.
|
||||
- **Image:** out of scope. Source-only. No `become:` between sessions, no snapshotting.
|
||||
- **Reflection:** `class`, `respondsTo:`, `perform:`, `doesNotUnderstand:` in. `become:` (object-identity swap) **in** — it's a good CEK exercise. Method modification at runtime in.
|
||||
- **GUI / Morphic / threads:** out entirely.
|
||||
|
||||
## Ground rules
|
||||
|
||||
- **Scope:** only touch `lib/smalltalk/**` and `plans/smalltalk-on-sx.md`. Don't edit `spec/`, `hosts/`, `shared/`, or any other `lib/<lang>/**`. Smalltalk primitives go in `lib/smalltalk/runtime.sx`.
|
||||
- **SX files:** use `sx-tree` MCP tools only.
|
||||
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick roadmap boxes.
|
||||
|
||||
## Architecture sketch
|
||||
|
||||
```
|
||||
Smalltalk source
|
||||
│
|
||||
▼
|
||||
lib/smalltalk/tokenizer.sx — selectors, keywords, literals, $c, #sym, #(…), $'…'
|
||||
│
|
||||
▼
|
||||
lib/smalltalk/parser.sx — AST: classes, methods, blocks, cascades, sends
|
||||
│
|
||||
▼
|
||||
lib/smalltalk/transpile.sx — AST → SX AST (entry: smalltalk-eval-ast)
|
||||
│
|
||||
▼
|
||||
lib/smalltalk/runtime.sx — class table, MOP, dispatch, primitives
|
||||
```
|
||||
|
||||
Core mapping:
|
||||
- **Class** = SX dict `{:name :superclass :ivars :methods :class-methods :metaclass}`. Class table is a flat dict keyed by class name.
|
||||
- **Object** = SX dict `{:class :ivars}` — `ivars` keyed by symbol. Tagged ints / floats / strings / symbols are not boxed; their class is looked up by SX type.
|
||||
- **Method** = SX lambda closing over a `self` binding + temps. Body wrapped in a delimited continuation so `^` can escape.
|
||||
- **Message send** = `(st-send receiver selector args)` — does class-table lookup, walks superclass chain, falls back to `doesNotUnderstand:` with a `Message` object.
|
||||
- **Block** `[:x | … ^v … ]` = lambda + captured `^k` (the method-return continuation). Invoking `^` calls `k`; outer block invocation past method return raises `BlockContext>>cannotReturn:`.
|
||||
- **Cascade** `r m1; m2; m3` = `(let ((tmp r)) (st-send tmp 'm1 ()) (st-send tmp 'm2 ()) (st-send tmp 'm3 ()))`.
|
||||
- **`ifTrue:ifFalse:` / `whileTrue:`** = ordinary block sends; the runtime intrinsifies them in the JIT path so they compile to native branches (Tier 1 of bytecode expansion already covers this pattern).
|
||||
- **`become:`** = swap two object identities everywhere — in SX this is a heap walk, but we restrict to `oneWayBecome:` (cheap: rewrite class field) by default.
|
||||
|
||||
## Roadmap
|
||||
|
||||
### Phase 1 — tokenizer + parser
|
||||
- [x] Tokenizer: identifiers, keywords (`foo:`), binary selectors (`+`, `==`, `,`, `->`, `~=` etc.), numbers (radix `16r1F`; **scaled `1.5s2` deferred**), strings `'…''…'`, characters `$c`, symbols `#foo` `#'foo bar'` `#+`, byte arrays `#[1 2 3]` (open token), literal arrays `#(1 #foo 'x')` (open token), comments `"…"`
|
||||
- [x] Parser (expression level): blocks `[:a :b | | t1 t2 | …]`, cascades, message precedence (unary > binary > keyword), assignment, return, statement sequences, literal arrays, byte arrays, paren grouping, method headers (`+ other`, `at:put:`, unary, with temps and body). Class-definition keyword messages parse as ordinary keyword sends — no special-case needed.
|
||||
- [x] Parser (chunk-stream level): `st-read-chunks` splits source on `!` (with `!!` doubling) and `st-parse-chunks` runs the Pharo file-in state machine — `methodsFor:` / `class methodsFor:` opens a method batch, an empty chunk closes it. Pragmas `<primitive: …>` (incl. multiple keyword pairs, before or after temps, multiple per method) parsed into the method AST.
|
||||
- [x] Unit tests in `lib/smalltalk/tests/parse.sx`
|
||||
|
||||
### Phase 2 — object model + sequential eval
|
||||
- [x] Class table + bootstrap (`lib/smalltalk/runtime.sx`): canonical hierarchy installed (`Object`, `Behavior`, `ClassDescription`, `Class`, `Metaclass`, `UndefinedObject`, `Boolean`/`True`/`False`, `Magnitude`/`Number`/`Integer`/`SmallInteger`/`Float`/`Character`, `Collection`/`SequenceableCollection`/`ArrayedCollection`/`Array`/`String`/`Symbol`/`OrderedCollection`/`Dictionary`, `BlockClosure`). User class definition via `st-class-define!`, methods via `st-class-add-method!` (stamps `:defining-class` for super), method lookup walks chain, ivars accumulated through superclass chain, native SX value types map to Smalltalk classes via `st-class-of`.
|
||||
- [x] `smalltalk-eval-ast` (`lib/smalltalk/eval.sx`): all literal kinds, ident resolution (locals → ivars → class refs), self/super/thisContext, assignment (locals or ivars, mutating), message send, cascade, sequence, and ^return via a sentinel marker (proper continuation-based escape is the Phase 3 showcase). Frames carry a parent chain so blocks close over outer locals. Primitive method tables for SmallInteger/Float, String/Symbol, Boolean, UndefinedObject, Array, BlockClosure (value/value:/whileTrue:/etc.), and class-side `new`/`name`/etc. Also satisfies "30+ tests" — 60 eval tests.
|
||||
- [ ] Method lookup: walk class → superclass; cache hit-class on `(class, selector)`
|
||||
- [ ] `doesNotUnderstand:` fallback constructing `Message` object
|
||||
- [ ] `super` send (lookup starts at superclass of *defining* class, not receiver class)
|
||||
- [x] 30+ tests in `lib/smalltalk/tests/eval.sx` (60 tests, covering literals through user-class method dispatch with cascades and closures)
|
||||
|
||||
### Phase 3 — blocks + non-local return (THE SHOWCASE)
|
||||
- [ ] Method invocation captures a `^k` (the return continuation) and binds it as the block's escape
|
||||
- [ ] `^expr` from inside a block invokes that captured `^k`
|
||||
- [ ] `BlockContext>>value`, `value:`, `value:value:`, …, `valueWithArguments:`
|
||||
- [ ] `whileTrue:` / `whileTrue` / `whileFalse:` / `whileFalse` as ordinary block sends — runtime intrinsifies the loop in the bytecode JIT
|
||||
- [ ] `ifTrue:` / `ifFalse:` / `ifTrue:ifFalse:` as block sends, similarly intrinsified
|
||||
- [ ] Escape past returned-from method raises `BlockContext>>cannotReturn:`
|
||||
- [ ] Classic programs in `lib/smalltalk/tests/programs/`:
|
||||
- [ ] `eight-queens.st`
|
||||
- [ ] `quicksort.st`
|
||||
- [ ] `mandelbrot.st`
|
||||
- [ ] `life.st` (Conway's Life, glider gun)
|
||||
- [ ] `fibonacci.st` (recursive + memoised)
|
||||
- [ ] `lib/smalltalk/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
|
||||
|
||||
### Phase 4 — reflection + MOP
|
||||
- [ ] `Object>>class`, `class>>name`, `class>>superclass`, `class>>methodDict`, `class>>selectors`
|
||||
- [ ] `Object>>perform:` / `perform:with:` / `perform:withArguments:`
|
||||
- [ ] `Object>>respondsTo:`, `Object>>isKindOf:`, `Object>>isMemberOf:`
|
||||
- [ ] `Behavior>>compile:` — runtime method addition
|
||||
- [ ] `Object>>becomeForward:` (one-way become; rewrites the class field of `aReceiver`)
|
||||
- [ ] Exceptions: `Exception`, `Error`, `signal`, `signal:`, `on:do:`, `ensure:`, `ifCurtailed:` — built on top of SX `handler-bind`/`raise`
|
||||
|
||||
### Phase 5 — collections + numeric tower
|
||||
- [ ] `SequenceableCollection`/`OrderedCollection`/`Array`/`String`/`Symbol`
|
||||
- [ ] `HashedCollection`/`Set`/`Dictionary`/`IdentityDictionary`
|
||||
- [ ] `Stream` hierarchy: `ReadStream`/`WriteStream`/`ReadWriteStream`
|
||||
- [ ] `Number` tower: `SmallInteger`/`LargePositiveInteger`/`Float`/`Fraction`
|
||||
- [ ] `String>>format:`, `printOn:` for everything
|
||||
|
||||
### Phase 6 — SUnit + corpus to 200+
|
||||
- [ ] Port SUnit (TestCase, TestSuite, TestResult) — written in SX-Smalltalk, runs in itself
|
||||
- [ ] Vendor a slice of Pharo `Kernel-Tests` and `Collections-Tests`
|
||||
- [ ] Drive the scoreboard up: aim for 200+ green tests
|
||||
- [ ] Stretch: ANSI Smalltalk validator subset
|
||||
|
||||
### Phase 7 — speed (optional)
|
||||
- [ ] Method-dictionary inline caching (already in CEK as a primitive; just wire selector cache)
|
||||
- [ ] Block intrinsification beyond `whileTrue:` / `ifTrue:`
|
||||
- [ ] Compare against GNU Smalltalk on the corpus
|
||||
|
||||
## Progress log
|
||||
|
||||
_Newest first. Agent appends on every commit._
|
||||
|
||||
- 2026-04-25: `smalltalk-eval-ast` + 60 eval tests (`lib/smalltalk/eval.sx`, `lib/smalltalk/tests/eval.sx`). Frame chain with mutable locals/ivars (via `dict-set!`), full literal eval, send dispatch (user methods + native primitive tables for Number/String/Boolean/Nil/Array/Block/Class), block closures, while/to:do:, cascades returning last, sentinel-based `^return`. User Point class round-trip works including `+` returning a fresh point. 245/245 total.
|
||||
- 2026-04-25: class table + bootstrap (`lib/smalltalk/runtime.sx`, `lib/smalltalk/tests/runtime.sx`). Canonical hierarchy, type→class mapping for native SX values, instance construction, ivar inheritance, method install with `:defining-class` stamp, instance- and class-side method lookup walking the superclass chain. 54 new tests, 185/185 total.
|
||||
- 2026-04-25: chunk-stream parser + pragmas + 21 chunk/pragma tests (`lib/smalltalk/tests/parse_chunks.sx`). `st-read-chunks` (with `!!` doubling), `st-parse-chunks` state machine for `methodsFor:` batches incl. class-side. Pragmas with multiple keyword pairs, signed numeric / string / symbol args, in either pragma-then-temps or temps-then-pragma order. 131/131 tests pass.
|
||||
- 2026-04-25: expression-level parser + 47 parse tests (`lib/smalltalk/parser.sx`, `lib/smalltalk/tests/parse.sx`). Full message precedence (unary > binary > keyword), cascades, blocks with params/temps, literal/byte arrays, assignment chain, method headers (unary/binary/keyword). Chunk-format `! !` driver deferred to a follow-up box. 110/110 tests pass.
|
||||
- 2026-04-25: tokenizer + 63 tests (`lib/smalltalk/tokenizer.sx`, `lib/smalltalk/tests/tokenize.sx`, `lib/smalltalk/test.sh`). All token types covered except scaled decimals `1.5s2` (deferred). `#(` and `#[` emit open tokens; literal-array contents lexed as ordinary tokens for the parser to interpret.
|
||||
|
||||
## Blockers
|
||||
|
||||
_Shared-file issues that need someone else to fix. Minimal repro only._
|
||||
|
||||
- _(none yet)_
|
||||
@@ -30,7 +30,7 @@ fi
|
||||
|
||||
if [ "$CLEAN" = "1" ]; then
|
||||
cd "$(dirname "$0")/.."
|
||||
for lang in lua prolog forth erlang haskell js hs; do
|
||||
for lang in lua prolog forth erlang haskell js hs smalltalk; do
|
||||
wt="$WORKTREE_BASE/$lang"
|
||||
if [ -d "$wt" ]; then
|
||||
git worktree remove --force "$wt" 2>/dev/null || rm -rf "$wt"
|
||||
@@ -39,5 +39,5 @@ if [ "$CLEAN" = "1" ]; then
|
||||
done
|
||||
git worktree prune
|
||||
echo "Worktree branches (loops/<lang>) are preserved. Delete manually if desired:"
|
||||
echo " git branch -D loops/lua loops/prolog loops/forth loops/erlang loops/haskell loops/js loops/hs"
|
||||
echo " git branch -D loops/lua loops/prolog loops/forth loops/erlang loops/haskell loops/js loops/hs loops/smalltalk"
|
||||
fi
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
#!/usr/bin/env bash
|
||||
# Spawn 7 claude sessions in tmux, one per language loop.
|
||||
# Spawn 8 claude sessions in tmux, one per language loop.
|
||||
# Each runs in its own git worktree rooted at /root/rose-ash-loops/<lang>,
|
||||
# on branch loops/<lang>. No two loops share a working tree, so there's
|
||||
# zero risk of file collisions between languages.
|
||||
@@ -9,7 +9,7 @@
|
||||
#
|
||||
# After the script prints done:
|
||||
# tmux a -t sx-loops
|
||||
# Ctrl-B + <window-number> to switch (0=lua ... 6=hs)
|
||||
# Ctrl-B + <window-number> to switch (0=lua ... 7=smalltalk)
|
||||
# Ctrl-B + d to detach (loops keep running, SSH-safe)
|
||||
#
|
||||
# Stop: ./scripts/sx-loops-down.sh
|
||||
@@ -38,8 +38,9 @@ declare -A BRIEFING=(
|
||||
[haskell]=haskell-loop.md
|
||||
[js]=loop.md
|
||||
[hs]=hs-loop.md
|
||||
[smalltalk]=smalltalk-loop.md
|
||||
)
|
||||
ORDER=(lua prolog forth erlang haskell js hs)
|
||||
ORDER=(lua prolog forth erlang haskell js hs smalltalk)
|
||||
|
||||
mkdir -p "$WORKTREE_BASE"
|
||||
|
||||
@@ -66,7 +67,7 @@ for lang in "${ORDER[@]:1}"; do
|
||||
tmux new-window -t "$SESSION" -n "$lang" -c "$WORKTREE_BASE/$lang"
|
||||
done
|
||||
|
||||
echo "Starting 7 claude sessions..."
|
||||
echo "Starting 8 claude sessions..."
|
||||
for lang in "${ORDER[@]}"; do
|
||||
tmux send-keys -t "$SESSION:$lang" "claude" C-m
|
||||
done
|
||||
@@ -89,10 +90,10 @@ for lang in "${ORDER[@]}"; do
|
||||
done
|
||||
|
||||
echo ""
|
||||
echo "Done. 7 loops started in tmux session '$SESSION', each in its own worktree."
|
||||
echo "Done. 8 loops started in tmux session '$SESSION', each in its own worktree."
|
||||
echo ""
|
||||
echo " Attach: tmux a -t $SESSION"
|
||||
echo " Switch: Ctrl-B <0..6> (0=lua 1=prolog 2=forth 3=erlang 4=haskell 5=js 6=hs)"
|
||||
echo " Switch: Ctrl-B <0..7> (0=lua 1=prolog 2=forth 3=erlang 4=haskell 5=js 6=hs 7=smalltalk)"
|
||||
echo " List: Ctrl-B w"
|
||||
echo " Detach: Ctrl-B d"
|
||||
echo " Stop: ./scripts/sx-loops-down.sh"
|
||||
|
||||
Reference in New Issue
Block a user