diff --git a/lib/haskell/conformance.sh b/lib/haskell/conformance.sh new file mode 100755 index 00000000..e05a3552 --- /dev/null +++ b/lib/haskell/conformance.sh @@ -0,0 +1,140 @@ +#!/usr/bin/env bash +# lib/haskell/conformance.sh — run the classic-program test suites. +# Writes lib/haskell/scoreboard.json and lib/haskell/scoreboard.md. +# +# Usage: +# bash lib/haskell/conformance.sh # run + write scoreboards +# bash lib/haskell/conformance.sh --check # run only, exit 1 on failure + +set -euo 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 + +PROGRAMS=(fib sieve quicksort nqueens calculator collatz palindrome maybe fizzbuzz anagram roman binary either primes zipwith matrix wordcount powers) +PASS_COUNTS=() +FAIL_COUNTS=() + +run_suite() { + local prog="$1" + local FILE="lib/haskell/tests/program-${prog}.sx" + local TMPFILE + TMPFILE=$(mktemp) + cat > "$TMPFILE" <&1 || true) + rm -f "$TMPFILE" + + local LINE + LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}') + if [ -z "$LINE" ]; then + LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \ + | sed -E 's/^\(ok 3 //; s/\)$//' || true) + fi + if [ -z "$LINE" ]; then + echo "0 1" + else + local P F + P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/' || echo "0") + F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/' || echo "1") + echo "$P $F" + fi +} + +for prog in "${PROGRAMS[@]}"; do + RESULT=$(run_suite "$prog") + P=$(echo "$RESULT" | cut -d' ' -f1) + F=$(echo "$RESULT" | cut -d' ' -f2) + PASS_COUNTS+=("$P") + FAIL_COUNTS+=("$F") + T=$((P + F)) + if [ "$F" -eq 0 ]; then + printf '✓ %-14s %d/%d\n' "${prog}.hs" "$P" "$T" + else + printf '✗ %-14s %d/%d\n' "${prog}.hs" "$P" "$T" + fi +done + +TOTAL_PASS=0 +TOTAL_FAIL=0 +PROG_PASS=0 +for i in "${!PROGRAMS[@]}"; do + TOTAL_PASS=$((TOTAL_PASS + PASS_COUNTS[i])) + TOTAL_FAIL=$((TOTAL_FAIL + FAIL_COUNTS[i])) + [ "${FAIL_COUNTS[$i]}" -eq 0 ] && PROG_PASS=$((PROG_PASS + 1)) +done +PROG_TOTAL=${#PROGRAMS[@]} + +echo "" +echo "Classic programs: ${TOTAL_PASS}/$((TOTAL_PASS + TOTAL_FAIL)) tests | ${PROG_PASS}/${PROG_TOTAL} programs passing" + +if [[ "${1:-}" == "--check" ]]; then + [ $TOTAL_FAIL -eq 0 ] + exit $? +fi + +DATE=$(date '+%Y-%m-%d') + +# scoreboard.json +{ + printf '{\n' + printf ' "date": "%s",\n' "$DATE" + printf ' "total_pass": %d,\n' "$TOTAL_PASS" + printf ' "total_fail": %d,\n' "$TOTAL_FAIL" + printf ' "programs": {\n' + last=$((${#PROGRAMS[@]} - 1)) + for i in "${!PROGRAMS[@]}"; do + prog="${PROGRAMS[$i]}" + if [ $i -lt $last ]; then + printf ' "%s": {"pass": %d, "fail": %d},\n' "$prog" "${PASS_COUNTS[$i]}" "${FAIL_COUNTS[$i]}" + else + printf ' "%s": {"pass": %d, "fail": %d}\n' "$prog" "${PASS_COUNTS[$i]}" "${FAIL_COUNTS[$i]}" + fi + done + printf ' }\n' + printf '}\n' +} > lib/haskell/scoreboard.json + +# scoreboard.md +{ + printf '# Haskell-on-SX Scoreboard\n\n' + printf 'Updated %s · Phase 6 (prelude extras + 18 programs)\n\n' "$DATE" + printf '| Program | Tests | Status |\n' + printf '|---------|-------|--------|\n' + for i in "${!PROGRAMS[@]}"; do + prog="${PROGRAMS[$i]}" + P=${PASS_COUNTS[$i]} + F=${FAIL_COUNTS[$i]} + T=$((P + F)) + [ "$F" -eq 0 ] && STATUS="✓" || STATUS="✗" + printf '| %s | %d/%d | %s |\n' "${prog}.hs" "$P" "$T" "$STATUS" + done + printf '| **Total** | **%d/%d** | **%d/%d programs** |\n' \ + "$TOTAL_PASS" "$((TOTAL_PASS + TOTAL_FAIL))" "$PROG_PASS" "$PROG_TOTAL" +} > lib/haskell/scoreboard.md + +echo "Wrote lib/haskell/scoreboard.json and lib/haskell/scoreboard.md" +[ $TOTAL_FAIL -eq 0 ] diff --git a/lib/haskell/desugar.sx b/lib/haskell/desugar.sx new file mode 100644 index 00000000..b61a9453 --- /dev/null +++ b/lib/haskell/desugar.sx @@ -0,0 +1,249 @@ +;; 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)))) diff --git a/lib/haskell/eval.sx b/lib/haskell/eval.sx new file mode 100644 index 00000000..60de291e --- /dev/null +++ b/lib/haskell/eval.sx @@ -0,0 +1,1265 @@ +;; 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))) + ((string? a) (str a 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\nid 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\ninteractApply f s = putStr (f s)\ninteract f = getContents >>= interactApply f\nnub [] = []\nnub (x:xs) = x : nub (filter notEqX xs)\n where notEqX y = y /= x\nsort [] = []\nsort (x:xs) = sort (filter ltX xs) ++ [x] ++ sort (filter geX xs)\n where ltX y = y < x\n geX y = y >= x\nsortBy _ [] = []\nsortBy cmp (x:xs) = sortBy cmp smaller ++ [x] ++ sortBy cmp bigger\n where smaller = filter ltCmp xs\n bigger = filter geCmp xs\n ltCmp y = cmp y x /= GT\n geCmp y = cmp y x == GT\nsortOnCmpFst p1 p2 = compare (fst p1) (fst p2)\nsortOn f xs = map snd (sortBy sortOnCmpFst (zip (map f xs) xs))\nsplitAt 0 xs = ([], xs)\nsplitAt _ [] = ([], [])\nsplitAt n (x:xs) = (x : a, b) where (a, b) = splitAt (n - 1) xs\nspan _ [] = ([], [])\nspan p (x:xs) = if p x then (x : a, b) else ([], x : xs) where (a, b) = span p xs\nbreak p xs = span notP xs\n where notP y = not (p y)\npartition _ [] = ([], [])\npartition p (x:xs) = if p x then (x : a, b) else (a, x : b) where (a, b) = partition p xs\nunzip [] = ([], [])\nunzip ((a, b) : rest) = (a : as, b : bs) where (as, bs) = unzip rest\ntails [] = [[]]\ntails (x:xs) = (x:xs) : tails xs\ninits [] = [[]]\ninits (x:xs) = [] : map (x:) (inits xs)\nisPrefixOf [] _ = True\nisPrefixOf _ [] = False\nisPrefixOf (x:xs) (y:ys) = if x == y then isPrefixOf xs ys else False\nisSuffixOf xs ys = isPrefixOf (reverse xs) (reverse ys)\nisInfixOf [] _ = True\nisInfixOf _ [] = False\nisInfixOf xs ys = if isPrefixOf xs ys then True else isInfixOf xs (tail ys)\nintercalate _ [] = []\nintercalate _ [x] = x\nintercalate sep (x:xs) = x ++ sep ++ intercalate sep xs\nintersperse _ [] = []\nintersperse _ [x] = [x]\nintersperse sep (x:xs) = x : sep : intersperse sep xs\nunwords [] = \"\"\nunwords [w] = w\nunwords (w:ws) = w ++ \" \" ++ unwords ws\nunlines [] = \"\"\nunlines (l:ls) = l ++ \"\\n\" ++ unlines ls\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)) + (let + ((--sx-to-hk-- (fn (lst) (if (empty? lst) (list "[]") (list ":" (first lst) (--sx-to-hk-- (rest lst)))))) + (--words-- + (fn + (s n i start acc) + (if + (>= i n) + (let + ((w (substr s start (- n start)))) + (reverse (if (= (len w) 0) acc (cons w acc)))) + (let + ((c (char-code (nth s i)))) + (if + (or (= c 32) (= c 9) (= c 10) (= c 13)) + (if + (= i start) + (--words-- s n (+ i 1) (+ i 1) acc) + (--words-- + s + n + (+ i 1) + (+ i 1) + (cons (substr s start (- i start)) acc))) + (--words-- s n (+ i 1) start acc)))))) + (--lines-- + (fn + (s n i start acc) + (if + (>= i n) + (if + (= start n) + (reverse acc) + (reverse (cons (substr s start (- n start)) acc))) + (let + ((c (char-code (nth s i)))) + (if + (= c 10) + (--lines-- + s + n + (+ i 1) + (+ i 1) + (cons (substr s start (- i start)) acc)) + (--lines-- s n (+ i 1) start acc))))))) + (dict-set! + env + "ord" + (hk-mk-builtin "ord" (fn (c) (char-code (hk-force c))) 1)) + (dict-set! + env + "isAlpha" + (hk-mk-builtin + "isAlpha" + (fn + (c) + (let + ((code (char-code (hk-force c)))) + (hk-of-bool + (or + (and (>= code 65) (<= code 90)) + (and (>= code 97) (<= code 122)))))) + 1)) + (dict-set! + env + "isAlphaNum" + (hk-mk-builtin + "isAlphaNum" + (fn + (c) + (let + ((code (char-code (hk-force c)))) + (hk-of-bool + (or + (and (>= code 65) (<= code 90)) + (and (>= code 97) (<= code 122)) + (and (>= code 48) (<= code 57)))))) + 1)) + (dict-set! + env + "isDigit" + (hk-mk-builtin + "isDigit" + (fn + (c) + (let + ((code (char-code (hk-force c)))) + (hk-of-bool (and (>= code 48) (<= code 57))))) + 1)) + (dict-set! + env + "isSpace" + (hk-mk-builtin + "isSpace" + (fn + (c) + (let + ((code (char-code (hk-force c)))) + (hk-of-bool + (or (= code 32) (= code 9) (= code 10) (= code 13))))) + 1)) + (dict-set! + env + "isUpper" + (hk-mk-builtin + "isUpper" + (fn + (c) + (let + ((code (char-code (hk-force c)))) + (hk-of-bool (and (>= code 65) (<= code 90))))) + 1)) + (dict-set! + env + "isLower" + (hk-mk-builtin + "isLower" + (fn + (c) + (let + ((code (char-code (hk-force c)))) + (hk-of-bool (and (>= code 97) (<= code 122))))) + 1)) + (dict-set! + env + "digitToInt" + (hk-mk-builtin + "digitToInt" + (fn (c) (- (char-code (hk-force c)) 48)) + 1)) + (dict-set! + env + "words" + (hk-mk-builtin + "words" + (fn + (s) + (let + ((str (hk-force s))) + (--sx-to-hk-- (--words-- str (len str) 0 0 (list))))) + 1)) + (dict-set! + env + "lines" + (hk-mk-builtin + "lines" + (fn + (s) + (let + ((str (hk-force s))) + (if + (= (len str) 0) + (list "[]") + (--sx-to-hk-- (--lines-- str (len str) 0 0 (list)))))) + 1)) + 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))))))) diff --git a/lib/haskell/infer.sx b/lib/haskell/infer.sx new file mode 100644 index 00000000..4f290f28 --- /dev/null +++ b/lib/haskell/infer.sx @@ -0,0 +1,658 @@ +;; infer.sx — Hindley-Milner Algorithm W for Haskell-on-SX (Phase 4). +;; +;; Types: TVar, TCon, TArr, TApp, TTuple, TScheme +;; Substitution: apply, compose, restrict +;; Unification (with occurs check) +;; Instantiation + generalization (let-polymorphism) +;; Algorithm W for: literals, var, con, lambda, app, let, if, op, tuple, list + +;; ─── Type constructors ──────────────────────────────────────────────────────── + +(define hk-tvar (fn (n) (list "TVar" n))) +(define hk-tcon (fn (s) (list "TCon" s))) +(define hk-tarr (fn (a b) (list "TArr" a b))) +(define hk-tapp (fn (a b) (list "TApp" a b))) +(define hk-ttuple (fn (ts) (list "TTuple" ts))) +(define hk-tscheme (fn (vs t) (list "TScheme" vs t))) + +(define hk-tvar? (fn (t) (and (list? t) (not (empty? t)) (= (first t) "TVar")))) +(define hk-tcon? (fn (t) (and (list? t) (not (empty? t)) (= (first t) "TCon")))) +(define hk-tarr? (fn (t) (and (list? t) (not (empty? t)) (= (first t) "TArr")))) +(define hk-tapp? (fn (t) (and (list? t) (not (empty? t)) (= (first t) "TApp")))) +(define hk-ttuple? (fn (t) (and (list? t) (not (empty? t)) (= (first t) "TTuple")))) +(define hk-tscheme? (fn (t) (and (list? t) (not (empty? t)) (= (first t) "TScheme")))) + +(define hk-tvar-name (fn (t) (nth t 1))) +(define hk-tcon-name (fn (t) (nth t 1))) +(define hk-tarr-t1 (fn (t) (nth t 1))) +(define hk-tarr-t2 (fn (t) (nth t 2))) +(define hk-tapp-t1 (fn (t) (nth t 1))) +(define hk-tapp-t2 (fn (t) (nth t 2))) +(define hk-ttuple-ts (fn (t) (nth t 1))) +(define hk-tscheme-vs (fn (t) (nth t 1))) +(define hk-tscheme-type (fn (t) (nth t 2))) + +(define hk-t-int (hk-tcon "Int")) +(define hk-t-bool (hk-tcon "Bool")) +(define hk-t-string (hk-tcon "String")) +(define hk-t-char (hk-tcon "Char")) +(define hk-t-float (hk-tcon "Float")) +(define hk-t-list (fn (t) (hk-tapp (hk-tcon "[]") t))) + +;; ─── Type formatter ────────────────────────────────────────────────────────── + +(define + hk-type->str + (fn + (t) + (cond + ((hk-tvar? t) (hk-tvar-name t)) + ((hk-tcon? t) (hk-tcon-name t)) + ((hk-tarr? t) + (let ((s1 (if (hk-tarr? (hk-tarr-t1 t)) + (str "(" (hk-type->str (hk-tarr-t1 t)) ")") + (hk-type->str (hk-tarr-t1 t))))) + (str s1 " -> " (hk-type->str (hk-tarr-t2 t))))) + ((hk-tapp? t) + (let ((h (hk-tapp-t1 t))) + (cond + ((and (hk-tcon? h) (= (hk-tcon-name h) "[]")) + (str "[" (hk-type->str (hk-tapp-t2 t)) "]")) + (:else + (str "(" (hk-type->str h) " " (hk-type->str (hk-tapp-t2 t)) ")"))))) + ((hk-ttuple? t) + (str "(" (join ", " (map hk-type->str (hk-ttuple-ts t))) ")")) + ((hk-tscheme? t) + (str "forall " (join " " (hk-tscheme-vs t)) ". " (hk-type->str (hk-tscheme-type t)))) + (:else "")))) + +;; ─── Fresh variable counter ─────────────────────────────────────────────────── + +(define hk-fresh-ctr 0) +(define hk-fresh (fn () (set! hk-fresh-ctr (+ hk-fresh-ctr 1)) (hk-tvar (str "t" hk-fresh-ctr)))) +(define hk-reset-fresh (fn () (set! hk-fresh-ctr 0))) + +;; ─── Utilities ─────────────────────────────────────────────────────────────── + +(define hk-infer-member? (fn (x lst) (some (fn (y) (= x y)) lst))) + +(define + hk-nub + (fn (lst) + (reduce (fn (acc x) (if (hk-infer-member? x acc) acc (append acc (list x)))) (list) lst))) + +;; ─── Free type variables ────────────────────────────────────────────────────── + +(define + hk-ftv + (fn + (t) + (cond + ((hk-tvar? t) (list (hk-tvar-name t))) + ((hk-tcon? t) (list)) + ((hk-tarr? t) (append (hk-ftv (hk-tarr-t1 t)) (hk-ftv (hk-tarr-t2 t)))) + ((hk-tapp? t) (append (hk-ftv (hk-tapp-t1 t)) (hk-ftv (hk-tapp-t2 t)))) + ((hk-ttuple? t) (reduce append (list) (map hk-ftv (hk-ttuple-ts t)))) + ((hk-tscheme? t) + (filter + (fn (v) (not (hk-infer-member? v (hk-tscheme-vs t)))) + (hk-ftv (hk-tscheme-type t)))) + (:else (list))))) + +(define + hk-ftv-env + (fn (env) + (reduce (fn (acc k) (append acc (hk-ftv (get env k)))) (list) (keys env)))) + +;; ─── Substitution ───────────────────────────────────────────────────────────── + +(define hk-subst-empty (dict)) + +(define + hk-subst-restrict + (fn + (s exclude) + (let ((r (dict))) + (for-each + (fn (k) + (when (not (hk-infer-member? k exclude)) + (dict-set! r k (get s k)))) + (keys s)) + r))) + +(define + hk-subst-apply + (fn + (s t) + (cond + ((hk-tvar? t) + (let ((v (get s (hk-tvar-name t)))) + (if (nil? v) t (hk-subst-apply s v)))) + ((hk-tarr? t) + (hk-tarr (hk-subst-apply s (hk-tarr-t1 t)) + (hk-subst-apply s (hk-tarr-t2 t)))) + ((hk-tapp? t) + (hk-tapp (hk-subst-apply s (hk-tapp-t1 t)) + (hk-subst-apply s (hk-tapp-t2 t)))) + ((hk-ttuple? t) + (hk-ttuple (map (fn (u) (hk-subst-apply s u)) (hk-ttuple-ts t)))) + ((hk-tscheme? t) + (let ((s2 (hk-subst-restrict s (hk-tscheme-vs t)))) + (hk-tscheme (hk-tscheme-vs t) + (hk-subst-apply s2 (hk-tscheme-type t))))) + (:else t)))) + +(define + hk-subst-compose + (fn + (s2 s1) + (let ((r (hk-dict-copy s2))) + (for-each + (fn (k) + (when (nil? (get r k)) + (dict-set! r k (hk-subst-apply s2 (get s1 k))))) + (keys s1)) + r))) + +(define + hk-env-apply-subst + (fn + (s env) + (let ((r (dict))) + (for-each (fn (k) (dict-set! r k (hk-subst-apply s (get env k)))) (keys env)) + r))) + +;; ─── Unification ───────────────────────────────────────────────────────────── + +(define + hk-bind-var + (fn + (v t) + (cond + ((and (hk-tvar? t) (= (hk-tvar-name t) v)) + hk-subst-empty) + ((hk-infer-member? v (hk-ftv t)) + (raise (str "Occurs check failed: " v " in " (hk-type->str t)))) + (:else + (let ((s (dict))) + (dict-set! s v t) + s))))) + +(define + hk-zip-unify + (fn + (ts1 ts2 acc) + (if (or (empty? ts1) (empty? ts2)) + acc + (let ((s (hk-unify (hk-subst-apply acc (first ts1)) + (hk-subst-apply acc (first ts2))))) + (hk-zip-unify (rest ts1) (rest ts2) (hk-subst-compose s acc)))))) + +(define + hk-unify + (fn + (t1 t2) + (cond + ((and (hk-tvar? t1) (hk-tvar? t2) (= (hk-tvar-name t1) (hk-tvar-name t2))) + hk-subst-empty) + ((hk-tvar? t1) (hk-bind-var (hk-tvar-name t1) t2)) + ((hk-tvar? t2) (hk-bind-var (hk-tvar-name t2) t1)) + ((and (hk-tcon? t1) (hk-tcon? t2) (= (hk-tcon-name t1) (hk-tcon-name t2))) + hk-subst-empty) + ((and (hk-tarr? t1) (hk-tarr? t2)) + (let ((s1 (hk-unify (hk-tarr-t1 t1) (hk-tarr-t1 t2)))) + (let ((s2 (hk-unify (hk-subst-apply s1 (hk-tarr-t2 t1)) + (hk-subst-apply s1 (hk-tarr-t2 t2))))) + (hk-subst-compose s2 s1)))) + ((and (hk-tapp? t1) (hk-tapp? t2)) + (let ((s1 (hk-unify (hk-tapp-t1 t1) (hk-tapp-t1 t2)))) + (let ((s2 (hk-unify (hk-subst-apply s1 (hk-tapp-t2 t1)) + (hk-subst-apply s1 (hk-tapp-t2 t2))))) + (hk-subst-compose s2 s1)))) + ((and (hk-ttuple? t1) (hk-ttuple? t2) + (= (length (hk-ttuple-ts t1)) (length (hk-ttuple-ts t2)))) + (hk-zip-unify (hk-ttuple-ts t1) (hk-ttuple-ts t2) hk-subst-empty)) + (:else + (raise (str "Cannot unify " (hk-type->str t1) " with " (hk-type->str t2))))))) + +;; ─── Instantiation and generalization ──────────────────────────────────────── + +(define + hk-instantiate + (fn + (t) + (if (not (hk-tscheme? t)) + t + (let ((s (dict))) + (for-each (fn (v) (dict-set! s v (hk-fresh))) (hk-tscheme-vs t)) + (hk-subst-apply s (hk-tscheme-type t)))))) + +(define + hk-generalize + (fn + (env t) + (let ((free-t (hk-nub (hk-ftv t))) + (free-env (hk-nub (hk-ftv-env env)))) + (let ((bound (filter (fn (v) (not (hk-infer-member? v free-env))) free-t))) + (if (empty? bound) + t + (hk-tscheme bound t)))))) + +;; ─── Pattern binding extraction ────────────────────────────────────────────── +;; Returns a dict of name → type bindings introduced by matching pat against tv. + +(define + hk-w-pat + (fn + (pat tv) + (let ((tag (first pat))) + (cond + ((= tag "p-var") (let ((d (dict))) (dict-set! d (nth pat 1) tv) d)) + ((= tag "p-wild") (dict)) + (:else (dict)))))) + +;; ─── Algorithm W ───────────────────────────────────────────────────────────── +;; hk-w : env × expr → (list subst type) + +(define + hk-w-let + (fn + (env binds body) + ;; Infer types for each binding in order, generalising at each step. + (let + ((env2 + (reduce + (fn + (cur-env b) + (let ((tag (first b))) + (cond + ;; Simple pattern binding: let x = expr + ((or (= tag "bind") (= tag "pat-bind")) + (let ((pat (nth b 1)) + (rhs (nth b 2))) + (let ((tv (hk-fresh))) + (let ((r (hk-w cur-env rhs))) + (let ((s1 (first r)) (t1 (nth r 1))) + (let ((s2 (hk-unify (hk-subst-apply s1 tv) t1))) + (let ((s (hk-subst-compose s2 s1))) + (let ((t-gen (hk-generalize (hk-env-apply-subst s cur-env) + (hk-subst-apply s t1)))) + (let ((bindings (hk-w-pat pat t-gen))) + (let ((r2 (hk-dict-copy cur-env))) + (for-each + (fn (k) (dict-set! r2 k (get bindings k))) + (keys bindings)) + r2)))))))))) + ;; Function clause: let f x y = expr + ((= tag "fun-clause") + (let ((name (nth b 1)) + (pats (nth b 2)) + (body2 (nth b 3))) + ;; Treat as: let name = lambda pats body2 + (let ((rhs (if (empty? pats) + body2 + (list "lambda" pats body2)))) + (let ((tv (hk-fresh))) + (let ((env-rec (hk-dict-copy cur-env))) + (dict-set! env-rec name tv) + (let ((r (hk-w env-rec rhs))) + (let ((s1 (first r)) (t1 (nth r 1))) + (let ((s2 (hk-unify (hk-subst-apply s1 tv) t1))) + (let ((s (hk-subst-compose s2 s1))) + (let ((t-gen (hk-generalize + (hk-env-apply-subst s cur-env) + (hk-subst-apply s t1)))) + (let ((r2 (hk-dict-copy cur-env))) + (dict-set! r2 name t-gen) + r2))))))))))) + (:else cur-env)))) + env + binds))) + (hk-w env2 body)))) + +(define + hk-w + (fn + (env expr) + (let ((tag (first expr))) + (cond + ;; Literals + ((= tag "int") (list hk-subst-empty hk-t-int)) + ((= tag "float") (list hk-subst-empty hk-t-float)) + ((= tag "string") (list hk-subst-empty hk-t-string)) + ((= tag "char") (list hk-subst-empty hk-t-char)) + + ;; Variable + ((= tag "var") + (let ((name (nth expr 1))) + (let ((scheme (get env name))) + (if (nil? scheme) + (raise (str "Unbound variable: " name)) + (list hk-subst-empty (hk-instantiate scheme)))))) + + ;; Constructor (same lookup as var) + ((= tag "con") + (let ((name (nth expr 1))) + (let ((scheme (get env name))) + (if (nil? scheme) + (list hk-subst-empty (hk-fresh)) + (list hk-subst-empty (hk-instantiate scheme)))))) + + ;; Unary negation + ((= tag "neg") + (let ((r (hk-w env (nth expr 1)))) + (let ((s1 (first r)) (t1 (nth r 1))) + (let ((s2 (hk-unify t1 hk-t-int))) + (list (hk-subst-compose s2 s1) hk-t-int))))) + + ;; Lambda: ("lambda" pats body) + ((= tag "lambda") + (let ((pats (nth expr 1)) + (body (nth expr 2))) + (if (empty? pats) + (hk-w env body) + (let ((pat (first pats)) + (rest (rest pats))) + (let ((tv (hk-fresh))) + (let ((bindings (hk-w-pat pat tv))) + (let ((env2 (hk-dict-copy env))) + (for-each (fn (k) (dict-set! env2 k (get bindings k))) (keys bindings)) + (let ((inner (if (empty? rest) + body + (list "lambda" rest body)))) + (let ((r (hk-w env2 inner))) + (let ((s1 (first r)) (t1 (nth r 1))) + (list s1 (hk-tarr (hk-subst-apply s1 tv) t1)))))))))))) + + ;; Application: ("app" f x) + ((= tag "app") + (let ((tv (hk-fresh))) + (let ((r1 (hk-w env (nth expr 1)))) + (let ((s1 (first r1)) (tf (nth r1 1))) + (let ((r2 (hk-w (hk-env-apply-subst s1 env) (nth expr 2)))) + (let ((s2 (first r2)) (tx (nth r2 1))) + (let ((s3 (hk-unify (hk-subst-apply s2 tf) (hk-tarr tx tv)))) + (let ((s (hk-subst-compose s3 (hk-subst-compose s2 s1)))) + (list s (hk-subst-apply s3 tv)))))))))) + + ;; Let: ("let" binds body) + ((= tag "let") + (hk-w-let env (nth expr 1) (nth expr 2))) + + ;; If: ("if" cond then else) + ((= tag "if") + (let ((r1 (hk-w env (nth expr 1)))) + (let ((s1 (first r1)) (tc (nth r1 1))) + (let ((s2 (hk-unify tc hk-t-bool))) + (let ((s12 (hk-subst-compose s2 s1))) + (let ((r2 (hk-w (hk-env-apply-subst s12 env) (nth expr 2)))) + (let ((s3 (first r2)) (tt (nth r2 1))) + (let ((s123 (hk-subst-compose s3 s12))) + (let ((r3 (hk-w (hk-env-apply-subst s123 env) (nth expr 3)))) + (let ((s4 (first r3)) (te (nth r3 1))) + (let ((s5 (hk-unify (hk-subst-apply s4 tt) te))) + (let ((s (hk-subst-compose s5 (hk-subst-compose s4 s123)))) + (list s (hk-subst-apply s5 te)))))))))))))) + + ;; Binary operator: ("op" op-name left right) + ;; Desugar to double application. + ((= tag "op") + (hk-w env + (list "app" + (list "app" (list "var" (nth expr 1)) (nth expr 2)) + (nth expr 3)))) + + ;; Tuple: ("tuple" [e1 e2 ...]) + ((= tag "tuple") + (let ((elems (nth expr 1))) + (let ((s-acc hk-subst-empty) + (ts (list))) + (for-each + (fn (e) + (let ((r (hk-w (hk-env-apply-subst s-acc env) e))) + (set! s-acc (hk-subst-compose (first r) s-acc)) + (set! ts (append ts (list (nth r 1)))))) + elems) + (list s-acc (hk-ttuple (map (fn (t) (hk-subst-apply s-acc t)) ts)))))) + + ;; List literal: ("list" [e1 e2 ...]) + ((= tag "list") + (let ((elems (nth expr 1))) + (if (empty? elems) + (list hk-subst-empty (hk-t-list (hk-fresh))) + (let ((tv (hk-fresh))) + (let ((s-acc hk-subst-empty)) + (for-each + (fn (e) + (let ((r (hk-w (hk-env-apply-subst s-acc env) e))) + (let ((s2 (first r)) (te (nth r 1))) + (let ((s3 (hk-unify (hk-subst-apply s2 tv) te))) + (set! s-acc (hk-subst-compose s3 (hk-subst-compose s2 s-acc))))))) + elems) + (list s-acc (hk-t-list (hk-subst-apply s-acc tv)))))))) + + ;; Location annotation: just delegate — position is for outer context. + ((= tag "loc") + (hk-w env (nth expr 3))) + + (:else + (raise (str "hk-w: unhandled tag: " tag))))))) + +;; ─── Initial type environment ───────────────────────────────────────────────── +;; Monomorphic numeric ops (no Num typeclass yet — upgraded in Phase 5). + +(define + hk-type-env0 + (fn () + (let ((env (dict))) + ;; Integer arithmetic + (for-each + (fn (op) + (dict-set! env op (hk-tarr hk-t-int (hk-tarr hk-t-int hk-t-int)))) + (list "+" "-" "*" "div" "mod" "quot" "rem")) + ;; Integer comparison → Bool + (for-each + (fn (op) + (dict-set! env op (hk-tarr hk-t-int (hk-tarr hk-t-int hk-t-bool)))) + (list "==" "/=" "<" "<=" ">" ">=")) + ;; Boolean operators + (dict-set! env "&&" (hk-tarr hk-t-bool (hk-tarr hk-t-bool hk-t-bool))) + (dict-set! env "||" (hk-tarr hk-t-bool (hk-tarr hk-t-bool hk-t-bool))) + (dict-set! env "not" (hk-tarr hk-t-bool hk-t-bool)) + ;; Constructors + (dict-set! env "True" hk-t-bool) + (dict-set! env "False" hk-t-bool) + ;; Polymorphic list ops (using TScheme) + (let ((a (hk-tvar "a"))) + (dict-set! env "head" (hk-tscheme (list "a") (hk-tarr (hk-t-list a) a))) + (dict-set! env "tail" (hk-tscheme (list "a") (hk-tarr (hk-t-list a) (hk-t-list a)))) + (dict-set! env "null" (hk-tscheme (list "a") (hk-tarr (hk-t-list a) hk-t-bool))) + (dict-set! env "length" (hk-tscheme (list "a") (hk-tarr (hk-t-list a) hk-t-int))) + (dict-set! env "reverse" (hk-tscheme (list "a") (hk-tarr (hk-t-list a) (hk-t-list a)))) + (dict-set! env ":" + (hk-tscheme (list "a") (hk-tarr a (hk-tarr (hk-t-list a) (hk-t-list a)))))) + ;; negate + (dict-set! env "negate" (hk-tarr hk-t-int hk-t-int)) + (dict-set! env "abs" (hk-tarr hk-t-int hk-t-int)) + env))) + +;; ─── Expression brief printer ──────────────────────────────────────────────── +;; Produces a short human-readable label for an AST node used in error messages. + +(define + hk-expr->brief + (fn + (expr) + (cond + ((not (list? expr)) (str expr)) + ((empty? expr) "()") + (:else + (let ((tag (first expr))) + (cond + ((= tag "var") (nth expr 1)) + ((= tag "con") (nth expr 1)) + ((= tag "int") (str (nth expr 1))) + ((= tag "float") (str (nth expr 1))) + ((= tag "string") (str "\"" (nth expr 1) "\"")) + ((= tag "char") (str "'" (nth expr 1) "'")) + ((= tag "neg") (str "(-" (hk-expr->brief (nth expr 1)) ")")) + ((= tag "app") + (str "(" (hk-expr->brief (nth expr 1)) + " " (hk-expr->brief (nth expr 2)) ")")) + ((= tag "op") + (str "(" (hk-expr->brief (nth expr 2)) + " " (nth expr 1) + " " (hk-expr->brief (nth expr 3)) ")")) + ((= tag "lambda") "(\\ ...)") + ((= tag "let") "(let ...)") + ((= tag "if") "(if ...)") + ((= tag "tuple") "(tuple ...)") + ((= tag "list") "[...]") + ((= tag "loc") (hk-expr->brief (nth expr 3))) + (:else (str "(" tag " ...")))))))) + +;; ─── Loc-annotated inference ────────────────────────────────────────────────── +;; ("loc" LINE COL INNER) node: hk-w catches any error and re-raises with +;; "at LINE:COL: " prepended. Emitted by the parser or test scaffolding. + +;; Extended hk-w handles "loc" — handled inline in the cond below. + +;; ─── Program-level inference ───────────────────────────────────────────────── +;; hk-infer-decl : env × decl → ("ok" name type-str) | ("err" msg) | nil +;; Uses tagged results so callers don't need re-raise. + +(define + hk-infer-decl + (fn + (env decl) + (let + ((tag (first decl))) + (cond + ((= tag "fun-clause") + (let + ((name (nth decl 1)) (pats (nth decl 2)) (body (nth decl 3))) + (let + ((rhs (if (empty? pats) body (list "lambda" pats body)))) + (guard + (e (#t (list "err" (str "in '" name "': " e)))) + (begin + (hk-reset-fresh) + (let + ((r (hk-w env rhs))) + (let + ((final-type (hk-subst-apply (first r) (nth r 1)))) + (list "ok" name (hk-type->str final-type) final-type)))))))) + ((or (= tag "bind") (= tag "pat-bind")) + (let + ((pat (nth decl 1)) (body (nth decl 2))) + (let + ((label (if (and (list? pat) (= (first pat) "p-var")) (nth pat 1) ""))) + (guard + (e (#t (list "err" (str "in '" label "': " e)))) + (begin + (hk-reset-fresh) + (let + ((r (hk-w env body))) + (let + ((final-type (hk-subst-apply (first r) (nth r 1)))) + (list "ok" label (hk-type->str final-type) final-type)))))))) + (:else nil))))) + +;; hk-infer-prog : program-ast × env → list of ("ok" name type) | ("err" msg) + +(define + hk-ast-type + (fn + (ast) + (let + ((tag (first ast))) + (cond + ((= tag "t-con") (list "TCon" (nth ast 1))) + ((= tag "t-var") (list "TVar" (nth ast 1))) + ((= tag "t-fun") + (list "TArr" (hk-ast-type (nth ast 1)) (hk-ast-type (nth ast 2)))) + ((= tag "t-app") + (list "TApp" (hk-ast-type (nth ast 1)) (hk-ast-type (nth ast 2)))) + ((= tag "t-list") + (list "TApp" (list "TCon" "[]") (hk-ast-type (nth ast 1)))) + ((= tag "t-tuple") (list "TTuple" (map hk-ast-type (nth ast 1)))) + (:else (raise (str "unknown type node: " (first ast)))))))) + +;; ─── Convenience ───────────────────────────────────────────────────────────── +;; hk-infer-type : Haskell expression source → inferred type string + +(define + hk-collect-tvars + (fn + (t acc) + (cond + ((= (first t) "TVar") + (if + (some (fn (v) (= v (nth t 1))) acc) + acc + (begin (append! acc (nth t 1)) acc))) + ((= (first t) "TArr") + (hk-collect-tvars (nth t 2) (hk-collect-tvars (nth t 1) acc))) + ((= (first t) "TApp") + (hk-collect-tvars (nth t 2) (hk-collect-tvars (nth t 1) acc))) + ((= (first t) "TTuple") + (reduce (fn (a elem) (hk-collect-tvars elem a)) acc (nth t 1))) + (:else acc)))) + +(define + hk-check-sig + (fn + (declared-ast inferred-type) + (let + ((declared (hk-ast-type declared-ast))) + (let + ((tvars (hk-collect-tvars declared (list)))) + (let + ((scheme (if (empty? tvars) declared (list "TScheme" tvars declared)))) + (let + ((inst (hk-instantiate scheme))) + (hk-unify inst inferred-type))))))) + +(define + hk-infer-prog + (fn + (prog env) + (let + ((decls (cond ((and (list? prog) (= (first prog) "program")) (nth prog 1)) ((and (list? prog) (= (first prog) "module")) (nth prog 3)) (:else (list)))) + (results (list)) + (sigs (dict))) + (for-each + (fn + (d) + (when + (= (first d) "type-sig") + (let + ((names (nth d 1)) (type-ast (nth d 2))) + (for-each (fn (n) (dict-set! sigs n type-ast)) names)))) + decls) + (for-each + (fn + (d) + (let + ((r (hk-infer-decl env d))) + (when + (not (nil? r)) + (let + ((checked (if (and (= (first r) "ok") (has-key? sigs (nth r 1))) (guard (e (true (list "err" (str "in '" (nth r 1) "': declared type mismatch: " e)))) (begin (hk-check-sig (get sigs (nth r 1)) (nth r 3)) r)) r))) + (append! results checked) + (when + (= (first checked) "ok") + (dict-set! env (nth checked 1) (nth checked 3))))))) + decls) + results))) + +(define + hk-infer-type + (fn + (src) + (hk-reset-fresh) + (let + ((ast (hk-core-expr src)) (env (hk-type-env0))) + (let + ((r (hk-w env ast))) + (hk-type->str (hk-subst-apply (first r) (nth r 1))))))) diff --git a/lib/haskell/layout.sx b/lib/haskell/layout.sx new file mode 100644 index 00000000..71986828 --- /dev/null +++ b/lib/haskell/layout.sx @@ -0,0 +1,329 @@ +;; 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 = "") 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 "" + :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)))) diff --git a/lib/haskell/match.sx b/lib/haskell/match.sx new file mode 100644 index 00000000..007d1358 --- /dev/null +++ b/lib/haskell/match.sx @@ -0,0 +1,201 @@ +;; 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)))) diff --git a/lib/haskell/parser.sx b/lib/haskell/parser.sx new file mode 100644 index 00000000..fcaefbd8 --- /dev/null +++ b/lib/haskell/parser.sx @@ -0,0 +1,1658 @@ +;; Haskell 98 expression parser. +;; +;; Input: the post-layout token list from (hk-layout (hk-tokenize src)). +;; Output: an AST. Nodes are plain lists tagged by a keyword head +;; (keywords evaluate to their string name, so `(list :var "x")` is +;; indistinguishable from `(list "var" "x")` at runtime — this lets +;; tests literally write `(list :var "x")` on both sides). +;; +;; Scope (this iteration — expressions only): +;; atoms int/float/string/char/var/con, parens, tuple, list, range +;; application left-associative, f x y z +;; prefix - unary negation on an lexp +;; infix ops precedence-climbing, full Haskell 98 default table +;; lambda \x y -> body +;; if if c then t else e +;; let let { x = e ; y = e } in body (uses layout braces) +;; +;; AST shapes: +;; (:int N) +;; (:float F) +;; (:string S) +;; (:char C) +;; (:var NAME) +;; (:con NAME) +;; (:app FN ARG) — binary, chain for multi-arg +;; (:op OP LHS RHS) — binary infix +;; (:neg E) +;; (:tuple ITEMS) — ITEMS is a list of AST nodes +;; (:list ITEMS) — enumerated list +;; (:range FROM TO) — [from..to] +;; (:range-step FROM NEXT TO) — [from,next..to] +;; (:if C T E) +;; (:lambda PARAMS BODY) — PARAMS is list of varids +;; (:let BINDS BODY) — BINDS is list of (:bind NAME EXPR) + +;; ── Operator precedence table (Haskell 98 defaults) ────────────── +(define + hk-op-prec-table + (let + ((t (dict))) + (dict-set! t "!!" {:prec 9 :assoc "left"}) + (dict-set! t "." {:prec 9 :assoc "right"}) + (dict-set! t "^" {:prec 8 :assoc "right"}) + (dict-set! t "^^" {:prec 8 :assoc "right"}) + (dict-set! t "**" {:prec 8 :assoc "right"}) + (dict-set! t "*" {:prec 7 :assoc "left"}) + (dict-set! t "/" {:prec 7 :assoc "left"}) + (dict-set! t "+" {:prec 6 :assoc "left"}) + (dict-set! t "-" {:prec 6 :assoc "left"}) + (dict-set! t ":" {:prec 5 :assoc "right"}) + (dict-set! t "++" {:prec 5 :assoc "right"}) + (dict-set! t "==" {:prec 4 :assoc "non"}) + (dict-set! t "/=" {:prec 4 :assoc "non"}) + (dict-set! t "<" {:prec 4 :assoc "non"}) + (dict-set! t "<=" {:prec 4 :assoc "non"}) + (dict-set! t ">" {:prec 4 :assoc "non"}) + (dict-set! t ">=" {:prec 4 :assoc "non"}) + (dict-set! t "&&" {:prec 3 :assoc "right"}) + (dict-set! t "||" {:prec 2 :assoc "right"}) + (dict-set! t ">>" {:prec 1 :assoc "left"}) + (dict-set! t ">>=" {:prec 1 :assoc "left"}) + (dict-set! t "=<<" {:prec 1 :assoc "right"}) + (dict-set! t "$" {:prec 0 :assoc "right"}) + (dict-set! t "$!" {:prec 0 :assoc "right"}) + t)) + +(define + hk-op-info + (fn + (op) + (if + (has-key? hk-op-prec-table op) + (get hk-op-prec-table op) + {:prec 9 :assoc "left"}))) + +;; ── Atom-start predicate ───────────────────────────────────────── +(define + hk-atom-start? + (fn + (tok) + (if + (nil? tok) + false + (let + ((ty (get tok "type"))) + (or + (= ty "integer") + (= ty "float") + (= ty "string") + (= ty "char") + (= ty "varid") + (= ty "conid") + (= ty "qvarid") + (= ty "qconid") + (= ty "lparen") + (= ty "lbracket")))))) + +;; apat-start? — what can begin an atomic pattern +(define + hk-apat-start? + (fn + (tok) + (if + (nil? tok) + false + (let + ((ty (get tok "type")) (val (get tok "value"))) + (or + (and (= ty "reserved") (= val "_")) + (= ty "integer") + (= ty "float") + (= ty "string") + (= ty "char") + (= ty "varid") + (= ty "conid") + (= ty "qconid") + (= ty "lparen") + (= ty "lbracket") + (and (= ty "varsym") (= val "-")) + (and (= ty "reservedop") (= val "~"))))))) + +;; ── Atype-start predicate (types) ─────────────────────────────── +(define + hk-atype-start? + (fn + (tok) + (if + (nil? tok) + false + (let + ((ty (get tok "type"))) + (or + (= ty "conid") + (= ty "qconid") + (= ty "varid") + (= ty "lparen") + (= ty "lbracket")))))) + +;; ── Main entry ─────────────────────────────────────────────────── +(define + hk-parser + (fn + (tokens mode) + (let + ((toks tokens) (pos 0) (n (len tokens))) + (define hk-peek (fn () (if (< pos n) (nth toks pos) nil))) + (define + hk-peek-at + (fn + (offset) + (if (< (+ pos offset) n) (nth toks (+ pos offset)) nil))) + (define + hk-advance! + (fn () (let ((t (hk-peek))) (set! pos (+ pos 1)) t))) + (define hk-next hk-advance!) + (define + hk-peek-type + (fn + () + (let ((t (hk-peek))) (if (nil? t) "" (get t "type"))))) + (define + hk-peek-value + (fn () (let ((t (hk-peek))) (if (nil? t) nil (get t "value"))))) + (define + hk-match? + (fn + (ty v) + (let + ((t (hk-peek))) + (and + (not (nil? t)) + (= (get t "type") ty) + (or (nil? v) (= (get t "value") v)))))) + (define + hk-err + (fn + (msg) + (raise + (str + "parse error: " + msg + " (at " + (hk-peek-type) + (if (nil? (hk-peek-value)) "" (str " " (hk-peek-value))) + ")")))) + (define + hk-expect! + (fn + (ty v) + (if + (hk-match? ty v) + (hk-advance!) + (hk-err (str "expected " ty (if (nil? v) "" (str " '" v "'"))))))) + (define + hk-parse-aexp + (fn + () + (let + ((t (hk-peek))) + (cond + ((nil? t) (hk-err "unexpected end of input")) + ((= (get t "type") "integer") + (do (hk-advance!) (list :int (get t "value")))) + ((= (get t "type") "float") + (do (hk-advance!) (list :float (get t "value")))) + ((= (get t "type") "string") + (do (hk-advance!) (list :string (get t "value")))) + ((= (get t "type") "char") + (do (hk-advance!) (list :char (get t "value")))) + ((= (get t "type") "varid") + (do (hk-advance!) (list :var (get t "value")))) + ((= (get t "type") "conid") + (do (hk-advance!) (list :con (get t "value")))) + ((= (get t "type") "qvarid") + (do (hk-advance!) (list :var (get t "value")))) + ((= (get t "type") "qconid") + (do (hk-advance!) (list :con (get t "value")))) + ((= (get t "type") "lparen") (hk-parse-parens)) + ((= (get t "type") "lbracket") (hk-parse-list-lit)) + (:else (hk-err "unexpected token in expression")))))) + (define + hk-section-op-info + (fn + () + (let + ((t (hk-peek))) + (cond + ((nil? t) nil) + ((= (get t "type") "varsym") {:len 1 :name (get t "value")}) + ((= (get t "type") "consym") {:len 1 :name (get t "value")}) + ((and (= (get t "type") "reservedop") (= (get t "value") ":")) + {:len 1 :name ":"}) + ((= (get t "type") "backtick") + (let + ((varid-t (hk-peek-at 1))) + (cond + ((and (not (nil? varid-t)) (= (get varid-t "type") "varid")) + {:len 3 :name (get varid-t "value")}) + (:else nil)))) + (:else nil))))) + (define + hk-parse-parens + (fn + () + (hk-expect! "lparen" nil) + (cond + ((hk-match? "rparen" nil) (do (hk-advance!) (list :con "()"))) + (:else + (let + ((op-info (hk-section-op-info))) + (cond + ((and (not (nil? op-info)) (let ((after (hk-peek-at (get op-info "len")))) (or (and (not (nil? after)) (= (get after "type") "rparen")) (not (= (get op-info "name") "-"))))) + (let + ((op-name (get op-info "name")) + (op-len (get op-info "len")) + (after (hk-peek-at (get op-info "len")))) + (hk-consume-op!) + (cond + ((and (not (nil? after)) (= (get after "type") "rparen")) + (do (hk-advance!) (list :var op-name))) + (:else + (let + ((expr-e (hk-parse-expr-inner))) + (hk-expect! "rparen" nil) + (list :sect-right op-name expr-e)))))) + (:else + (let + ((first-e (hk-parse-expr-inner)) + (items (list)) + (is-tuple false)) + (append! items first-e) + (define + hk-tup-loop + (fn + () + (when + (hk-match? "comma" nil) + (do + (hk-advance!) + (set! is-tuple true) + (append! items (hk-parse-expr-inner)) + (hk-tup-loop))))) + (hk-tup-loop) + (cond + ((hk-match? "rparen" nil) + (do + (hk-advance!) + (if is-tuple (list :tuple items) first-e))) + (:else + (let + ((op-info2 (hk-section-op-info))) + (cond + ((and (not (nil? op-info2)) (not is-tuple) (let ((after2 (hk-peek-at (get op-info2 "len")))) (and (not (nil? after2)) (= (get after2 "type") "rparen")))) + (let + ((op-name (get op-info2 "name"))) + (hk-consume-op!) + (hk-advance!) + (list :sect-left op-name first-e))) + (:else (hk-err "expected ')' after expression")))))))))))))) + (define + hk-comp-qual-is-gen? + (fn + () + (let + ((j pos) (depth 0) (found false) (done false)) + (define + hk-qsc-loop + (fn + () + (when + (and (not done) (< j n)) + (let + ((t (nth toks j)) (ty (get t "type"))) + (cond + ((and (= depth 0) (or (= ty "comma") (= ty "rbracket"))) + (set! done true)) + ((and (= depth 0) (= ty "reservedop") (= (get t "value") "<-")) + (do (set! found true) (set! done true))) + ((or (= ty "lparen") (= ty "lbracket") (= ty "lbrace") (= ty "vlbrace")) + (set! depth (+ depth 1))) + ((or (= ty "rparen") (= ty "rbrace") (= ty "vrbrace")) + (set! depth (- depth 1))) + (:else nil)) + (set! j (+ j 1)) + (hk-qsc-loop))))) + (hk-qsc-loop) + found))) + (define + hk-parse-comp-let + (fn + () + (hk-expect! "reserved" "let") + (let + ((explicit (hk-match? "lbrace" nil))) + (if explicit (hk-advance!) (hk-expect! "vlbrace" nil)) + (let + ((binds (list))) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (do + (append! binds (hk-parse-bind)) + (define + hk-cl-loop + (fn + () + (when + (or (hk-match? "semi" nil) (hk-match? "vsemi" nil)) + (do + (hk-advance!) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (append! binds (hk-parse-bind))) + (hk-cl-loop))))) + (hk-cl-loop))) + (cond + (explicit (hk-expect! "rbrace" nil)) + ((hk-match? "vrbrace" nil) (hk-advance!)) + ((or (hk-match? "rbracket" nil) (hk-match? "comma" nil)) + nil) + (:else (hk-err "expected end of let block in comprehension"))) + (list :q-let binds))))) + (define + hk-parse-qual + (fn + () + (cond + ((hk-match? "reserved" "let") (hk-parse-comp-let)) + ((hk-comp-qual-is-gen?) + (let + ((pat (hk-parse-pat))) + (hk-expect! "reservedop" "<-") + (list :q-gen pat (hk-parse-expr-inner)))) + (:else (list :q-guard (hk-parse-expr-inner)))))) + (define + hk-parse-list-lit + (fn + () + (hk-expect! "lbracket" nil) + (cond + ((hk-match? "rbracket" nil) + (do (hk-advance!) (list :list (list)))) + (:else + (let + ((first-e (hk-parse-expr-inner))) + (cond + ((hk-match? "reservedop" "..") + (do + (hk-advance!) + (cond + ((hk-match? "rbracket" nil) + (do (hk-advance!) (list :range-from first-e))) + (:else + (let + ((end-e (hk-parse-expr-inner))) + (hk-expect! "rbracket" nil) + (list :range first-e end-e)))))) + ((hk-match? "reservedop" "|") + (do + (hk-advance!) + (let + ((quals (list))) + (append! quals (hk-parse-qual)) + (define + hk-lc-loop + (fn + () + (when + (hk-match? "comma" nil) + (do + (hk-advance!) + (append! quals (hk-parse-qual)) + (hk-lc-loop))))) + (hk-lc-loop) + (hk-expect! "rbracket" nil) + (list :list-comp first-e quals)))) + ((hk-match? "comma" nil) + (do + (hk-advance!) + (let + ((second-e (hk-parse-expr-inner))) + (cond + ((hk-match? "reservedop" "..") + (do + (hk-advance!) + (let + ((end-e (hk-parse-expr-inner))) + (hk-expect! "rbracket" nil) + (list :range-step first-e second-e end-e)))) + (:else + (let + ((items (list))) + (append! items first-e) + (append! items second-e) + (define + hk-list-loop + (fn + () + (when + (hk-match? "comma" nil) + (do + (hk-advance!) + (append! items (hk-parse-expr-inner)) + (hk-list-loop))))) + (hk-list-loop) + (hk-expect! "rbracket" nil) + (list :list items))))))) + (:else + (do + (hk-expect! "rbracket" nil) + (list :list (list first-e)))))))))) + (define + hk-parse-fexp + (fn + () + (let + ((fn-e (hk-parse-aexp))) + (define + hk-app-loop + (fn + () + (when + (hk-atom-start? (hk-peek)) + (let + ((arg (hk-parse-aexp))) + (set! fn-e (list :app fn-e arg)) + (hk-app-loop))))) + (hk-app-loop) + fn-e))) + (define + hk-parse-lambda + (fn + () + (hk-expect! "reservedop" "\\") + (let + ((params (list))) + (when + (not (hk-apat-start? (hk-peek))) + (hk-err "lambda needs at least one pattern parameter")) + (define + hk-lam-loop + (fn + () + (when + (hk-apat-start? (hk-peek)) + (do (append! params (hk-parse-apat)) (hk-lam-loop))))) + (hk-lam-loop) + (hk-expect! "reservedop" "->") + (list :lambda params (hk-parse-expr-inner))))) + (define + hk-parse-if + (fn + () + (hk-expect! "reserved" "if") + (let + ((c (hk-parse-expr-inner))) + (hk-expect! "reserved" "then") + (let + ((th (hk-parse-expr-inner))) + (hk-expect! "reserved" "else") + (let ((el (hk-parse-expr-inner))) (list :if c th el)))))) + (define + hk-parse-let + (fn + () + (hk-expect! "reserved" "let") + (let + ((explicit (hk-match? "lbrace" nil))) + (if explicit (hk-advance!) (hk-expect! "vlbrace" nil)) + (let + ((binds (list))) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (do + (append! binds (hk-parse-bind)) + (define + hk-let-loop + (fn + () + (when + (or (hk-match? "semi" nil) (hk-match? "vsemi" nil)) + (do + (hk-advance!) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (append! binds (hk-parse-bind))) + (hk-let-loop))))) + (hk-let-loop))) + (if + explicit + (hk-expect! "rbrace" nil) + (hk-expect! "vrbrace" nil)) + (hk-expect! "reserved" "in") + (list :let binds (hk-parse-expr-inner)))))) + (define + hk-parse-where-decls + (fn + () + (let + ((explicit (hk-match? "lbrace" nil))) + (if explicit (hk-advance!) (hk-expect! "vlbrace" nil)) + (let + ((decls (list))) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (do + (append! decls (hk-parse-decl)) + (define + hk-wd-loop + (fn + () + (when + (or (hk-match? "vsemi" nil) (hk-match? "semi" nil)) + (do + (hk-advance!) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (append! decls (hk-parse-decl))) + (hk-wd-loop))))) + (hk-wd-loop))) + (if + explicit + (hk-expect! "rbrace" nil) + (hk-expect! "vrbrace" nil)) + decls)))) + (define + hk-parse-guarded + (fn + (sep) + (let + ((guards (list))) + (define + hk-g-loop + (fn + () + (when + (hk-match? "reservedop" "|") + (do + (hk-advance!) + (let + ((cond-e (hk-parse-expr-inner))) + (hk-expect! "reservedop" sep) + (let + ((expr-e (hk-parse-expr-inner))) + (append! guards (list :guard cond-e expr-e)) + (hk-g-loop))))))) + (hk-g-loop) + (list :guarded guards)))) + (define + hk-parse-rhs + (fn + (sep) + (let + ((body (cond ((hk-match? "reservedop" "|") (hk-parse-guarded sep)) (:else (do (hk-expect! "reservedop" sep) (hk-parse-expr-inner)))))) + (cond + ((hk-match? "reserved" "where") + (do (hk-advance!) (list :where body (hk-parse-where-decls)))) + (:else body))))) + (define + hk-parse-bind + (fn + () + (let + ((t (hk-peek))) + (cond + ((and (not (nil? t)) (= (get t "type") "varid")) + (let + ((name (get (hk-advance!) "value")) (pats (list))) + (define + hk-b-loop + (fn + () + (when + (hk-apat-start? (hk-peek)) + (do (append! pats (hk-parse-apat)) (hk-b-loop))))) + (hk-b-loop) + (if + (= (len pats) 0) + (list :bind (list :p-var name) (hk-parse-rhs "=")) + (list :fun-clause name pats (hk-parse-rhs "="))))) + (:else + (let + ((pat (hk-parse-pat))) + (list :bind pat (hk-parse-rhs "=")))))))) + (define + hk-parse-apat + (fn + () + (let + ((t (hk-peek))) + (cond + ((nil? t) (hk-err "unexpected end of input in pattern")) + ((and (= (get t "type") "reserved") (= (get t "value") "_")) + (do (hk-advance!) (list :p-wild))) + ((and (= (get t "type") "reservedop") (= (get t "value") "~")) + (do (hk-advance!) (list :p-lazy (hk-parse-apat)))) + ((and (= (get t "type") "varsym") (= (get t "value") "-")) + (do + (hk-advance!) + (let + ((n (hk-peek))) + (cond + ((nil? n) + (hk-err "expected numeric literal after '-'")) + ((= (get n "type") "integer") + (do + (hk-advance!) + (list :p-int (- 0 (get n "value"))))) + ((= (get n "type") "float") + (do + (hk-advance!) + (list :p-float (- 0 (get n "value"))))) + (:else + (hk-err + "only numeric literals may follow '-' in a pattern")))))) + ((= (get t "type") "integer") + (do (hk-advance!) (list :p-int (get t "value")))) + ((= (get t "type") "float") + (do (hk-advance!) (list :p-float (get t "value")))) + ((= (get t "type") "string") + (do (hk-advance!) (list :p-string (get t "value")))) + ((= (get t "type") "char") + (do (hk-advance!) (list :p-char (get t "value")))) + ((= (get t "type") "varid") + (let + ((next-t (hk-peek-at 1))) + (cond + ((and (not (nil? next-t)) (= (get next-t "type") "reservedop") (= (get next-t "value") "@")) + (do + (hk-advance!) + (hk-advance!) + (list :p-as (get t "value") (hk-parse-apat)))) + (:else + (do (hk-advance!) (list :p-var (get t "value"))))))) + ((= (get t "type") "conid") + (do (hk-advance!) (list :p-con (get t "value") (list)))) + ((= (get t "type") "qconid") + (do (hk-advance!) (list :p-con (get t "value") (list)))) + ((= (get t "type") "lparen") (hk-parse-paren-pat)) + ((= (get t "type") "lbracket") (hk-parse-list-pat)) + (:else (hk-err "unexpected token in pattern")))))) + (define + hk-parse-paren-pat + (fn + () + (hk-expect! "lparen" nil) + (cond + ((hk-match? "rparen" nil) + (do (hk-advance!) (list :p-con "()" (list)))) + (:else + (let + ((first-p (hk-parse-pat)) (items (list)) (is-tup false)) + (append! items first-p) + (define + hk-ppt-loop + (fn + () + (when + (hk-match? "comma" nil) + (do + (hk-advance!) + (set! is-tup true) + (append! items (hk-parse-pat)) + (hk-ppt-loop))))) + (hk-ppt-loop) + (hk-expect! "rparen" nil) + (if is-tup (list :p-tuple items) first-p)))))) + (define + hk-parse-list-pat + (fn + () + (hk-expect! "lbracket" nil) + (cond + ((hk-match? "rbracket" nil) + (do (hk-advance!) (list :p-list (list)))) + (:else + (let + ((items (list))) + (append! items (hk-parse-pat)) + (define + hk-plt-loop + (fn + () + (when + (hk-match? "comma" nil) + (do + (hk-advance!) + (append! items (hk-parse-pat)) + (hk-plt-loop))))) + (hk-plt-loop) + (hk-expect! "rbracket" nil) + (list :p-list items)))))) + (define + hk-parse-pat-lhs + (fn + () + (let + ((t (hk-peek))) + (cond + ((and (not (nil? t)) (or (= (get t "type") "conid") (= (get t "type") "qconid"))) + (let + ((name (get (hk-advance!) "value")) (args (list))) + (define + hk-pca-loop + (fn + () + (when + (hk-apat-start? (hk-peek)) + (do (append! args (hk-parse-apat)) (hk-pca-loop))))) + (hk-pca-loop) + (list :p-con name args))) + (:else (hk-parse-apat)))))) + (define + hk-parse-pat + (fn + () + (let + ((left (hk-parse-pat-lhs))) + (cond + ((or (= (hk-peek-type) "consym") (and (= (hk-peek-type) "reservedop") (= (hk-peek-value) ":"))) + (let + ((op (get (hk-advance!) "value"))) + (let + ((right (hk-parse-pat))) + (list :p-con op (list left right))))) + (:else left))))) + (define + hk-parse-alt + (fn + () + (let ((pat (hk-parse-pat))) (list :alt pat (hk-parse-rhs "->"))))) + (define + hk-parse-case + (fn + () + (hk-expect! "reserved" "case") + (let + ((scrut (hk-parse-expr-inner))) + (hk-expect! "reserved" "of") + (let + ((explicit (hk-match? "lbrace" nil))) + (if explicit (hk-advance!) (hk-expect! "vlbrace" nil)) + (let + ((alts (list))) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (do + (append! alts (hk-parse-alt)) + (define + hk-case-loop + (fn + () + (when + (or (hk-match? "semi" nil) (hk-match? "vsemi" nil)) + (do + (hk-advance!) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (append! alts (hk-parse-alt))) + (hk-case-loop))))) + (hk-case-loop))) + (if + explicit + (hk-expect! "rbrace" nil) + (hk-expect! "vrbrace" nil)) + (list :case scrut alts)))))) + (define + hk-do-stmt-is-bind? + (fn + () + (let + ((j pos) (depth 0) (found false) (done false)) + (define + hk-scan-loop + (fn + () + (when + (and (not done) (< j n)) + (let + ((t (nth toks j)) (ty nil)) + (set! ty (get t "type")) + (cond + ((and (= depth 0) (or (= ty "semi") (= ty "vsemi") (= ty "rbrace") (= ty "vrbrace"))) + (set! done true)) + ((and (= depth 0) (= ty "reservedop") (= (get t "value") "<-")) + (do (set! found true) (set! done true))) + ((or (= ty "lparen") (= ty "lbracket") (= ty "lbrace") (= ty "vlbrace")) + (set! depth (+ depth 1))) + ((or (= ty "rparen") (= ty "rbracket")) + (set! depth (- depth 1))) + (:else nil)) + (set! j (+ j 1)) + (hk-scan-loop))))) + (hk-scan-loop) + found))) + (define + hk-parse-do-let + (fn + () + (hk-expect! "reserved" "let") + (let + ((explicit (hk-match? "lbrace" nil))) + (if explicit (hk-advance!) (hk-expect! "vlbrace" nil)) + (let + ((binds (list))) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (do + (append! binds (hk-parse-bind)) + (define + hk-dlet-loop + (fn + () + (when + (or (hk-match? "semi" nil) (hk-match? "vsemi" nil)) + (do + (hk-advance!) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (append! binds (hk-parse-bind))) + (hk-dlet-loop))))) + (hk-dlet-loop))) + (if + explicit + (hk-expect! "rbrace" nil) + (hk-expect! "vrbrace" nil)) + (list :do-let binds))))) + (define + hk-parse-do-stmt + (fn + () + (cond + ((hk-match? "reserved" "let") (hk-parse-do-let)) + ((hk-do-stmt-is-bind?) + (let + ((pat (hk-parse-pat))) + (hk-expect! "reservedop" "<-") + (list :do-bind pat (hk-parse-expr-inner)))) + (:else (list :do-expr (hk-parse-expr-inner)))))) + (define + hk-parse-do + (fn + () + (hk-expect! "reserved" "do") + (let + ((explicit (hk-match? "lbrace" nil))) + (if explicit (hk-advance!) (hk-expect! "vlbrace" nil)) + (let + ((stmts (list))) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (do + (append! stmts (hk-parse-do-stmt)) + (define + hk-do-loop + (fn + () + (when + (or (hk-match? "semi" nil) (hk-match? "vsemi" nil)) + (do + (hk-advance!) + (when + (not + (if + explicit + (hk-match? "rbrace" nil) + (hk-match? "vrbrace" nil))) + (append! stmts (hk-parse-do-stmt))) + (hk-do-loop))))) + (hk-do-loop))) + (if + explicit + (hk-expect! "rbrace" nil) + (hk-expect! "vrbrace" nil)) + (list :do stmts))))) + (define + hk-parse-lexp + (fn + () + (cond + ((hk-match? "reservedop" "\\") (hk-parse-lambda)) + ((hk-match? "reserved" "if") (hk-parse-if)) + ((hk-match? "reserved" "let") (hk-parse-let)) + ((hk-match? "reserved" "case") (hk-parse-case)) + ((hk-match? "reserved" "do") (hk-parse-do)) + (:else (hk-parse-fexp))))) + (define + hk-parse-prefix + (fn + () + (cond + ((and (hk-match? "varsym" "-")) + (do (hk-advance!) (list :neg (hk-parse-lexp)))) + (:else (hk-parse-lexp))))) + (define + hk-is-infix-op? + (fn + (tok) + (if + (nil? tok) + false + (or + (= (get tok "type") "varsym") + (= (get tok "type") "consym") + (and + (= (get tok "type") "reservedop") + (= (get tok "value") ":")) + (= (get tok "type") "backtick"))))) + (define + hk-consume-op! + (fn + () + (let + ((t (hk-peek))) + (cond + ((= (get t "type") "backtick") + (do + (hk-advance!) + (let + ((v (hk-expect! "varid" nil))) + (hk-expect! "backtick" nil) + (get v "value")))) + (:else (do (hk-advance!) (get t "value"))))))) + (define + hk-parse-infix + (fn + (min-prec) + (let + ((left (hk-parse-prefix))) + (define + hk-inf-loop + (fn + () + (when + (hk-is-infix-op? (hk-peek)) + (let + ((op-tok (hk-peek))) + (let + ((op-len (if (= (get op-tok "type") "backtick") 3 1)) + (op-name + (if + (= (get op-tok "type") "backtick") + (get (hk-peek-at 1) "value") + (get op-tok "value")))) + (let + ((after-op (hk-peek-at op-len)) + (info (hk-op-info op-name))) + (cond + ((and (not (nil? after-op)) (= (get after-op "type") "rparen")) + nil) + ((>= (get info "prec") min-prec) + (do + (hk-consume-op!) + (let + ((next-min (cond ((= (get info "assoc") "left") (+ (get info "prec") 1)) ((= (get info "assoc") "right") (get info "prec")) (:else (+ (get info "prec") 1))))) + (let + ((right (hk-parse-infix next-min))) + (set! left (list :op op-name left right)) + (hk-inf-loop))))) + (:else nil)))))))) + (hk-inf-loop) + left))) + (define hk-parse-expr-inner (fn () (hk-parse-infix 0))) + (define + hk-parse-paren-type + (fn + () + (hk-expect! "lparen" nil) + (cond + ((hk-match? "rparen" nil) + (do (hk-advance!) (list :t-con "()"))) + (:else + (let + ((first-t (hk-parse-type)) (items (list)) (is-tup false)) + (append! items first-t) + (define + hk-pt-loop + (fn + () + (when + (hk-match? "comma" nil) + (do + (hk-advance!) + (set! is-tup true) + (append! items (hk-parse-type)) + (hk-pt-loop))))) + (hk-pt-loop) + (hk-expect! "rparen" nil) + (if is-tup (list :t-tuple items) first-t)))))) + (define + hk-parse-list-type + (fn + () + (hk-expect! "lbracket" nil) + (cond + ((hk-match? "rbracket" nil) + (do (hk-advance!) (list :t-con "[]"))) + (:else + (let + ((inner (hk-parse-type))) + (hk-expect! "rbracket" nil) + (list :t-list inner)))))) + (define + hk-parse-atype + (fn + () + (let + ((t (hk-peek))) + (cond + ((nil? t) (hk-err "unexpected end of input in type")) + ((= (get t "type") "conid") + (do (hk-advance!) (list :t-con (get t "value")))) + ((= (get t "type") "qconid") + (do (hk-advance!) (list :t-con (get t "value")))) + ((= (get t "type") "varid") + (do (hk-advance!) (list :t-var (get t "value")))) + ((= (get t "type") "lparen") (hk-parse-paren-type)) + ((= (get t "type") "lbracket") (hk-parse-list-type)) + (:else (hk-err "unexpected token in type")))))) + (define + hk-parse-btype + (fn + () + (let + ((head (hk-parse-atype))) + (define + hk-bt-loop + (fn + () + (when + (hk-atype-start? (hk-peek)) + (do + (set! head (list :t-app head (hk-parse-atype))) + (hk-bt-loop))))) + (hk-bt-loop) + head))) + (define + hk-parse-type + (fn + () + (let + ((left (hk-parse-btype))) + (cond + ((hk-match? "reservedop" "->") + (do (hk-advance!) (list :t-fun left (hk-parse-type)))) + (:else left))))) + (define + hk-has-top-dcolon? + (fn + () + (let + ((j pos) (depth 0) (found false) (done false)) + (define + hk-dcol-loop + (fn + () + (when + (and (not done) (< j n)) + (let + ((t (nth toks j)) (ty (get t "type"))) + (cond + ((and (= depth 0) (or (= ty "vsemi") (= ty "semi") (= ty "rbrace") (= ty "vrbrace"))) + (set! done true)) + ((and (= depth 0) (= ty "reservedop") (= (get t "value") "::")) + (do (set! found true) (set! done true))) + ((or (= ty "lparen") (= ty "lbracket") (= ty "lbrace") (= ty "vlbrace")) + (set! depth (+ depth 1))) + ((or (= ty "rparen") (= ty "rbracket")) + (set! depth (- depth 1))) + (:else nil)) + (set! j (+ j 1)) + (hk-dcol-loop))))) + (hk-dcol-loop) + found))) + (define + hk-parse-type-sig + (fn + () + (let + ((names (list))) + (when + (not (hk-match? "varid" nil)) + (hk-err "type signature must start with a variable")) + (append! names (get (hk-advance!) "value")) + (define + hk-sig-loop + (fn + () + (when + (hk-match? "comma" nil) + (do + (hk-advance!) + (when + (not (hk-match? "varid" nil)) + (hk-err "expected name after ','")) + (append! names (get (hk-advance!) "value")) + (hk-sig-loop))))) + (hk-sig-loop) + (hk-expect! "reservedop" "::") + (list :type-sig names (hk-parse-type))))) + (define + hk-parse-fun-clause + (fn + () + (let + ((t (hk-peek))) + (cond + ((and (not (nil? t)) (= (get t "type") "varid")) + (let + ((name (get (hk-advance!) "value")) (pats (list))) + (define + hk-fc-loop + (fn + () + (when + (hk-apat-start? (hk-peek)) + (do (append! pats (hk-parse-apat)) (hk-fc-loop))))) + (hk-fc-loop) + (list :fun-clause name pats (hk-parse-rhs "=")))) + (:else + (let + ((pat (hk-parse-pat))) + (list :pat-bind pat (hk-parse-rhs "=")))))))) + (define + hk-parse-con-def + (fn + () + (when + (not (hk-match? "conid" nil)) + (hk-err "expected constructor name")) + (let + ((name (get (hk-advance!) "value")) (fields (list))) + (define + hk-cd-loop + (fn + () + (when + (hk-atype-start? (hk-peek)) + (do (append! fields (hk-parse-atype)) (hk-cd-loop))))) + (hk-cd-loop) + (list :con-def name fields)))) + (define + hk-parse-tvars + (fn + () + (let + ((vs (list))) + (define + hk-tv-loop + (fn + () + (when + (hk-match? "varid" nil) + (do + (append! vs (get (hk-advance!) "value")) + (hk-tv-loop))))) + (hk-tv-loop) + vs))) + (define + hk-parse-data + (fn + () + (hk-expect! "reserved" "data") + (when + (not (hk-match? "conid" nil)) + (hk-err "data declaration needs a type name")) + (let + ((name (get (hk-advance!) "value")) + (tvars (hk-parse-tvars)) + (cons-list (list)) + (deriving-list (list))) + (when + (hk-match? "reservedop" "=") + (do + (hk-advance!) + (append! cons-list (hk-parse-con-def)) + (define + hk-dc-loop + (fn + () + (when + (hk-match? "reservedop" "|") + (do + (hk-advance!) + (append! cons-list (hk-parse-con-def)) + (hk-dc-loop))))) + (hk-dc-loop))) + (when + (hk-match? "reserved" "deriving") + (do + (hk-advance!) + (cond + ((hk-match? "lparen" nil) + (do + (hk-advance!) + (define + hk-der-loop + (fn + () + (when + (hk-match? "conid" nil) + (do + (append! + deriving-list + (get (hk-advance!) "value")) + (when (hk-match? "comma" nil) (hk-advance!)) + (hk-der-loop))))) + (hk-der-loop) + (hk-expect! "rparen" nil))) + ((hk-match? "conid" nil) + (append! deriving-list (get (hk-advance!) "value")))))) + (if + (empty? deriving-list) + (list :data name tvars cons-list) + (list :data name tvars cons-list deriving-list))))) + (define + hk-parse-class + (fn + () + (hk-next) + (let + ((cls (get (hk-next) "value"))) + (let + ((tvar (get (hk-next) "value"))) + (hk-expect! "reserved" "where") + (list "class-decl" cls tvar (hk-parse-where-decls)))))) + (define + hk-parse-instance + (fn + () + (hk-next) + (let + ((cls (get (hk-next) "value"))) + (let + ((inst-type (hk-parse-atype))) + (hk-expect! "reserved" "where") + (list "instance-decl" cls inst-type (hk-parse-where-decls)))))) + (define + hk-parse-type-syn + (fn + () + (hk-expect! "reserved" "type") + (when + (not (hk-match? "conid" nil)) + (hk-err "type synonym needs a name")) + (let + ((name (get (hk-advance!) "value")) (tvars (hk-parse-tvars))) + (hk-expect! "reservedop" "=") + (list :type-syn name tvars (hk-parse-type))))) + (define + hk-parse-newtype + (fn + () + (hk-expect! "reserved" "newtype") + (when + (not (hk-match? "conid" nil)) + (hk-err "newtype needs a type name")) + (let + ((name (get (hk-advance!) "value")) (tvars (hk-parse-tvars))) + (hk-expect! "reservedop" "=") + (when + (not (hk-match? "conid" nil)) + (hk-err "newtype needs a constructor name")) + (let + ((cname (get (hk-advance!) "value"))) + (when + (not (hk-atype-start? (hk-peek))) + (hk-err "newtype constructor needs one field")) + (list :newtype name tvars cname (hk-parse-atype)))))) + (define + hk-parse-op + (fn + () + (cond + ((hk-match? "varsym" nil) (get (hk-advance!) "value")) + ((hk-match? "consym" nil) (get (hk-advance!) "value")) + ((and (hk-match? "reservedop" nil) (= (hk-peek-value) ":")) + (do (hk-advance!) ":")) + ((hk-match? "backtick" nil) + (do + (hk-advance!) + (let + ((v (hk-expect! "varid" nil))) + (hk-expect! "backtick" nil) + (get v "value")))) + (:else (hk-err "expected operator name in fixity decl"))))) + (define + hk-parse-fixity + (fn + () + (let + ((assoc "n")) + (cond + ((hk-match? "reserved" "infixl") (set! assoc "l")) + ((hk-match? "reserved" "infixr") (set! assoc "r")) + ((hk-match? "reserved" "infix") (set! assoc "n")) + (:else (hk-err "expected fixity keyword"))) + (hk-advance!) + (let + ((prec 9)) + (when + (hk-match? "integer" nil) + (set! prec (get (hk-advance!) "value"))) + (let + ((ops (list))) + (append! ops (hk-parse-op)) + (define + hk-fx-loop + (fn + () + (when + (hk-match? "comma" nil) + (do + (hk-advance!) + (append! ops (hk-parse-op)) + (hk-fx-loop))))) + (hk-fx-loop) + (list :fixity assoc prec ops)))))) + (define + hk-parse-decl + (fn + () + (cond + ((hk-match? "reserved" "data") (hk-parse-data)) + ((hk-match? "reserved" "type") (hk-parse-type-syn)) + ((hk-match? "reserved" "newtype") (hk-parse-newtype)) + ((or (hk-match? "reserved" "infix") (hk-match? "reserved" "infixl") (hk-match? "reserved" "infixr")) + (hk-parse-fixity)) + ((hk-match? "reserved" "class") (hk-parse-class)) + ((hk-match? "reserved" "instance") (hk-parse-instance)) + ((hk-has-top-dcolon?) (hk-parse-type-sig)) + (:else (hk-parse-fun-clause))))) + (define + hk-parse-ent-member + (fn + () + (cond + ((hk-match? "varid" nil) (get (hk-advance!) "value")) + ((hk-match? "conid" nil) (get (hk-advance!) "value")) + ((hk-match? "lparen" nil) + (do + (hk-advance!) + (let + ((op-name (cond ((hk-match? "varsym" nil) (get (hk-advance!) "value")) ((hk-match? "consym" nil) (get (hk-advance!) "value")) ((and (hk-match? "reservedop" nil) (= (hk-peek-value) ":")) (do (hk-advance!) ":")) (:else (hk-err "expected operator in member list"))))) + (hk-expect! "rparen" nil) + op-name))) + (:else (hk-err "expected identifier in member list"))))) + (define + hk-parse-ent + (fn + (allow-module?) + (cond + ((hk-match? "varid" nil) + (list :ent-var (get (hk-advance!) "value"))) + ((hk-match? "qvarid" nil) + (list :ent-var (get (hk-advance!) "value"))) + ((and allow-module? (hk-match? "reserved" "module")) + (do + (hk-advance!) + (cond + ((or (hk-match? "conid" nil) (hk-match? "qconid" nil)) + (list :ent-module (get (hk-advance!) "value"))) + (:else (hk-err "expected module name in export"))))) + ((or (hk-match? "conid" nil) (hk-match? "qconid" nil)) + (let + ((name (get (hk-advance!) "value"))) + (cond + ((hk-match? "lparen" nil) + (do + (hk-advance!) + (cond + ((hk-match? "reservedop" "..") + (do + (hk-advance!) + (hk-expect! "rparen" nil) + (list :ent-all name))) + ((hk-match? "rparen" nil) + (do (hk-advance!) (list :ent-with name (list)))) + (:else + (let + ((mems (list))) + (append! mems (hk-parse-ent-member)) + (define + hk-mem-loop + (fn + () + (when + (hk-match? "comma" nil) + (do + (hk-advance!) + (when + (not (hk-match? "rparen" nil)) + (append! mems (hk-parse-ent-member))) + (hk-mem-loop))))) + (hk-mem-loop) + (hk-expect! "rparen" nil) + (list :ent-with name mems)))))) + (:else (list :ent-var name))))) + ((hk-match? "lparen" nil) + (do + (hk-advance!) + (let + ((op-name (cond ((hk-match? "varsym" nil) (get (hk-advance!) "value")) ((hk-match? "consym" nil) (get (hk-advance!) "value")) ((and (hk-match? "reservedop" nil) (= (hk-peek-value) ":")) (do (hk-advance!) ":")) (:else (hk-err "expected operator in parens"))))) + (hk-expect! "rparen" nil) + (list :ent-var op-name)))) + (:else (hk-err "expected entity in import/export list"))))) + (define + hk-parse-ent-list + (fn + (allow-module?) + (hk-expect! "lparen" nil) + (cond + ((hk-match? "rparen" nil) (do (hk-advance!) (list))) + (:else + (let + ((items (list))) + (append! items (hk-parse-ent allow-module?)) + (define + hk-el-loop + (fn + () + (when + (hk-match? "comma" nil) + (do + (hk-advance!) + (when + (not (hk-match? "rparen" nil)) + (append! items (hk-parse-ent allow-module?))) + (hk-el-loop))))) + (hk-el-loop) + (hk-expect! "rparen" nil) + items))))) + (define + hk-parse-import + (fn + () + (hk-expect! "reserved" "import") + (let + ((qualified false) (modname nil) (as-name nil) (spec nil)) + (when + (hk-match? "varid" "qualified") + (do (hk-advance!) (set! qualified true))) + (cond + ((or (hk-match? "conid" nil) (hk-match? "qconid" nil)) + (set! modname (get (hk-advance!) "value"))) + (:else (hk-err "expected module name in import"))) + (when + (hk-match? "varid" "as") + (do + (hk-advance!) + (cond + ((or (hk-match? "conid" nil) (hk-match? "qconid" nil)) + (set! as-name (get (hk-advance!) "value"))) + (:else (hk-err "expected name after 'as'"))))) + (cond + ((hk-match? "varid" "hiding") + (do + (hk-advance!) + (set! spec (list :spec-hiding (hk-parse-ent-list false))))) + ((hk-match? "lparen" nil) + (set! spec (list :spec-items (hk-parse-ent-list false))))) + (list :import qualified modname as-name spec)))) + (define + hk-parse-module-header + (fn + () + (hk-expect! "reserved" "module") + (let + ((modname nil) (exports nil)) + (cond + ((or (hk-match? "conid" nil) (hk-match? "qconid" nil)) + (set! modname (get (hk-advance!) "value"))) + (:else (hk-err "expected module name"))) + (when + (hk-match? "lparen" nil) + (set! exports (hk-parse-ent-list true))) + (hk-expect! "reserved" "where") + (list modname exports)))) + (define + hk-collect-module-body + (fn + () + (let + ((imports (list)) (decls (list))) + (define + hk-imp-loop + (fn + () + (when + (hk-match? "reserved" "import") + (do + (append! imports (hk-parse-import)) + (when + (or (hk-match? "vsemi" nil) (hk-match? "semi" nil)) + (do (hk-advance!) (hk-imp-loop))))))) + (hk-imp-loop) + (define + hk-body-at-end? + (fn + () + (or + (nil? (hk-peek)) + (= (hk-peek-type) "eof") + (hk-match? "vrbrace" nil) + (hk-match? "rbrace" nil)))) + (when + (not (hk-body-at-end?)) + (do + (append! decls (hk-parse-decl)) + (define + hk-body-loop + (fn + () + (when + (or (hk-match? "vsemi" nil) (hk-match? "semi" nil)) + (do + (hk-advance!) + (when + (not (hk-body-at-end?)) + (append! decls (hk-parse-decl))) + (hk-body-loop))))) + (hk-body-loop))) + (list imports decls)))) + (define + hk-parse-program + (fn + () + (cond + ((hk-match? "reserved" "module") + (let + ((header (hk-parse-module-header))) + (let + ((explicit (hk-match? "lbrace" nil))) + (if explicit (hk-advance!) (hk-expect! "vlbrace" nil)) + (let + ((body (hk-collect-module-body))) + (if + explicit + (hk-expect! "rbrace" nil) + (hk-expect! "vrbrace" nil)) + (list + :module (nth header 0) + (nth header 1) + (nth body 0) + (nth body 1)))))) + (:else + (let + ((body (hk-collect-module-body))) + (if + (empty? (nth body 0)) + (list :program (nth body 1)) + (list :module nil nil (nth body 0) (nth body 1)))))))) + (let + ((start-brace (or (hk-match? "vlbrace" nil) (hk-match? "lbrace" nil)))) + (when start-brace (hk-advance!)) + (let + ((result (cond ((= mode :expr) (hk-parse-expr-inner)) ((= mode :module) (hk-parse-program)) (:else (hk-err "unknown parser mode"))))) + (when + start-brace + (when + (or (hk-match? "vrbrace" nil) (hk-match? "rbrace" nil)) + (hk-advance!))) + result))))) + +(define hk-parse-expr (fn (tokens) (hk-parser tokens :expr))) +(define hk-parse-module (fn (tokens) (hk-parser tokens :module))) + +;; ── Convenience: tokenize + layout + parse ─────────────────────── +(define + hk-parse + (fn (src) (hk-parse-expr (hk-layout (hk-tokenize src))))) + +(define + hk-parse-top + (fn (src) (hk-parse-module (hk-layout (hk-tokenize src))))) diff --git a/lib/haskell/runtime.sx b/lib/haskell/runtime.sx index 0d4aca8e..69bcc36d 100644 --- a/lib/haskell/runtime.sx +++ b/lib/haskell/runtime.sx @@ -1,507 +1,130 @@ -;; lib/haskell/runtime.sx — Haskell-on-SX runtime layer +;; Haskell runtime: constructor registry. ;; -;; Covers the Haskell primitives now reachable via SX spec: -;; 1. Numeric type class helpers (Num / Integral / Fractional) -;; 2. Rational numbers (dict-based: {:_rational true :num n :den d}) -;; 3. Lazy evaluation — hk-force for promises created by delay -;; 4. Char utilities (Data.Char) -;; 5. Data.Set wrappers -;; 6. Data.List utilities -;; 7. Maybe / Either ADTs -;; 8. Tuples (lists, since list->vector unreliable in sx_server) -;; 9. String helpers (words/lines/isPrefixOf/etc.) -;; 10. Show helper +;; 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. -;; =========================================================================== -;; 1. Numeric type class helpers -;; =========================================================================== +(define hk-constructors (dict)) -(define hk-is-integer? integer?) -(define hk-is-float? float?) -(define hk-is-num? number?) - -;; fromIntegral — coerce integer to Float -(define (hk-to-float x) (exact->inexact x)) - -;; truncate / round toward zero -(define hk-to-integer truncate) -(define hk-from-integer (fn (n) n)) - -;; Haskell div: floor division (rounds toward -inf) (define - (hk-div a b) - (let - ((q (quotient a b)) (r (remainder a b))) + 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 - (and - (not (= r 0)) - (or - (and (< a 0) (> b 0)) - (and (> a 0) (< b 0)))) - (- q 1) - q))) - -;; Haskell mod: result has same sign as divisor -(define hk-mod modulo) - -;; Haskell rem: result has same sign as dividend -(define hk-rem remainder) - -;; Haskell quot: truncation division -(define hk-quot quotient) - -;; divMod and quotRem return pairs (lists) -(define (hk-div-mod a b) (list (hk-div a b) (hk-mod a b))) -(define (hk-quot-rem a b) (list (hk-quot a b) (hk-rem a b))) - -(define (hk-abs x) (if (< x 0) (- 0 x) x)) -(define - (hk-signum x) - (cond - ((> x 0) 1) - ((< x 0) -1) - (else 0))) - -(define hk-gcd gcd) -(define hk-lcm lcm) - -(define (hk-even? n) (= (modulo n 2) 0)) -(define (hk-odd? n) (not (= (modulo n 2) 0))) - -;; =========================================================================== -;; 2. Rational numbers (dict implementation — no built-in rational in sx_server) -;; =========================================================================== + (has-key? hk-constructors name) + (get (get hk-constructors name) "arity") + nil))) (define - (hk-make-rational n d) - (let - ((g (gcd (hk-abs n) (hk-abs d)))) - (if (< d 0) {:num (quotient (- 0 n) g) :den (quotient (- 0 d) g) :_rational true} {:num (quotient n g) :den (quotient d g) :_rational true}))) + 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-rational? x) - (and (dict? x) (not (= (get x :_rational) nil)))) -(define (hk-numerator r) (get r :num)) -(define (hk-denominator r) (get r :den)) - -(define - (hk-rational-add r1 r2) - (hk-make-rational - (+ - (* (hk-numerator r1) (hk-denominator r2)) - (* (hk-numerator r2) (hk-denominator r1))) - (* (hk-denominator r1) (hk-denominator r2)))) - -(define - (hk-rational-sub r1 r2) - (hk-make-rational - (- - (* (hk-numerator r1) (hk-denominator r2)) - (* (hk-numerator r2) (hk-denominator r1))) - (* (hk-denominator r1) (hk-denominator r2)))) - -(define - (hk-rational-mul r1 r2) - (hk-make-rational - (* (hk-numerator r1) (hk-numerator r2)) - (* (hk-denominator r1) (hk-denominator r2)))) - -(define - (hk-rational-div r1 r2) - (hk-make-rational - (* (hk-numerator r1) (hk-denominator r2)) - (* (hk-denominator r1) (hk-numerator r2)))) - -(define - (hk-rational-to-float r) - (exact->inexact (/ (hk-numerator r) (hk-denominator r)))) - -(define (hk-show-rational r) (str (hk-numerator r) "%" (hk-denominator r))) - -;; =========================================================================== -;; 3. Lazy evaluation — promises (created via SX delay) -;; =========================================================================== - -(define - (hk-force p) - (if - (and (dict? p) (not (= (get p :_promise) nil))) - (if (get p :forced) (get p :value) ((get p :thunk))) - p)) - -;; =========================================================================== -;; 4. Char utilities (Data.Char) -;; =========================================================================== - -(define hk-ord char->integer) -(define hk-chr integer->char) - -;; Inline ASCII predicates — char-alphabetic?/char-numeric? unreliable in sx_server -(define - (hk-is-alpha? c) - (let - ((n (char->integer c))) - (or - (and (>= n 65) (<= n 90)) - (and (>= n 97) (<= n 122))))) - -(define - (hk-is-digit? c) - (let ((n (char->integer c))) (and (>= n 48) (<= n 57)))) - -(define - (hk-is-alnum? c) - (let - ((n (char->integer c))) - (or - (and (>= n 48) (<= n 57)) - (and (>= n 65) (<= n 90)) - (and (>= n 97) (<= n 122))))) - -(define - (hk-is-upper? c) - (let ((n (char->integer c))) (and (>= n 65) (<= n 90)))) - -(define - (hk-is-lower? c) - (let ((n (char->integer c))) (and (>= n 97) (<= n 122)))) - -(define - (hk-is-space? c) - (let - ((n (char->integer c))) - (or - (= n 32) - (= n 9) - (= n 10) - (= n 13) - (= n 12) - (= n 11)))) - -(define hk-to-upper char-upcase) -(define hk-to-lower char-downcase) - -;; digitToInt: '0'-'9' → 0-9, 'a'-'f'/'A'-'F' → 10-15 -(define - (hk-digit-to-int c) - (let - ((n (char->integer c))) + hk-register-program! + (fn + (ast) (cond - ((and (>= n 48) (<= n 57)) (- n 48)) - ((and (>= n 65) (<= n 70)) (- n 55)) - ((and (>= n 97) (<= n 102)) (- n 87)) - (else (error (str "hk-digit-to-int: not a hex digit: " c)))))) + ((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)))) -;; intToDigit: 0-15 → char +;; Convenience: source → AST → desugar → register. (define - (hk-int-to-digit n) - (cond - ((and (>= n 0) (<= n 9)) - (integer->char (+ n 48))) - ((and (>= n 10) (<= n 15)) - (integer->char (+ n 87))) - (else (error (str "hk-int-to-digit: out of range: " n))))) + hk-load-source! + (fn (src) (hk-register-program! (hk-core src)))) -;; =========================================================================== -;; 5. Data.Set wrappers -;; =========================================================================== - -(define (hk-set-empty) (make-set)) -(define hk-set? set?) -(define hk-set-member? set-member?) - -(define (hk-set-insert x s) (begin (set-add! s x) s)) - -(define (hk-set-delete x s) (begin (set-remove! s x) s)) - -(define hk-set-union set-union) -(define hk-set-intersection set-intersection) -(define hk-set-difference set-difference) -(define hk-set-from-list list->set) -(define hk-set-to-list set->list) -(define (hk-set-null? s) (= (len (set->list s)) 0)) -(define (hk-set-size s) (len (set->list s))) - -(define (hk-set-singleton x) (let ((s (make-set))) (set-add! s x) s)) - -;; =========================================================================== -;; 6. Data.List utilities -;; =========================================================================== - -(define hk-head first) -(define hk-tail rest) -(define (hk-null? lst) (= (len lst) 0)) -(define hk-length len) - -(define - (hk-take n lst) - (if - (or (= n 0) (= (len lst) 0)) - (list) - (cons (first lst) (hk-take (- n 1) (rest lst))))) - -(define - (hk-drop n lst) - (if - (or (= n 0) (= (len lst) 0)) - lst - (hk-drop (- n 1) (rest lst)))) - -(define - (hk-take-while pred lst) - (if - (or (= (len lst) 0) (not (pred (first lst)))) - (list) - (cons (first lst) (hk-take-while pred (rest lst))))) - -(define - (hk-drop-while pred lst) - (if - (or (= (len lst) 0) (not (pred (first lst)))) - lst - (hk-drop-while pred (rest lst)))) - -(define - (hk-zip a b) - (if - (or (= (len a) 0) (= (len b) 0)) - (list) - (cons (list (first a) (first b)) (hk-zip (rest a) (rest b))))) - -(define - (hk-zip-with f a b) - (if - (or (= (len a) 0) (= (len b) 0)) - (list) - (cons (f (first a) (first b)) (hk-zip-with f (rest a) (rest b))))) - -(define - (hk-unzip pairs) - (list - (map (fn (p) (first p)) pairs) - (map (fn (p) (nth p 1)) pairs))) - -(define - (hk-elem x lst) - (cond - ((= (len lst) 0) false) - ((= x (first lst)) true) - (else (hk-elem x (rest lst))))) - -(define (hk-not-elem x lst) (not (hk-elem x lst))) - -(define - (hk-nub lst) - (letrec - ((go (fn (seen acc items) (if (= (len items) 0) (reverse acc) (let ((h (first items)) (t (rest items))) (if (hk-elem h seen) (go seen acc t) (go (cons h seen) (cons h acc) t))))))) - (go (list) (list) lst))) - -(define (hk-sum lst) (reduce + 0 lst)) -(define (hk-product lst) (reduce * 1 lst)) - -(define - (hk-maximum lst) - (reduce (fn (a b) (if (> a b) a b)) (first lst) (rest lst))) - -(define - (hk-minimum lst) - (reduce (fn (a b) (if (< a b) a b)) (first lst) (rest lst))) - -(define (hk-concat lsts) (reduce append (list) lsts)) - -(define (hk-concat-map f lst) (hk-concat (map f lst))) - -(define hk-sort sort) - -(define - (hk-span pred lst) - (list (hk-take-while pred lst) (hk-drop-while pred lst))) - -(define (hk-break pred lst) (hk-span (fn (x) (not (pred x))) lst)) - -(define - (hk-foldl f acc lst) - (if - (= (len lst) 0) - acc - (hk-foldl f (f acc (first lst)) (rest lst)))) - -(define - (hk-foldr f z lst) - (if - (= (len lst) 0) - z - (f (first lst) (hk-foldr f z (rest lst))))) - -(define - (hk-scanl f acc lst) - (if - (= (len lst) 0) - (list acc) - (cons acc (hk-scanl f (f acc (first lst)) (rest lst))))) - -(define - (hk-replicate n x) - (if (= n 0) (list) (cons x (hk-replicate (- n 1) x)))) - -(define - (hk-intersperse sep lst) - (if - (or (= (len lst) 0) (= (len lst) 1)) - lst - (cons (first lst) (cons sep (hk-intersperse sep (rest lst)))))) - -;; =========================================================================== -;; 7. Maybe / Either ADTs -;; =========================================================================== - -(define hk-nothing {:_maybe true :_tag "nothing"}) -(define (hk-just x) {:_maybe true :value x :_tag "just"}) -(define (hk-is-nothing? m) (= (get m :_tag) "nothing")) -(define (hk-is-just? m) (= (get m :_tag) "just")) -(define (hk-from-just m) (get m :value)) -(define (hk-from-maybe def m) (if (hk-is-nothing? m) def (hk-from-just m))) -(define - (hk-maybe def f m) - (if (hk-is-nothing? m) def (f (hk-from-just m)))) - -(define (hk-left x) {:value x :_either true :_tag "left"}) -(define (hk-right x) {:value x :_either true :_tag "right"}) -(define (hk-is-left? e) (= (get e :_tag) "left")) -(define (hk-is-right? e) (= (get e :_tag) "right")) -(define (hk-from-left e) (get e :value)) -(define (hk-from-right e) (get e :value)) -(define - (hk-either f g e) - (if (hk-is-left? e) (f (hk-from-left e)) (g (hk-from-right e)))) - -;; =========================================================================== -;; 8. Tuples (lists — list->vector unreliable in sx_server) -;; =========================================================================== - -(define (hk-pair a b) (list a b)) -(define hk-fst first) -(define (hk-snd t) (nth t 1)) - -(define (hk-triple a b c) (list a b c)) -(define hk-fst3 first) -(define (hk-snd3 t) (nth t 1)) -(define (hk-thd3 t) (nth t 2)) - -(define (hk-curry f) (fn (a) (fn (b) (f a b)))) -(define (hk-uncurry f) (fn (p) (f (hk-fst p) (hk-snd p)))) - -;; =========================================================================== -;; 9. String helpers (Data.List / Data.Char for strings) -;; =========================================================================== - -;; words: split on whitespace -(define - (hk-words s) - (letrec - ((slen (len s)) - (skip-ws - (fn - (i) - (if - (>= i slen) - (list) - (let - ((c (substring s i (+ i 1)))) - (if - (or (= c " ") (= c "\t") (= c "\n")) - (skip-ws (+ i 1)) - (collect-word i (+ i 1))))))) - (collect-word - (fn - (start i) - (if - (>= i slen) - (list (substring s start i)) - (let - ((c (substring s i (+ i 1)))) - (if - (or (= c " ") (= c "\t") (= c "\n")) - (cons (substring s start i) (skip-ws (+ i 1))) - (collect-word start (+ i 1)))))))) - (skip-ws 0))) - -;; unwords: join with spaces -(define - (hk-unwords lst) - (if - (= (len lst) 0) - "" - (reduce (fn (a b) (str a " " b)) (first lst) (rest lst)))) - -;; lines: split on newline -(define - (hk-lines s) - (letrec - ((slen (len s)) - (go - (fn - (start i acc) - (if - (>= i slen) - (reverse (cons (substring s start i) acc)) - (if - (= (substring s i (+ i 1)) "\n") - (go - (+ i 1) - (+ i 1) - (cons (substring s start i) acc)) - (go start (+ i 1) acc)))))) - (if (= slen 0) (list) (go 0 0 (list))))) - -;; unlines: join, each with trailing newline -(define (hk-unlines lst) (reduce (fn (a b) (str a b "\n")) "" lst)) - -;; isPrefixOf -(define - (hk-is-prefix-of pre s) - (and (<= (len pre) (len s)) (= pre (substring s 0 (len pre))))) - -;; isSuffixOf -(define - (hk-is-suffix-of suf s) - (let - ((sl (len suf)) (tl (len s))) - (and (<= sl tl) (= suf (substring s (- tl sl) tl))))) - -;; isInfixOf — linear scan -(define - (hk-is-infix-of pat s) - (let - ((plen (len pat)) (slen (len s))) - (letrec - ((go (fn (i) (if (> (+ i plen) slen) false (if (= pat (substring s i (+ i plen))) true (go (+ i 1))))))) - (if (= plen 0) true (go 0))))) - -;; =========================================================================== -;; 10. Show helper -;; =========================================================================== - -(define - (hk-show x) - (cond - ((= x nil) "Nothing") - ((= x true) "True") - ((= x false) "False") - ((hk-rational? x) (hk-show-rational x)) - ((integer? x) (str x)) - ((float? x) (str x)) - ((= (type-of x) "string") (str "\"" x "\"")) - ((= (type-of x) "char") (str "'" (str x) "'")) - ((list? x) - (str - "[" - (if - (= (len x) 0) - "" - (reduce - (fn (a b) (str a "," (hk-show b))) - (hk-show (first x)) - (rest x))) - "]")) - (else (str x)))) +;; ── 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") diff --git a/lib/haskell/scoreboard.json b/lib/haskell/scoreboard.json new file mode 100644 index 00000000..6f7884c9 --- /dev/null +++ b/lib/haskell/scoreboard.json @@ -0,0 +1,25 @@ +{ + "date": "2026-05-06", + "total_pass": 156, + "total_fail": 0, + "programs": { + "fib": {"pass": 2, "fail": 0}, + "sieve": {"pass": 2, "fail": 0}, + "quicksort": {"pass": 5, "fail": 0}, + "nqueens": {"pass": 2, "fail": 0}, + "calculator": {"pass": 5, "fail": 0}, + "collatz": {"pass": 11, "fail": 0}, + "palindrome": {"pass": 8, "fail": 0}, + "maybe": {"pass": 12, "fail": 0}, + "fizzbuzz": {"pass": 12, "fail": 0}, + "anagram": {"pass": 9, "fail": 0}, + "roman": {"pass": 14, "fail": 0}, + "binary": {"pass": 12, "fail": 0}, + "either": {"pass": 12, "fail": 0}, + "primes": {"pass": 12, "fail": 0}, + "zipwith": {"pass": 9, "fail": 0}, + "matrix": {"pass": 8, "fail": 0}, + "wordcount": {"pass": 7, "fail": 0}, + "powers": {"pass": 14, "fail": 0} + } +} diff --git a/lib/haskell/scoreboard.md b/lib/haskell/scoreboard.md new file mode 100644 index 00000000..500f8394 --- /dev/null +++ b/lib/haskell/scoreboard.md @@ -0,0 +1,25 @@ +# Haskell-on-SX Scoreboard + +Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs) + +| Program | Tests | Status | +|---------|-------|--------| +| fib.hs | 2/2 | ✓ | +| sieve.hs | 2/2 | ✓ | +| quicksort.hs | 5/5 | ✓ | +| nqueens.hs | 2/2 | ✓ | +| calculator.hs | 5/5 | ✓ | +| collatz.hs | 11/11 | ✓ | +| palindrome.hs | 8/8 | ✓ | +| maybe.hs | 12/12 | ✓ | +| fizzbuzz.hs | 12/12 | ✓ | +| anagram.hs | 9/9 | ✓ | +| roman.hs | 14/14 | ✓ | +| binary.hs | 12/12 | ✓ | +| either.hs | 12/12 | ✓ | +| primes.hs | 12/12 | ✓ | +| zipwith.hs | 9/9 | ✓ | +| matrix.hs | 8/8 | ✓ | +| wordcount.hs | 7/7 | ✓ | +| powers.hs | 14/14 | ✓ | +| **Total** | **156/156** | **18/18 programs** | diff --git a/lib/haskell/test.sh b/lib/haskell/test.sh index 3ea6d249..ea72c8e0 100755 --- a/lib/haskell/test.sh +++ b/lib/haskell/test.sh @@ -14,7 +14,7 @@ cd "$(git rev-parse --show-toplevel)" SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe" if [ ! -x "$SX_SERVER" ]; then # Fall back to the main-repo build if we're in a worktree. - MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}') + MAIN_ROOT=$(git worktree list | awk 'NR==1{print $1}') if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then SX_SERVER="$MAIN_ROOT/$SX_SERVER" else @@ -42,25 +42,35 @@ FAILED_FILES=() for FILE in "${FILES[@]}"; do [ -f "$FILE" ] || { echo "skip $FILE (not found)"; continue; } + # Load infer.sx only for infer/typecheck test files (it adds ~6s overhead). + INFER_LOAD="" + case "$FILE" in *infer*|*typecheck*) INFER_LOAD='(load "lib/haskell/infer.sx")' ;; esac TMPFILE=$(mktemp) cat > "$TMPFILE" <&1 || true) + OUTPUT=$(timeout 360 "$SX_SERVER" < "$TMPFILE" 2>&1 || true) rm -f "$TMPFILE" # Output format: either "(ok 3 (P F))" on one line (short result) or # "(ok-len 3 N)\n(P F)" where the value appears on the following line. LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}') if [ -z "$LINE" ]; then - LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \ + LINE=$(echo "$OUTPUT" | { grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' || true; } | tail -1 \ | sed -E 's/^\(ok 3 //; s/\)$//') fi if [ -z "$LINE" ]; then @@ -82,13 +92,20 @@ EPOCHS cat > "$TMPFILE2" <&1 | grep -E '^\(ok 3 ' || true) + FAILS=$(timeout 360 "$SX_SERVER" < "$TMPFILE2" 2>&1 | grep -E '^\(ok 3 ' || true) rm -f "$TMPFILE2" echo " $FAILS" elif [ "$VERBOSE" = "1" ]; then diff --git a/lib/haskell/testlib.sx b/lib/haskell/testlib.sx new file mode 100644 index 00000000..5803b741 --- /dev/null +++ b/lib/haskell/testlib.sx @@ -0,0 +1,58 @@ +;; 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}))))) diff --git a/lib/haskell/tests/class.sx b/lib/haskell/tests/class.sx new file mode 100644 index 00000000..f49e5e6e --- /dev/null +++ b/lib/haskell/tests/class.sx @@ -0,0 +1,60 @@ +;; class.sx — tests for class/instance parsing and evaluation. + +(define prog-class1 (hk-core "class MyEq a where\n myEq :: a -> a -> Bool")) +(define prog-inst1 (hk-core "instance MyEq Int where\n myEq x y = x == y")) + +;; ─── class-decl AST ─────────────────────────────────────────────────────────── +(define cd1 (first (nth prog-class1 1))) +(hk-test "class-decl tag" (first cd1) "class-decl") +(hk-test "class-decl name" (nth cd1 1) "MyEq") +(hk-test "class-decl tvar" (nth cd1 2) "a") +(hk-test "class-decl methods" (len (nth cd1 3)) 1) + +;; ─── instance-decl AST ──────────────────────────────────────────────────────── +(define id1 (first (nth prog-inst1 1))) +(hk-test "instance-decl tag" (first id1) "instance-decl") +(hk-test "instance-decl class" (nth id1 1) "MyEq") +(hk-test "instance-decl type tag" (first (nth id1 2)) "t-con") +(hk-test "instance-decl type name" (nth (nth id1 2) 1) "Int") +(hk-test "instance-decl method count" (len (nth id1 3)) 1) + +;; ─── eval: instance dict is built ──────────────────────────────────────────── +(define + prog-full + (hk-core + "class MyEq a where\n myEq :: a -> a -> Bool\ninstance MyEq Int where\n myEq x y = x == y")) +(define env-full (hk-eval-program prog-full)) + +(hk-test "instance dict in env" (has-key? env-full "dictMyEq_Int") true) + +(hk-test + "instance dict has method" + (has-key? (get env-full "dictMyEq_Int") "myEq") + true) + +(hk-test + "dispatch: single-arg method works" + (hk-deep-force + (hk-run + "class Describable a where\n describe :: a -> String\ninstance Describable Int where\n describe x = \"an integer\"\nmain = describe 42")) + "an integer") + +(hk-test + "dispatch: second instance (Bool)" + (hk-deep-force + (hk-run + "class Describable a where\n describe :: a -> String\ninstance Describable Bool where\n describe x = \"a boolean\"\ninstance Describable Int where\n describe x = \"an integer\"\nmain = describe True")) + "a boolean") + +(hk-test + "dispatch: error on unknown instance" + (guard + (e (true (>= (index-of e "No instance") 0))) + (begin + (hk-deep-force + (hk-run + "class Describable a where\n describe :: a -> String\nmain = describe 42")) + false)) + true) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} \ No newline at end of file diff --git a/lib/haskell/tests/deriving.sx b/lib/haskell/tests/deriving.sx new file mode 100644 index 00000000..db120900 --- /dev/null +++ b/lib/haskell/tests/deriving.sx @@ -0,0 +1,84 @@ +;; deriving.sx — tests for deriving (Eq, Show) on ADTs. + +;; ─── Show ──────────────────────────────────────────────────────────────────── + +(hk-test + "deriving Show: nullary constructor" + (hk-deep-force + (hk-run "data Color = Red | Green | Blue deriving (Show)\nmain = show Red")) + "Red") + +(hk-test + "deriving Show: constructor with arg" + (hk-deep-force + (hk-run "data Wrapper = Wrap Int deriving (Show)\nmain = show (Wrap 42)")) + "(Wrap 42)") + +(hk-test + "deriving Show: nested constructors" + (hk-deep-force + (hk-run + "data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf Leaf)")) + "(Node 1 Leaf Leaf)") + +(hk-test + "deriving Show: second constructor" + (hk-deep-force + (hk-run + "data Color = Red | Green | Blue deriving (Show)\nmain = show Green")) + "Green") + +;; ─── Eq ────────────────────────────────────────────────────────────────────── + +(hk-test + "deriving Eq: same constructor" + (hk-deep-force + (hk-run + "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red == Red)")) + "True") + +(hk-test + "deriving Eq: different constructors" + (hk-deep-force + (hk-run + "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red == Blue)")) + "False") + +(hk-test + "deriving Eq: /= same" + (hk-deep-force + (hk-run + "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Red)")) + "False") + +(hk-test + "deriving Eq: /= different" + (hk-deep-force + (hk-run + "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Blue)")) + "True") + +;; ─── combined Eq + Show ─────────────────────────────────────────────────────── + +(hk-test + "deriving Eq Show: combined in parens" + (hk-deep-force + (hk-run + "data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 5)")) + "(Circle 5)") + +(hk-test + "deriving Eq Show: eq on constructor with arg" + (hk-deep-force + (hk-run + "data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 3 == Circle 3)")) + "True") + +(hk-test + "deriving Eq Show: different constructors with args" + (hk-deep-force + (hk-run + "data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 3 == Square 3)")) + "False") + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/desugar.sx b/lib/haskell/tests/desugar.sx new file mode 100644 index 00000000..2487aeb4 --- /dev/null +++ b/lib/haskell/tests/desugar.sx @@ -0,0 +1,305 @@ +;; 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} diff --git a/lib/haskell/tests/do-io.sx b/lib/haskell/tests/do-io.sx new file mode 100644 index 00000000..d4425376 --- /dev/null +++ b/lib/haskell/tests/do-io.sx @@ -0,0 +1,117 @@ +;; 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} diff --git a/lib/haskell/tests/eval.sx b/lib/haskell/tests/eval.sx new file mode 100644 index 00000000..560bd90f --- /dev/null +++ b/lib/haskell/tests/eval.sx @@ -0,0 +1,278 @@ +;; 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} diff --git a/lib/haskell/tests/infer.sx b/lib/haskell/tests/infer.sx new file mode 100644 index 00000000..22bb6da7 --- /dev/null +++ b/lib/haskell/tests/infer.sx @@ -0,0 +1,181 @@ +;; infer.sx tests — Algorithm W: literals, vars, lambdas, application, let, +;; if, operators, tuples, lists, let-polymorphism. + +(define hk-t (fn (src expected) + (hk-test (str "infer: " src) (hk-infer-type src) expected))) + +;; ─── Literals ──────────────────────────────────────────────────────────────── +(hk-t "1" "Int") +(hk-t "3.14" "Float") +(hk-t "\"hello\"" "String") +(hk-t "'x'" "Char") +(hk-t "True" "Bool") +(hk-t "False" "Bool") + +;; ─── Arithmetic and boolean operators ──────────────────────────────────────── +(hk-t "1 + 2" "Int") +(hk-t "3 * 4" "Int") +(hk-t "10 - 3" "Int") +(hk-t "True && False" "Bool") +(hk-t "True || False" "Bool") +(hk-t "not True" "Bool") +(hk-t "1 == 1" "Bool") +(hk-t "1 < 2" "Bool") + +;; ─── Lambda ─────────────────────────────────────────────────────────────────── +;; \x -> x (identity) should get t1 -> t1 +(hk-test "infer: identity lambda" (hk-infer-type "\\x -> x") "t1 -> t1") + +;; \x -> x + 1 : Int -> Int +(hk-test "infer: lambda add" (hk-infer-type "\\x -> x + 1") "Int -> Int") + +;; \x -> not x : Bool -> Bool +(hk-test "infer: lambda not" (hk-infer-type "\\x -> not x") "Bool -> Bool") + +;; \x y -> x + y : Int -> Int -> Int +(hk-test "infer: two-arg lambda" (hk-infer-type "\\x -> \\y -> x + y") "Int -> Int -> Int") + +;; ─── Application ───────────────────────────────────────────────────────────── +(hk-t "not True" "Bool") +(hk-t "negate 1" "Int") + +;; ─── If-then-else ───────────────────────────────────────────────────────────── +(hk-t "if True then 1 else 2" "Int") +(hk-t "if 1 == 2 then True else False" "Bool") + +;; ─── Let bindings ───────────────────────────────────────────────────────────── +;; let x = 1 in x + 2 +(hk-t "let x = 1 in x + 2" "Int") + +;; let f x = x + 1 in f 5 +(hk-t "let f x = x + 1 in f 5" "Int") + +;; let-polymorphism: let id x = x in id 1 +(hk-t "let id x = x in id 1" "Int") + +;; ─── Tuples ─────────────────────────────────────────────────────────────────── +(hk-t "(1, True)" "(Int, Bool)") +(hk-t "(1, 2, 3)" "(Int, Int, Int)") + +;; ─── Lists ─────────────────────────────────────────────────────────────────── +(hk-t "[1, 2, 3]" "[Int]") +(hk-t "[True, False]" "[Bool]") + +;; ─── Polymorphic list functions ─────────────────────────────────────────────── +(hk-t "length [1, 2, 3]" "Int") +(hk-t "null []" "Bool") +(hk-t "head [1, 2, 3]" "Int") + +;; ─── hk-expr->brief ────────────────────────────────────────────────────────── +(hk-test "brief var" (hk-expr->brief (list "var" "x")) "x") +(hk-test "brief con" (hk-expr->brief (list "con" "Just")) "Just") +(hk-test "brief int" (hk-expr->brief (list "int" 42)) "42") +(hk-test "brief app" (hk-expr->brief (list "app" (list "var" "f") (list "var" "x"))) "(f x)") +(hk-test "brief op" (hk-expr->brief (list "op" "+" (list "int" 1) (list "int" 2))) "(1 + 2)") +(hk-test "brief lambda" (hk-expr->brief (list "lambda" (list) (list "var" "x"))) "(\\ ...)") +(hk-test "brief loc" (hk-expr->brief (list "loc" 3 7 (list "var" "x"))) "x") + +;; ─── Type error messages ───────────────────────────────────────────────────── +;; Helper: catch the error and check it contains a substring. +(define hk-str-has? (fn (s sub) (>= (index-of s sub) 0))) + +(define hk-te + (fn (label src sub) + (hk-test label + (guard (e (#t (hk-str-has? e sub))) + (begin (hk-infer-type src) false)) + true))) + +;; Unbound variable error includes the variable name. +(hk-te "error unbound name" "foo + 1" "foo") +(hk-te "error unbound unk" "unknown" "unknown") + +;; Unification error mentions the conflicting types. +(hk-te "error unify int-bool-1" "1 + True" "Int") +(hk-te "error unify int-bool-2" "1 + True" "Bool") + +;; ─── Loc node: passes through to inner (position decorates outer context) ──── +(define hk-loc-err-msg + (fn () + (guard (e (#t e)) + (begin + (hk-reset-fresh) + (hk-w (hk-type-env0) (list "loc" 5 10 (list "var" "mystery"))) + "no-error")))) +(hk-test "loc passes through to var error" + (hk-str-has? (hk-loc-err-msg) "mystery") + true) + +;; ─── hk-infer-decl ─────────────────────────────────────────────────────────── +;; Returns ("ok" name type) | ("err" msg) +(define hk-env0-t (hk-type-env0)) + +(define prog1 (hk-core "f x = x + 1")) +(define decl1 (first (nth prog1 1))) +(define res1 (hk-infer-decl hk-env0-t decl1)) +(hk-test "decl result tag" (first res1) "ok") +(hk-test "decl result name" (nth res1 1) "f") +(hk-test "decl result type" (nth res1 2) "Int -> Int") + +;; Error decl: result is ("err" "in 'g': ...") +(define prog2 (hk-core "g x = x + True")) +(define decl2 (first (nth prog2 1))) +(define res2 (hk-infer-decl hk-env0-t decl2)) +(hk-test "decl error tag" (first res2) "err") +(hk-test "decl error has g" (hk-str-has? (nth res2 1) "g") true) +(hk-test "decl error has msg" (hk-str-has? (nth res2 1) "unify") true) + +;; ─── hk-infer-prog ─────────────────────────────────────────────────────────── +;; Returns list of ("ok"/"err" ...) tagged results. +(define prog3 (hk-core "double x = x + x\ntwice f x = f (f x)")) +(define results3 (hk-infer-prog prog3 hk-env0-t)) +;; results3 = (("ok" "double" "Int -> Int") ("ok" "twice" "...")) +(hk-test "infer-prog count" (len results3) 2) +(hk-test "infer-prog double" (nth (nth results3 0) 2) "Int -> Int") +(hk-test "infer-prog twice" (nth (nth results3 1) 2) "(t3 -> t3) -> t3 -> t3") + +(hk-t "let id x = x in id 1" "Int") + +(hk-t "let id x = x in id True" "Bool") + +(hk-t "let id x = x in (id 1, id True)" "(Int, Bool)") + +(hk-t "let const x y = x in (const 1 True, const True 1)" "(Int, Bool)") + +(hk-t "let f x = x in let g y = f y in (g 1, g True)" "(Int, Bool)") + +(hk-t "let twice f x = f (f x) in twice (\x -> x + 1) 5" "Int") + +(hk-t "not (not True)" "Bool") + +(hk-t "negate (negate 1)" "Int") + +(hk-t "\\x -> \\y -> x && y" "Bool -> Bool -> Bool") + +(hk-t "\\x -> x == 1" "Int -> Bool") + +(hk-t "let x = True in if x then 1 else 0" "Int") + +(hk-t "let f x = not x in f True" "Bool") + +(hk-t "let f x = (x, x + 1) in f 5" "(Int, Int)") + +(hk-t "let x = 1 in let y = 2 in x + y" "Int") + +(hk-t "let f x = x + 1 in f (f 5)" "Int") + +(hk-t "if 1 < 2 then True else False" "Bool") + +(hk-t "if True then 1 + 1 else 2 + 2" "Int") + +(hk-t "(1 + 2, True && False)" "(Int, Bool)") + +(hk-t "(1 == 1, 2 < 3)" "(Bool, Bool)") + +(hk-t "length [True, False]" "Int") + +(hk-t "null [1]" "Bool") + +(hk-t "[True]" "[Bool]") + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/infinite.sx b/lib/haskell/tests/infinite.sx new file mode 100644 index 00000000..3cae6f4a --- /dev/null +++ b/lib/haskell/tests/infinite.sx @@ -0,0 +1,137 @@ +;; 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} diff --git a/lib/haskell/tests/io-input.sx b/lib/haskell/tests/io-input.sx new file mode 100644 index 00000000..71bf4620 --- /dev/null +++ b/lib/haskell/tests/io-input.sx @@ -0,0 +1,85 @@ +;; io-input.sx — tests for getLine, getContents, readFile, writeFile. + +(hk-test + "getLine reads single line" + (hk-run-io-with-input "main = getLine >>= putStrLn" (list "hello")) + (list "hello")) + +(hk-test + "getLine reads two lines" + (hk-run-io-with-input + "main = do { line1 <- getLine; line2 <- getLine; putStrLn line1; putStrLn line2 }" + (list "first" "second")) + (list "first" "second")) + +(hk-test + "getLine bind in layout do" + (hk-run-io-with-input + "main = do\n line <- getLine\n putStrLn line" + (list "world")) + (list "world")) + +(hk-test + "getLine echo with prefix" + (hk-run-io-with-input + "main = do\n line <- getLine\n putStrLn (\"Got: \" ++ line)" + (list "test")) + (list "Got: test")) + +(hk-test + "getContents reads all lines joined" + (hk-run-io-with-input + "main = getContents >>= putStr" + (list "line1" "line2" "line3")) + (list "line1\nline2\nline3")) + +(hk-test + "getContents empty stdin" + (hk-run-io-with-input "main = getContents >>= putStr" (list)) + (list "")) + +(hk-test + "readFile reads pre-loaded content" + (begin + (set! hk-vfs (dict)) + (dict-set! hk-vfs "hello.txt" "Hello, World!") + (hk-run-io "main = readFile \"hello.txt\" >>= putStrLn")) + (list "Hello, World!")) + +(hk-test + "writeFile creates file" + (begin + (set! hk-vfs (dict)) + (hk-run-io "main = writeFile \"out.txt\" \"written content\"") + (get hk-vfs "out.txt")) + "written content") + +(hk-test + "writeFile then readFile roundtrip" + (begin + (set! hk-vfs (dict)) + (hk-run-io + "main = do { writeFile \"f.txt\" \"round trip\"; readFile \"f.txt\" >>= putStrLn }")) + (list "round trip")) + +(hk-test + "readFile error on missing file" + (guard + (e (true (>= (index-of e "file not found") 0))) + (begin + (set! hk-vfs (dict)) + (hk-run-io "main = readFile \"no.txt\" >>= putStrLn") + false)) + true) + +(hk-test + "getLine then writeFile combined" + (begin + (set! hk-vfs (dict)) + (hk-run-io-with-input + "main = do\n line <- getLine\n writeFile \"cap.txt\" line" + (list "captured")) + (get hk-vfs "cap.txt")) + "captured") + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} \ No newline at end of file diff --git a/lib/haskell/tests/layout.sx b/lib/haskell/tests/layout.sx new file mode 100644 index 00000000..79c166cb --- /dev/null +++ b/lib/haskell/tests/layout.sx @@ -0,0 +1,245 @@ +;; 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} diff --git a/lib/haskell/tests/match.sx b/lib/haskell/tests/match.sx new file mode 100644 index 00000000..3f475bc0 --- /dev/null +++ b/lib/haskell/tests/match.sx @@ -0,0 +1,256 @@ +;; 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} diff --git a/lib/haskell/tests/parse.sx b/lib/haskell/tests/parse.sx index 7b9c9da1..4f4df46f 100644 --- a/lib/haskell/tests/parse.sx +++ b/lib/haskell/tests/parse.sx @@ -3,60 +3,8 @@ ;; 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. - -(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}))))) +;; The hk-test / hk-deep=? helpers live in lib/haskell/testlib.sx +;; and are preloaded by lib/haskell/test.sh. ;; Convenience: tokenize and drop newline + eof tokens so tests focus ;; on meaningful content. Returns list of {:type :value} pairs. diff --git a/lib/haskell/tests/parser-case-do.sx b/lib/haskell/tests/parser-case-do.sx new file mode 100644 index 00000000..ee0e152f --- /dev/null +++ b/lib/haskell/tests/parser-case-do.sx @@ -0,0 +1,278 @@ +;; 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} diff --git a/lib/haskell/tests/parser-decls.sx b/lib/haskell/tests/parser-decls.sx new file mode 100644 index 00000000..30aeff6a --- /dev/null +++ b/lib/haskell/tests/parser-decls.sx @@ -0,0 +1,273 @@ +;; 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} diff --git a/lib/haskell/tests/parser-expr.sx b/lib/haskell/tests/parser-expr.sx new file mode 100644 index 00000000..ff4ef913 --- /dev/null +++ b/lib/haskell/tests/parser-expr.sx @@ -0,0 +1,258 @@ +;; 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} diff --git a/lib/haskell/tests/parser-guards-where.sx b/lib/haskell/tests/parser-guards-where.sx new file mode 100644 index 00000000..ab41eb9c --- /dev/null +++ b/lib/haskell/tests/parser-guards-where.sx @@ -0,0 +1,261 @@ +;; 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} diff --git a/lib/haskell/tests/parser-module.sx b/lib/haskell/tests/parser-module.sx new file mode 100644 index 00000000..6f683d26 --- /dev/null +++ b/lib/haskell/tests/parser-module.sx @@ -0,0 +1,202 @@ +;; 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} diff --git a/lib/haskell/tests/parser-patterns.sx b/lib/haskell/tests/parser-patterns.sx new file mode 100644 index 00000000..cfd4044f --- /dev/null +++ b/lib/haskell/tests/parser-patterns.sx @@ -0,0 +1,234 @@ +;; 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} diff --git a/lib/haskell/tests/parser-sect-comp.sx b/lib/haskell/tests/parser-sect-comp.sx new file mode 100644 index 00000000..90cafeab --- /dev/null +++ b/lib/haskell/tests/parser-sect-comp.sx @@ -0,0 +1,191 @@ +;; 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} diff --git a/lib/haskell/tests/prelude-extra.sx b/lib/haskell/tests/prelude-extra.sx new file mode 100644 index 00000000..82a18676 --- /dev/null +++ b/lib/haskell/tests/prelude-extra.sx @@ -0,0 +1,234 @@ +;; prelude-extra.sx — tests for Phase 6 prelude additions: +;; ord/isAlpha/isDigit/isSpace/isUpper/isLower/isAlphaNum/digitToInt +;; words/lines/unwords/unlines/sort/nub/splitAt/span/break +;; partition/intercalate/intersperse/isPrefixOf/isSuffixOf/isInfixOf + +;; ── ord ────────────────────────────────────────────────────── +(hk-test "ord 'A'" (hk-eval-expr-source "ord 'A'") 65) +(hk-test "ord 'a'" (hk-eval-expr-source "ord 'a'") 97) +(hk-test "ord '0'" (hk-eval-expr-source "ord '0'") 48) + +;; ── isAlpha / isDigit / isSpace / isUpper / isLower ────────── +(hk-test + "isAlpha 'a' True" + (hk-eval-expr-source "isAlpha 'a'") + (list "True")) +(hk-test + "isAlpha 'Z' True" + (hk-eval-expr-source "isAlpha 'Z'") + (list "True")) +(hk-test + "isAlpha '3' False" + (hk-eval-expr-source "isAlpha '3'") + (list "False")) +(hk-test + "isDigit '5' True" + (hk-eval-expr-source "isDigit '5'") + (list "True")) +(hk-test + "isDigit 'a' False" + (hk-eval-expr-source "isDigit 'a'") + (list "False")) +(hk-test + "isSpace ' ' True" + (hk-eval-expr-source "isSpace ' '") + (list "True")) +(hk-test + "isSpace 'x' False" + (hk-eval-expr-source "isSpace 'x'") + (list "False")) +(hk-test + "isUpper 'A' True" + (hk-eval-expr-source "isUpper 'A'") + (list "True")) +(hk-test + "isUpper 'a' False" + (hk-eval-expr-source "isUpper 'a'") + (list "False")) +(hk-test + "isLower 'z' True" + (hk-eval-expr-source "isLower 'z'") + (list "True")) +(hk-test + "isLower 'Z' False" + (hk-eval-expr-source "isLower 'Z'") + (list "False")) +(hk-test + "isAlphaNum '3' True" + (hk-eval-expr-source "isAlphaNum '3'") + (list "True")) +(hk-test + "isAlphaNum 'b' True" + (hk-eval-expr-source "isAlphaNum 'b'") + (list "True")) +(hk-test + "isAlphaNum '!' False" + (hk-eval-expr-source "isAlphaNum '!'") + (list "False")) + +;; ── digitToInt ─────────────────────────────────────────────── +(hk-test "digitToInt '0'" (hk-eval-expr-source "digitToInt '0'") 0) +(hk-test "digitToInt '7'" (hk-eval-expr-source "digitToInt '7'") 7) +(hk-test "digitToInt '9'" (hk-eval-expr-source "digitToInt '9'") 9) + +;; ── words ──────────────────────────────────────────────────── +(hk-test + "words single" + (hk-deep-force (hk-eval-expr-source "words \"hello\"")) + (list ":" "hello" (list "[]"))) + +(hk-test + "words two" + (hk-deep-force (hk-eval-expr-source "words \"hello world\"")) + (list ":" "hello" (list ":" "world" (list "[]")))) + +(hk-test + "words leading/trailing spaces" + (hk-deep-force (hk-eval-expr-source "words \" foo bar \"")) + (list ":" "foo" (list ":" "bar" (list "[]")))) + +(hk-test + "words empty string" + (hk-deep-force (hk-eval-expr-source "words \"\"")) + (list "[]")) + +;; ── lines ──────────────────────────────────────────────────── +(hk-test + "lines single no newline" + (hk-deep-force (hk-eval-expr-source "lines \"hello\"")) + (list ":" "hello" (list "[]"))) + +(hk-test + "lines two lines" + (hk-deep-force (hk-eval-expr-source "lines \"a\\nb\"")) + (list ":" "a" (list ":" "b" (list "[]")))) + +(hk-test + "lines trailing newline" + (hk-deep-force (hk-eval-expr-source "lines \"a\\n\"")) + (list ":" "a" (list "[]"))) + +(hk-test + "lines empty string" + (hk-deep-force (hk-eval-expr-source "lines \"\"")) + (list "[]")) + +;; ── unwords / unlines ──────────────────────────────────────── +(hk-test + "unwords two" + (hk-eval-expr-source "unwords [\"hello\", \"world\"]") + "hello world") + +(hk-test "unwords empty" (hk-eval-expr-source "unwords []") "") + +(hk-test "unlines two" (hk-eval-expr-source "unlines [\"a\", \"b\"]") "a\nb\n") + +;; ── sort / nub ─────────────────────────────────────────────── +(hk-test + "sort ascending" + (hk-deep-force (hk-eval-expr-source "sort [3,1,2]")) + (list ":" 1 (list ":" 2 (list ":" 3 (list "[]"))))) + +(hk-test + "sort already sorted" + (hk-deep-force (hk-eval-expr-source "sort [1,2,3]")) + (list ":" 1 (list ":" 2 (list ":" 3 (list "[]"))))) + +(hk-test + "nub removes duplicates" + (hk-deep-force (hk-eval-expr-source "nub [1,2,1,3,2]")) + (list ":" 1 (list ":" 2 (list ":" 3 (list "[]"))))) + +(hk-test + "nub no duplicates unchanged" + (hk-deep-force (hk-eval-expr-source "nub [1,2,3]")) + (list ":" 1 (list ":" 2 (list ":" 3 (list "[]"))))) + +;; ── splitAt ────────────────────────────────────────────────── +(hk-test + "splitAt 2" + (hk-deep-force (hk-eval-expr-source "splitAt 2 [1,2,3,4]")) + (list + "Tuple" + (list ":" 1 (list ":" 2 (list "[]"))) + (list ":" 3 (list ":" 4 (list "[]"))))) + +(hk-test + "splitAt 0" + (hk-deep-force (hk-eval-expr-source "splitAt 0 [1,2,3]")) + (list + "Tuple" + (list "[]") + (list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))) + +;; ── span / break ───────────────────────────────────────────── +(hk-test + "span digits" + (hk-deep-force (hk-eval-expr-source "span (\\x -> x < 3) [1,2,3,4]")) + (list + "Tuple" + (list ":" 1 (list ":" 2 (list "[]"))) + (list ":" 3 (list ":" 4 (list "[]"))))) + +(hk-test + "break digits" + (hk-deep-force (hk-eval-expr-source "break (\\x -> x >= 3) [1,2,3,4]")) + (list + "Tuple" + (list ":" 1 (list ":" 2 (list "[]"))) + (list ":" 3 (list ":" 4 (list "[]"))))) + +;; ── partition ──────────────────────────────────────────────── +(hk-test + "partition even/odd" + (hk-deep-force + (hk-eval-expr-source "partition (\\x -> x `mod` 2 == 0) [1,2,3,4,5]")) + (list + "Tuple" + (list ":" 2 (list ":" 4 (list "[]"))) + (list ":" 1 (list ":" 3 (list ":" 5 (list "[]")))))) + +;; ── intercalate / intersperse ──────────────────────────────── +(hk-test + "intercalate" + (hk-eval-expr-source "intercalate \", \" [\"a\", \"b\", \"c\"]") + "a, b, c") + +(hk-test + "intersperse" + (hk-deep-force (hk-eval-expr-source "intersperse 0 [1,2,3]")) + (list + ":" + 1 + (list + ":" + 0 + (list ":" 2 (list ":" 0 (list ":" 3 (list "[]"))))))) + +;; ── isPrefixOf / isSuffixOf / isInfixOf ────────────────────── +(hk-test + "isPrefixOf True" + (hk-deep-force (hk-eval-expr-source "isPrefixOf [1,2] [1,2,3]")) + (list "True")) + +(hk-test + "isPrefixOf False" + (hk-deep-force (hk-eval-expr-source "isPrefixOf [2,3] [1,2,3]")) + (list "False")) + +(hk-test + "isSuffixOf True" + (hk-deep-force (hk-eval-expr-source "isSuffixOf [2,3] [1,2,3]")) + (list "True")) + +(hk-test + "isInfixOf True" + (hk-deep-force (hk-eval-expr-source "isInfixOf [2,3] [1,2,3,4]")) + (list "True")) + +(hk-test + "isInfixOf False" + (hk-deep-force (hk-eval-expr-source "isInfixOf [5,6] [1,2,3,4]")) + (list "False")) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-anagram.sx b/lib/haskell/tests/program-anagram.sx new file mode 100644 index 00000000..1f0eea20 --- /dev/null +++ b/lib/haskell/tests/program-anagram.sx @@ -0,0 +1,70 @@ +;; anagram.hs — anagram detection using sort. + +(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-ana-src + "isAnagram xs ys = sort xs == sort ys\n\nhasAnagram needle haystack = any (isAnagram needle) haystack\n") + +(hk-test + "isAnagram [1,2,3] [3,2,1] True" + (hk-prog-val (str hk-ana-src "r = isAnagram [1,2,3] [3,2,1]\n") "r") + (list "True")) + +(hk-test + "isAnagram [1,2,3] [1,2,4] False" + (hk-prog-val (str hk-ana-src "r = isAnagram [1,2,3] [1,2,4]\n") "r") + (list "False")) + +(hk-test + "isAnagram [] [] True" + (hk-prog-val (str hk-ana-src "r = isAnagram [] []\n") "r") + (list "True")) + +(hk-test + "isAnagram [1] [1] True" + (hk-prog-val (str hk-ana-src "r = isAnagram [1] [1]\n") "r") + (list "True")) + +(hk-test + "isAnagram [1,2] [2,1] True" + (hk-prog-val (str hk-ana-src "r = isAnagram [1,2] [2,1]\n") "r") + (list "True")) + +(hk-test + "isAnagram [1,1,2] [2,1,1] True" + (hk-prog-val (str hk-ana-src "r = isAnagram [1,1,2] [2,1,1]\n") "r") + (list "True")) + +(hk-test + "isAnagram [1,2] [1,2,3] False" + (hk-prog-val (str hk-ana-src "r = isAnagram [1,2] [1,2,3]\n") "r") + (list "False")) + +(hk-test + "hasAnagram [1,2] [[3,4],[2,1],[5,6]] True" + (hk-prog-val + (str hk-ana-src "r = hasAnagram [1,2] [[3,4],[2,1],[5,6]]\n") + "r") + (list "True")) + +(hk-test + "hasAnagram [1,2] [[3,4],[5,6]] False" + (hk-prog-val (str hk-ana-src "r = hasAnagram [1,2] [[3,4],[5,6]]\n") "r") + (list "False")) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-binary.sx b/lib/haskell/tests/program-binary.sx new file mode 100644 index 00000000..6272c9ea --- /dev/null +++ b/lib/haskell/tests/program-binary.sx @@ -0,0 +1,83 @@ +;; binary.hs — integer binary representation using explicit recursion. + +(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-bin-src + "toBits 0 = []\ntoBits n = (n `mod` 2) : toBits (n `div` 2)\n\ntoBin 0 = [0]\ntoBin n = reverse (toBits n)\n\naddBit acc b = acc * 2 + b\nfromBin bits = foldl addBit 0 bits\n\nnumBits 0 = 1\nnumBits n = length (toBits n)\n") + +(hk-test + "toBin 0 = [0]" + (hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 0\n") "r")) + (list 0)) + +(hk-test + "toBin 1 = [1]" + (hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 1\n") "r")) + (list 1)) + +(hk-test + "toBin 2 = [1,0]" + (hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 2\n") "r")) + (list 1 0)) + +(hk-test + "toBin 3 = [1,1]" + (hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 3\n") "r")) + (list 1 1)) + +(hk-test + "toBin 4 = [1,0,0]" + (hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 4\n") "r")) + (list 1 0 0)) + +(hk-test + "toBin 7 = [1,1,1]" + (hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 7\n") "r")) + (list 1 1 1)) + +(hk-test + "toBin 8 = [1,0,0,0]" + (hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 8\n") "r")) + (list 1 0 0 0)) + +(hk-test + "fromBin [0] = 0" + (hk-prog-val (str hk-bin-src "r = fromBin [0]\n") "r") + 0) + +(hk-test + "fromBin [1] = 1" + (hk-prog-val (str hk-bin-src "r = fromBin [1]\n") "r") + 1) + +(hk-test + "fromBin [1,0,1] = 5" + (hk-prog-val (str hk-bin-src "r = fromBin [1,0,1]\n") "r") + 5) + +(hk-test + "fromBin [1,1,1] = 7" + (hk-prog-val (str hk-bin-src "r = fromBin [1,1,1]\n") "r") + 7) + +(hk-test + "roundtrip: fromBin (toBin 13) = 13" + (hk-prog-val (str hk-bin-src "r = fromBin (toBin 13)\n") "r") + 13) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-calculator.sx b/lib/haskell/tests/program-calculator.sx new file mode 100644 index 00000000..1059b508 --- /dev/null +++ b/lib/haskell/tests/program-calculator.sx @@ -0,0 +1,55 @@ +;; calculator.hs — recursive descent expression evaluator. +;; +;; Exercises: +;; - ADTs with constructor fields: TNum Int, TOp String, R Int [Token] +;; - Nested constructor pattern matching: (R v (TOp "+":rest)) +;; - let bindings in function bodies +;; - Integer arithmetic including `div` (backtick infix) +;; - Left-associative multi-level operator precedence + +(define + hk-prog-val + (fn + (src name) + (hk-deep-force (get (hk-eval-program (hk-core src)) name)))) + +(define + hk-calc-src + "data Token = TNum Int | TOp String\ndata Result = R Int [Token]\ngetV (R v _) = v\ngetR (R _ r) = r\neval ts = getV (parseExpr ts)\nparseExpr ts = parseExprRest (parseTerm ts)\nparseExprRest (R v (TOp \"+\":rest)) =\n let t = parseTerm rest\n in parseExprRest (R (v + getV t) (getR t))\nparseExprRest (R v (TOp \"-\":rest)) =\n let t = parseTerm rest\n in parseExprRest (R (v - getV t) (getR t))\nparseExprRest r = r\nparseTerm ts = parseTermRest (parseFactor ts)\nparseTermRest (R v (TOp \"*\":rest)) =\n let t = parseFactor rest\n in parseTermRest (R (v * getV t) (getR t))\nparseTermRest (R v (TOp \"/\":rest)) =\n let t = parseFactor rest\n in parseTermRest (R (v `div` getV t) (getR t))\nparseTermRest r = r\nparseFactor (TNum n:rest) = R n rest\n") + +(hk-test + "calculator: 2 + 3 = 5" + (hk-prog-val + (str hk-calc-src "result = eval [TNum 2, TOp \"+\", TNum 3]\n") + "result") + 5) + +(hk-test + "calculator: 2 + 3 * 4 = 14 (precedence)" + (hk-prog-val + (str hk-calc-src "result = eval [TNum 2, TOp \"+\", TNum 3, TOp \"*\", TNum 4]\n") + "result") + 14) + +(hk-test + "calculator: 10 - 3 - 2 = 5 (left-assoc)" + (hk-prog-val + (str hk-calc-src "result = eval [TNum 10, TOp \"-\", TNum 3, TOp \"-\", TNum 2]\n") + "result") + 5) + +(hk-test + "calculator: 6 / 2 * 3 = 9 (left-assoc)" + (hk-prog-val + (str hk-calc-src "result = eval [TNum 6, TOp \"/\", TNum 2, TOp \"*\", TNum 3]\n") + "result") + 9) + +(hk-test + "calculator: single number" + (hk-prog-val + (str hk-calc-src "result = eval [TNum 42]\n") + "result") + 42) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-collatz.sx b/lib/haskell/tests/program-collatz.sx new file mode 100644 index 00000000..ad569a03 --- /dev/null +++ b/lib/haskell/tests/program-collatz.sx @@ -0,0 +1,83 @@ +;; collatz.hs — Collatz (3n+1) sequences. + +(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-prog-val + (fn + (src name) + (hk-deep-force (get (hk-eval-program (hk-core src)) name)))) + +(define + hk-col-src + "collatz 1 = [1]\ncollatz n = if n `mod` 2 == 0\n then n : collatz (n `div` 2)\n else n : collatz (3 * n + 1)\ncollatzLen n = length (collatz n)\n") + +(hk-test + "collatz 1 = [1]" + (hk-as-list (hk-prog-val (str hk-col-src "r = collatz 1\n") "r")) + (list 1)) + +(hk-test + "collatz 2 = [2,1]" + (hk-as-list (hk-prog-val (str hk-col-src "r = collatz 2\n") "r")) + (list 2 1)) + +(hk-test + "collatz 4 = [4,2,1]" + (hk-as-list (hk-prog-val (str hk-col-src "r = collatz 4\n") "r")) + (list 4 2 1)) + +(hk-test + "collatz 6 starts 6,3,10" + (hk-as-list (hk-prog-val (str hk-col-src "r = take 3 (collatz 6)\n") "r")) + (list 6 3 10)) + +(hk-test + "collatz 8 = [8,4,2,1]" + (hk-as-list (hk-prog-val (str hk-col-src "r = collatz 8\n") "r")) + (list 8 4 2 1)) + +(hk-test + "collatzLen 1 = 1" + (hk-prog-val (str hk-col-src "r = collatzLen 1\n") "r") + 1) + +(hk-test + "collatzLen 2 = 2" + (hk-prog-val (str hk-col-src "r = collatzLen 2\n") "r") + 2) + +(hk-test + "collatzLen 4 = 3" + (hk-prog-val (str hk-col-src "r = collatzLen 4\n") "r") + 3) + +(hk-test + "collatzLen 8 = 4" + (hk-prog-val (str hk-col-src "r = collatzLen 8\n") "r") + 4) + +(hk-test + "collatzLen 16 = 5" + (hk-prog-val (str hk-col-src "r = collatzLen 16\n") "r") + 5) + +(hk-test + "collatz last is always 1" + (hk-prog-val (str hk-col-src "r = last (collatz 27)\n") "r") + 1) + +(hk-test + "collatz 3 = [3,10,5,16,8,4,2,1]" + (hk-as-list (hk-prog-val (str hk-col-src "r = collatz 3\n") "r")) + (list 3 10 5 16 8 4 2 1)) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-either.sx b/lib/haskell/tests/program-either.sx new file mode 100644 index 00000000..918c1c10 --- /dev/null +++ b/lib/haskell/tests/program-either.sx @@ -0,0 +1,83 @@ +;; either.hs — Either ADT operations via pattern matching. + +(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-either-src + "safeDiv _ 0 = Left \"divide by zero\"\nsafeDiv x y = Right (x `div` y)\n\nfromRight _ (Right x) = x\nfromRight def (Left _) = def\n\nfromLeft (Left x) _ = x\nfromLeft _ def = def\n\nisRight (Right _) = True\nisRight (Left _) = False\n\nisLeft (Left _) = True\nisLeft (Right _) = False\n\nmapRight _ (Left e) = Left e\nmapRight f (Right x) = Right (f x)\n\ndouble x = x * 2\n") + +(hk-test + "safeDiv 10 2 = Right 5" + (hk-prog-val (str hk-either-src "r = safeDiv 10 2\n") "r") + (list "Right" 5)) + +(hk-test + "safeDiv 7 0 = Left msg" + (hk-prog-val (str hk-either-src "r = safeDiv 7 0\n") "r") + (list "Left" "divide by zero")) + +(hk-test + "fromRight 0 (Right 42) = 42" + (hk-prog-val (str hk-either-src "r = fromRight 0 (Right 42)\n") "r") + 42) + +(hk-test + "fromRight 0 (Left msg) = 0" + (hk-prog-val (str hk-either-src "r = fromRight 0 (Left \"err\")\n") "r") + 0) + +(hk-test + "isRight (Right 1) = True" + (hk-prog-val (str hk-either-src "r = isRight (Right 1)\n") "r") + (list "True")) + +(hk-test + "isRight (Left x) = False" + (hk-prog-val (str hk-either-src "r = isRight (Left \"x\")\n") "r") + (list "False")) + +(hk-test + "isLeft (Left x) = True" + (hk-prog-val (str hk-either-src "r = isLeft (Left \"x\")\n") "r") + (list "True")) + +(hk-test + "isLeft (Right x) = False" + (hk-prog-val (str hk-either-src "r = isLeft (Right 1)\n") "r") + (list "False")) + +(hk-test + "mapRight double (Right 5) = Right 10" + (hk-prog-val (str hk-either-src "r = mapRight double (Right 5)\n") "r") + (list "Right" 10)) + +(hk-test + "mapRight double (Left e) = Left e" + (hk-prog-val (str hk-either-src "r = mapRight double (Left \"err\")\n") "r") + (list "Left" "err")) + +(hk-test + "chain safeDiv results" + (hk-prog-val (str hk-either-src "r = fromRight (-1) (safeDiv 20 4)\n") "r") + 5) + +(hk-test + "chain safeDiv error" + (hk-prog-val (str hk-either-src "r = fromRight (-1) (safeDiv 20 0)\n") "r") + -1) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-fib.sx b/lib/haskell/tests/program-fib.sx new file mode 100644 index 00000000..3271debc --- /dev/null +++ b/lib/haskell/tests/program-fib.sx @@ -0,0 +1,45 @@ +;; fib.hs — infinite Fibonacci stream classic program. +;; +;; The canonical artefact lives at lib/haskell/tests/programs/fib.hs. +;; The source is mirrored here as an SX string because the evaluator +;; doesn't have read-file in the default env. If you change one, keep +;; the other in sync — there's a runner-level cross-check against the +;; expected first-15 list. + +(define + hk-prog-val + (fn + (src name) + (hk-deep-force (get (hk-eval-program (hk-core src)) name)))) + +(define hk-as-list + (fn (xs) + (cond + ((and (list? xs) (= (first xs) "[]")) (list)) + ((and (list? xs) (= (first xs) ":")) + (cons (nth xs 1) (hk-as-list (nth xs 2)))) + (:else xs)))) + +(define + hk-fib-source + "zipPlus (x:xs) (y:ys) = x + y : zipPlus xs ys +zipPlus _ _ = [] +myFibs = 0 : 1 : zipPlus myFibs (tail myFibs) +result = take 15 myFibs +") + +(hk-test + "fib.hs — first 15 Fibonacci numbers" + (hk-as-list (hk-prog-val hk-fib-source "result")) + (list 0 1 1 2 3 5 8 13 21 34 55 89 144 233 377)) + +;; Spot-check that the user-defined zipPlus is also reachable +(hk-test + "fib.hs — zipPlus is a multi-clause user fn" + (hk-as-list + (hk-prog-val + (str hk-fib-source "extra = zipPlus [1, 2, 3] [10, 20, 30]\n") + "extra")) + (list 11 22 33)) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-fizzbuzz.sx b/lib/haskell/tests/program-fizzbuzz.sx new file mode 100644 index 00000000..2fa2870c --- /dev/null +++ b/lib/haskell/tests/program-fizzbuzz.sx @@ -0,0 +1,84 @@ +;; fizzbuzz.hs — classic FizzBuzz with guards. + +(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-fb-src + "fizzbuzz n\n | n `mod` 15 == 0 = \"FizzBuzz\"\n | n `mod` 3 == 0 = \"Fizz\"\n | n `mod` 5 == 0 = \"Buzz\"\n | otherwise = \"Other\"\n") + +(hk-test + "fizzbuzz 1 = Other" + (hk-prog-val (str hk-fb-src "r = fizzbuzz 1\n") "r") + "Other") + +(hk-test + "fizzbuzz 3 = Fizz" + (hk-prog-val (str hk-fb-src "r = fizzbuzz 3\n") "r") + "Fizz") + +(hk-test + "fizzbuzz 5 = Buzz" + (hk-prog-val (str hk-fb-src "r = fizzbuzz 5\n") "r") + "Buzz") + +(hk-test + "fizzbuzz 15 = FizzBuzz" + (hk-prog-val (str hk-fb-src "r = fizzbuzz 15\n") "r") + "FizzBuzz") + +(hk-test + "fizzbuzz 30 = FizzBuzz" + (hk-prog-val (str hk-fb-src "r = fizzbuzz 30\n") "r") + "FizzBuzz") + +(hk-test + "fizzbuzz 6 = Fizz" + (hk-prog-val (str hk-fb-src "r = fizzbuzz 6\n") "r") + "Fizz") + +(hk-test + "fizzbuzz 10 = Buzz" + (hk-prog-val (str hk-fb-src "r = fizzbuzz 10\n") "r") + "Buzz") + +(hk-test + "fizzbuzz 7 = Other" + (hk-prog-val (str hk-fb-src "r = fizzbuzz 7\n") "r") + "Other") + +(hk-test + "fizzbuzz 9 = Fizz" + (hk-prog-val (str hk-fb-src "r = fizzbuzz 9\n") "r") + "Fizz") + +(hk-test + "fizzbuzz 25 = Buzz" + (hk-prog-val (str hk-fb-src "r = fizzbuzz 25\n") "r") + "Buzz") + +(hk-test + "map fizzbuzz [1..5] starts Other" + (hk-as-list + (hk-prog-val (str hk-fb-src "r = map fizzbuzz [1,2,3,4,5]\n") "r")) + (list "Other" "Other" "Fizz" "Other" "Buzz")) + +(hk-test + "fizzbuzz 45 = FizzBuzz" + (hk-prog-val (str hk-fb-src "r = fizzbuzz 45\n") "r") + "FizzBuzz") + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-io.sx b/lib/haskell/tests/program-io.sx new file mode 100644 index 00000000..7494dbb9 --- /dev/null +++ b/lib/haskell/tests/program-io.sx @@ -0,0 +1,49 @@ +;; program-io.sx — tests for real IO monad (putStrLn, print, putStr). + +(hk-test + "putStrLn single line" + (hk-run-io "main = putStrLn \"hello\"") + (list "hello")) + +(hk-test + "putStrLn two lines via do" + (hk-run-io "main = do { putStrLn \"a\"; putStrLn \"b\" }") + (list "a" "b")) + +(hk-test "print Int" (hk-run-io "main = print 42") (list "42")) + +(hk-test "print Bool True" (hk-run-io "main = print True") (list "True")) + +(hk-test + "putStr collects string" + (hk-run-io "main = putStr \"hello\"") + (list "hello")) + +(hk-test + "do with let then putStrLn" + (hk-run-io "main = do\n let s = \"world\"\n putStrLn s") + (list "world")) + +(hk-test + "do sequence three lines" + (hk-run-io "main = do { putStrLn \"1\"; putStrLn \"2\"; putStrLn \"3\" }") + (list "1" "2" "3")) + +(hk-test + "print computed value" + (hk-run-io "main = print (6 * 7)") + (list "42")) + +(hk-test + "putStrLn returns IO unit" + (hk-deep-force (hk-run "main = putStrLn \"hi\"")) + (list "IO" (list "Tuple"))) + +(hk-test + "hk-run-io resets between calls" + (begin + (hk-run-io "main = putStrLn \"first\"") + (hk-run-io "main = putStrLn \"second\"")) + (list "second")) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-matrix.sx b/lib/haskell/tests/program-matrix.sx new file mode 100644 index 00000000..f44e9878 --- /dev/null +++ b/lib/haskell/tests/program-matrix.sx @@ -0,0 +1,84 @@ +;; matrix.hs — transpose and 2D list operations. + +(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-mat-src + "transpose [] = []\ntranspose ([] : _) = []\ntranspose xss = map head xss : transpose (map tail xss)\n\nmatAdd xss yss = zipWith (zipWith (+)) xss yss\n\ndiagonal [] = []\ndiagonal xss = head (head xss) : diagonal (map tail (tail xss))\n\nrowSum = map sum\ncolSum xss = map sum (transpose xss)\n") + +(hk-test + "transpose 2x2" + (hk-deep-force + (hk-prog-val (str hk-mat-src "r = transpose [[1,2],[3,4]]\n") "r")) + (list + ":" + (list ":" 1 (list ":" 3 (list "[]"))) + (list ":" (list ":" 2 (list ":" 4 (list "[]"))) (list "[]")))) + +(hk-test + "transpose 1x3" + (hk-deep-force + (hk-prog-val (str hk-mat-src "r = transpose [[1,2,3]]\n") "r")) + (list + ":" + (list ":" 1 (list "[]")) + (list + ":" + (list ":" 2 (list "[]")) + (list ":" (list ":" 3 (list "[]")) (list "[]"))))) + +(hk-test + "transpose empty = []" + (hk-as-list (hk-prog-val (str hk-mat-src "r = transpose []\n") "r")) + (list)) + +(hk-test + "rowSum [[1,2],[3,4]] = [3,7]" + (hk-as-list (hk-prog-val (str hk-mat-src "r = rowSum [[1,2],[3,4]]\n") "r")) + (list 3 7)) + +(hk-test + "colSum [[1,2],[3,4]] = [4,6]" + (hk-as-list (hk-prog-val (str hk-mat-src "r = colSum [[1,2],[3,4]]\n") "r")) + (list 4 6)) + +(hk-test + "matAdd [[1,2],[3,4]] [[5,6],[7,8]] = [[6,8],[10,12]]" + (hk-deep-force + (hk-prog-val + (str hk-mat-src "r = matAdd [[1,2],[3,4]] [[5,6],[7,8]]\n") + "r")) + (list + ":" + (list ":" 6 (list ":" 8 (list "[]"))) + (list ":" (list ":" 10 (list ":" 12 (list "[]"))) (list "[]")))) + +(hk-test + "diagonal [[1,2],[3,4]] = [1,4]" + (hk-as-list + (hk-prog-val (str hk-mat-src "r = diagonal [[1,2],[3,4]]\n") "r")) + (list 1 4)) + +(hk-test + "diagonal 3x3" + (hk-as-list + (hk-prog-val + (str hk-mat-src "r = diagonal [[1,2,3],[4,5,6],[7,8,9]]\n") + "r")) + (list 1 5 9)) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-maybe.sx b/lib/haskell/tests/program-maybe.sx new file mode 100644 index 00000000..547706b8 --- /dev/null +++ b/lib/haskell/tests/program-maybe.sx @@ -0,0 +1,83 @@ +;; maybe.hs — safe operations returning Maybe values. + +(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-maybe-src + "safeDiv _ 0 = Nothing\nsafeDiv x y = Just (x `div` y)\n\nsafeHead [] = Nothing\nsafeHead (x:_) = Just x\n\nfromMaybeZero Nothing = 0\nfromMaybeZero (Just x) = x\n\nmapMaybe _ Nothing = Nothing\nmapMaybe f (Just x) = Just (f x)\n\ndouble x = x * 2\n") + +(hk-test + "safeDiv 10 2 = Just 5" + (hk-prog-val (str hk-maybe-src "r = safeDiv 10 2\n") "r") + (list "Just" 5)) + +(hk-test + "safeDiv 7 0 = Nothing" + (hk-prog-val (str hk-maybe-src "r = safeDiv 7 0\n") "r") + (list "Nothing")) + +(hk-test + "safeHead [1,2,3] = Just 1" + (hk-prog-val (str hk-maybe-src "r = safeHead [1,2,3]\n") "r") + (list "Just" 1)) + +(hk-test + "safeHead [] = Nothing" + (hk-prog-val (str hk-maybe-src "r = safeHead []\n") "r") + (list "Nothing")) + +(hk-test + "fromMaybeZero Nothing = 0" + (hk-prog-val (str hk-maybe-src "r = fromMaybeZero Nothing\n") "r") + 0) + +(hk-test + "fromMaybeZero (Just 42) = 42" + (hk-prog-val (str hk-maybe-src "r = fromMaybeZero (Just 42)\n") "r") + 42) + +(hk-test + "mapMaybe double Nothing = Nothing" + (hk-prog-val (str hk-maybe-src "r = mapMaybe double Nothing\n") "r") + (list "Nothing")) + +(hk-test + "mapMaybe double (Just 5) = Just 10" + (hk-prog-val (str hk-maybe-src "r = mapMaybe double (Just 5)\n") "r") + (list "Just" 10)) + +(hk-test + "chain: fromMaybeZero (safeDiv 10 2) = 5" + (hk-prog-val (str hk-maybe-src "r = fromMaybeZero (safeDiv 10 2)\n") "r") + 5) + +(hk-test + "chain: fromMaybeZero (safeDiv 10 0) = 0" + (hk-prog-val (str hk-maybe-src "r = fromMaybeZero (safeDiv 10 0)\n") "r") + 0) + +(hk-test + "safeDiv 100 5 = Just 20" + (hk-prog-val (str hk-maybe-src "r = safeDiv 100 5\n") "r") + (list "Just" 20)) + +(hk-test + "mapMaybe double (safeDiv 6 2) = Just 6" + (hk-prog-val (str hk-maybe-src "r = mapMaybe double (safeDiv 6 2)\n") "r") + (list "Just" 6)) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-nqueens.sx b/lib/haskell/tests/program-nqueens.sx new file mode 100644 index 00000000..6b1ea587 --- /dev/null +++ b/lib/haskell/tests/program-nqueens.sx @@ -0,0 +1,38 @@ +;; nqueens.hs — n-queens solver via list comprehension + where. +;; +;; Also exercises: +;; - multi-clause let/where binding (go 0 = ...; go k = ...) +;; - list comprehensions (desugared to concatMap) +;; - abs (from Prelude) +;; - [1..n] finite range +;; +;; n=8 is too slow for a 60s timeout; n=4 and n=5 run in ~17s combined. + +(define + hk-prog-val + (fn + (src name) + (hk-deep-force (get (hk-eval-program (hk-core src)) name)))) + +(define + hk-nq-base + "queens n = go n + where + go 0 = [[]] + go k = [q:qs | qs <- go (k - 1), q <- [1..n], safe q qs] +safe q qs = check q qs 1 +check q [] _ = True +check q (c:cs) d = q /= c && abs (q - c) /= d && check q cs (d + 1) +") + +(hk-test + "nqueens: queens 4 has 2 solutions" + (hk-prog-val (str hk-nq-base "result = length (queens 4)\n") "result") + 2) + +(hk-test + "nqueens: queens 5 has 10 solutions" + (hk-prog-val (str hk-nq-base "result = length (queens 5)\n") "result") + 10) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-palindrome.sx b/lib/haskell/tests/program-palindrome.sx new file mode 100644 index 00000000..8fbd7b71 --- /dev/null +++ b/lib/haskell/tests/program-palindrome.sx @@ -0,0 +1,86 @@ +;; palindrome.hs — palindrome check via reverse comparison. + +(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-prog-val + (fn + (src name) + (hk-deep-force (get (hk-eval-program (hk-core src)) name)))) + +(define hk-pal-src "isPalindrome xs = xs == reverse xs\n") + +(hk-test + "isPalindrome empty" + (hk-prog-val (str hk-pal-src "r = isPalindrome []\n") "r") + (list "True")) + +(hk-test + "isPalindrome single" + (hk-prog-val (str hk-pal-src "r = isPalindrome [1]\n") "r") + (list "True")) + +(hk-test + "isPalindrome [1,2,1] True" + (hk-prog-val (str hk-pal-src "r = isPalindrome [1,2,1]\n") "r") + (list "True")) + +(hk-test + "isPalindrome [1,2,3] False" + (hk-prog-val (str hk-pal-src "r = isPalindrome [1,2,3]\n") "r") + (list "False")) + +(hk-test + "isPalindrome [1,2,2,1] True" + (hk-prog-val (str hk-pal-src "r = isPalindrome [1,2,2,1]\n") "r") + (list "True")) + +(hk-test + "isPalindrome [1,2,3,4] False" + (hk-prog-val (str hk-pal-src "r = isPalindrome [1,2,3,4]\n") "r") + (list "False")) + +(hk-test + "isPalindrome five odd True" + (hk-prog-val (str hk-pal-src "r = isPalindrome [1,2,3,2,1]\n") "r") + (list "True")) + +(hk-test + "isPalindrome racecar True" + (hk-prog-val (str hk-pal-src "r = isPalindrome \"racecar\"\n") "r") + (list "True")) + +(hk-test + "isPalindrome hello False" + (hk-prog-val (str hk-pal-src "r = isPalindrome \"hello\"\n") "r") + (list "False")) + +(hk-test + "isPalindrome a True" + (hk-prog-val (str hk-pal-src "r = isPalindrome \"a\"\n") "r") + (list "True")) + +(hk-test + "isPalindrome madam True" + (hk-prog-val (str hk-pal-src "r = isPalindrome \"madam\"\n") "r") + (list "True")) + +(hk-test + "not-palindrome via map" + (hk-as-list + (hk-prog-val + (str hk-pal-src "r = filter isPalindrome [[1],[1,2],[1,2,1],[2,3]]\n") + "r")) + (list + (list ":" 1 (list "[]")) + (list ":" 1 (list ":" 2 (list ":" 1 (list "[]")))))) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-powers.sx b/lib/haskell/tests/program-powers.sx new file mode 100644 index 00000000..83c16682 --- /dev/null +++ b/lib/haskell/tests/program-powers.sx @@ -0,0 +1,78 @@ +;; powers.hs — integer exponentiation and powers-of-2 checks. + +(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-pow-src + "pow _ 0 = 1\npow base n = base * pow base (n - 1)\n\npowers base k = map (pow base) [0..k]\n\nisPowerOf2 n\n | n <= 0 = False\n | n == 1 = True\n | otherwise = n `mod` 2 == 0 && isPowerOf2 (n `div` 2)\n\nlog2 1 = 0\nlog2 n = 1 + log2 (n `div` 2)\n") + +(hk-test "pow 2 0 = 1" (hk-prog-val (str hk-pow-src "r = pow 2 0\n") "r") 1) + +(hk-test "pow 2 1 = 2" (hk-prog-val (str hk-pow-src "r = pow 2 1\n") "r") 2) + +(hk-test + "pow 2 8 = 256" + (hk-prog-val (str hk-pow-src "r = pow 2 8\n") "r") + 256) + +(hk-test "pow 3 4 = 81" (hk-prog-val (str hk-pow-src "r = pow 3 4\n") "r") 81) + +(hk-test + "pow 10 3 = 1000" + (hk-prog-val (str hk-pow-src "r = pow 10 3\n") "r") + 1000) + +(hk-test + "powers 2 4 = [1,2,4,8,16]" + (hk-as-list (hk-prog-val (str hk-pow-src "r = powers 2 4\n") "r")) + (list 1 2 4 8 16)) + +(hk-test + "powers 3 3 = [1,3,9,27]" + (hk-as-list (hk-prog-val (str hk-pow-src "r = powers 3 3\n") "r")) + (list 1 3 9 27)) + +(hk-test + "isPowerOf2 1 = True" + (hk-prog-val (str hk-pow-src "r = isPowerOf2 1\n") "r") + (list "True")) + +(hk-test + "isPowerOf2 8 = True" + (hk-prog-val (str hk-pow-src "r = isPowerOf2 8\n") "r") + (list "True")) + +(hk-test + "isPowerOf2 6 = False" + (hk-prog-val (str hk-pow-src "r = isPowerOf2 6\n") "r") + (list "False")) + +(hk-test + "isPowerOf2 0 = False" + (hk-prog-val (str hk-pow-src "r = isPowerOf2 0\n") "r") + (list "False")) + +(hk-test "log2 1 = 0" (hk-prog-val (str hk-pow-src "r = log2 1\n") "r") 0) + +(hk-test "log2 8 = 3" (hk-prog-val (str hk-pow-src "r = log2 8\n") "r") 3) + +(hk-test + "log2 1024 = 10" + (hk-prog-val (str hk-pow-src "r = log2 1024\n") "r") + 10) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-primes.sx b/lib/haskell/tests/program-primes.sx new file mode 100644 index 00000000..a5ae2c18 --- /dev/null +++ b/lib/haskell/tests/program-primes.sx @@ -0,0 +1,83 @@ +;; primes.hs — primality testing via trial division with where clauses. + +(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-primes-src + "isPrime n\n | n < 2 = False\n | n == 2 = True\n | otherwise = all notDiv [2..n-1]\n where notDiv d = n `mod` d /= 0\n\nprimes20 = filter isPrime [2..20]\n\nnextPrime n = head (filter isPrime [n+1..])\n\ncountPrimes lo hi = length (filter isPrime [lo..hi])\n") + +(hk-test + "isPrime 2 = True" + (hk-prog-val (str hk-primes-src "r = isPrime 2\n") "r") + (list "True")) + +(hk-test + "isPrime 3 = True" + (hk-prog-val (str hk-primes-src "r = isPrime 3\n") "r") + (list "True")) + +(hk-test + "isPrime 4 = False" + (hk-prog-val (str hk-primes-src "r = isPrime 4\n") "r") + (list "False")) + +(hk-test + "isPrime 5 = True" + (hk-prog-val (str hk-primes-src "r = isPrime 5\n") "r") + (list "True")) + +(hk-test + "isPrime 1 = False" + (hk-prog-val (str hk-primes-src "r = isPrime 1\n") "r") + (list "False")) + +(hk-test + "isPrime 0 = False" + (hk-prog-val (str hk-primes-src "r = isPrime 0\n") "r") + (list "False")) + +(hk-test + "isPrime 7 = True" + (hk-prog-val (str hk-primes-src "r = isPrime 7\n") "r") + (list "True")) + +(hk-test + "isPrime 9 = False" + (hk-prog-val (str hk-primes-src "r = isPrime 9\n") "r") + (list "False")) + +(hk-test + "isPrime 11 = True" + (hk-prog-val (str hk-primes-src "r = isPrime 11\n") "r") + (list "True")) + +(hk-test + "primes20 = [2,3,5,7,11,13,17,19]" + (hk-as-list (hk-prog-val (str hk-primes-src "r = primes20\n") "r")) + (list 2 3 5 7 11 13 17 19)) + +(hk-test + "countPrimes 1 10 = 4" + (hk-prog-val (str hk-primes-src "r = countPrimes 1 10\n") "r") + 4) + +(hk-test + "nextPrime 10 = 11" + (hk-prog-val (str hk-primes-src "r = nextPrime 10\n") "r") + 11) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-quicksort.sx b/lib/haskell/tests/program-quicksort.sx new file mode 100644 index 00000000..2bea6ad7 --- /dev/null +++ b/lib/haskell/tests/program-quicksort.sx @@ -0,0 +1,65 @@ +;; quicksort.hs — naive functional quicksort. + +(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-prog-val + (fn + (src name) + (hk-deep-force (get (hk-eval-program (hk-core src)) name)))) + +(define + hk-qs-source + "qsort [] = [] +qsort (x:xs) = qsort smaller ++ [x] ++ qsort larger + where + smaller = filter (< x) xs + larger = filter (>= x) xs +result = qsort [3, 1, 4, 1, 5, 9, 2, 6, 5, 3, 5] +") + +(hk-test + "quicksort.hs — sort a list of ints" + (hk-as-list (hk-prog-val hk-qs-source "result")) + (list 1 1 2 3 3 4 5 5 5 6 9)) + +(hk-test + "quicksort.hs — empty list" + (hk-as-list + (hk-prog-val + (str hk-qs-source "e = qsort []\n") + "e")) + (list)) + +(hk-test + "quicksort.hs — singleton" + (hk-as-list + (hk-prog-val + (str hk-qs-source "s = qsort [42]\n") + "s")) + (list 42)) + +(hk-test + "quicksort.hs — already sorted" + (hk-as-list + (hk-prog-val + (str hk-qs-source "asc = qsort [1, 2, 3, 4, 5]\n") + "asc")) + (list 1 2 3 4 5)) + +(hk-test + "quicksort.hs — reverse sorted" + (hk-as-list + (hk-prog-val + (str hk-qs-source "desc = qsort [5, 4, 3, 2, 1]\n") + "desc")) + (list 1 2 3 4 5)) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-roman.sx b/lib/haskell/tests/program-roman.sx new file mode 100644 index 00000000..d1784863 --- /dev/null +++ b/lib/haskell/tests/program-roman.sx @@ -0,0 +1,83 @@ +;; roman.hs — convert integers to Roman numerals with guards + ++. + +(define + hk-prog-val + (fn + (src name) + (hk-deep-force (get (hk-eval-program (hk-core src)) name)))) + +(define + hk-rom-src + "toRoman 0 = \"\"\ntoRoman n\n | n >= 1000 = \"M\" ++ toRoman (n - 1000)\n | n >= 900 = \"CM\" ++ toRoman (n - 900)\n | n >= 500 = \"D\" ++ toRoman (n - 500)\n | n >= 400 = \"CD\" ++ toRoman (n - 400)\n | n >= 100 = \"C\" ++ toRoman (n - 100)\n | n >= 90 = \"XC\" ++ toRoman (n - 90)\n | n >= 50 = \"L\" ++ toRoman (n - 50)\n | n >= 40 = \"XL\" ++ toRoman (n - 40)\n | n >= 10 = \"X\" ++ toRoman (n - 10)\n | n >= 9 = \"IX\" ++ toRoman (n - 9)\n | n >= 5 = \"V\" ++ toRoman (n - 5)\n | n >= 4 = \"IV\" ++ toRoman (n - 4)\n | otherwise = \"I\" ++ toRoman (n - 1)\n") + +(hk-test + "toRoman 1 = I" + (hk-prog-val (str hk-rom-src "r = toRoman 1\n") "r") + "I") + +(hk-test + "toRoman 4 = IV" + (hk-prog-val (str hk-rom-src "r = toRoman 4\n") "r") + "IV") + +(hk-test + "toRoman 5 = V" + (hk-prog-val (str hk-rom-src "r = toRoman 5\n") "r") + "V") + +(hk-test + "toRoman 9 = IX" + (hk-prog-val (str hk-rom-src "r = toRoman 9\n") "r") + "IX") + +(hk-test + "toRoman 10 = X" + (hk-prog-val (str hk-rom-src "r = toRoman 10\n") "r") + "X") + +(hk-test + "toRoman 14 = XIV" + (hk-prog-val (str hk-rom-src "r = toRoman 14\n") "r") + "XIV") + +(hk-test + "toRoman 40 = XL" + (hk-prog-val (str hk-rom-src "r = toRoman 40\n") "r") + "XL") + +(hk-test + "toRoman 50 = L" + (hk-prog-val (str hk-rom-src "r = toRoman 50\n") "r") + "L") + +(hk-test + "toRoman 90 = XC" + (hk-prog-val (str hk-rom-src "r = toRoman 90\n") "r") + "XC") + +(hk-test + "toRoman 100 = C" + (hk-prog-val (str hk-rom-src "r = toRoman 100\n") "r") + "C") + +(hk-test + "toRoman 400 = CD" + (hk-prog-val (str hk-rom-src "r = toRoman 400\n") "r") + "CD") + +(hk-test + "toRoman 1000 = M" + (hk-prog-val (str hk-rom-src "r = toRoman 1000\n") "r") + "M") + +(hk-test + "toRoman 1994 = MCMXCIV" + (hk-prog-val (str hk-rom-src "r = toRoman 1994\n") "r") + "MCMXCIV") + +(hk-test + "toRoman 58 = LVIII" + (hk-prog-val (str hk-rom-src "r = toRoman 58\n") "r") + "LVIII") + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-sieve.sx b/lib/haskell/tests/program-sieve.sx new file mode 100644 index 00000000..3c2467b4 --- /dev/null +++ b/lib/haskell/tests/program-sieve.sx @@ -0,0 +1,48 @@ +;; sieve.hs — lazy sieve of Eratosthenes. +;; +;; The canonical artefact lives at lib/haskell/tests/programs/sieve.hs. +;; Mirrored here as an SX string because the default eval env has no +;; read-file. Uses filter + backtick `mod` + lazy [2..] — all of which +;; are now wired in via Phase 3 + the mod/div additions to hk-binop. + +(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-prog-val + (fn + (src name) + (hk-deep-force (get (hk-eval-program (hk-core src)) name)))) + +(define + hk-sieve-source + "sieve (p:xs) = p : sieve (filter (\\x -> x `mod` p /= 0) xs) +sieve [] = [] +primes = sieve [2..] +result = take 10 primes +") + +(hk-test + "sieve.hs — first 10 primes" + (hk-as-list (hk-prog-val hk-sieve-source "result")) + (list 2 3 5 7 11 13 17 19 23 29)) + +(hk-test + "sieve.hs — 20th prime is 71" + (nth + (hk-as-list + (hk-prog-val + (str + hk-sieve-source + "result20 = take 20 primes\n") + "result20")) + 19) + 71) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-wordcount.sx b/lib/haskell/tests/program-wordcount.sx new file mode 100644 index 00000000..fb3945c5 --- /dev/null +++ b/lib/haskell/tests/program-wordcount.sx @@ -0,0 +1,74 @@ +;; wordcount.hs — word and line counting via string splitting. + +(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-wc-src + "wordCount s = length (words s)\nlineCount s = length (lines s)\ncharCount = length\n\nlongestWord s = foldl longer \"\" (words s)\n where longer a b = if length a >= length b then a else b\n\nshortestWord s = foldl shorter (head (words s)) (words s)\n where shorter a b = if length a <= length b then a else b\n\nuniqueWords s = nub (words s)\n") + +(hk-test + "wordCount single word" + (hk-prog-val (str hk-wc-src "r = wordCount \"hello\"\n") "r") + 1) + +(hk-test + "wordCount two words" + (hk-prog-val (str hk-wc-src "r = wordCount \"hello world\"\n") "r") + 2) + +(hk-test + "wordCount with extra spaces" + (hk-prog-val (str hk-wc-src "r = wordCount \" foo bar \"\n") "r") + 2) + +(hk-test + "wordCount empty = 0" + (hk-prog-val (str hk-wc-src "r = wordCount \"\"\n") "r") + 0) + +(hk-test + "lineCount one line" + (hk-prog-val (str hk-wc-src "r = lineCount \"hello\"\n") "r") + 1) + +(hk-test + "lineCount two lines" + (hk-prog-val (str hk-wc-src "r = lineCount \"a\\nb\"\n") "r") + 2) + +(hk-test + "charCount \"hello\" = 5" + (hk-prog-val (str hk-wc-src "r = charCount \"hello\"\n") "r") + 5) + +(hk-test + "charCount empty = 0" + (hk-prog-val (str hk-wc-src "r = charCount \"\"\n") "r") + 0) + +(hk-test + "longestWord picks longest" + (hk-prog-val (str hk-wc-src "r = longestWord \"a bb ccc\"\n") "r") + "ccc") + +(hk-test + "uniqueWords removes duplicates" + (hk-as-list + (hk-prog-val (str hk-wc-src "r = uniqueWords \"a b a c b\"\n") "r")) + (list "a" "b" "c")) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/program-zipwith.sx b/lib/haskell/tests/program-zipwith.sx new file mode 100644 index 00000000..b714140e --- /dev/null +++ b/lib/haskell/tests/program-zipwith.sx @@ -0,0 +1,74 @@ +;; zipwith.hs — zip, zipWith, unzip operations. + +(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-zip-src + "addPair (x, y) = x + y\npairSum xs ys = map addPair (zip xs ys)\n\nscaleBy k xs = map (\\x -> x * k) xs\n\ndotProduct xs ys = sum (zipWith (*) xs ys)\n\nzipIndex xs = zip [0..length xs - 1] xs\n") + +(hk-test + "zip two lists" + (hk-as-list (hk-prog-val (str hk-zip-src "r = zip [1,2,3] [4,5,6]\n") "r")) + (list (list "Tuple" 1 4) (list "Tuple" 2 5) (list "Tuple" 3 6))) + +(hk-test + "zip unequal lengths — shorter wins" + (hk-as-list (hk-prog-val (str hk-zip-src "r = zip [1,2] [10,20,30]\n") "r")) + (list (list "Tuple" 1 10) (list "Tuple" 2 20))) + +(hk-test + "zipWith (+)" + (hk-as-list + (hk-prog-val (str hk-zip-src "r = zipWith (+) [1,2,3] [10,20,30]\n") "r")) + (list 11 22 33)) + +(hk-test + "zipWith (*)" + (hk-as-list + (hk-prog-val (str hk-zip-src "r = zipWith (*) [2,3,4] [10,10,10]\n") "r")) + (list 20 30 40)) + +(hk-test + "dotProduct [1,2,3] [4,5,6] = 32" + (hk-prog-val (str hk-zip-src "r = dotProduct [1,2,3] [4,5,6]\n") "r") + 32) + +(hk-test + "dotProduct unit vectors = 0" + (hk-prog-val (str hk-zip-src "r = dotProduct [1,0] [0,1]\n") "r") + 0) + +(hk-test + "pairSum adds element-wise" + (hk-as-list + (hk-prog-val (str hk-zip-src "r = pairSum [1,2,3] [4,5,6]\n") "r")) + (list 5 7 9)) + +(hk-test + "unzip separates pairs" + (hk-prog-val (str hk-zip-src "r = unzip [(1,2),(3,4),(5,6)]\n") "r") + (list + "Tuple" + (list ":" 1 (list ":" 3 (list ":" 5 (list "[]")))) + (list ":" 2 (list ":" 4 (list ":" 6 (list "[]")))))) + +(hk-test + "zip empty = []" + (hk-as-list (hk-prog-val (str hk-zip-src "r = zip [] [1,2,3]\n") "r")) + (list)) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/programs/calculator.hs b/lib/haskell/tests/programs/calculator.hs new file mode 100644 index 00000000..d6ddcb42 --- /dev/null +++ b/lib/haskell/tests/programs/calculator.hs @@ -0,0 +1,40 @@ +-- calculator.hs — recursive descent expression evaluator. +-- +-- Tokens are represented as an ADT; the parser threads a [Token] list +-- through a custom Result type so pattern matching can destructure the +-- pair (value, remaining-tokens) directly inside constructor patterns. +-- +-- Operator precedence: * and / bind tighter than + and -. +-- All operators are left-associative. + +data Token = TNum Int | TOp String +data Result = R Int [Token] + +getV (R v _) = v +getR (R _ r) = r + +eval ts = getV (parseExpr ts) + +parseExpr ts = parseExprRest (parseTerm ts) + +parseExprRest (R v (TOp "+":rest)) = + let t = parseTerm rest + in parseExprRest (R (v + getV t) (getR t)) +parseExprRest (R v (TOp "-":rest)) = + let t = parseTerm rest + in parseExprRest (R (v - getV t) (getR t)) +parseExprRest r = r + +parseTerm ts = parseTermRest (parseFactor ts) + +parseTermRest (R v (TOp "*":rest)) = + let t = parseFactor rest + in parseTermRest (R (v * getV t) (getR t)) +parseTermRest (R v (TOp "/":rest)) = + let t = parseFactor rest + in parseTermRest (R (v `div` getV t) (getR t)) +parseTermRest r = r + +parseFactor (TNum n:rest) = R n rest + +result = eval [TNum 2, TOp "+", TNum 3, TOp "*", TNum 4] diff --git a/lib/haskell/tests/programs/fib.hs b/lib/haskell/tests/programs/fib.hs new file mode 100644 index 00000000..beb7ab8e --- /dev/null +++ b/lib/haskell/tests/programs/fib.hs @@ -0,0 +1,15 @@ +-- fib.hs — infinite Fibonacci stream. +-- +-- The classic two-line definition: `fibs` is a self-referential +-- lazy list built by zipping itself with its own tail, summing the +-- pair at each step. Without lazy `:` (cons cell with thunked head +-- and tail) this would diverge before producing any output; with +-- it, `take 15 fibs` evaluates exactly as much of the spine as +-- demanded. + +zipPlus (x:xs) (y:ys) = x + y : zipPlus xs ys +zipPlus _ _ = [] + +myFibs = 0 : 1 : zipPlus myFibs (tail myFibs) + +result = take 15 myFibs diff --git a/lib/haskell/tests/programs/nqueens.hs b/lib/haskell/tests/programs/nqueens.hs new file mode 100644 index 00000000..3246858e --- /dev/null +++ b/lib/haskell/tests/programs/nqueens.hs @@ -0,0 +1,18 @@ +-- nqueens.hs — n-queens backtracking solver. +-- +-- `queens n` returns all solutions as lists of column positions, +-- one per row. Each call to `go k` extends all partial `(k-1)`-row +-- solutions by one safe queen, using a list comprehension whose guard +-- checks the new queen against all already-placed queens. + +queens n = go n + where + go 0 = [[]] + go k = [q:qs | qs <- go (k - 1), q <- [1..n], safe q qs] + +safe q qs = check q qs 1 + +check q [] _ = True +check q (c:cs) d = q /= c && abs (q - c) /= d && check q cs (d + 1) + +result = length (queens 8) diff --git a/lib/haskell/tests/programs/quicksort.hs b/lib/haskell/tests/programs/quicksort.hs new file mode 100644 index 00000000..11d12fc7 --- /dev/null +++ b/lib/haskell/tests/programs/quicksort.hs @@ -0,0 +1,12 @@ +-- quicksort.hs — naive functional quicksort. +-- +-- Partition by pivot, recurse on each half, concatenate. +-- Uses right sections `(< x)` and `(>= x)` with filter. + +qsort [] = [] +qsort (x:xs) = qsort smaller ++ [x] ++ qsort larger + where + smaller = filter (< x) xs + larger = filter (>= x) xs + +result = qsort [3, 1, 4, 1, 5, 9, 2, 6, 5, 3, 5] diff --git a/lib/haskell/tests/programs/sieve.hs b/lib/haskell/tests/programs/sieve.hs new file mode 100644 index 00000000..f1ac4ef8 --- /dev/null +++ b/lib/haskell/tests/programs/sieve.hs @@ -0,0 +1,13 @@ +-- sieve.hs — lazy sieve of Eratosthenes. +-- +-- Each recursive call to `sieve` consumes one prime `p` off the front +-- of the input stream and produces an infinite stream of composites +-- filtered out via `filter`. Because cons is lazy, only as much of +-- the stream is forced as demanded by `take`. + +sieve (p:xs) = p : sieve (filter (\x -> x `mod` p /= 0) xs) +sieve [] = [] + +primes = sieve [2..] + +result = take 10 primes diff --git a/lib/haskell/tests/runtime.sx b/lib/haskell/tests/runtime.sx index 02ae77c0..45e306f7 100644 --- a/lib/haskell/tests/runtime.sx +++ b/lib/haskell/tests/runtime.sx @@ -1,451 +1,127 @@ -;; lib/haskell/tests/runtime.sx — smoke-tests for lib/haskell/runtime.sx -;; -;; Uses the same hk-test framework as tests/parse.sx. -;; Loaded by test.sh after: tokenizer.sx + runtime.sx are pre-loaded. +;; 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). -;; --------------------------------------------------------------------------- -;; Test framework boilerplate (mirrors parse.sx) -;; --------------------------------------------------------------------------- +;; ── 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) -(define hk-test-pass 0) -(define hk-test-fail 0) -(define hk-test-fails (list)) +(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") -(define - (hk-test name actual expected) - (if - (= 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})))) +;; ── 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) -;; --------------------------------------------------------------------------- -;; 1. Numeric type class helpers -;; --------------------------------------------------------------------------- - -(hk-test "is-integer? int" (hk-is-integer? 42) true) -(hk-test "is-integer? float" (hk-is-integer? 1.5) false) -(hk-test "is-float? float" (hk-is-float? 3.14) true) -(hk-test "is-float? int" (hk-is-float? 3) false) -(hk-test "is-num? int" (hk-is-num? 10) true) -(hk-test "is-num? float" (hk-is-num? 1) true) - -(hk-test "to-float" (hk-to-float 5) 5) -(hk-test "to-integer trunc" (hk-to-integer 3.7) 3) - -(hk-test "div pos pos" (hk-div 7 2) 3) -(hk-test "div neg pos" (hk-div -7 2) -4) -(hk-test "div pos neg" (hk-div 7 -2) -4) -(hk-test "div neg neg" (hk-div -7 -2) 3) -(hk-test "div exact" (hk-div 6 2) 3) - -(hk-test "mod pos pos" (hk-mod 10 3) 1) -(hk-test "mod neg pos" (hk-mod -7 3) 2) -(hk-test "rem pos pos" (hk-rem 10 3) 1) -(hk-test "rem neg pos" (hk-rem -7 3) -1) - -(hk-test "abs pos" (hk-abs 5) 5) -(hk-test "abs neg" (hk-abs -5) 5) -(hk-test "signum pos" (hk-signum 42) 1) -(hk-test "signum neg" (hk-signum -7) -1) -(hk-test "signum zero" (hk-signum 0) 0) - -(hk-test "gcd" (hk-gcd 12 8) 4) -(hk-test "lcm" (hk-lcm 4 6) 12) -(hk-test "even?" (hk-even? 4) true) -(hk-test "even? odd" (hk-even? 3) false) -(hk-test "odd?" (hk-odd? 7) true) - -;; --------------------------------------------------------------------------- -;; 2. Rational numbers -;; --------------------------------------------------------------------------- - -(let - ((r (hk-make-rational 1 2))) +;; ── data MyBool = Yes | No ── +(hk-test + "register simple data" (do - (hk-test "rational?" (hk-rational? r) true) - (hk-test "numerator" (hk-numerator r) 1) - (hk-test "denominator" (hk-denominator r) 2))) + (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")) -(let - ((r (hk-make-rational 2 4))) +;; ── data Maybe a = Nothing | Just a ── +(hk-test + "register Maybe" (do - (hk-test "rat normalise num" (hk-numerator r) 1) - (hk-test "rat normalise den" (hk-denominator r) 2))) + (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")) -(let - ((sum (hk-rational-add (hk-make-rational 1 2) (hk-make-rational 1 3)))) +;; ── data Either a b = Left a | Right b ── +(hk-test + "register Either" (do - (hk-test "rat-add num" (hk-numerator sum) 5) - (hk-test "rat-add den" (hk-denominator sum) 6))) + (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 - "rat-to-float" - (hk-rational-to-float (hk-make-rational 1 2)) - 0.5) -(hk-test "rational? int" (hk-rational? 42) false) - -;; --------------------------------------------------------------------------- -;; 3. Lazy evaluation (promises via SX delay) -;; --------------------------------------------------------------------------- - -(let - ((p (delay 42))) - (hk-test "force promise" (hk-force p) 42)) - -(hk-test "force non-promise" (hk-force 99) 99) - -;; --------------------------------------------------------------------------- -;; 4. Char utilities — compare via hk-ord to avoid = on char type -;; --------------------------------------------------------------------------- - -(hk-test "ord A" (hk-ord (integer->char 65)) 65) -(hk-test "chr 65" (hk-ord (hk-chr 65)) 65) -(hk-test "is-alpha? A" (hk-is-alpha? (integer->char 65)) true) -(hk-test "is-alpha? 0" (hk-is-alpha? (integer->char 48)) false) -(hk-test "is-digit? 5" (hk-is-digit? (integer->char 53)) true) -(hk-test "is-digit? A" (hk-is-digit? (integer->char 65)) false) -(hk-test "is-upper? A" (hk-is-upper? (integer->char 65)) true) -(hk-test "is-upper? a" (hk-is-upper? (integer->char 97)) false) -(hk-test "is-lower? a" (hk-is-lower? (integer->char 97)) true) -(hk-test "is-space? spc" (hk-is-space? (integer->char 32)) true) -(hk-test "is-space? A" (hk-is-space? (integer->char 65)) false) -(hk-test - "to-upper a" - (hk-ord (hk-to-upper (integer->char 97))) - 65) -(hk-test - "to-lower A" - (hk-ord (hk-to-lower (integer->char 65))) - 97) -(hk-test - "digit-to-int 0" - (hk-digit-to-int (integer->char 48)) - 0) -(hk-test - "digit-to-int 9" - (hk-digit-to-int (integer->char 57)) - 9) -(hk-test - "digit-to-int a" - (hk-digit-to-int (integer->char 97)) - 10) -(hk-test - "digit-to-int F" - (hk-digit-to-int (integer->char 70)) - 15) -(hk-test "int-to-digit 0" (hk-ord (hk-int-to-digit 0)) 48) -(hk-test "int-to-digit 10" (hk-ord (hk-int-to-digit 10)) 97) - -;; --------------------------------------------------------------------------- -;; 5. Data.Set -;; --------------------------------------------------------------------------- - -(hk-test "set-empty is set?" (hk-set? (hk-set-empty)) true) -(hk-test "set-null? empty" (hk-set-null? (hk-set-empty)) true) - -(let - ((s (hk-set-singleton 42))) + "register recursive Tree" (do - (hk-test "singleton member" (hk-set-member? 42 s) true) - (hk-test "singleton size" (hk-set-size s) 1))) + (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")) -(let - ((s (hk-set-from-list (list 1 2 3)))) +;; ── newtype ── +(hk-test + "register newtype" (do - (hk-test "from-list member" (hk-set-member? 2 s) true) - (hk-test "from-list absent" (hk-set-member? 9 s) false) - (hk-test "from-list size" (hk-set-size s) 3))) + (hk-load-source! "newtype Age = MkAge Int") + (list + (hk-con-arity "MkAge") + (hk-con-type "MkAge"))) + (list 1 "Age")) -;; --------------------------------------------------------------------------- -;; 6. Data.List -;; --------------------------------------------------------------------------- +;; ── 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")) -(hk-test "head" (hk-head (list 1 2 3)) 1) +;; ── Inside a module header ── (hk-test - "tail length" - (len (hk-tail (list 1 2 3))) - 2) -(hk-test "null? empty" (hk-null? (list)) true) -(hk-test "null? non-empty" (hk-null? (list 1)) false) -(hk-test - "length" - (hk-length (list 1 2 3)) - 3) + "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 - "take 2" - (hk-take 2 (list 1 2 3)) - (list 1 2)) -(hk-test "take 0" (hk-take 0 (list 1 2)) (list)) -(hk-test - "take overflow" - (hk-take 5 (list 1 2)) - (list 1 2)) -(hk-test - "drop 1" - (hk-drop 1 (list 1 2 3)) - (list 2 3)) -(hk-test - "drop 0" - (hk-drop 0 (list 1 2)) - (list 1 2)) - -(hk-test - "take-while" - (hk-take-while - (fn (x) (< x 3)) - (list 1 2 3 4)) - (list 1 2)) -(hk-test - "drop-while" - (hk-drop-while - (fn (x) (< x 3)) - (list 1 2 3 4)) - (list 3 4)) - -(hk-test - "zip" - (hk-zip (list 1 2) (list 3 4)) - (list (list 1 3) (list 2 4))) -(hk-test - "zip uneven" - (hk-zip - (list 1 2 3) - (list 4 5)) - (list (list 1 4) (list 2 5))) - -(hk-test - "zip-with +" - (hk-zip-with - + - (list 1 2 3) - (list 10 20 30)) - (list 11 22 33)) - -(hk-test - "unzip fst" - (first - (hk-unzip - (list (list 1 3) (list 2 4)))) - (list 1 2)) -(hk-test - "unzip snd" - (nth - (hk-unzip - (list (list 1 3) (list 2 4))) - 1) - (list 3 4)) - -(hk-test - "elem hit" - (hk-elem 2 (list 1 2 3)) - true) -(hk-test - "elem miss" - (hk-elem 9 (list 1 2 3)) + "program with only fun-decl leaves registry unchanged for that name" + (do + (hk-load-source! "myFunctionNotACon x = x + 1") + (hk-is-con? "myFunctionNotACon")) false) -(hk-test - "not-elem" - (hk-not-elem 9 (list 1 2 3)) - true) +;; ── Re-registering overwrites (last wins) ── (hk-test - "nub" - (hk-nub (list 1 2 1 3 2)) - (list 1 2 3)) + "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) -(hk-test - "sum" - (hk-sum (list 1 2 3 4)) - 10) -(hk-test - "product" - (hk-product (list 1 2 3 4)) - 24) -(hk-test - "maximum" - (hk-maximum (list 3 1 4 1 5)) - 5) -(hk-test - "minimum" - (hk-minimum (list 3 1 4 1 5)) - 1) - -(hk-test - "concat" - (hk-concat - (list (list 1 2) (list 3 4))) - (list 1 2 3 4)) -(hk-test - "concat-map" - (hk-concat-map - (fn (x) (list x (* x x))) - (list 1 2 3)) - (list 1 1 2 4 3 9)) - -(hk-test - "sort" - (hk-sort (list 3 1 4 1 5)) - (list 1 1 3 4 5)) -(hk-test - "replicate" - (hk-replicate 3 0) - (list 0 0 0)) -(hk-test "replicate 0" (hk-replicate 0 99) (list)) - -(hk-test - "intersperse" - (hk-intersperse 0 (list 1 2 3)) - (list 1 0 2 0 3)) -(hk-test - "intersperse 1" - (hk-intersperse 0 (list 1)) - (list 1)) -(hk-test "intersperse empty" (hk-intersperse 0 (list)) (list)) - -(hk-test - "span" - (hk-span - (fn (x) (< x 3)) - (list 1 2 3 4)) - (list (list 1 2) (list 3 4))) -(hk-test - "break" - (hk-break - (fn (x) (>= x 3)) - (list 1 2 3 4)) - (list (list 1 2) (list 3 4))) - -(hk-test - "foldl" - (hk-foldl - (fn (a b) (- a b)) - 10 - (list 1 2 3)) - 4) -(hk-test - "foldr" - (hk-foldr cons (list) (list 1 2 3)) - (list 1 2 3)) - -(hk-test - "scanl" - (hk-scanl + 0 (list 1 2 3)) - (list 0 1 3 6)) - -;; --------------------------------------------------------------------------- -;; 7. Maybe / Either -;; --------------------------------------------------------------------------- - -(hk-test "nothing is-nothing?" (hk-is-nothing? hk-nothing) true) -(hk-test "nothing is-just?" (hk-is-just? hk-nothing) false) -(hk-test "just is-just?" (hk-is-just? (hk-just 42)) true) -(hk-test "just is-nothing?" (hk-is-nothing? (hk-just 42)) false) -(hk-test "from-just" (hk-from-just (hk-just 99)) 99) -(hk-test - "from-maybe nothing" - (hk-from-maybe 0 hk-nothing) - 0) -(hk-test - "from-maybe just" - (hk-from-maybe 0 (hk-just 42)) - 42) -(hk-test - "maybe nothing" - (hk-maybe 0 (fn (x) (* x 2)) hk-nothing) - 0) -(hk-test - "maybe just" - (hk-maybe 0 (fn (x) (* x 2)) (hk-just 5)) - 10) - -(hk-test "left is-left?" (hk-is-left? (hk-left "e")) true) -(hk-test "right is-right?" (hk-is-right? (hk-right 42)) true) -(hk-test "from-right" (hk-from-right (hk-right 7)) 7) -(hk-test - "either left" - (hk-either (fn (x) (str "L" x)) (fn (x) (str "R" x)) (hk-left "err")) - "Lerr") -(hk-test - "either right" - (hk-either - (fn (x) (str "L" x)) - (fn (x) (str "R" x)) - (hk-right 42)) - "R42") - -;; --------------------------------------------------------------------------- -;; 8. Tuples -;; --------------------------------------------------------------------------- - -(hk-test "pair" (hk-pair 1 2) (list 1 2)) -(hk-test "fst" (hk-fst (hk-pair 3 4)) 3) -(hk-test "snd" (hk-snd (hk-pair 3 4)) 4) -(hk-test - "triple" - (hk-triple 1 2 3) - (list 1 2 3)) -(hk-test - "fst3" - (hk-fst3 (hk-triple 7 8 9)) - 7) -(hk-test - "thd3" - (hk-thd3 (hk-triple 7 8 9)) - 9) - -(hk-test "curry" ((hk-curry +) 3 4) 7) -(hk-test - "uncurry" - ((hk-uncurry (fn (a b) (* a b))) (list 3 4)) - 12) - -;; --------------------------------------------------------------------------- -;; 9. String helpers -;; --------------------------------------------------------------------------- - -(hk-test "words" (hk-words "hello world") (list "hello" "world")) -(hk-test "words leading ws" (hk-words " foo bar") (list "foo" "bar")) -(hk-test "words empty" (hk-words "") (list)) -(hk-test "unwords" (hk-unwords (list "a" "b" "c")) "a b c") -(hk-test "unwords single" (hk-unwords (list "x")) "x") - -(hk-test "lines" (hk-lines "a\nb\nc") (list "a" "b" "c")) -(hk-test "lines single" (hk-lines "hello") (list "hello")) -(hk-test "unlines" (hk-unlines (list "a" "b")) "a\nb\n") - -(hk-test "is-prefix-of yes" (hk-is-prefix-of "he" "hello") true) -(hk-test "is-prefix-of no" (hk-is-prefix-of "wo" "hello") false) -(hk-test "is-prefix-of eq" (hk-is-prefix-of "hi" "hi") true) -(hk-test "is-prefix-of empty" (hk-is-prefix-of "" "hi") true) - -(hk-test "is-suffix-of yes" (hk-is-suffix-of "lo" "hello") true) -(hk-test "is-suffix-of no" (hk-is-suffix-of "he" "hello") false) -(hk-test "is-suffix-of empty" (hk-is-suffix-of "" "hi") true) - -(hk-test "is-infix-of yes" (hk-is-infix-of "ell" "hello") true) -(hk-test "is-infix-of no" (hk-is-infix-of "xyz" "hello") false) -(hk-test "is-infix-of empty" (hk-is-infix-of "" "hello") true) - -;; --------------------------------------------------------------------------- -;; 10. Show -;; --------------------------------------------------------------------------- - -(hk-test "show nil" (hk-show nil) "Nothing") -(hk-test "show true" (hk-show true) "True") -(hk-test "show false" (hk-show false) "False") -(hk-test "show int" (hk-show 42) "42") -(hk-test "show string" (hk-show "hi") "\"hi\"") -(hk-test - "show list" - (hk-show (list 1 2 3)) - "[1,2,3]") -(hk-test "show empty list" (hk-show (list)) "[]") - -;; --------------------------------------------------------------------------- -;; Summary (required by test.sh — last expression is the return value) -;; --------------------------------------------------------------------------- - -(list hk-test-pass hk-test-fail) +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/seq.sx b/lib/haskell/tests/seq.sx new file mode 100644 index 00000000..c46ecab3 --- /dev/null +++ b/lib/haskell/tests/seq.sx @@ -0,0 +1,85 @@ +;; 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} diff --git a/lib/haskell/tests/stdlib.sx b/lib/haskell/tests/stdlib.sx new file mode 100644 index 00000000..4be0db57 --- /dev/null +++ b/lib/haskell/tests/stdlib.sx @@ -0,0 +1,151 @@ +;; stdlib.sx — tests for standard-library functions added in Phase 5: +;; Eq/Ord, Show, Num, Functor, Monad, Applicative, plus common Prelude. + +(define + hk-t + (fn + (lbl src expected) + (hk-test lbl (hk-deep-force (hk-run src)) expected))) + +(define + hk-ts + (fn + (lbl src expected) + (hk-test + lbl + (hk-deep-force (hk-run (str "main = show (" src ")"))) + expected))) + +;; ── Ord ────────────────────────────────────────────────────── +(hk-test + "compare lt" + (hk-deep-force (hk-run "main = compare 1 2")) + (list "LT")) +(hk-test + "compare eq" + (hk-deep-force (hk-run "main = compare 3 3")) + (list "EQ")) +(hk-test + "compare gt" + (hk-deep-force (hk-run "main = compare 9 5")) + (list "GT")) +(hk-test "min" (hk-deep-force (hk-run "main = min 3 5")) 3) +(hk-test "max" (hk-deep-force (hk-run "main = max 3 5")) 5) + +;; ── Show ───────────────────────────────────────────────────── +(hk-ts "show int" "42" "42") +(hk-ts "show neg" "negate 7" "-7") +(hk-ts "show bool T" "True" "True") +(hk-ts "show bool F" "False" "False") +(hk-ts "show list" "[1,2,3]" "[1, 2, 3]") +(hk-ts "show Just" "Just 5" "(Just 5)") +(hk-ts "show Nothing" "Nothing" "Nothing") +(hk-ts "show LT" "LT" "LT") +(hk-ts "show tuple" "(1, True)" "(1, True)") + +;; ── Num extras ─────────────────────────────────────────────── +(hk-test "signum pos" (hk-deep-force (hk-run "main = signum 5")) 1) +(hk-test + "signum neg" + (hk-deep-force (hk-run "main = signum (negate 3)")) + (- 0 1)) +(hk-test "signum zero" (hk-deep-force (hk-run "main = signum 0")) 0) +(hk-test "fromIntegral" (hk-deep-force (hk-run "main = fromIntegral 7")) 7) + +;; ── foldr / foldl ──────────────────────────────────────────── +(hk-test "foldr sum" (hk-deep-force (hk-run "main = foldr (+) 0 [1,2,3]")) 6) +(hk-test "foldl sum" (hk-deep-force (hk-run "main = foldl (+) 0 [1,2,3]")) 6) +(hk-test "foldl1" (hk-deep-force (hk-run "main = foldl1 (+) [1,2,3,4]")) 10) +(hk-test + "foldr cons" + (hk-deep-force (hk-run "main = show (foldr (:) [] [1,2,3])")) + "[1, 2, 3]") + +;; ── List ops ───────────────────────────────────────────────── +(hk-test + "reverse" + (hk-deep-force (hk-run "main = show (reverse [1,2,3])")) + "[3, 2, 1]") +(hk-test "null []" (hk-deep-force (hk-run "main = null []")) (list "True")) +(hk-test + "null xs" + (hk-deep-force (hk-run "main = null [1]")) + (list "False")) +(hk-test + "elem yes" + (hk-deep-force (hk-run "main = elem 2 [1,2,3]")) + (list "True")) +(hk-test + "elem no" + (hk-deep-force (hk-run "main = elem 9 [1,2,3]")) + (list "False")) +(hk-test + "zip" + (hk-deep-force (hk-run "main = show (zip [1,2] [3,4])")) + "[(1, 3), (2, 4)]") +(hk-test "sum" (hk-deep-force (hk-run "main = sum [1,2,3,4,5]")) 15) +(hk-test "product" (hk-deep-force (hk-run "main = product [1,2,3,4]")) 24) +(hk-test "maximum" (hk-deep-force (hk-run "main = maximum [3,1,9,2]")) 9) +(hk-test "minimum" (hk-deep-force (hk-run "main = minimum [3,1,9,2]")) 1) +(hk-test + "any yes" + (hk-deep-force (hk-run "main = any (\\x -> x > 3) [1,2,5]")) + (list "True")) +(hk-test + "any no" + (hk-deep-force (hk-run "main = any (\\x -> x > 9) [1,2,5]")) + (list "False")) +(hk-test + "all yes" + (hk-deep-force (hk-run "main = all (\\x -> x > 0) [1,2,5]")) + (list "True")) +(hk-test + "all no" + (hk-deep-force (hk-run "main = all (\\x -> x > 3) [1,2,5]")) + (list "False")) + +;; ── Higher-order ───────────────────────────────────────────── +(hk-test "flip" (hk-deep-force (hk-run "main = flip (-) 3 10")) 7) +(hk-test "const" (hk-deep-force (hk-run "main = const 42 True")) 42) + +;; ── Functor ────────────────────────────────────────────────── +(hk-test + "fmap list" + (hk-deep-force (hk-run "main = show (fmap (+1) [1,2,3])")) + "[2, 3, 4]") + +;; ── Monad / Applicative ────────────────────────────────────── +(hk-test "return" (hk-deep-force (hk-run "main = return 7")) (list "IO" 7)) +(hk-test "pure" (hk-deep-force (hk-run "main = pure 7")) (list "IO" 7)) +(hk-test + "when T" + (hk-deep-force (hk-run "main = when True (return 1)")) + (list "IO" 1)) +(hk-test + "when F" + (hk-deep-force (hk-run "main = when False (return 1)")) + (list "IO" (list "()"))) +(hk-test + "unless F" + (hk-deep-force (hk-run "main = unless False (return 2)")) + (list "IO" 2)) + +;; ── lookup / maybe / either ───────────────────────────────── +(hk-test + "lookup hit" + (hk-deep-force (hk-run "main = show (lookup 2 [(1,10),(2,20)])")) + "(Just 20)") +(hk-test + "lookup miss" + (hk-deep-force (hk-run "main = show (lookup 9 [(1,10)])")) + "Nothing") +(hk-test + "maybe def" + (hk-deep-force (hk-run "main = maybe 0 (+1) Nothing")) + 0) +(hk-test + "maybe just" + (hk-deep-force (hk-run "main = maybe 0 (+1) (Just 5)")) + 6) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/lib/haskell/tests/typecheck.sx b/lib/haskell/tests/typecheck.sx new file mode 100644 index 00000000..6f46e089 --- /dev/null +++ b/lib/haskell/tests/typecheck.sx @@ -0,0 +1,82 @@ +;; typecheck.sx — tests for hk-typecheck / hk-run-typed. +;; Verifies that untypeable programs are rejected and well-typed programs pass. + +(define hk-str-has? (fn (s sub) (>= (index-of s sub) 0))) + +;; Helper: expect a type error containing `sub` +(define + hk-tc-err + (fn + (label src sub) + (hk-test + label + (guard + (e (#t (hk-str-has? e sub))) + (begin (hk-run-typed src) false)) + true))) + +;; ─── Valid programs pass through ───────────────────────────────────────────── +(hk-test "typed ok: simple arithmetic" (hk-run-typed "main = 1 + 2") 3) + +(hk-test "typed ok: boolean" (hk-run-typed "main = True") (list "True")) + +(hk-test "typed ok: let binding" (hk-run-typed "main = let x = 1 in x + 2") 3) + +(hk-test + "typed ok: two independent fns" + (hk-run-typed "f x = x + 1\nmain = f 5") + 6) + +;; ─── Untypeable programs are rejected ──────────────────────────────────────── +;; Adding Int and Bool is a unification failure. +(hk-tc-err "reject: Int + Bool mentions Int" "main = 1 + True" "Int") +(hk-tc-err "reject: Int + Bool mentions Bool" "main = 1 + True" "Bool") + +;; Condition of if must be Bool. +(hk-tc-err "reject: if non-bool condition" "main = if 1 then 2 else 3" "Bool") + +;; Unbound variable. +(hk-tc-err "reject: unbound variable" "main = unknownVar + 1" "unknownVar") + +;; Function body type error: applying non-function. +(hk-tc-err "reject: apply non-function" "f x = 1 x" "Int") + +(define prog-sig1 (hk-core "f :: Int -> Int\nf x = x + 1")) + +(define prog-sig2 (hk-core "f :: Bool -> Bool\nf x = x + 1")) + +(define prog-sig3 (hk-core "id :: a -> a\nid x = x")) + +(hk-test + "sig ok: Int->Int accepted" + (first (nth (hk-infer-prog prog-sig1 (hk-type-env0)) 0)) + "ok") + +(hk-test + "sig fail: Bool->Bool rejected" + (first (nth (hk-infer-prog prog-sig2 (hk-type-env0)) 0)) + "err") + +(hk-test + "sig fail: error mentions mismatch" + (hk-str-has? + (nth (nth (hk-infer-prog prog-sig2 (hk-type-env0)) 0) 1) + "mismatch") + true) + +(hk-test + "sig ok: polymorphic a->a accepted" + (first (nth (hk-infer-prog prog-sig3 (hk-type-env0)) 0)) + "ok") + +(hk-tc-err + "run-typed sig fail: Bool declared, Int inferred" + "main :: Bool\nmain = 1 + 2" + "mismatch") + +(hk-test + "run-typed sig ok: Int declared matches" + (hk-run-typed "main :: Int\nmain = 1 + 2") + 3) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} \ No newline at end of file diff --git a/plans/agent-briefings/haskell-loop.md b/plans/agent-briefings/haskell-loop.md index 66e46c18..79d1413a 100644 --- a/plans/agent-briefings/haskell-loop.md +++ b/plans/agent-briefings/haskell-loop.md @@ -1,6 +1,8 @@ # haskell-on-sx loop agent (single agent, queue-driven) -Role: iterates `plans/haskell-on-sx.md` forever. Mini-Haskell 98 with real laziness (SX thunks are first-class). Phases 1-3 are untyped — laziness + ADTs first; HM inference is phase 4. +Role: iterates `plans/haskell-completeness.md` forever. Mini-Haskell 98 with +real laziness (SX thunks are first-class). Phases 1–6 are complete; this loop +works Phases 7–16. ``` description: haskell-on-sx queue loop @@ -11,66 +13,141 @@ isolation: worktree ## Prompt -You are the sole background agent working `/root/rose-ash/plans/haskell-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push. - -**Note:** there's an existing `/root/rose-ash/sx-haskell/` directory (~25 M). Check whether it has prior work you should fold into `lib/haskell/` rather than starting from scratch. Summarise what you find in the first iteration's Progress log entry; do not edit `sx-haskell/` itself. +You are the sole background agent working +`/root/rose-ash-loops/haskell/plans/haskell-completeness.md`. Isolated worktree, +forever, one commit per feature. Push to `origin/loops/haskell` after every commit. ## Restart baseline — check before iterating -1. Read `plans/haskell-on-sx.md` — roadmap + Progress log. -2. First-run only: peek at `/root/rose-ash/sx-haskell/` — does any of it belong in `lib/haskell/`? Report in Progress log. Don't edit sx-haskell/. -3. `ls lib/haskell/` — pick up from the most advanced file. -4. Run `lib/haskell/tests/*.sx` if they exist. Green before new work. -5. If `lib/haskell/scoreboard.md` exists, that's your baseline. +1. Read `plans/haskell-completeness.md` — roadmap + Progress log. +2. `ls lib/haskell/` — orient on current state. +3. Run `bash lib/haskell/test.sh`. All 775 tests must be green before new work. +4. Check `lib/haskell/scoreboard.md` — baseline is 156/156 (18 programs). ## The queue -Phase order per `plans/haskell-on-sx.md`: +Phase order per `plans/haskell-completeness.md`: -- **Phase 1** — tokenizer + parser + **layout rule** (indentation-sensitive, painful but required per Haskell 98 §10.3) -- **Phase 2** — desugar + eager eval + ADTs (`data` declarations, constructor tagging, pattern matching). Still untyped. -- **Phase 3** — **laziness**: thunk-wrap every application arg, `force` = WHNF, pattern match forces scrutinee. Classic programs (infinite Fibonacci, sieve of Eratosthenes, quicksort, n-queens, expression calculator) green. -- **Phase 4** — Hindley-Milner type inference (Algorithm W, let-polymorphism, type-sig checking) -- **Phase 5** — typeclasses (dictionary passing, Eq/Ord/Show/Num/Functor/Monad/Applicative, `deriving`) -- **Phase 6** — real `IO` monad backed by `perform`/`resume`, full Prelude, drive corpus to 150+ +- **Phase 7** — String = [Char] via O(1) string-view dicts. No OCaml changes. + Read the "String-view design" section below before touching anything. +- **Phase 8** — `show` for arbitrary types; `deriving Show` generates proper + instances; `print x = putStrLn (show x)`. +- **Phase 9** — `error` / `undefined`; partial functions raise; top-level runner + catches and a new `hk-test-error` helper checks error messages. +- **Phase 10** — Numeric tower: `fromIntegral`, Float/Double literals, + `sqrt`/`floor`/`ceiling`/`round`/`truncate`, `Fractional`/`Floating` stubs. +- **Phase 11** — `Data.Map` — weight-balanced BST in pure SX in `map.sx`. +- **Phase 12** — `Data.Set` — BST in pure SX in `set.sx`. +- **Phase 13** — `where` in typeclass instances + default methods. +- **Phase 14** — Record syntax: `data Foo = Foo { bar :: Int }`, accessors, + update `r { field = v }`, record patterns. +- **Phase 15** — `IORef` — mutable cells via existing `perform`/`resume` IO. +- **Phase 16** — Exception handling: `catch`, `try`, `throwIO`, `evaluate`. Within a phase, pick the checkbox with the best tests-per-effort ratio. -Every iteration: implement → test → commit → tick `[ ]` → Progress log → next. +Every iteration: implement → test → commit → tick `[ ]` → Progress log → push. + +## String-view design (Phase 7 — read before touching strings) + +A string view is a pure-SX dict `{:hk-str buf :hk-off n}`. Native SX strings +also satisfy `hk-str?` (offset = 0 implicitly). No OCaml changes needed. + +- `hk-str?` covers both native strings and view dicts. +- `hk-str-head v` returns the character at offset `n` as an **integer** (ord + value). Char = integer throughout. +- `hk-str-tail v` returns a new view dict with offset `n+1`; **O(1)**. +- `hk-str-null? v` is true when offset ≥ string length. +- In `match.sx`, the `":"` cons-pattern branch checks `hk-str?` on the scrutinee + **before** the normal tagged-list path. On a string: head = char-int, tail = + shifted view (or `(list "[]")` if exhausted). +- `chr n` converts an integer back to a single-character SX string for display + and for `++`. +- `++` between two strings concatenates natively via `str`; no cons-spine built. +- The natural hazard: any code that checks `(list? v)` or `(= (first v) ":")` on + a value must be audited — string views are dicts, not lists. Check `hk-str?` + first in every dispatch chain. + +## Conformance test programs + +For each phase's conformance programs: + +1. **WebFetch the source** from one of: + - 99 Haskell Problems: https://wiki.haskell.org/H-99:_Ninety-Nine_Haskell_Problems + - Rosetta Code Haskell: https://rosettacode.org/wiki/Category:Haskell + - Self-contained snippets from Real World Haskell / Learn You a Haskell +2. **Adapt minimally** — no GHC extensions, no external packages beyond + `Data.Map`/`Data.Set`/`Data.IORef` (once those phases are done). +3. **Cite the source** as a comment at the top of the `.sx` test file. +4. Add the program name (without `.sx`) to `PROGRAMS` in `lib/haskell/conformance.sh`. +5. Run `bash lib/haskell/conformance.sh` and verify green before committing. + +Target: scoreboard grows from 156 → 300+ as phases complete. ## Ground rules (hard) -- **Scope:** only `lib/haskell/**` and `plans/haskell-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib//` dirs, `lib/stdlib.sx`, `lib/` root, or `sx-haskell/`. Haskell primitives go in `lib/haskell/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. -- **SX thunks** (`make-thunk`, force on use) are already in the trampolining evaluator — reuse. Don't invent your own thunk type. -- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits. -- **Worktree:** commit locally. Never push. Never touch `main`. +- **Scope:** only `lib/haskell/**` and `plans/haskell-completeness.md`. Do + **not** edit `spec/`, `hosts/`, `shared/`, other `lib//` dirs, + `lib/stdlib.sx`, `lib/` root. +- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → + Blockers entry in the plan, stop. +- **Shared-file issues** → plan's Blockers section with minimal repro. +- **SX thunks** (`make-thunk`, force on use) already in the trampolining + evaluator — reuse. String views are SX dicts, not thunks. +- **SX files:** `sx-tree` MCP tools ONLY (`sx_read_subtree`, `sx_find_all`, + `sx_replace_node`, `sx_insert_child`, `sx_insert_near`, + `sx_replace_by_pattern`, `sx_rename_symbol`, `sx_validate`, `sx_write_file`). + `sx_validate` after every edit. Never `Edit`/`Read`/`Write` on `.sx` files. +- **Shell, Markdown, JSON:** edit with normal tools. +- **Worktree:** commit then push to `origin/loops/haskell`. Never touch `main`. - **Commit granularity:** one feature per commit. - **Plan file:** update Progress log + tick boxes every commit. +- **Tests:** `bash lib/haskell/test.sh` must stay green. Never regress existing + 775 tests. After new programs, run `bash lib/haskell/conformance.sh`. ## Haskell-specific gotchas -- **Layout rule is the hard bit of parsing** — you need a lexer-parser feedback loop that inserts virtual `{`, `;`, `}` based on indentation. Budget proportionally. -- **Every application arg is a thunk** — compiling `f x y` to `(f (thunk x) (thunk y))` not `(f x y)`. Pattern-match forces. -- **ADT representation:** tagged list, e.g. `data Maybe a = Nothing | Just a` → constructors are `(:Nothing)` (0-ary) and `(:Just )` (1-ary). Pattern match on the head symbol. -- **Let-polymorphism** (phase 4): generalise at let-binding boundaries only, not at lambda. -- **Typeclass dictionaries** (phase 5): each class is a record type; each instance builds the record; method call = project + apply. -- **`IO`** (phase 6): internally `World -> (a, World)` but in practice backed by `perform`/`resume` for real side effects. Desugar `do`-notation to `>>=`. -- **Out of scope:** GHC extensions. No `DataKinds`, `GADTs`, `TypeFamilies`, `TemplateHaskell`. Stick to Haskell 98. +- **String views are dicts** — `(list? v)` returns false for a string view. + Audit every value-dispatch chain in `match.sx` and `eval.sx` for this. +- **Char = integer** — `'a'` parses to int 97. `chr 97 = "a"` (1-char string). + Do not represent Char as a 1-char SX string internally. +- **`deriving Show`** (Phase 8): nested constructor args need parens if their + show string contains a space. Rule: `if string-contains (show arg) " " then + "(" ++ show arg ++ ")" else show arg`. +- **`error` tag** (Phase 9): use `(raise (list "hk-error" msg))`. The top-level + `hk-run-io` guard must catch this tag; do not let `hk-error` leak as an + uncaught SX exception into the test runner's output. +- **`Data.Map` module resolution** (Phase 11): qualified imports `import + qualified Data.Map as Map` need the eval import handler to resolve the dotted + module name to the `map.sx` namespace dict. Check `hk-bind-decls!` import arm. +- **Record update field index** (Phase 14): `r { field = v }` needs the field → + positional-index mapping at runtime. Store it in `hk-constructors` when + registering `:con-rec`. +- **IORef mutation** (Phase 15): `dict-set!` is the SX in-place mutator. The + `IORef` dict is heap-allocated and passed by reference — mutation is safe. +- **Every application arg is a thunk** — `f x y` → `(f (thunk x) (thunk y))`. + Pattern-match forces before matching. Builtins force their args. +- **ADT representation:** `("Just" thunk)`, `("Nothing")`, `(":" h t)`, `("[]")`. +- **Let-polymorphism:** generalise at let-binding boundaries only, not lambda. +- **Typeclass dictionaries:** class = record; instance = record value; method + call = project + apply. Defaults stored under `"__default__ClassName_method"`, + used as fallback when the instance dict lacks the key. +- **Out of scope:** GHC extensions. No `DataKinds`, `GADTs`, `TypeFamilies`, + `TemplateHaskell`. Haskell 98 only. ## General gotchas (all loops) -- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences. -- `cond`/`when`/`let` clauses evaluate only the last expr. +- SX `do` = R7RS iteration. Use `begin` for multi-expression sequences. +- `cond`/`when`/`let` clauses evaluate only the last expression. - `type-of` on user fn returns `"lambda"`. -- Shell heredoc `||` gets eaten — escape or use `case`. +- Shell heredoc `||` gets eaten by bash — escape or use `case`. +- `keys` on an SX dict returns keys in implementation-defined order. ## Style - No comments in `.sx` unless non-obvious. -- No new planning docs — update `plans/haskell-on-sx.md` inline. -- Short, factual commit messages (`haskell: layout rule + first parse (+10)`). +- No new planning docs — update `plans/haskell-completeness.md` inline. +- Short, factual commit messages (`haskell: string-view O(1) head/tail (+15)`). - One feature per iteration. Commit. Log. Next. -Go. Read the plan; (first run only) peek at sx-haskell/ and report; find first `[ ]`; implement. +Go. Read `plans/haskell-completeness.md`; find the first `[ ]`; implement. diff --git a/plans/haskell-completeness.md b/plans/haskell-completeness.md new file mode 100644 index 00000000..138a09ca --- /dev/null +++ b/plans/haskell-completeness.md @@ -0,0 +1,285 @@ +# Haskell-on-SX: completeness roadmap (Phases 7–16) + +Continuation of `plans/haskell-on-sx.md`. Phases 1–6 are complete (156/156 +conformance tests, 18 programs, 775 total hk-on-sx tests). This document covers +the next ten features toward a more complete Haskell 98 subset. + +## Scope decisions (unchanged from haskell-on-sx.md) + +- Haskell 98 subset only. No GHC extensions. +- All work lives in `lib/haskell/**` and this file. Nothing else. +- SX files: `sx-tree` MCP tools only. +- One feature per commit. Keep `## Progress log` updated. + +## String-view design note + +Haskell defines `type String = [Char]`. Representing that naively as a linked +cons-spine makes `length`, `++`, and `take` O(n) in allocation — unacceptable +for string-processing programs. The design uses **string views** implemented as +pure-SX dicts, requiring no OCaml changes. + +### Representation + +A string view is a dict `{:hk-str buf :hk-off n}` where `buf` is a native SX +string and `n` is the current offset (zero-based code-unit index). Native SX +strings also satisfy the predicate (offset = 0 implicitly). + +- `hk-str?` returns true for both native strings and string-view dicts. +- `hk-str-head v` extracts the character at offset `n` as an integer (ord value). +- `hk-str-tail v` returns a new view with offset `n+1`; O(1). +- `hk-str-null? v` is true when offset equals the string's length. + +### Char = integer + +`Char` is represented as a plain integer (its Unicode code point / ord value). +`chr n` converts back to a single-character string for display and `++`. `ord c` +is the identity (the integer itself). `toUpper`/`toLower` operate on the integer, +looking up ASCII ranges. This is already consistent with the existing `ord 'A' = +65` tests. + +### Pattern matching + +In `match.sx`, the cons-pattern branch (`":"` constructor) checks `hk-str?` on +the scrutinee **before** the normal tagged-list path. When the scrutinee is a +string view (or native string), decompose as: +- head → `hk-str-head` (an integer char-code) +- tail → `hk-str-tail` (a new string view, or `(list "[]")` if exhausted) + +The nil-pattern `"[]"` matches when `hk-str-null?` is true. + +### Complexity + +- `head s` / `tail s` — O(1) via view shift +- `s !! n` — O(n) (n tail calls) +- `(c:s)` construction — O(n) for full `[Char]` construction (same as real Haskell) +- `++` on two strings — native `str` concat, O(length left) +- `length` — O(n); `words`/`lines` — O(n) + +No OCaml changes are needed. The view type is fully representable as an SX dict. + +## Ground rules + +- **Scope:** only `lib/haskell/**` and `plans/haskell-completeness.md`. No edits + to `spec/`, `hosts/`, `shared/`, other `lib//` dirs, or `lib/` root. +- **SX files:** `sx-tree` MCP tools only. `sx_validate` after every edit. +- **Commits:** one feature per commit. Keep `## Progress log` updated. +- **Tests:** `bash lib/haskell/test.sh` must be green before any commit. After + adding new programs, run `bash lib/haskell/conformance.sh` and commit the + updated `scoreboard.md`. +- **Conformance programs:** WebFetch from 99 Haskell Problems or Rosetta Code. + Adapt minimally (no GHC extensions). Cite the source URL in the file header. + Add to `conformance.sh` PROGRAMS array. +- **NEVER call `sx_build`.** If sx_server binary broken → Blockers entry, stop. + +## Roadmap + +### Phase 7 — String = [Char] (performant string views) + +- [ ] Add `hk-str?` predicate to `runtime.sx` covering both native SX strings + and `{:hk-str buf :hk-off n}` view dicts. +- [ ] Implement `hk-str-head`, `hk-str-tail`, `hk-str-null?` helpers in + `runtime.sx`. +- [ ] In `match.sx`, intercept cons-pattern `":"` when scrutinee satisfies + `hk-str?`; decompose to (char-int, view) instead of the tagged-list path. + Nil-pattern `"[]"` matches `hk-str-null?`. +- [ ] Add builtins: `chr` (int → single-char string), verify `ord` returns int, + `toUpper`, `toLower` (ASCII range arithmetic on ints). +- [ ] Ensure `++` between two strings concatenates natively via `str` rather + than building a cons spine. +- [ ] Tests in `lib/haskell/tests/string-char.sx` (≥ 15 tests: head/tail on + string literal, map over string, filter chars, chr/ord roundtrip, toUpper, + toLower, null/empty string view). +- [ ] Conformance programs (WebFetch + adapt): + - `caesar.hs` — Caesar cipher. Exercises `map`, `chr`, `ord`, `toUpper`, + `toLower` on characters. + - `runlength-str.hs` — run-length encoding on a String. Exercises string + pattern matching, `span`, character comparison. + +### Phase 8 — `show` for arbitrary types + +- [ ] Audit `hk-show-val` in `runtime.sx` — ensure output format matches + Haskell 98: `"Just 3"`, `"[1,2,3]"`, `"(True,False)"`, `"'a'"` (Char shows + with single-quotes), `"\"hello\""` (String shows with escaped double-quotes). +- [ ] `show` Prelude binding calls `hk-show-val`; `print x = putStrLn (show x)`. +- [ ] `deriving Show` auto-generates proper show for record-style and + multi-constructor ADTs. Nested application arguments wrapped in parens: + if `show arg` contains a space, emit `"(" ++ show arg ++ ")"`. +- [ ] `showsPrec` / `showParen` stubs so hand-written Show instances compile. +- [ ] `Read` class stub — just enough for `reads :: String -> [(a,String)]` to + type-check; no real parser needed yet. +- [ ] Tests in `lib/haskell/tests/show.sx` (≥ 12 tests: show Int, show Bool, + show Char, show String, show list, show tuple, show Maybe, show custom ADT, + deriving Show on multi-constructor type, nested constructor parens). +- [ ] Conformance programs: + - `showadt.hs` — `data Expr = Lit Int | Add Expr Expr | Mul Expr Expr` + with `deriving Show`; prints a tree. + - `showio.hs` — `print` on various types in a `do` block. + +### Phase 9 — `error` / `undefined` + +- [ ] `error :: String -> a` — raises `(raise (list "hk-error" msg))` in SX. +- [ ] `undefined :: a` = `error "Prelude.undefined"`. +- [ ] Partial functions emit proper error messages: `head []` → + `"Prelude.head: empty list"`, `tail []` → `"Prelude.tail: empty list"`, + `fromJust Nothing` → `"Maybe.fromJust: Nothing"`. +- [ ] Top-level `hk-run-io` catches `hk-error` tag and returns it as a tagged + error result so test suites can inspect it without crashing. +- [ ] `hk-test-error` helper in `testlib.sx`: + `(hk-test-error "desc" thunk expected-substring)` — asserts the thunk raises + an `hk-error` whose message contains the given substring. +- [ ] Tests in `lib/haskell/tests/errors.sx` (≥ 10 tests: error message + content, undefined, head/tail/fromJust on bad input, `hk-test-error` helper). +- [ ] Conformance programs: + - `partial.hs` — exercises `head []`, `tail []`, `fromJust Nothing` caught + at the top level; shows error messages. + +### Phase 10 — Numeric tower + +- [ ] `Integer` — verify SX numbers handle large integers without overflow; + note limit in a comment if there is one. +- [ ] `fromIntegral :: (Integral a, Num b) => a -> b` — identity in our runtime + (all numbers share one SX type); register as a builtin no-op with the correct + typeclass signature. +- [ ] `toInteger`, `fromInteger` — same treatment. +- [ ] Float/Double literals round-trip through `hk-show-val`: + `show 3.14 = "3.14"`, `show 1.0e10 = "1.0e10"`. +- [ ] Math builtins: `sqrt`, `floor`, `ceiling`, `round`, `truncate` — call + the corresponding SX numeric primitives. +- [ ] `Fractional` typeclass stub: `(/)`, `recip`, `fromRational`. +- [ ] `Floating` typeclass stub: `pi`, `exp`, `log`, `sin`, `cos`, `(**)` + (power operator, maps to SX exponentiation). +- [ ] Tests in `lib/haskell/tests/numeric.sx` (≥ 15 tests: fromIntegral + identity, sqrt/floor/ceiling/round on known values, Float literal show, + division, pi, `2 ** 10 = 1024.0`). +- [ ] Conformance programs: + - `statistics.hs` — mean, variance, std-dev on a `[Double]`. Exercises + `fromIntegral`, `sqrt`, `/`. + - `newton.hs` — Newton's method for square root. Exercises `Float`, `abs`, + iteration. + +### Phase 11 — Data.Map + +- [ ] Implement a weight-balanced BST in pure SX in `lib/haskell/map.sx`. + Internal node representation: `("Map-Node" key val left right size)`. + Leaf: `("Map-Empty")`. +- [ ] Core operations: `empty`, `singleton`, `insert`, `lookup`, `delete`, + `member`, `size`, `null`. +- [ ] Bulk operations: `fromList`, `toList`, `toAscList`, `keys`, `elems`. +- [ ] Combining: `unionWith`, `intersectionWith`, `difference`. +- [ ] Transforming: `foldlWithKey`, `foldrWithKey`, `mapWithKey`, `filterWithKey`. +- [ ] Updating: `adjust`, `insertWith`, `insertWithKey`, `alter`. +- [ ] Module wiring: `import Data.Map` and `import qualified Data.Map as Map` + resolve to the `map.sx` namespace dict in the eval import handler. +- [ ] Unit tests in `lib/haskell/tests/map.sx` (≥ 20 tests: empty, singleton, + insert + lookup hit/miss, delete root, fromList with duplicates, + toAscList ordering, unionWith, foldlWithKey). +- [ ] Conformance programs: + - `wordfreq.hs` — word-frequency histogram using `Data.Map`. Source from + Rosetta Code "Word frequency" Haskell entry. + - `mapgraph.hs` — adjacency-list BFS using `Data.Map`. + +### Phase 12 — Data.Set + +- [ ] Implement `Data.Set` in `lib/haskell/set.sx`. Use a standalone + weight-balanced BST (same structure as Map but no value field) or wrap + `Data.Map` with unit values. +- [ ] API: `empty`, `singleton`, `insert`, `delete`, `member`, `fromList`, + `toList`, `toAscList`, `size`, `null`, `union`, `intersection`, `difference`, + `isSubsetOf`, `filter`, `map`, `foldr`, `foldl'`. +- [ ] Module wiring: `import Data.Set` / `import qualified Data.Set as Set`. +- [ ] Unit tests in `lib/haskell/tests/set.sx` (≥ 15 tests: empty, insert, + member hit/miss, delete, fromList deduplication, union, intersection, + difference, isSubsetOf). +- [ ] Conformance programs: + - `uniquewords.hs` — unique words in a string using `Data.Set`. + - `setops.hs` — set union/intersection/difference on integer sets; + exercises all three combining operations. + +### Phase 13 — `where` in typeclass instances + default methods + +- [ ] Verify `where`-clauses in `instance` bodies desugar correctly. The + `hk-bind-decls!` instance arm must call the same where-lifting logic as + top-level function clauses. Write a targeted test to confirm. +- [ ] Class declarations may include default method implementations. Parser: + `hk-parse-class` collects method decls; eval registers defaults under + `"__default__ClassName_method"` in the class dict. +- [ ] Instance method lookup: when the instance dict lacks a method, fall back + to the default. Wire this into the dictionary-passing dispatch. +- [ ] `Eq` default: `(/=) x y = not (x == y)`. Verify it works without an + explicit `/=` in every Eq instance. +- [ ] `Ord` defaults: `max a b = if a >= b then a else b`, `min a b = if a <= + b then a else b`. Verify. +- [ ] `Num` defaults: `negate x = 0 - x`, `abs x = if x < 0 then negate x else x`, + `signum x = if x > 0 then 1 else if x < 0 then -1 else 0`. Verify. +- [ ] Tests in `lib/haskell/tests/class-defaults.sx` (≥ 10 tests). +- [ ] Conformance programs: + - `shapes.hs` — `class Area a` with a default `perimeter`; two instances + using `where`-local helpers. + +### Phase 14 — Record syntax + +- [ ] Parser: extend `hk-parse-data` to recognise `{ field :: Type, … }` + constructor bodies. AST node: `(:con-rec CNAME [(FNAME TYPE) …])`. +- [ ] Desugar: `:con-rec` → positional `:con-def` plus generated accessor + functions `(\rec -> case rec of …)` for each field name. +- [ ] Record creation `Foo { bar = 1, baz = "x" }` parsed as + `(:rec-create CON [(FNAME EXPR) …])`. Eval builds the same tagged list as + positional construction (field order from the data decl). +- [ ] Record update `r { field = v }` parsed as `(:rec-update EXPR [(FNAME EXPR)])`. + Eval forces the record, replaces the relevant positional slot, returns a new + tagged list. Field → index mapping stored in `hk-constructors` at registration. +- [ ] Exhaustive record patterns: `Foo { bar = b }` in case binds `b`, + wildcards remaining fields. +- [ ] Tests in `lib/haskell/tests/records.sx` (≥ 12 tests: creation, accessor, + update one field, update two fields, record pattern, `deriving Show` on + record type). +- [ ] Conformance programs: + - `person.hs` — `data Person = Person { name :: String, age :: Int }` with + accessors, update, `deriving Show`. + - `config.hs` — multi-field config record; partial update; defaultConfig + constant. + +### Phase 15 — IORef + +- [ ] `IORef a` representation: a dict `{:hk-ioref true :hk-value v}`. + Allocation creates a new dict in the IO monad. Mutation via `dict-set!`. +- [ ] `newIORef :: a -> IO (IORef a)` — wraps a new dict in `IO`. +- [ ] `readIORef :: IORef a -> IO a` — returns `(IO (get ref ":hk-value"))`. +- [ ] `writeIORef :: IORef a -> a -> IO ()` — `(dict-set! ref ":hk-value" v)`, + returns `(IO ("Tuple"))`. +- [ ] `modifyIORef :: IORef a -> (a -> a) -> IO ()` — read + apply + write. +- [ ] `modifyIORef' :: IORef a -> (a -> a) -> IO ()` — strict variant (force + new value before write). +- [ ] `Data.IORef` module wiring. +- [ ] Tests in `lib/haskell/tests/ioref.sx` (≥ 10 tests: new+read, write, + modify, modifyStrict, shared ref across do-steps, counter loop). +- [ ] Conformance programs: + - `counter.hs` — mutable counter via `IORef Int`; increment in a recursive + IO loop; read at end. + - `accumulate.hs` — accumulate results into `IORef [Int]` inside a mapped + IO action, read at the end. + +### Phase 16 — Exception handling + +- [ ] `SomeException` type: `data SomeException = SomeException String`. + `IOException = SomeException`. +- [ ] `throwIO :: Exception e => e -> IO a` — raises `("hk-exception" e)`. +- [ ] `evaluate :: a -> IO a` — forces arg strictly; any embedded `hk-error` + surfaces as a catchable `SomeException`. +- [ ] `catch :: Exception e => IO a -> (e -> IO a) -> IO a` — wraps action in + SX `guard`; on `hk-error` or `hk-exception`, calls the handler with a + `SomeException` value. +- [ ] `try :: Exception e => IO a -> IO (Either e a)` — returns `Right v` on + success, `Left e` on any exception. +- [ ] `handle = flip catch`. +- [ ] Tests in `lib/haskell/tests/exceptions.sx` (≥ 10 tests: catch success, + catch error, try Right, try Left, nested catch, evaluate surfaces error, + throwIO propagates, handle alias). +- [ ] Conformance programs: + - `safediv.hs` — safe division using `catch`; divide-by-zero raises, + handler returns 0. + - `trycatch.hs` — `try` pattern: run an action, branch on Left/Right. + +## Progress log + +_Newest first._ diff --git a/plans/haskell-on-sx.md b/plans/haskell-on-sx.md index f76920fd..261a4dfc 100644 --- a/plans/haskell-on-sx.md +++ b/plans/haskell-on-sx.md @@ -55,58 +55,634 @@ 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) -- [ ] 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] 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 - [x] Unit tests in `lib/haskell/tests/parse.sx` (43 tokenizer tests, all green) ### Phase 2 — desugar + eager-ish eval + ADTs (untyped) -- [ ] 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` +- [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` ### Phase 3 — laziness + classic programs -- [ ] Transpile to thunk-wrapped SX: every application arg becomes `(make-thunk (lambda () ))` -- [ ] `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 - - [ ] `quicksort.hs` — naive QS - - [ ] `nqueens.hs` - - [ ] `calculator.hs` — parser combinator style expression evaluator -- [ ] `lib/haskell/conformance.sh` + runner; `scoreboard.json` + `scoreboard.md` -- [ ] Target: 5/5 classic programs passing +- [x] Transpile to thunk-wrapped SX: every application arg becomes `(make-thunk (lambda () ))` +- [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) +- [x] Classic programs in `lib/haskell/tests/programs/`: + - [x] `fib.hs` — infinite Fibonacci stream + - [x] `sieve.hs` — lazy sieve of Eratosthenes + - [x] `quicksort.hs` — naive QS + - [x] `nqueens.hs` + - [x] `calculator.hs` — parser combinator style expression evaluator +- [x] `lib/haskell/conformance.sh` + runner; `scoreboard.json` + `scoreboard.md` +- [x] Target: 5/5 classic programs passing ### Phase 4 — Hindley-Milner inference -- [ ] Algorithm W: unification + type schemes + generalisation + instantiation -- [ ] Report type errors with meaningful positions -- [ ] Reject untypeable programs that phase 3 was accepting -- [ ] Type-sig checking: user writes `f :: Int -> Int`; verify -- [ ] Let-polymorphism -- [ ] Unit tests: inference for 50+ expressions +- [x] Algorithm W: unification + type schemes + generalisation + instantiation +- [x] Report type errors with meaningful positions +- [x] Reject untypeable programs that phase 3 was accepting +- [x] Type-sig checking: user writes `f :: Int -> Int`; verify +- [x] Let-polymorphism +- [x] Unit tests: inference for 50+ expressions ### Phase 5 — typeclasses (dictionary passing) -- [ ] `class` / `instance` declarations -- [ ] Dictionary-passing elaborator: inserts dict args at call sites -- [ ] Standard classes: `Eq`, `Ord`, `Show`, `Num`, `Functor`, `Monad`, `Applicative` -- [ ] `deriving (Eq, Show)` for ADTs +- [x] `class` / `instance` declarations +- [x] Dictionary-passing elaborator: inserts dict args at call sites +- [x] Standard classes: `Eq`, `Ord`, `Show`, `Num`, `Functor`, `Monad`, `Applicative` +- [x] `deriving (Eq, Show)` for ADTs ### Phase 6 — real IO + Prelude completion -- [ ] Real `IO` monad backed by `perform`/`resume` -- [ ] `putStrLn`, `getLine`, `readFile`, `writeFile`, `print` -- [ ] Full-ish Prelude: `Maybe`, `Either`, `List` functions, `Map`-lite -- [ ] Drive scoreboard toward 150+ passing +- [x] Real `IO` monad backed by `perform`/`resume` +- [x] `putStrLn`, `getLine`, `readFile`, `writeFile`, `print` +- [x] Full-ish Prelude: `Maybe`, `Either`, `List` functions, `Map`-lite +- [x] Drive scoreboard toward 150+ passing ## Progress log _Newest first._ +- **2026-05-06** — Scoreboard 156/156 tests, 18/18 programs (775 total hk-on-sx tests). Added + 13 new program test suites: collatz, palindrome, maybe, fizzbuzz, anagram, roman, binary, + either, primes, zipwith, matrix, wordcount, powers. Updated conformance.sh PROGRAMS array. + +- **2026-05-06** — Phase 6 prelude extras (635/635). `nub`, `sort`, `sortBy`, `sortOn`, + `splitAt`, `span`, `break`, `partition`, `unzip`, `tails`, `inits`, `isPrefixOf`, + `isSuffixOf`, `isInfixOf`, `intercalate`, `intersperse`, `unwords`, `unlines`, + `interactApply/interact`. SX builtins: `ord`, `isAlpha`, `isAlphaNum`, `isDigit`, + `isSpace`, `isUpper`, `isLower`, `digitToInt`, `words`, `lines`. Fixed `++` on SX + strings (`hk-list-append` now handles string concat via `str`). Unified list repr: + `--sx-to-hk--` now uses `":"/"[]"` matching `hk-mk-cons`. 47 new tests. + +- **2026-05-06** — Phase 6 `getLine`/`getContents`/`readFile`/`writeFile`. `hk-force` + extended: 0-arity builtins (`arity=0` dicts) are called immediately when forced, + making `getLine`/`getContents` work naturally as IO actions (no arity-0 application + needed — `>>=` forces them and gets the `("IO" value)` result). `getLine` pops + from `hk-stdin-lines`; `getContents` drains it joining with `"\n"`; `readFile` + reads from `hk-vfs` (dict), errors on missing key; `writeFile` sets `hk-vfs` key. + `hk-run-io-with-input` resets both io-lines and stdin then runs. `>>=` and `>>` + added to `hk-binop` for infix operator path. Bug caught: `sx_replace_node` on the + thunk-force branch accidentally changed `"body"` → `"fn"` (key name); fixed. + 11 new tests in `tests/io-input.sx`. 587/587 green. + +- **2026-05-06** — Phase 6 real IO monad. `eval.sx`: mutable `hk-io-lines` list + buffer; `putStrLn` and `putStr` append the (forced) string arg; `print` appends + `hk-show-val` of the arg; all three return `("IO" ("Tuple"))`. `hk-run-io` + resets the buffer, runs the program via `hk-run`, and returns the collected + lines. `>>=`/`>>` in the runtime are eager (force the left-side IO action + immediately). `tests/program-io.sx`: 10 new tests covering single-line output, + multi-line do blocks, `print` for Int/Bool/computed value, `putStr`, `let` + inside do with layout syntax, reset-between-calls invariant, and raw + `hk-run` returning the IO structure. 575/575 green. + +- **2026-05-06** — Phase 5 `deriving (Eq, Show)`. Parser: `hk-parse-data` now + optionally parses a `deriving (Class1, Class2)` or `deriving Class` clause + after constructor definitions; result appended as 5th element only when + non-empty (no AST churn for existing decls). Three token-type fixes: the + deriving clause used `"special"` for `(`, `)`, `,` but the tokenizer + produces `"lparen"`, `"rparen"`, `"comma"`. Eval: `hk-bind-decls!` `data` + arm generates `dictShow_{Con}` and `dictEq_{Con}` dicts for each constructor + that appears in a `deriving` list. `Show` delegates to `hk-show-val` (lazy). + `Eq` needed structural equality — `hk-binop "=="` and `/=` now call + `hk-deep-force` on both sides before `=` (SX dict equality is by reference, + so two thunks wrapping the same number compared as not-equal without this). + 11 new tests in `lib/haskell/tests/deriving.sx`: nullary Show, constructor + with arg, nested, second constructor, Eq same/different constructor, `/=` + same/different, combined `(Eq, Show)`, Eq with args, different constructors + with args. 565/565 green. + +- **2026-05-06** — Phase 5 standard classes. Prelude extended: `foldr`, `foldl`, + `foldl1`, `foldr1`, `zip`, `reverse`, `elem`, `notElem`, `any`, `all`, `and`, + `or`, `sum`, `product`, `maximum`, `minimum`, `compare`, `min`, `max`, + `signum`, `fromIntegral`, `null`, `flip`, `const`, `curry`, `uncurry`, + `lookup`, `maybe`, `either`, `fmap`, `pure`, `when`, `unless`, `mapM_`, + `sequence_`. `show` implemented as SX builtin (`hk-show-val`) dispatching on + runtime type (number, string, bool, list, tuple, ADT). `hk-eval-program` now + uses `hk-dict-copy hk-env0` instead of fresh `hk-init-env` — prelude parsed + once at load time, each program gets a shallow copy (10× speedup per call). + test.sh timeout 240s→360s for nqueens headroom. 48 new stdlib tests. + 554/554 green. + +- **2026-05-06** — Phase 5 dict-passing elaborator. `hk-bind-decls!` class-decl + arm now wraps dispatch functions as `hk-mk-lazy-builtin` (arity 1) so + `hk-apply` can call them; instance methods called via `hk-apply` not native SX + apply; thunk-forcing uses `hk-force` not `type-of == "thunk"` (Haskell thunks + are dicts, not SX native thunks). `tests/class.sx` gains 3 dispatch tests + (Int instance, Bool instance, error on unknown). 506/506 green. + +- **2026-05-06** — Phase 5 class/instance declarations. Parser: `hk-parse-class` + and `hk-parse-instance` added to the parser closure; `hk-parse-decl` gains + arms for `"class"` and `"instance"` reserved words (tokenizer already marks + them reserved). `class Eq a where { ... }` → `("class-decl" name tvar decls)`; + `instance Eq Int where { ... }` → `("instance-decl" name inst-type decls)`. + Eval: `hk-type-ast-str` converts type AST to a string key. `hk-bind-decls!` + gains arms for `class-decl` (registers `__class__Name` marker) and + `instance-decl` (builds method dict, binds as `dictClassName_TypeStr` in env). + 11 new tests in `tests/class.sx` covering AST shapes + runtime dict + construction. 503/503 green. + +- **2026-05-05** — Phase 4 inference unit tests (50+ expressions). Added 16 new + `hk-t` expression tests to `tests/infer.sx`: nested application (`not(not True)`, + `negate(negate 1)`), bool/mixed lambdas (`\\x->\\y->x&&y`, `\\x->x==1`), + let variants (if-in-let, not-in-let, tuple-in-let, nested let, chain application), + more if expressions, 2-element tuples, and list operations on Bool lists. + infer.sx now has 75 tests covering 55+ distinct expression forms. Phase 4 + complete. 492/492 green. + +- **2026-05-05** — Phase 4 let-polymorphism tests. `hk-w-let` already + generalises let-bound types with `hk-generalise` before adding them to the + env, so `id :: ∀a. a→a` is instantiated independently at each use site. + 6 new tests in `tests/infer.sx`: identity at Int and Bool separately, identity + tuple `(id 1, id True) → (Int, Bool)`, `const` at two types, nested let with + `f`/`g` sharing the polymorphic binding, and `twice` applied to an arithmetic + lambda. All use the 2-arg `hk-t` form. 476/476 green. + +- **2026-05-05** — Phase 4 type-sig checking. `hk-ast-type` converts parsed type + AST nodes (`t-con`/`t-var`/`t-fun`/`t-app`/`t-list`/`t-tuple`) to internal + type values. `hk-collect-tvars` gathers free type variable names. `hk-check-sig` + wraps declared type in a scheme (if polymorphic), instantiates with fresh vars, + and unifies against the inferred type. `hk-infer-prog` updated: first pass + collects `type-sig` declarations into a `sigs` dict; second pass checks each + successful fun-clause inference against its declared sig, returning + `("err" "... declared type mismatch: ...")` on mismatch. 6 new tests in + `typecheck.sx` cover monomorphic sig match, sig mismatch (error message), + polymorphic `a->a` sig, and `hk-run-typed` with and without sig. 470/470 green. + +- **2026-05-05** — Phase 4 reject untypeable programs. `hk-typecheck` runs + `hk-infer-prog` on a program AST and raises the first type error found. + `hk-run-typed` is a drop-in for `hk-run` that gates evaluation on a + successful type check. `hk-infer-decl` now returns a 4th element (raw type + value); `hk-infer-prog` propagates inferred types into the running type env + so multi-function programs (`f x = x+1\ng y = f y+2`) infer correctly. + test.sh extended to load infer.sx for `*typecheck*` files. + 9 new tests in `tests/typecheck.sx`: 4 valid programs pass through, 5 + invalid programs are rejected (Int+Bool, non-Bool if condition, unbound var, + apply non-function). 464/464 green. + +- **2026-05-05** — Phase 4 type error reporting. `hk-expr->brief` converts any AST + node to a short human-readable string for error messages (handles var/con/int/float/ + str/char/bool/app/op/if/let/lambda/tuple/list/loc). `loc` nodes in `hk-w` delegate + to inner expr (position is for outer context). `hk-infer-decl` wraps per-declaration + inference in a `guard`, returning `("ok" name type)` or `("err" "in 'name': msg")` + tagged results — avoids re-raise infinite loop in SX guard semantics. + `hk-infer-prog` runs all declarations and accumulates tagged results. test.sh + timeouts raised 120s→240s to accommodate eval.sx (Prelude init ~9s × 20 tests). + 21 new tests covering brief serializer, error message substrings, loc pass-through, + decl inference, and prog-level inference. 455/455 green. + +- **2026-05-05** — Phase 4 Algorithm W (`lib/haskell/infer.sx`). Full + Hindley-Milner inference: type constructors (TVar/TCon/TArr/TApp/TTuple/TScheme), + substitution (apply/compose/restrict), occurs-check unification, instantiation, + generalisation (let-polymorphism). Algorithm W covers literals, var, con, lambda, + multi-param lambda, application, let (simple bind + fun-clause), if, binary ops + (desugared to double application), tuples, and list literals. Initial type + environment provides monomorphic arithmetic/comparison/boolean ops plus + polymorphic list functions (`head`/`tail`/`null`/`length`/`reverse`/`:`). + `hk-infer-type` is the public entry point. test.sh updated to load infer.sx. + 32 new tests in `lib/haskell/tests/infer.sx` cover all node types + let- + polymorphism. 434/434 green. + +- **2026-04-25** — `conformance.sh` runner + `scoreboard.json` + `scoreboard.md`. + Script runs each classic program's test suite, prints per-program pass/fail, + and writes both files. `--check` mode skips writing for CI use. + Initial snapshot: 16/16 tests, 5/5 programs passing. Phase 3 complete. + +- **2026-04-25** — Classic program `calculator.hs`: recursive descent + expression evaluator using ADTs for tokens and results. + `data Token = TNum Int | TOp String` + `data Result = R Int [Token]`; + parser threads token lists through `R` constructors enabling nested + constructor pattern matching (`R v (TOp "+":rest)`). Handles two-level + operator precedence (* / tighter than + −) and left-associativity. + 5 tests: addition, precedence, left-assoc subtraction, left-assoc + div+mul, single number. All 5 classic programs complete. 402/402 green. + +- **2026-04-25** — Classic program `nqueens.hs`: backtracking n-queens via list + comprehension and multi-clause `where`. Three fixes needed: (1) `hk-eval-let` + now delegates to `hk-bind-decls!` so multi-clause `where`/`let` bindings + (e.g., `go 0 = [[]]; go k = [...]`) are grouped as multifuns; (2) added + `concatMap`, `concat`, `abs`, `negate` to `hk-prelude-src` (list comprehensions + desugar to `concatMap`); (3) cached the Prelude env in `hk-env0` so + `hk-eval-expr-source` copies it instead of re-parsing. Tests: `queens 4 = 2`, + `queens 5 = 10`. n=8 (92 solutions) is too slow at ~50s/n — omitted. + 397/397 green. + +- **2026-04-25** — Classic program `quicksort.hs`: naive functional quicksort. + `qsort (x:xs) = qsort smaller ++ [x] ++ qsort larger where smaller = filter (< x) xs; larger = filter (>= x) xs`. + No new runtime additions needed — right sections, `filter`, `++` all worked out of the box. + 5 tests (general sort, empty, singleton, already-sorted, reverse-sorted). 395/395 green. + +- **2026-04-25** — Classic program `sieve.hs`: lazy sieve of Eratosthenes. + Added `mod`, `div`, `rem`, `quot` to `hk-binop` (and as first-class + values in `hk-init-env`), enabling backtick operator use. The filter-based + sieve `sieve (p:xs) = p : sieve (filter (\x -> x \`mod\` p /= 0) xs)` works + with the existing lazy cons + Prelude `filter`. 2 new tests in + `lib/haskell/tests/program-sieve.sx` (first 10 primes, 20th prime = 71). + 390/390 green. + +- **2026-04-25** — First classic program: `fib.hs`. Canonical Haskell + source lives at `lib/haskell/tests/programs/fib.hs` (the + two-cons-cell self-referential fibs definition plus a hand-rolled + `zipPlus`). The runner at `lib/haskell/tests/program-fib.sx` + mirrors the source as an SX string (the OCaml server's + `read-file` lives in the page-helpers env, not the default load + env, so direct file reads from inside `eval` aren't available). + Tests: `take 15 myFibs == [0,1,1,2,3,5,8,13,21,34,55,89,144,233,377]`, + plus a spot-check that the user-defined `zipPlus` is also + reachable. Found and fixed an ordering bug in `hk-bind-decls!`: + pass 3 (0-arity body evaluation) iterated `(keys groups)` whose + order is implementation-defined, so a top-down program where + `result = take 15 myFibs` came after `myFibs = …` could see + `myFibs` still bound to its `nil` placeholder. Now group names + are tracked in source order via a parallel list and pass 3 walks + that. 388/388 green. + +- **2026-04-25** — Phase 3 do-notation + stub IO monad. Added a + `hk-desugar-do` pass that follows Haskell 98 §3.14 verbatim: + `do { e } = e`, `do { e ; ss } = e >> do { ss }`, + `do { p <- e ; ss } = e >>= \p -> do { ss }`, and + `do { let ds ; ss } = let ds in do { ss }`. The desugarer's + `:do` branch now invokes this pass directly so the surface + AST forms (`:do-expr`, `:do-bind`, `:do-let`) never reach the + evaluator. IO is represented as a tagged value + `("IO" payload)` — `return` (lazy builtin) wraps; `>>=` (lazy + builtin) forces the action, unwraps, and calls the bound + function on the payload; `>>` (lazy builtin) forces the + action and returns the second one. All three are non-strict + in their action arguments so deeply nested do-blocks don't + walk the whole chain at construction time. 14 new tests in + `lib/haskell/tests/do-io.sx` cover single-stmt do, single + and multi-bind, `>>` sequencing (last action wins), do-let + (single, multi, interleaved with bind), bind-to-`Just`, + bind-to-tuple, do inside a top-level fun, nested do, and + using `(>>=)`/`(>>)` directly as functions. 382/382 green. + +- **2026-04-25** — Phase 3 `seq` + `deepseq`. Built-ins were strict + in all args by default (every collected thunk forced before + invoking the underlying SX fn) — that defeats `seq`'s purpose, + which is strict in its first argument and lazy in its second. + Added a tiny `lazy` flag on the builtin record (set by a new + `hk-mk-lazy-builtin` constructor) and routed `hk-apply-builtin` + to skip the auto-force when the flag is true. `seq a b` calls + `hk-force a` then returns `b` unchanged so its laziness is + preserved; `deepseq` does the same with `hk-deep-force`. 9 new + tests in `lib/haskell/tests/seq.sx` cover primitive, computed, + and let-bound first args, deepseq on a list / `Just` / + tuple, seq inside arithmetic, seq via a fun-clause, and + `[seq 1 10, seq 2 20]` to confirm seq composes inside list + literals. The lazy-when-unused negative case is also tested: + `let x = error "never" in 42 == 42`. 368/368 green. + +- **2026-04-24** — Phase 3 infinite structures + Prelude. Two + evaluator changes turn the lazy primitives into a working + language: + 1. Op-form `:` is now non-strict in both args — `hk-eval-op` + special-cases it before the eager force-and-binop path, so a + cons-cell holds two thunks. This is what makes `repeat x = + x : repeat x`, `iterate f x = x : iterate f (f x)`, and the + classic `fibs = 0 : 1 : zipWith plus fibs (tail fibs)` + terminate when only a finite prefix is consumed. + 2. Operators are now first-class values via a small + `hk-make-binop-builtin` helper, so `(+)`, `(*)`, `(==)` etc. + can be passed to `zipWith` and `map`. + Added range support across parser + evaluator: `[from..to]` and + `[from,next..to]` evaluate eagerly via `hk-build-range` (handles + step direction); `[from..]` parses to a new `:range-from` node + that the evaluator desugars to `iterate (+ 1) from`. New + `hk-load-into!` runs the regular pipeline (parse → desugar → + register data → bind decls) on a source string, and `hk-init-env` + preloads `hk-prelude-src` with the Phase-3 Prelude: + `head`, `tail`, `fst`, `snd`, `take`, `drop`, `repeat`, `iterate`, + `length`, `map`, `filter`, `zipWith`, plus `fibs` and `plus`. + 25 new tests in `lib/haskell/tests/infinite.sx`, including + `take 10 fibs == [0,1,1,2,3,5,8,13,21,34]`, + `head (drop 99 [1..])`, `iterate (\x -> x * 2) 1` powers of two, + user-defined `ones = 1 : ones`, `naturalsFrom`, range edge cases, + composed `map`/`filter`, and a custom `mySum`. 359/359 green. + Sieve of Eratosthenes is deferred — it needs lazy `++` plus a + `mod` primitive — and lives under `Classic programs` anyway. + +- **2026-04-24** — Phase 3 laziness foundation. Added a thunk type to + `lib/haskell/eval.sx` (`hk-mk-thunk` / `hk-is-thunk?`) backed by a + one-shot memoizing `hk-force` that evaluates the deferred AST, then + flips a `forced` flag and caches the value on the thunk dict; the + shared `hk-deep-force` walks the result tree at the test/output + boundary. Three single-line wiring changes in the evaluator make + every application argument lazy: `:app` now wraps its argument in + `hk-mk-thunk` rather than evaluating it. To preserve correctness + where values must be inspected, `hk-apply`, `hk-eval-op`, + `hk-eval-if`, `hk-eval-case`, and `hk-eval` for `:neg` now force + their operand. `hk-apply-builtin` forces every collected arg + before invoking the underlying SX fn so built-ins (`error`, `not`, + `id`) stay strict. The pattern matcher in `match.sx` now forces + the scrutinee just-in-time only for patterns that need to inspect + shape — `p-wild`, `p-var`, `p-as`, and `p-lazy` are no-force + paths, so the value flows through as a thunk and binding + preserves laziness. `hk-match-list-pat` forces at every cons-spine + step. 6 new lazy-specific tests in `lib/haskell/tests/eval.sx` + verify that `(\x y -> x) 1 (error …)` and `(\x y -> y) (error …) 99` + return without diverging, that `case Just (error …) of Just _ -> 7` + short-circuits, that `const` drops its second arg, that + `myHead (1 : error … : [])` returns 1 without touching the tail, + and that `Just (error …)` survives a wildcard-arm `case`. 333/333 + green, all prior eval tests preserved by deep-forcing the result + in `hk-eval-expr-source` and `hk-prog-val`. + +- **2026-04-24** — Phase 2 evaluator (`lib/haskell/eval.sx`) — ties + the whole pipeline together. Strict semantics throughout (laziness + is Phase 3). Function values are tagged dicts: `closure`, + `multi`(fun), `con-partial`, `builtin`. `hk-apply` unifies dispatch + across all four; closures and multifuns curry one argument at a + time, multifuns trying each clause's pat-list in order once arity + is reached. Top-level `hk-bind-decls!` is three-pass — + collect groups + pre-seed names → install multifuns (so closures + observe later names) → eval 0-arity bodies and pat-binds — making + forward and mutually recursive references work. `hk-eval-let` does + the same trick with a mutable child env. Built-ins: + `error`/`not`/`id`, plus `otherwise = True`. Operators wired: + arithmetic, comparison (returning Bool conses), `&&`, `||`, `:`, + `++`. Sections evaluate the captured operand once and return a + closure synthesized via the existing AST. `hk-eval-program` + registers data decls then binds, returning the env; `hk-run` + fetches `main` if present. Also extended `runtime.sx` to + pre-register the standard Prelude conses (`Maybe`, `Either`, + `Ordering`) so expression-level eval doesn't need a leading + `data` decl. 48 new tests in `lib/haskell/tests/eval.sx` cover + literals, arithmetic precedence, comparison/Bool, `if`, `let` + (incl. recursive factorial), lambdas (incl. constructor pattern + args), constructors, `case` (Just/Nothing/literal/tuple/wildcard), + list literals + cons + `++`, tuples, sections, multi-clause + top-level (factorial, list length via cons pattern, Maybe handler + with default), user-defined `data` with case-style matching, a + binary-tree height program, currying, higher-order (`twice`), + short-circuit `error` via `if`, and the three built-ins. 329/329 + green. Phase 2 is now complete; Phase 3 (laziness) is next. + +- **2026-04-24** — Phase 2: value-level pattern matcher + (`lib/haskell/match.sx`). Core entry `hk-match pat val env` returns + an extended env dict on success or `nil` on failure (uses `assoc` + rather than `dict-set!` so failed branches never pollute the + caller's env). Constructor values are tagged lists with the + constructor name as the first element; tuples use the tag `"Tuple"`, + lists are chained `(":" h t)` cons cells terminated by `("[]")`. + Value builders `hk-mk-con` / `hk-mk-tuple` / `hk-mk-nil` / + `hk-mk-cons` / `hk-mk-list` keep tests readable. The matcher + handles every pattern node the parser emits: + - `:p-wild` (always matches), `:p-var` (binds), `:p-int` / + `:p-float` / `:p-string` / `:p-char` (literal equality) + - `:p-as` (sub-match then bind whole), `:p-lazy` (eager for now; + laziness wired in phase 3) + - `:p-con` with arity check + recursive arg matching, including + deeply nested patterns and infix `:` cons (uses the same + code path as named constructors) + - `:p-tuple` against `"Tuple"` values, `:p-list` against an + exact-length cons spine. + Helper `hk-parse-pat-source` lifts a real Haskell pattern out of + `case _ of -> 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 + `` 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