giles
041cb9f3ef
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 21s
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
1111 lines
36 KiB
Plaintext
1111 lines
36 KiB
Plaintext
;; 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))))
|
|
((and (dict? v) (= (get v "type") "builtin") (= (get v "arity") 0))
|
|
((get v "fn")))
|
|
(: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)
|
|
;; Reuse hk-bind-decls! so multi-clause fun bindings in where/let
|
|
;; are grouped into multifuns, enabling patterns like:
|
|
;; let { go 0 = [[]]; go k = [...] } in go n
|
|
(let ((new-env (hk-dict-copy env)))
|
|
(hk-bind-decls! 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 (= (hk-deep-force lv) (hk-deep-force rv))))
|
|
((= op "/=")
|
|
(hk-of-bool (not (= (hk-deep-force lv) (hk-deep-force 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))
|
|
((= op "mod") (mod lv rv))
|
|
((= op "div") (floor (/ lv rv)))
|
|
((= op "rem") (mod lv rv))
|
|
((= op "quot") (truncate (/ lv rv)))
|
|
((= op ">>=")
|
|
(if
|
|
(and (list? lv) (= (first lv) "IO"))
|
|
(hk-apply rv (nth lv 1))
|
|
(raise "(>>=): left side is not an IO action")))
|
|
((= op ">>")
|
|
(if
|
|
(and (list? lv) (= (first lv) "IO"))
|
|
rv
|
|
(raise "(>>): left side is not an IO action")))
|
|
(: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\ntail (_:xs) = xs\nfst (a, _) = a\nsnd (_, b) = b\ntake 0 _ = []\ntake _ [] = []\ntake n (x:xs) = x : take (n - 1) xs\ndrop 0 xs = xs\ndrop _ [] = []\ndrop n (_:xs) = drop (n - 1) xs\nrepeat x = x : repeat x\niterate f x = x : iterate f (f x)\nlength [] = 0\nlength (_:xs) = 1 + length xs\nmap _ [] = []\nmap f (x:xs) = f x : map f xs\nfilter _ [] = []\nfilter p (x:xs) = if p x then x : filter p xs else filter p xs\nzipWith _ [] _ = []\nzipWith _ _ [] = []\nzipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\nfibs = 0 : 1 : zipWith plus fibs (tail fibs)\nplus a b = a + b\nconcat [] = []\nconcat (xs:xss) = xs ++ concat xss\nconcatMap f [] = []\nconcatMap f (x:xs) = f x ++ concatMap f xs\nabs x = if x < 0 then 0 - x else x\nnegate x = 0 - x\nnull [] = True\nnull _ = False\nflip f x y = f y x\nconst x _ = x\ncurry f x y = f (x, y)\nuncurry f p = f (fst p) (snd p)\nfoldr f z [] = z\nfoldr f z (x:xs) = f x (foldr f z xs)\nfoldl f z [] = z\nfoldl f z (x:xs) = foldl f (f z x) xs\nfoldl1 f (x:xs) = foldl f x xs\nfoldr1 f [x] = x\nfoldr1 f (x:xs) = f x (foldr1 f xs)\nzip [] _ = []\nzip _ [] = []\nzip (x:xs) (y:ys) = (x, y) : zip xs ys\nreverse [] = []\nreverse (x:xs) = reverse xs ++ [x]\nelem _ [] = False\nelem x (y:ys) = if x == y then True else elem x ys\nnotElem x xs = not (elem x xs)\nany _ [] = False\nany f (x:xs) = if f x then True else any f xs\nall _ [] = True\nall f (x:xs) = if f x then all f xs else False\nand [] = True\nand (x:xs) = if x then and xs else False\nor [] = False\nor (x:xs) = if x then True else or xs\nsum [] = 0\nsum (x:xs) = x + sum xs\nproduct [] = 1\nproduct (x:xs) = x * product xs\nmaximum [x] = x\nmaximum (x:xs) = let m = maximum xs in if x >= m then x else m\nminimum [x] = x\nminimum (x:xs) = let m = minimum xs in if x <= m then x else m\ncompare x y = if x < y then LT else if x == y then EQ else GT\nmin x y = if x <= y then x else y\nmax x y = if x >= y then x else y\nsignum x = if x < 0 then negate 1 else if x == 0 then 0 else 1\nfromIntegral x = x\nfromInteger x = x\ntoInteger x = x\nceiling x = x\nfloor x = x\nround x = x\ntruncate x = x\nlookup _ [] = Nothing\nlookup k ((k2,v):rest) = if k == k2 then Just v else lookup k rest\nmaybe d _ Nothing = d\nmaybe _ f (Just x) = f x\neither f _ (Left x) = f x\neither _ g (Right y) = g y\nmapMaybe _ [] = []\nmapMaybe f (x:xs) = case f x of { Nothing -> mapMaybe f xs; Just y -> y : mapMaybe f xs }\nfmap = map\npure = return\nwhen b m = if b then m else return ()\nunless b m = if b then return () else m\nmapM_ _ [] = return ()\nmapM_ f (x:xs) = f x >> mapM_ f xs\nsequence_ [] = return ()\nsequence_ (m:ms) = m >> sequence_ ms\ninteract f = getContents >>= \\s -> putStr (f s)\n")
|
|
|
|
(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-join-strs
|
|
(fn
|
|
(strs sep)
|
|
(cond
|
|
((empty? strs) "")
|
|
((= (len strs) 1) (first strs))
|
|
(:else
|
|
(let
|
|
((acc (first strs)))
|
|
(for-each (fn (s) (set! acc (str acc sep s))) (rest strs))
|
|
acc)))))
|
|
|
|
(define
|
|
hk-collect-hk-list
|
|
(fn
|
|
(v)
|
|
(let
|
|
((result (list)))
|
|
(let
|
|
((loop (fn (node) (let ((fnode (hk-force node))) (cond ((and (list? fnode) (= (first fnode) "[]")) result) ((and (list? fnode) (= (first fnode) ":")) (do (append! result (nth fnode 1)) (loop (nth fnode 2)))) (:else (do (append! result fnode) result)))))))
|
|
(loop v)
|
|
result))))
|
|
|
|
(define
|
|
hk-show-val
|
|
(fn
|
|
(v)
|
|
(let
|
|
((fv (hk-force v)))
|
|
(cond
|
|
((= (type-of fv) "number") (str fv))
|
|
((= (type-of fv) "string") (str "\"" fv "\""))
|
|
((= (type-of fv) "boolean") (if fv "True" "False"))
|
|
((not (list? fv)) (str fv))
|
|
((empty? fv) "()")
|
|
((= (first fv) "[]") "[]")
|
|
((= (first fv) ":")
|
|
(let
|
|
((elems (hk-collect-hk-list fv)))
|
|
(str "[" (hk-join-strs (map hk-show-val elems) ", ") "]")))
|
|
((= (first fv) "Tuple")
|
|
(str "(" (hk-join-strs (map hk-show-val (rest fv)) ", ") ")"))
|
|
((= (first fv) "()") "()")
|
|
(:else
|
|
(let
|
|
((cname (first fv)) (args (rest fv)))
|
|
(if
|
|
(empty? args)
|
|
cname
|
|
(str
|
|
"("
|
|
cname
|
|
" "
|
|
(hk-join-strs (map hk-show-val args) " ")
|
|
")"))))))))
|
|
|
|
;; ── Source-level convenience ────────────────────────────────
|
|
(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))
|
|
(dict-set!
|
|
env
|
|
"seq"
|
|
(hk-mk-lazy-builtin "seq" (fn (a b) (do (hk-force a) b)) 2))
|
|
(dict-set!
|
|
env
|
|
"deepseq"
|
|
(hk-mk-lazy-builtin
|
|
"deepseq"
|
|
(fn (a b) (do (hk-deep-force a) b))
|
|
2))
|
|
(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))
|
|
(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 "++" "++"))
|
|
(dict-set! env "mod" (hk-make-binop-builtin "mod" "mod"))
|
|
(dict-set! env "div" (hk-make-binop-builtin "div" "div"))
|
|
(dict-set! env "rem" (hk-make-binop-builtin "rem" "rem"))
|
|
(dict-set! env "quot" (hk-make-binop-builtin "quot" "quot"))
|
|
(dict-set! env "show" (hk-mk-lazy-builtin "show" hk-show-val 1))
|
|
(hk-load-into! env hk-prelude-src)
|
|
(begin
|
|
(dict-set!
|
|
env
|
|
"putStrLn"
|
|
(hk-mk-lazy-builtin
|
|
"putStrLn"
|
|
(fn
|
|
(s)
|
|
(begin
|
|
(append! hk-io-lines (hk-force s))
|
|
(list "IO" (list "Tuple"))))
|
|
1))
|
|
(dict-set!
|
|
env
|
|
"putStr"
|
|
(hk-mk-lazy-builtin
|
|
"putStr"
|
|
(fn
|
|
(s)
|
|
(begin
|
|
(append! hk-io-lines (hk-force s))
|
|
(list "IO" (list "Tuple"))))
|
|
1))
|
|
(dict-set!
|
|
env
|
|
"print"
|
|
(hk-mk-lazy-builtin
|
|
"print"
|
|
(fn
|
|
(x)
|
|
(begin
|
|
(append! hk-io-lines (hk-show-val x))
|
|
(list "IO" (list "Tuple"))))
|
|
1))
|
|
(dict-set!
|
|
env
|
|
"getLine"
|
|
(hk-mk-lazy-builtin
|
|
"getLine"
|
|
(fn
|
|
()
|
|
(if
|
|
(empty? hk-stdin-lines)
|
|
(error "getLine: no more input")
|
|
(let
|
|
((line (first hk-stdin-lines)))
|
|
(begin
|
|
(set! hk-stdin-lines (rest hk-stdin-lines))
|
|
(list "IO" line)))))
|
|
0))
|
|
(dict-set!
|
|
env
|
|
"getContents"
|
|
(hk-mk-lazy-builtin
|
|
"getContents"
|
|
(fn
|
|
()
|
|
(let
|
|
((lines hk-stdin-lines))
|
|
(begin
|
|
(set! hk-stdin-lines (list))
|
|
(list
|
|
"IO"
|
|
(if
|
|
(empty? lines)
|
|
""
|
|
(reduce
|
|
(fn (acc s) (str acc "\n" s))
|
|
(first lines)
|
|
(rest lines)))))))
|
|
0))
|
|
(dict-set!
|
|
env
|
|
"readFile"
|
|
(hk-mk-lazy-builtin
|
|
"readFile"
|
|
(fn
|
|
(path)
|
|
(let
|
|
((p (hk-force path)))
|
|
(if
|
|
(has-key? hk-vfs p)
|
|
(list "IO" (get hk-vfs p))
|
|
(error (str "readFile: " p ": file not found")))))
|
|
1))
|
|
(dict-set!
|
|
env
|
|
"writeFile"
|
|
(hk-mk-lazy-builtin
|
|
"writeFile"
|
|
(fn
|
|
(path contents)
|
|
(begin
|
|
(dict-set! hk-vfs (hk-force path) (hk-force contents))
|
|
(list "IO" (list "Tuple"))))
|
|
2))
|
|
env))))
|
|
|
|
;; Eagerly build the Prelude env once at load time; each call to
|
|
;; hk-eval-expr-source copies it instead of re-parsing the whole Prelude.
|
|
(define
|
|
hk-bind-decls!
|
|
(fn
|
|
(env decls)
|
|
(let
|
|
((groups (dict)) (group-order (list)) (pat-binds (list)))
|
|
(for-each
|
|
(fn
|
|
(d)
|
|
(cond
|
|
((= (first d) "fun-clause")
|
|
(let
|
|
((name (nth d 1)))
|
|
(when
|
|
(not (has-key? groups name))
|
|
(append! group-order name))
|
|
(dict-set!
|
|
groups
|
|
name
|
|
(append
|
|
(if (has-key? groups name) (get groups name) (list))
|
|
(list (list (nth d 2) (nth d 3)))))
|
|
(when (not (has-key? env name)) (dict-set! env name nil))))
|
|
((or (= (first d) "bind") (= (first d) "pat-bind"))
|
|
(append! pat-binds d))
|
|
((= (first d) "class-decl")
|
|
(let
|
|
((cls (nth d 1))
|
|
(tvar (nth d 2))
|
|
(method-decls (nth d 3)))
|
|
(dict-set! env (str "__class__" cls) (list "class" cls tvar))
|
|
(for-each
|
|
(fn
|
|
(m)
|
|
(when
|
|
(= (first m) "type-sig")
|
|
(for-each
|
|
(fn
|
|
(mname)
|
|
(dict-set!
|
|
env
|
|
mname
|
|
(hk-mk-lazy-builtin
|
|
mname
|
|
(fn
|
|
(x)
|
|
(let
|
|
((tv (hk-force x)))
|
|
(let
|
|
((key (str "dict" cls "_" (hk-runtime-type tv))))
|
|
(if
|
|
(has-key? env key)
|
|
(hk-apply (get (get env key) mname) x)
|
|
(raise
|
|
(str
|
|
"No instance "
|
|
cls
|
|
" for "
|
|
(hk-runtime-type tv)))))))
|
|
1)))
|
|
(nth m 1))))
|
|
method-decls)))
|
|
((= (first d) "instance-decl")
|
|
(let
|
|
((cls (nth d 1))
|
|
(inst-type (nth d 2))
|
|
(method-decls (nth d 3)))
|
|
(let
|
|
((inst-dict (dict))
|
|
(type-str (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 (str "dict" cls "_" type-str) inst-dict)
|
|
(dict-set!
|
|
env
|
|
(str "dict" cls "_" (hk-type-to-runtime-key type-str))
|
|
inst-dict))))
|
|
((= (first d) "data")
|
|
(let
|
|
((deriving-list (if (> (len d) 4) (nth d 4) (list))))
|
|
(when
|
|
(not (empty? deriving-list))
|
|
(let
|
|
((cons-list (nth d 3)))
|
|
(for-each
|
|
(fn
|
|
(cls)
|
|
(for-each
|
|
(fn
|
|
(cdef)
|
|
(let
|
|
((con-name (nth cdef 1)))
|
|
(cond
|
|
((= cls "Show")
|
|
(let
|
|
((inst-dict (dict)))
|
|
(dict-set!
|
|
inst-dict
|
|
"show"
|
|
(hk-mk-lazy-builtin "show" hk-show-val 1))
|
|
(dict-set!
|
|
env
|
|
(str "dictShow_" con-name)
|
|
inst-dict)))
|
|
((= cls "Eq")
|
|
(let
|
|
((inst-dict (dict)))
|
|
(dict-set!
|
|
inst-dict
|
|
"=="
|
|
(hk-mk-builtin
|
|
"=="
|
|
(fn
|
|
(x y)
|
|
(hk-of-bool
|
|
(=
|
|
(hk-deep-force x)
|
|
(hk-deep-force y))))
|
|
2))
|
|
(dict-set!
|
|
inst-dict
|
|
"/="
|
|
(hk-mk-builtin
|
|
"/="
|
|
(fn
|
|
(x y)
|
|
(hk-of-bool
|
|
(not
|
|
(=
|
|
(hk-deep-force x)
|
|
(hk-deep-force y)))))
|
|
2))
|
|
(dict-set!
|
|
env
|
|
(str "dictEq_" con-name)
|
|
inst-dict))))))
|
|
cons-list))
|
|
deriving-list)))))
|
|
(:else nil)))
|
|
decls)
|
|
(let
|
|
((zero-arity (list)))
|
|
(for-each
|
|
(fn
|
|
(name)
|
|
(let
|
|
((clauses (get groups name)))
|
|
(let
|
|
((arity (len (first (first clauses)))))
|
|
(cond
|
|
((> arity 0)
|
|
(dict-set! env name (hk-mk-multifun arity clauses env)))
|
|
(:else (append! zero-arity name))))))
|
|
group-order)
|
|
(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-dict-copy hk-env0)))
|
|
(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))))))))
|
|
|
|
(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-io-lines (list))
|
|
|
|
(define
|
|
hk-run-io
|
|
(fn (src) (do (set! hk-io-lines (list)) (hk-run src) hk-io-lines)))
|
|
|
|
(define hk-stdin-lines (list))
|
|
|
|
(define hk-vfs (dict))
|
|
|
|
(define
|
|
hk-run-io-with-input
|
|
(fn
|
|
(src stdin-lines)
|
|
(begin
|
|
(set! hk-io-lines (list))
|
|
(set! hk-stdin-lines stdin-lines)
|
|
(hk-run src)
|
|
hk-io-lines)))
|
|
|
|
(define hk-env0 (hk-init-env))
|
|
|
|
(define
|
|
hk-eval-expr-source
|
|
(fn
|
|
(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-runtime-type
|
|
(fn
|
|
(val)
|
|
(let
|
|
((t (type-of val)))
|
|
(cond
|
|
((= t "number") "number")
|
|
((= t "boolean") "boolean")
|
|
((= t "string") "string")
|
|
((and (= t "list") (not (empty? val)))
|
|
(let
|
|
((tag (str (first val))))
|
|
(cond
|
|
((or (= tag "True") (= tag "False")) "Bool")
|
|
(:else tag))))
|
|
(:else t)))))
|
|
|
|
(define
|
|
hk-type-to-runtime-key
|
|
(fn
|
|
(ts)
|
|
(cond
|
|
((= ts "Int") "number")
|
|
((= ts "Float") "number")
|
|
((= ts "Bool") "Bool")
|
|
((= ts "String") "string")
|
|
((= ts "Char") "string")
|
|
(:else ts))))
|
|
|
|
(define
|
|
hk-typecheck
|
|
(fn
|
|
(prog)
|
|
(let
|
|
((results (hk-infer-prog prog (hk-type-env0))))
|
|
(let
|
|
((errors (filter (fn (r) (= (first r) "err")) results)))
|
|
(when (not (empty? errors)) (raise (nth (first errors) 1)))))))
|
|
|
|
(define
|
|
hk-run-typed
|
|
(fn
|
|
(src)
|
|
(let
|
|
((prog (hk-core src)))
|
|
(begin
|
|
(hk-typecheck prog)
|
|
(let
|
|
((env (hk-eval-program prog)))
|
|
(cond ((has-key? env "main") (get env "main")) (:else env)))))))
|