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

haskell: class/instance declarations — parse + instance dict eval (+11 tests, 503/503)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 53s
Details

Browse Source 
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-06 00:22:44 +00:00
parent 5c00b5c58b
commit 41a69ecca7
4 changed files with 305 additions and 585 deletions
Download Patch File Download Diff File Expand all files Collapse all files

116
lib/haskell/eval.sx
View File

@@ -681,73 +681,95 @@ negate x = 0 - x
(fn
(env decls)
(let
((groups (dict))
(group-order (list))
(pat-binds (list)))
;; Pass 1: collect fun-clause groups by name; track first-seen
;; order so pass 3 can evaluate 0-arity bodies in source order
;; (forward references to other 0-arity definitions still need
;; the earlier name to be bound first).
((groups (dict)) (group-order (list)) (pat-binds (list)))
(for-each
(fn (d)
(fn
(d)
(cond
((= (first d) "fun-clause")
(let
((name (nth d 1)))
(when (not (has-key? groups name))
(when
(not (has-key? groups name))
(append! group-order name))
(dict-set!
groups
name
(append
(if
(has-key? groups name)
(get groups name)
(list))
(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))))
(when (not (has-key? env name)) (dict-set! env name nil))))
((or (= (first d) "bind") (= (first d) "pat-bind"))
(append! pat-binds d))
((= (first d) "class-decl")
(dict-set!
env
(str "__class__" (nth d 1))
(list "class" (nth d 1) (nth d 2))))
((= (first d) "instance-decl")
(let
((cls (nth d 1))
(inst-type (nth d 2))
(method-decls (nth d 3)))
(let
((inst-dict (dict))
(inst-key
(str "dict" cls "_" (hk-type-ast-str inst-type))))
(for-each
(fn
(m)
(when
(= (first m) "fun-clause")
(let
((mname (nth m 1))
(pats (nth m 2))
(body (nth m 3)))
(dict-set!
inst-dict
mname
(if
(empty? pats)
(hk-eval body env)
(hk-eval (list "lambda" pats body) env))))))
method-decls)
(dict-set! env inst-key inst-dict))))
(:else nil)))
decls)
;; Pass 2: install multifuns (arity > 0) — order doesn't matter
;; because they're closures; collect 0-arity names in source
;; order for pass 3.
(let ((zero-arity (list)))
(let
((zero-arity (list)))
(for-each
(fn (name)
(let ((clauses (get groups name)))
(let ((arity (len (first (first clauses)))))
(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)))
(dict-set! env name (hk-mk-multifun arity clauses env)))
(:else (append! zero-arity name))))))
group-order)
;; Pass 3: evaluate 0-arity bodies and pat-binds in source
;; order — forward references to a later 0-arity name will
;; still see its placeholder (nil) and fail noisily, but the
;; common case of a top-down program works.
(for-each
(fn (name)
(let ((clauses (get groups name)))
(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)))
(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"))
((nil? res) (raise "top-level pattern bind failure"))
(:else (hk-extend-env-with-match! env res)))))))
pat-binds))
env)))
@@ -791,6 +813,22 @@ negate x = 0 - x
(src)
(hk-deep-force (hk-eval (hk-core-expr src) (hk-dict-copy hk-env0)))))
(define
hk-type-ast-str
(fn
(ast)
(cond
((= (first ast) "t-con") (nth ast 1))
((= (first ast) "t-var") (nth ast 1))
((= (first ast) "t-list")
(str "[" (hk-type-ast-str (nth ast 1)) "]"))
((= (first ast) "t-app")
(str
(hk-type-ast-str (nth ast 1))
" "
(hk-type-ast-str (nth ast 2))))
(:else "?"))))
(define
hk-typecheck
(fn