Compare commits
71 Commits
loops/mini
...
loops/hask
| Author | SHA1 | Date | |
|---|---|---|---|
| badb428100 | |||
| e83c01cdcc | |||
| 544e79f533 | |||
| 1eb9d0f8d2 | |||
| f182d04e6a | |||
| ab2c40c14c | |||
| d3c34b46b9 | |||
| 80dac0051d | |||
| b661318a45 | |||
| 47d9d07f2e | |||
| d75c61d408 | |||
| f1fea0f2f1 | |||
| a677585639 | |||
| c04f38a1ba | |||
| b13819c50c | |||
| f26f25f146 | |||
| d9cf00f287 | |||
| 0c0ed0605a | |||
| 63c1e17c75 | |||
| a4fd57cff1 | |||
| 76d141737a | |||
| 9307437679 | |||
| b89e321007 | |||
| ca9e12fc57 | |||
| 2adbc101fa | |||
| 4205989aee | |||
| 49252eaa5c | |||
| ebbf0fc10c | |||
| 8dfb3f6387 | |||
| 5a8c25bec7 | |||
| c821e21f94 | |||
| 5605fe1cc2 | |||
| 379bb93f14 | |||
| 7ce0c797f3 | |||
| 34513908df | |||
| 208953667b | |||
| e6d6273265 | |||
| e95ca4624b | |||
| e1a020dc90 | |||
| b0974b58c0 | |||
| 6620c0ac06 | |||
| 95cf653ba9 | |||
| 12de24e3a0 | |||
| 180b9009bf | |||
| a29bb6feca | |||
| d2638170db | |||
| a5c41d2573 | |||
| 882815e612 | |||
| e27daee4a8 | |||
| ef33e9a43a | |||
| 1b7bd86b43 | |||
| e5fe9ad2d4 | |||
| 2d373da06b | |||
| 25cf832998 | |||
| 29542ba9d2 | |||
| c2de220cce | |||
| d523df30c2 | |||
| 1b844f6a19 | |||
| 5f758d27c1 | |||
| 51f57aa2fa | |||
| 31308602ca | |||
| 788e8682f5 | |||
| bb134b88e3 | |||
| d8dec07df3 | |||
| 39c7baa44c | |||
| ee74a396c5 | |||
| a8997ab452 | |||
| 80d6507e57 | |||
| 685fcd11d5 | |||
| f6efba410a | |||
| 4a35998469 |
@@ -25,8 +25,9 @@
|
|||||||
; Glyph classification sets
|
; Glyph classification sets
|
||||||
; ============================================================
|
; ============================================================
|
||||||
|
|
||||||
(define apl-parse-op-glyphs
|
(define
|
||||||
(list "/" "\\" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@"))
|
apl-parse-op-glyphs
|
||||||
|
(list "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@"))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
apl-parse-fn-glyphs
|
apl-parse-fn-glyphs
|
||||||
@@ -82,22 +83,48 @@
|
|||||||
"⍎"
|
"⍎"
|
||||||
"⍕"))
|
"⍕"))
|
||||||
|
|
||||||
(define apl-quad-fn-names (list "⎕FMT"))
|
(define apl-quad-fn-names (list "⎕FMT" "⎕←"))
|
||||||
|
|
||||||
(define
|
(define apl-known-fn-names (list))
|
||||||
apl-parse-op-glyph?
|
|
||||||
(fn (v) (some (fn (g) (= g v)) apl-parse-op-glyphs)))
|
|
||||||
|
|
||||||
; ============================================================
|
; ============================================================
|
||||||
; Token accessors
|
; Token accessors
|
||||||
; ============================================================
|
; ============================================================
|
||||||
|
|
||||||
|
(define
|
||||||
|
apl-collect-fn-bindings
|
||||||
|
(fn
|
||||||
|
(stmt-groups)
|
||||||
|
(set! apl-known-fn-names (list))
|
||||||
|
(for-each
|
||||||
|
(fn
|
||||||
|
(toks)
|
||||||
|
(when
|
||||||
|
(and
|
||||||
|
(>= (len toks) 3)
|
||||||
|
(= (tok-type (nth toks 0)) :name)
|
||||||
|
(= (tok-type (nth toks 1)) :assign)
|
||||||
|
(= (tok-type (nth toks 2)) :lbrace))
|
||||||
|
(set!
|
||||||
|
apl-known-fn-names
|
||||||
|
(cons (tok-val (nth toks 0)) apl-known-fn-names))))
|
||||||
|
stmt-groups)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
apl-parse-op-glyph?
|
||||||
|
(fn (v) (some (fn (g) (= g v)) apl-parse-op-glyphs)))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
apl-parse-fn-glyph?
|
apl-parse-fn-glyph?
|
||||||
(fn (v) (some (fn (g) (= g v)) apl-parse-fn-glyphs)))
|
(fn (v) (some (fn (g) (= g v)) apl-parse-fn-glyphs)))
|
||||||
|
|
||||||
(define tok-type (fn (tok) (get tok :type)))
|
(define tok-type (fn (tok) (get tok :type)))
|
||||||
|
|
||||||
|
; ============================================================
|
||||||
|
; Collect trailing operators starting at index i
|
||||||
|
; Returns {:ops (op ...) :end new-i}
|
||||||
|
; ============================================================
|
||||||
|
|
||||||
(define tok-val (fn (tok) (get tok :value)))
|
(define tok-val (fn (tok) (get tok :value)))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -107,8 +134,8 @@
|
|||||||
(and (= (tok-type tok) :glyph) (apl-parse-op-glyph? (tok-val tok)))))
|
(and (= (tok-type tok) :glyph) (apl-parse-op-glyph? (tok-val tok)))))
|
||||||
|
|
||||||
; ============================================================
|
; ============================================================
|
||||||
; Collect trailing operators starting at index i
|
; Build a derived-fn node by chaining operators left-to-right
|
||||||
; Returns {:ops (op ...) :end new-i}
|
; (+/¨ → (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+"))))
|
||||||
; ============================================================
|
; ============================================================
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -119,15 +146,17 @@
|
|||||||
(and (= (tok-type tok) :glyph) (apl-parse-fn-glyph? (tok-val tok)))
|
(and (= (tok-type tok) :glyph) (apl-parse-fn-glyph? (tok-val tok)))
|
||||||
(and
|
(and
|
||||||
(= (tok-type tok) :name)
|
(= (tok-type tok) :name)
|
||||||
(some (fn (q) (= q (tok-val tok))) apl-quad-fn-names)))))
|
(or
|
||||||
|
(some (fn (q) (= q (tok-val tok))) apl-quad-fn-names)
|
||||||
|
(some (fn (q) (= q (tok-val tok))) apl-known-fn-names))))))
|
||||||
|
|
||||||
|
; ============================================================
|
||||||
|
; Find matching close bracket/paren/brace
|
||||||
|
; Returns the index of the matching close token
|
||||||
|
; ============================================================
|
||||||
|
|
||||||
(define collect-ops (fn (tokens i) (collect-ops-loop tokens i (list))))
|
(define collect-ops (fn (tokens i) (collect-ops-loop tokens i (list))))
|
||||||
|
|
||||||
; ============================================================
|
|
||||||
; Build a derived-fn node by chaining operators left-to-right
|
|
||||||
; (+/¨ → (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+"))))
|
|
||||||
; ============================================================
|
|
||||||
|
|
||||||
(define
|
(define
|
||||||
collect-ops-loop
|
collect-ops-loop
|
||||||
(fn
|
(fn
|
||||||
@@ -143,8 +172,10 @@
|
|||||||
{:end i :ops acc})))))
|
{:end i :ops acc})))))
|
||||||
|
|
||||||
; ============================================================
|
; ============================================================
|
||||||
; Find matching close bracket/paren/brace
|
; Segment collection: scan tokens left-to-right, building
|
||||||
; Returns the index of the matching close token
|
; a list of {:kind "val"/"fn" :node ast} segments.
|
||||||
|
; Operators following function glyphs are merged into
|
||||||
|
; derived-fn nodes during this pass.
|
||||||
; ============================================================
|
; ============================================================
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -163,12 +194,20 @@
|
|||||||
(find-matching-close-loop tokens start open-type close-type 1)))
|
(find-matching-close-loop tokens start open-type close-type 1)))
|
||||||
|
|
||||||
; ============================================================
|
; ============================================================
|
||||||
; Segment collection: scan tokens left-to-right, building
|
; Build tree from segment list
|
||||||
; a list of {:kind "val"/"fn" :node ast} segments.
|
;
|
||||||
; Operators following function glyphs are merged into
|
; The segments are in left-to-right order.
|
||||||
; derived-fn nodes during this pass.
|
; APL evaluates right-to-left, so the LEFTMOST function is
|
||||||
|
; the outermost (last-evaluated) node.
|
||||||
|
;
|
||||||
|
; Patterns:
|
||||||
|
; [val] → val node
|
||||||
|
; [fn val ...] → (:monad fn (build-tree rest))
|
||||||
|
; [val fn val ...] → (:dyad fn val (build-tree rest))
|
||||||
|
; [val val ...] → (:vec val1 val2 ...) — strand
|
||||||
; ============================================================
|
; ============================================================
|
||||||
|
|
||||||
|
; Find the index of the first function segment (returns -1 if none)
|
||||||
(define
|
(define
|
||||||
find-matching-close-loop
|
find-matching-close-loop
|
||||||
(fn
|
(fn
|
||||||
@@ -208,21 +247,9 @@
|
|||||||
collect-segments
|
collect-segments
|
||||||
(fn (tokens) (collect-segments-loop tokens 0 (list))))
|
(fn (tokens) (collect-segments-loop tokens 0 (list))))
|
||||||
|
|
||||||
; ============================================================
|
; Build an array node from 0..n value segments
|
||||||
; Build tree from segment list
|
; If n=1 → return that segment's node
|
||||||
;
|
; If n>1 → return (:vec node1 node2 ...)
|
||||||
; The segments are in left-to-right order.
|
|
||||||
; APL evaluates right-to-left, so the LEFTMOST function is
|
|
||||||
; the outermost (last-evaluated) node.
|
|
||||||
;
|
|
||||||
; Patterns:
|
|
||||||
; [val] → val node
|
|
||||||
; [fn val ...] → (:monad fn (build-tree rest))
|
|
||||||
; [val fn val ...] → (:dyad fn val (build-tree rest))
|
|
||||||
; [val val ...] → (:vec val1 val2 ...) — strand
|
|
||||||
; ============================================================
|
|
||||||
|
|
||||||
; Find the index of the first function segment (returns -1 if none)
|
|
||||||
(define
|
(define
|
||||||
collect-segments-loop
|
collect-segments-loop
|
||||||
(fn
|
(fn
|
||||||
@@ -242,24 +269,38 @@
|
|||||||
((= tt :str)
|
((= tt :str)
|
||||||
(collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)})))
|
(collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)})))
|
||||||
((= tt :name)
|
((= tt :name)
|
||||||
(if
|
(cond
|
||||||
(some (fn (q) (= q tv)) apl-quad-fn-names)
|
((some (fn (q) (= q tv)) apl-quad-fn-names)
|
||||||
(let
|
|
||||||
((op-result (collect-ops tokens (+ i 1))))
|
|
||||||
(let
|
(let
|
||||||
((ops (get op-result :ops)) (ni (get op-result :end)))
|
((op-result (collect-ops tokens (+ i 1))))
|
||||||
(let
|
(let
|
||||||
((fn-node (build-derived-fn (list :fn-glyph tv) ops)))
|
((ops (get op-result :ops))
|
||||||
(collect-segments-loop
|
(ni (get op-result :end)))
|
||||||
tokens
|
(let
|
||||||
ni
|
((fn-node (build-derived-fn (list :fn-glyph tv) ops)))
|
||||||
(append acc {:kind "fn" :node fn-node})))))
|
(collect-segments-loop
|
||||||
(let
|
tokens
|
||||||
((br (maybe-bracket (list :name tv) tokens (+ i 1))))
|
ni
|
||||||
(collect-segments-loop
|
(append acc {:kind "fn" :node fn-node}))))))
|
||||||
tokens
|
((some (fn (q) (= q tv)) apl-known-fn-names)
|
||||||
(nth br 1)
|
(let
|
||||||
(append acc {:kind "val" :node (nth br 0)})))))
|
((op-result (collect-ops tokens (+ i 1))))
|
||||||
|
(let
|
||||||
|
((ops (get op-result :ops))
|
||||||
|
(ni (get op-result :end)))
|
||||||
|
(let
|
||||||
|
((fn-node (build-derived-fn (list :fn-name tv) ops)))
|
||||||
|
(collect-segments-loop
|
||||||
|
tokens
|
||||||
|
ni
|
||||||
|
(append acc {:kind "fn" :node fn-node}))))))
|
||||||
|
(else
|
||||||
|
(let
|
||||||
|
((br (maybe-bracket (list :name tv) tokens (+ i 1))))
|
||||||
|
(collect-segments-loop
|
||||||
|
tokens
|
||||||
|
(nth br 1)
|
||||||
|
(append acc {:kind "val" :node (nth br 0)}))))))
|
||||||
((= tt :lparen)
|
((= tt :lparen)
|
||||||
(let
|
(let
|
||||||
((end (find-matching-close tokens (+ i 1) :lparen :rparen)))
|
((end (find-matching-close tokens (+ i 1) :lparen :rparen)))
|
||||||
@@ -267,11 +308,23 @@
|
|||||||
((inner-tokens (slice tokens (+ i 1) end))
|
((inner-tokens (slice tokens (+ i 1) end))
|
||||||
(after (+ end 1)))
|
(after (+ end 1)))
|
||||||
(let
|
(let
|
||||||
((br (maybe-bracket (parse-apl-expr inner-tokens) tokens after)))
|
((inner-segs (collect-segments inner-tokens)))
|
||||||
(collect-segments-loop
|
(if
|
||||||
tokens
|
(and
|
||||||
(nth br 1)
|
(>= (len inner-segs) 2)
|
||||||
(append acc {:kind "val" :node (nth br 0)}))))))
|
(every? (fn (s) (= (get s :kind) "fn")) inner-segs))
|
||||||
|
(let
|
||||||
|
((train-node (cons :train (map (fn (s) (get s :node)) inner-segs))))
|
||||||
|
(collect-segments-loop
|
||||||
|
tokens
|
||||||
|
after
|
||||||
|
(append acc {:kind "fn" :node train-node})))
|
||||||
|
(let
|
||||||
|
((br (maybe-bracket (parse-apl-expr inner-tokens) tokens after)))
|
||||||
|
(collect-segments-loop
|
||||||
|
tokens
|
||||||
|
(nth br 1)
|
||||||
|
(append acc {:kind "val" :node (nth br 0)}))))))))
|
||||||
((= tt :lbrace)
|
((= tt :lbrace)
|
||||||
(let
|
(let
|
||||||
((end (find-matching-close tokens (+ i 1) :lbrace :rbrace)))
|
((end (find-matching-close tokens (+ i 1) :lbrace :rbrace)))
|
||||||
@@ -346,9 +399,12 @@
|
|||||||
|
|
||||||
(define find-first-fn (fn (segs) (find-first-fn-loop segs 0)))
|
(define find-first-fn (fn (segs) (find-first-fn-loop segs 0)))
|
||||||
|
|
||||||
; Build an array node from 0..n value segments
|
|
||||||
; If n=1 → return that segment's node
|
; ============================================================
|
||||||
; If n>1 → return (:vec node1 node2 ...)
|
; Split token list on statement separators (diamond / newline)
|
||||||
|
; Only splits at depth 0 (ignores separators inside { } or ( ) )
|
||||||
|
; ============================================================
|
||||||
|
|
||||||
(define
|
(define
|
||||||
find-first-fn-loop
|
find-first-fn-loop
|
||||||
(fn
|
(fn
|
||||||
@@ -370,10 +426,9 @@
|
|||||||
(get (first segs) :node)
|
(get (first segs) :node)
|
||||||
(cons :vec (map (fn (s) (get s :node)) segs)))))
|
(cons :vec (map (fn (s) (get s :node)) segs)))))
|
||||||
|
|
||||||
|
|
||||||
; ============================================================
|
; ============================================================
|
||||||
; Split token list on statement separators (diamond / newline)
|
; Parse a dfn body (tokens between { and })
|
||||||
; Only splits at depth 0 (ignores separators inside { } or ( ) )
|
; Handles guard expressions: cond : expr
|
||||||
; ============================================================
|
; ============================================================
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -408,11 +463,6 @@
|
|||||||
split-statements
|
split-statements
|
||||||
(fn (tokens) (split-statements-loop tokens (list) (list) 0)))
|
(fn (tokens) (split-statements-loop tokens (list) (list) 0)))
|
||||||
|
|
||||||
; ============================================================
|
|
||||||
; Parse a dfn body (tokens between { and })
|
|
||||||
; Handles guard expressions: cond : expr
|
|
||||||
; ============================================================
|
|
||||||
|
|
||||||
(define
|
(define
|
||||||
split-statements-loop
|
split-statements-loop
|
||||||
(fn
|
(fn
|
||||||
@@ -467,6 +517,10 @@
|
|||||||
((stmt-groups (split-statements tokens)))
|
((stmt-groups (split-statements tokens)))
|
||||||
(let ((stmts (map parse-dfn-stmt stmt-groups))) (cons :dfn stmts)))))
|
(let ((stmts (map parse-dfn-stmt stmt-groups))) (cons :dfn stmts)))))
|
||||||
|
|
||||||
|
; ============================================================
|
||||||
|
; Parse a single statement (assignment or expression)
|
||||||
|
; ============================================================
|
||||||
|
|
||||||
(define
|
(define
|
||||||
parse-dfn-stmt
|
parse-dfn-stmt
|
||||||
(fn
|
(fn
|
||||||
@@ -483,12 +537,17 @@
|
|||||||
(parse-apl-expr body-tokens)))
|
(parse-apl-expr body-tokens)))
|
||||||
(parse-stmt tokens)))))
|
(parse-stmt tokens)))))
|
||||||
|
|
||||||
|
; ============================================================
|
||||||
|
; Parse an expression from a flat token list
|
||||||
|
; ============================================================
|
||||||
|
|
||||||
(define
|
(define
|
||||||
find-top-level-colon
|
find-top-level-colon
|
||||||
(fn (tokens i) (find-top-level-colon-loop tokens i 0)))
|
(fn (tokens i) (find-top-level-colon-loop tokens i 0)))
|
||||||
|
|
||||||
; ============================================================
|
; ============================================================
|
||||||
; Parse a single statement (assignment or expression)
|
; Main entry point
|
||||||
|
; parse-apl: string → AST
|
||||||
; ============================================================
|
; ============================================================
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -508,10 +567,6 @@
|
|||||||
((and (= tt :colon) (= depth 0)) i)
|
((and (= tt :colon) (= depth 0)) i)
|
||||||
(true (find-top-level-colon-loop tokens (+ i 1) depth)))))))
|
(true (find-top-level-colon-loop tokens (+ i 1) depth)))))))
|
||||||
|
|
||||||
; ============================================================
|
|
||||||
; Parse an expression from a flat token list
|
|
||||||
; ============================================================
|
|
||||||
|
|
||||||
(define
|
(define
|
||||||
parse-stmt
|
parse-stmt
|
||||||
(fn
|
(fn
|
||||||
@@ -526,11 +581,6 @@
|
|||||||
(parse-apl-expr (slice tokens 2)))
|
(parse-apl-expr (slice tokens 2)))
|
||||||
(parse-apl-expr tokens))))
|
(parse-apl-expr tokens))))
|
||||||
|
|
||||||
; ============================================================
|
|
||||||
; Main entry point
|
|
||||||
; parse-apl: string → AST
|
|
||||||
; ============================================================
|
|
||||||
|
|
||||||
(define
|
(define
|
||||||
parse-apl-expr
|
parse-apl-expr
|
||||||
(fn
|
(fn
|
||||||
@@ -547,13 +597,52 @@
|
|||||||
((tokens (apl-tokenize src)))
|
((tokens (apl-tokenize src)))
|
||||||
(let
|
(let
|
||||||
((stmt-groups (split-statements tokens)))
|
((stmt-groups (split-statements tokens)))
|
||||||
(if
|
(begin
|
||||||
(= (len stmt-groups) 0)
|
(apl-collect-fn-bindings stmt-groups)
|
||||||
nil
|
|
||||||
(if
|
(if
|
||||||
(= (len stmt-groups) 1)
|
(= (len stmt-groups) 0)
|
||||||
(parse-stmt (first stmt-groups))
|
nil
|
||||||
(cons :program (map parse-stmt stmt-groups))))))))
|
(if
|
||||||
|
(= (len stmt-groups) 1)
|
||||||
|
(parse-stmt (first stmt-groups))
|
||||||
|
(cons :program (map parse-stmt stmt-groups)))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
split-bracket-loop
|
||||||
|
(fn
|
||||||
|
(tokens current acc depth)
|
||||||
|
(if
|
||||||
|
(= (len tokens) 0)
|
||||||
|
(append acc (list current))
|
||||||
|
(let
|
||||||
|
((tok (first tokens)) (more (rest tokens)))
|
||||||
|
(let
|
||||||
|
((tt (tok-type tok)))
|
||||||
|
(cond
|
||||||
|
((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket))
|
||||||
|
(split-bracket-loop
|
||||||
|
more
|
||||||
|
(append current (list tok))
|
||||||
|
acc
|
||||||
|
(+ depth 1)))
|
||||||
|
((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket))
|
||||||
|
(split-bracket-loop
|
||||||
|
more
|
||||||
|
(append current (list tok))
|
||||||
|
acc
|
||||||
|
(- depth 1)))
|
||||||
|
((and (= tt :semi) (= depth 0))
|
||||||
|
(split-bracket-loop
|
||||||
|
more
|
||||||
|
(list)
|
||||||
|
(append acc (list current))
|
||||||
|
depth))
|
||||||
|
(else
|
||||||
|
(split-bracket-loop more (append current (list tok)) acc depth))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
split-bracket-content
|
||||||
|
(fn (tokens) (split-bracket-loop tokens (list) (list) 0)))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
maybe-bracket
|
maybe-bracket
|
||||||
@@ -569,8 +658,17 @@
|
|||||||
((inner-tokens (slice tokens (+ after 1) end))
|
((inner-tokens (slice tokens (+ after 1) end))
|
||||||
(next-after (+ end 1)))
|
(next-after (+ end 1)))
|
||||||
(let
|
(let
|
||||||
((idx-expr (parse-apl-expr inner-tokens)))
|
((sections (split-bracket-content inner-tokens)))
|
||||||
(let
|
(if
|
||||||
((indexed (list :dyad (list :fn-glyph "⌷") idx-expr val-node)))
|
(= (len sections) 1)
|
||||||
(maybe-bracket indexed tokens next-after)))))
|
(let
|
||||||
|
((idx-expr (parse-apl-expr inner-tokens)))
|
||||||
|
(let
|
||||||
|
((indexed (list :dyad (list :fn-glyph "⌷") idx-expr val-node)))
|
||||||
|
(maybe-bracket indexed tokens next-after)))
|
||||||
|
(let
|
||||||
|
((axis-exprs (map (fn (toks) (if (= (len toks) 0) :all (parse-apl-expr toks))) sections)))
|
||||||
|
(let
|
||||||
|
((indexed (cons :bracket (cons val-node axis-exprs))))
|
||||||
|
(maybe-bracket indexed tokens next-after)))))))
|
||||||
(list val-node after))))
|
(list val-node after))))
|
||||||
|
|||||||
@@ -883,7 +883,7 @@
|
|||||||
(let
|
(let
|
||||||
((sub (apl-permutations (- n 1))))
|
((sub (apl-permutations (- n 1))))
|
||||||
(reduce
|
(reduce
|
||||||
(fn (acc p) (append acc (apl-insert-everywhere n p)))
|
(fn (acc p) (append (apl-insert-everywhere n p) acc))
|
||||||
(list)
|
(list)
|
||||||
sub)))))
|
sub)))))
|
||||||
|
|
||||||
@@ -985,6 +985,38 @@
|
|||||||
(some (fn (c) (= c 0)) codes)
|
(some (fn (c) (= c 0)) codes)
|
||||||
(some (fn (c) (= c (nth e 1))) codes)))))
|
(some (fn (c) (= c (nth e 1))) codes)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
apl-cartesian
|
||||||
|
(fn
|
||||||
|
(lists)
|
||||||
|
(if
|
||||||
|
(= (len lists) 0)
|
||||||
|
(list (list))
|
||||||
|
(let
|
||||||
|
((rest-prods (apl-cartesian (rest lists))))
|
||||||
|
(reduce
|
||||||
|
(fn (acc x) (append acc (map (fn (p) (cons x p)) rest-prods)))
|
||||||
|
(list)
|
||||||
|
(first lists))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
apl-bracket-multi
|
||||||
|
(fn
|
||||||
|
(axes arr)
|
||||||
|
(let
|
||||||
|
((shape (get arr :shape)) (ravel (get arr :ravel)))
|
||||||
|
(let
|
||||||
|
((rank (len shape)) (strides (apl-strides shape)))
|
||||||
|
(let
|
||||||
|
((axis-info (map (fn (i) (let ((a (nth axes i))) (cond ((= a nil) {:idxs (range 0 (nth shape i)) :scalar? false}) ((= (len (get a :shape)) 0) {:idxs (list (- (first (get a :ravel)) apl-io)) :scalar? true}) (else {:idxs (map (fn (x) (- x apl-io)) (get a :ravel)) :scalar? false})))) (range 0 rank))))
|
||||||
|
(let
|
||||||
|
((cells (apl-cartesian (map (fn (a) (get a :idxs)) axis-info))))
|
||||||
|
(let
|
||||||
|
((result-ravel (map (fn (cell) (let ((flat (reduce + 0 (map (fn (i) (* (nth cell i) (nth strides i))) (range 0 rank))))) (nth ravel flat))) cells)))
|
||||||
|
(let
|
||||||
|
((result-shape (filter (fn (x) (>= x 0)) (map (fn (i) (let ((a (nth axis-info i))) (if (get a :scalar?) -1 (len (get a :idxs))))) (range 0 rank)))))
|
||||||
|
(make-array result-shape result-ravel)))))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
apl-reduce
|
apl-reduce
|
||||||
(fn
|
(fn
|
||||||
|
|||||||
@@ -39,6 +39,7 @@ cat > "$TMPFILE" << 'EPOCHS'
|
|||||||
(load "lib/apl/tests/idioms.sx")
|
(load "lib/apl/tests/idioms.sx")
|
||||||
(load "lib/apl/tests/eval-ops.sx")
|
(load "lib/apl/tests/eval-ops.sx")
|
||||||
(load "lib/apl/tests/pipeline.sx")
|
(load "lib/apl/tests/pipeline.sx")
|
||||||
|
(load "lib/apl/tests/programs-e2e.sx")
|
||||||
(epoch 4)
|
(epoch 4)
|
||||||
(eval "(list apl-test-pass apl-test-fail)")
|
(eval "(list apl-test-pass apl-test-fail)")
|
||||||
EPOCHS
|
EPOCHS
|
||||||
|
|||||||
@@ -178,3 +178,137 @@
|
|||||||
"apl-run \"(⍳5)[3] × 7\" → 21"
|
"apl-run \"(⍳5)[3] × 7\" → 21"
|
||||||
(mkrv (apl-run "(⍳5)[3] × 7"))
|
(mkrv (apl-run "(⍳5)[3] × 7"))
|
||||||
(list 21))
|
(list 21))
|
||||||
|
|
||||||
|
(apl-test "decimal: 3.7 → 3.7" (mkrv (apl-run "3.7")) (list 3.7))
|
||||||
|
|
||||||
|
(apl-test "decimal: ¯2.5 → -2.5" (mkrv (apl-run "¯2.5")) (list -2.5))
|
||||||
|
|
||||||
|
(apl-test "decimal: 1.5 + 2.5 → 4" (mkrv (apl-run "1.5 + 2.5")) (list 4))
|
||||||
|
|
||||||
|
(apl-test "decimal: ⌊3.7 → 3" (mkrv (apl-run "⌊ 3.7")) (list 3))
|
||||||
|
|
||||||
|
(apl-test "decimal: ⌈3.7 → 4" (mkrv (apl-run "⌈ 3.7")) (list 4))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"⎕← scalar passthrough"
|
||||||
|
(mkrv (apl-run "⎕← 42"))
|
||||||
|
(list 42))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"⎕← vector passthrough"
|
||||||
|
(mkrv (apl-run "⎕← 1 2 3"))
|
||||||
|
(list 1 2 3))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"string: 'abc' → 3-char vector"
|
||||||
|
(mkrv (apl-run "'abc'"))
|
||||||
|
(list "a" "b" "c"))
|
||||||
|
|
||||||
|
(apl-test "string: 'a' is rank-0 scalar" (mksh (apl-run "'a'")) (list))
|
||||||
|
|
||||||
|
(apl-test "string: 'hello' shape (5)" (mksh (apl-run "'hello'")) (list 5))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"named-fn: f ← {⍺+⍵} ⋄ 3 f 4 → 7"
|
||||||
|
(mkrv (apl-run "f ← {⍺+⍵} ⋄ 3 f 4"))
|
||||||
|
(list 7))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"named-fn monadic: sq ← {⍵×⍵} ⋄ sq 7 → 49"
|
||||||
|
(mkrv (apl-run "sq ← {⍵×⍵} ⋄ sq 7"))
|
||||||
|
(list 49))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"named-fn dyadic: hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4 → 25"
|
||||||
|
(mkrv (apl-run "hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4"))
|
||||||
|
(list 25))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"named-fn: dbl ← {⍵+⍵} ⋄ dbl ⍳5"
|
||||||
|
(mkrv (apl-run "dbl ← {⍵+⍵} ⋄ dbl ⍳5"))
|
||||||
|
(list 2 4 6 8 10))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"named-fn factorial via ∇ recursion"
|
||||||
|
(mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 5"))
|
||||||
|
(list 120))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"named-fn used twice in expr: dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4"
|
||||||
|
(mkrv (apl-run "dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4"))
|
||||||
|
(list 14))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"named-fn with vector arg: neg ← {-⍵} ⋄ neg 1 2 3"
|
||||||
|
(mkrv (apl-run "neg ← {-⍵} ⋄ neg 1 2 3"))
|
||||||
|
(list -1 -2 -3))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"multi-axis: M[2;2] → center"
|
||||||
|
(mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[2;2]"))
|
||||||
|
(list 5))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"multi-axis: M[1;] → first row"
|
||||||
|
(mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[1;]"))
|
||||||
|
(list 1 2 3))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"multi-axis: M[;2] → second column"
|
||||||
|
(mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[;2]"))
|
||||||
|
(list 2 5 8))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"multi-axis: M[1 2;1 2] → 2x2 block"
|
||||||
|
(mkrv (apl-run "M ← (2 3) ⍴ ⍳6 ⋄ M[1 2;1 2]"))
|
||||||
|
(list 1 2 4 5))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"multi-axis: M[1 2;1 2] shape (2 2)"
|
||||||
|
(mksh (apl-run "M ← (2 3) ⍴ ⍳6 ⋄ M[1 2;1 2]"))
|
||||||
|
(list 2 2))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"multi-axis: M[;] full matrix"
|
||||||
|
(mkrv (apl-run "M ← (2 2) ⍴ 10 20 30 40 ⋄ M[;]"))
|
||||||
|
(list 10 20 30 40))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"multi-axis: M[1;] shape collapsed"
|
||||||
|
(mksh (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[1;]"))
|
||||||
|
(list 3))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"multi-axis: select all rows of column 3"
|
||||||
|
(mkrv (apl-run "M ← (4 3) ⍴ 1 2 3 4 5 6 7 8 9 10 11 12 ⋄ M[;3]"))
|
||||||
|
(list 3 6 9 12))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"train: mean = (+/÷≢) on 1..5"
|
||||||
|
(mkrv (apl-run "(+/÷≢) 1 2 3 4 5"))
|
||||||
|
(list 3))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"train: mean of 2 4 6 8 10"
|
||||||
|
(mkrv (apl-run "(+/÷≢) 2 4 6 8 10"))
|
||||||
|
(list 6))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"train 2-atop: (- ⌊) 5 → -5"
|
||||||
|
(mkrv (apl-run "(- ⌊) 5"))
|
||||||
|
(list -5))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"train 3-fork dyadic: 2(+×-)5 → -21"
|
||||||
|
(mkrv (apl-run "2 (+ × -) 5"))
|
||||||
|
(list -21))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"train: range = (⌈/-⌊/) on vector"
|
||||||
|
(mkrv (apl-run "(⌈/-⌊/) 3 1 4 1 5 9 2 6"))
|
||||||
|
(list 8))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"train: mean of ⍳10 has shape ()"
|
||||||
|
(mksh (apl-run "(+/÷≢) ⍳10"))
|
||||||
|
(list))
|
||||||
|
|||||||
96
lib/apl/tests/programs-e2e.sx
Normal file
96
lib/apl/tests/programs-e2e.sx
Normal file
@@ -0,0 +1,96 @@
|
|||||||
|
; End-to-end tests of the classic-program archetypes — running APL
|
||||||
|
; source through the full pipeline (tokenize → parse → eval-ast → runtime).
|
||||||
|
;
|
||||||
|
; These mirror the algorithms documented in lib/apl/tests/programs/*.apl
|
||||||
|
; but use forms our pipeline supports today (named functions instead of
|
||||||
|
; the inline ⍵← rebinding idiom; multi-stmt over single one-liners).
|
||||||
|
|
||||||
|
(define mkrv (fn (arr) (get arr :ravel)))
|
||||||
|
(define mksh (fn (arr) (get arr :shape)))
|
||||||
|
|
||||||
|
; ---------- factorial via ∇ recursion (cf. n-queens style) ----------
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: factorial 5! = 120"
|
||||||
|
(mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 5"))
|
||||||
|
(list 120))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: factorial 7! = 5040"
|
||||||
|
(mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 7"))
|
||||||
|
(list 5040))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: factorial via ×/⍳N (no recursion)"
|
||||||
|
(mkrv (apl-run "fact ← {×/⍳⍵} ⋄ fact 6"))
|
||||||
|
(list 720))
|
||||||
|
|
||||||
|
; ---------- sum / triangular numbers (sum-1..N) ----------
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: triangular(10) = 55"
|
||||||
|
(mkrv (apl-run "tri ← {+/⍳⍵} ⋄ tri 10"))
|
||||||
|
(list 55))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: triangular(100) = 5050"
|
||||||
|
(mkrv (apl-run "tri ← {+/⍳⍵} ⋄ tri 100"))
|
||||||
|
(list 5050))
|
||||||
|
|
||||||
|
; ---------- sum of squares ----------
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: sum-of-squares 1..5 = 55"
|
||||||
|
(mkrv (apl-run "ss ← {+/⍵×⍵} ⋄ ss ⍳5"))
|
||||||
|
(list 55))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: sum-of-squares 1..10 = 385"
|
||||||
|
(mkrv (apl-run "ss ← {+/⍵×⍵} ⋄ ss ⍳10"))
|
||||||
|
(list 385))
|
||||||
|
|
||||||
|
; ---------- divisor-counting (prime-sieve building blocks) ----------
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: divisor counts 1..5 via outer mod"
|
||||||
|
(mkrv (apl-run "P ← ⍳ 5 ⋄ +⌿ 0 = P ∘.| P"))
|
||||||
|
(list 1 2 2 3 2))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: divisor counts 1..10"
|
||||||
|
(mkrv (apl-run "P ← ⍳ 10 ⋄ +⌿ 0 = P ∘.| P"))
|
||||||
|
(list 1 2 2 3 2 4 2 4 3 4))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: prime-mask 1..10 (count==2)"
|
||||||
|
(mkrv (apl-run "P ← ⍳ 10 ⋄ 2 = +⌿ 0 = P ∘.| P"))
|
||||||
|
(list 0 1 1 0 1 0 1 0 0 0))
|
||||||
|
|
||||||
|
; ---------- monadic primitives chained ----------
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: sum of |abs| = 15"
|
||||||
|
(mkrv (apl-run "+/|¯1 ¯2 ¯3 ¯4 ¯5"))
|
||||||
|
(list 15))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: max of squares 1..6"
|
||||||
|
(mkrv (apl-run "⌈/(⍳6)×⍳6"))
|
||||||
|
(list 36))
|
||||||
|
|
||||||
|
; ---------- nested named functions ----------
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: compose dbl and sq via two named fns"
|
||||||
|
(mkrv (apl-run "dbl ← {⍵+⍵} ⋄ sq ← {⍵×⍵} ⋄ sq dbl 3"))
|
||||||
|
(list 36))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: max-of-two as named dyadic fn"
|
||||||
|
(mkrv (apl-run "mx ← {⍺⌈⍵} ⋄ 5 mx 3"))
|
||||||
|
(list 5))
|
||||||
|
|
||||||
|
(apl-test
|
||||||
|
"e2e: sqrt-via-newton 1 step from 1 → 2.5"
|
||||||
|
(mkrv (apl-run "step ← {(⍵+⍺÷⍵)÷2} ⋄ 4 step 1"))
|
||||||
|
(list 2.5))
|
||||||
@@ -252,6 +252,8 @@
|
|||||||
|
|
||||||
(apl-test "queens 7 → 40 solutions" (mkrv (apl-queens 7)) (list 40))
|
(apl-test "queens 7 → 40 solutions" (mkrv (apl-queens 7)) (list 40))
|
||||||
|
|
||||||
|
(apl-test "queens 8 → 92 solutions" (mkrv (apl-queens 8)) (list 92))
|
||||||
|
|
||||||
(apl-test "permutations of 3 has 6" (len (apl-permutations 3)) 6)
|
(apl-test "permutations of 3 has 6" (len (apl-permutations 3)) 6)
|
||||||
|
|
||||||
(apl-test "permutations of 4 has 24" (len (apl-permutations 4)) 24)
|
(apl-test "permutations of 4 has 24" (len (apl-permutations 4)) 24)
|
||||||
|
|||||||
@@ -2,7 +2,7 @@
|
|||||||
(list "+" "-" "×" "÷" "*" "⍟" "⌈" "⌊" "|" "!" "?" "○" "~" "<" "≤" "=" "≥" ">" "≠"
|
(list "+" "-" "×" "÷" "*" "⍟" "⌈" "⌊" "|" "!" "?" "○" "~" "<" "≤" "=" "≥" ">" "≠"
|
||||||
"≢" "≡" "∊" "∧" "∨" "⍱" "⍲" "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆"
|
"≢" "≡" "∊" "∧" "∨" "⍱" "⍲" "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆"
|
||||||
"∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕"
|
"∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕"
|
||||||
"⍺" "⍵" "∇" "/" "\\" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯"))
|
"⍺" "⍵" "∇" "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯"))
|
||||||
|
|
||||||
(define apl-glyph?
|
(define apl-glyph?
|
||||||
(fn (ch)
|
(fn (ch)
|
||||||
@@ -138,12 +138,22 @@
|
|||||||
(begin
|
(begin
|
||||||
(consume! "¯")
|
(consume! "¯")
|
||||||
(let ((digits (read-digits! "")))
|
(let ((digits (read-digits! "")))
|
||||||
(tok-push! :num (- 0 (parse-int digits 0))))
|
(if (and (< pos src-len) (= (cur-byte) ".")
|
||||||
|
(< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1))))
|
||||||
|
(begin (advance!)
|
||||||
|
(let ((frac (read-digits! "")))
|
||||||
|
(tok-push! :num (- 0 (string->number (str digits "." frac))))))
|
||||||
|
(tok-push! :num (- 0 (parse-int digits 0)))))
|
||||||
(scan!)))
|
(scan!)))
|
||||||
((apl-digit? ch)
|
((apl-digit? ch)
|
||||||
(begin
|
(begin
|
||||||
(let ((digits (read-digits! "")))
|
(let ((digits (read-digits! "")))
|
||||||
(tok-push! :num (parse-int digits 0)))
|
(if (and (< pos src-len) (= (cur-byte) ".")
|
||||||
|
(< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1))))
|
||||||
|
(begin (advance!)
|
||||||
|
(let ((frac (read-digits! "")))
|
||||||
|
(tok-push! :num (string->number (str digits "." frac)))))
|
||||||
|
(tok-push! :num (parse-int digits 0))))
|
||||||
(scan!)))
|
(scan!)))
|
||||||
((= ch "'")
|
((= ch "'")
|
||||||
(begin
|
(begin
|
||||||
@@ -155,7 +165,9 @@
|
|||||||
(let ((start pos))
|
(let ((start pos))
|
||||||
(begin
|
(begin
|
||||||
(if (cur-sw? "⎕") (consume! "⎕") (advance!))
|
(if (cur-sw? "⎕") (consume! "⎕") (advance!))
|
||||||
(read-ident-cont!)
|
(if (and (< pos src-len) (cur-sw? "←"))
|
||||||
|
(consume! "←")
|
||||||
|
(read-ident-cont!))
|
||||||
(tok-push! :name (slice source start pos))
|
(tok-push! :name (slice source start pos))
|
||||||
(scan!))))
|
(scan!))))
|
||||||
(true
|
(true
|
||||||
|
|||||||
@@ -40,6 +40,7 @@
|
|||||||
((= g "⍋") apl-grade-up)
|
((= g "⍋") apl-grade-up)
|
||||||
((= g "⍒") apl-grade-down)
|
((= g "⍒") apl-grade-down)
|
||||||
((= g "⎕FMT") apl-quad-fmt)
|
((= g "⎕FMT") apl-quad-fmt)
|
||||||
|
((= g "⎕←") apl-quad-print)
|
||||||
(else (error "no monadic fn for glyph")))))
|
(else (error "no monadic fn for glyph")))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -97,6 +98,15 @@
|
|||||||
((tag (first node)))
|
((tag (first node)))
|
||||||
(cond
|
(cond
|
||||||
((= tag :num) (apl-scalar (nth node 1)))
|
((= tag :num) (apl-scalar (nth node 1)))
|
||||||
|
((= tag :str)
|
||||||
|
(let
|
||||||
|
((s (nth node 1)))
|
||||||
|
(if
|
||||||
|
(= (len s) 1)
|
||||||
|
(apl-scalar s)
|
||||||
|
(make-array
|
||||||
|
(list (len s))
|
||||||
|
(map (fn (i) (slice s i (+ i 1))) (range 0 (len s)))))))
|
||||||
((= tag :vec)
|
((= tag :vec)
|
||||||
(let
|
(let
|
||||||
((items (rest node)))
|
((items (rest node)))
|
||||||
@@ -139,6 +149,16 @@
|
|||||||
(apl-eval-ast rhs env)))))
|
(apl-eval-ast rhs env)))))
|
||||||
((= tag :program) (apl-eval-stmts (rest node) env))
|
((= tag :program) (apl-eval-stmts (rest node) env))
|
||||||
((= tag :dfn) node)
|
((= tag :dfn) node)
|
||||||
|
((= tag :bracket)
|
||||||
|
(let
|
||||||
|
((arr-expr (nth node 1)) (axis-exprs (rest (rest node))))
|
||||||
|
(let
|
||||||
|
((arr (apl-eval-ast arr-expr env))
|
||||||
|
(axes
|
||||||
|
(map
|
||||||
|
(fn (a) (if (= a :all) nil (apl-eval-ast a env)))
|
||||||
|
axis-exprs)))
|
||||||
|
(apl-bracket-multi axes arr))))
|
||||||
(else (error (list "apl-eval-ast: unknown node tag" tag node)))))))
|
(else (error (list "apl-eval-ast: unknown node tag" tag node)))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -419,6 +439,36 @@
|
|||||||
((f (apl-resolve-dyadic inner env)))
|
((f (apl-resolve-dyadic inner env)))
|
||||||
(fn (arr) (apl-commute f arr))))
|
(fn (arr) (apl-commute f arr))))
|
||||||
(else (error "apl-resolve-monadic: unsupported op")))))
|
(else (error "apl-resolve-monadic: unsupported op")))))
|
||||||
|
((= tag :fn-name)
|
||||||
|
(let
|
||||||
|
((nm (nth fn-node 1)))
|
||||||
|
(let
|
||||||
|
((bound (get env nm)))
|
||||||
|
(if
|
||||||
|
(and
|
||||||
|
(list? bound)
|
||||||
|
(> (len bound) 0)
|
||||||
|
(= (first bound) :dfn))
|
||||||
|
(fn (arg) (apl-call-dfn-m bound arg))
|
||||||
|
(error "apl-resolve-monadic: name not bound to dfn")))))
|
||||||
|
((= tag :train)
|
||||||
|
(let
|
||||||
|
((fns (rest fn-node)))
|
||||||
|
(let
|
||||||
|
((n (len fns)))
|
||||||
|
(cond
|
||||||
|
((= n 2)
|
||||||
|
(let
|
||||||
|
((g (apl-resolve-monadic (nth fns 0) env))
|
||||||
|
(h (apl-resolve-monadic (nth fns 1) env)))
|
||||||
|
(fn (arg) (g (h arg)))))
|
||||||
|
((= n 3)
|
||||||
|
(let
|
||||||
|
((f (apl-resolve-monadic (nth fns 0) env))
|
||||||
|
(g (apl-resolve-dyadic (nth fns 1) env))
|
||||||
|
(h (apl-resolve-monadic (nth fns 2) env)))
|
||||||
|
(fn (arg) (g (f arg) (h arg)))))
|
||||||
|
(else (error "monadic train arity not 2 or 3"))))))
|
||||||
(else (error "apl-resolve-monadic: unknown fn-node tag"))))))
|
(else (error "apl-resolve-monadic: unknown fn-node tag"))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -442,6 +492,18 @@
|
|||||||
((f (apl-resolve-dyadic inner env)))
|
((f (apl-resolve-dyadic inner env)))
|
||||||
(fn (a b) (apl-commute-dyadic f a b))))
|
(fn (a b) (apl-commute-dyadic f a b))))
|
||||||
(else (error "apl-resolve-dyadic: unsupported op")))))
|
(else (error "apl-resolve-dyadic: unsupported op")))))
|
||||||
|
((= tag :fn-name)
|
||||||
|
(let
|
||||||
|
((nm (nth fn-node 1)))
|
||||||
|
(let
|
||||||
|
((bound (get env nm)))
|
||||||
|
(if
|
||||||
|
(and
|
||||||
|
(list? bound)
|
||||||
|
(> (len bound) 0)
|
||||||
|
(= (first bound) :dfn))
|
||||||
|
(fn (a b) (apl-call-dfn bound a b))
|
||||||
|
(error "apl-resolve-dyadic: name not bound to dfn")))))
|
||||||
((= tag :outer)
|
((= tag :outer)
|
||||||
(let
|
(let
|
||||||
((inner (nth fn-node 2)))
|
((inner (nth fn-node 2)))
|
||||||
@@ -455,6 +517,24 @@
|
|||||||
((f (apl-resolve-dyadic f-node env))
|
((f (apl-resolve-dyadic f-node env))
|
||||||
(g (apl-resolve-dyadic g-node env)))
|
(g (apl-resolve-dyadic g-node env)))
|
||||||
(fn (a b) (apl-inner f g a b)))))
|
(fn (a b) (apl-inner f g a b)))))
|
||||||
|
((= tag :train)
|
||||||
|
(let
|
||||||
|
((fns (rest fn-node)))
|
||||||
|
(let
|
||||||
|
((n (len fns)))
|
||||||
|
(cond
|
||||||
|
((= n 2)
|
||||||
|
(let
|
||||||
|
((g (apl-resolve-monadic (nth fns 0) env))
|
||||||
|
(h (apl-resolve-dyadic (nth fns 1) env)))
|
||||||
|
(fn (a b) (g (h a b)))))
|
||||||
|
((= n 3)
|
||||||
|
(let
|
||||||
|
((f (apl-resolve-dyadic (nth fns 0) env))
|
||||||
|
(g (apl-resolve-dyadic (nth fns 1) env))
|
||||||
|
(h (apl-resolve-dyadic (nth fns 2) env)))
|
||||||
|
(fn (a b) (g (f a b) (h a b)))))
|
||||||
|
(else (error "dyadic train arity not 2 or 3"))))))
|
||||||
(else (error "apl-resolve-dyadic: unknown fn-node tag"))))))
|
(else (error "apl-resolve-dyadic: unknown fn-node tag"))))))
|
||||||
|
|
||||||
(define apl-run (fn (src) (apl-eval-ast (parse-apl src) {})))
|
(define apl-run (fn (src) (apl-eval-ast (parse-apl src) {})))
|
||||||
|
|||||||
180
lib/guest/hm.sx
Normal file
180
lib/guest/hm.sx
Normal file
@@ -0,0 +1,180 @@
|
|||||||
|
;; lib/guest/hm.sx — Hindley-Milner type-inference foundations.
|
||||||
|
;;
|
||||||
|
;; Builds on lib/guest/match.sx (terms + unify) and ast.sx (canonical
|
||||||
|
;; AST shapes). This file ships the ALGEBRA — types, schemes, free
|
||||||
|
;; type-vars, generalize / instantiate, substitution composition — so a
|
||||||
|
;; full Algorithm W (or J) can be assembled on top either inside this
|
||||||
|
;; file or in a host-specific consumer (haskell/infer.sx,
|
||||||
|
;; lib/ocaml/types.sx, …).
|
||||||
|
;;
|
||||||
|
;; Per the brief the second consumer for this step is OCaml-on-SX
|
||||||
|
;; Phase 5 (paired sequencing). Until that lands, the algebra is the
|
||||||
|
;; deliverable; the host-flavoured assembly (lambda / app / let
|
||||||
|
;; inference rules with substitution threading) lives in the host.
|
||||||
|
;;
|
||||||
|
;; Types
|
||||||
|
;; -----
|
||||||
|
;; A type is a canonical match.sx term — type variables use mk-var,
|
||||||
|
;; type constructors use mk-ctor:
|
||||||
|
;; (hm-tv NAME) type variable
|
||||||
|
;; (hm-arrow A B) A -> B
|
||||||
|
;; (hm-con NAME ARGS) named n-ary constructor
|
||||||
|
;; (hm-int) / (hm-bool) / (hm-string) primitive constructors
|
||||||
|
;;
|
||||||
|
;; Schemes
|
||||||
|
;; -------
|
||||||
|
;; (hm-scheme VARS TYPE) ∀ VARS . TYPE
|
||||||
|
;; (hm-monotype TYPE) empty quantifier
|
||||||
|
;; (hm-scheme? S) (hm-scheme-vars S) (hm-scheme-type S)
|
||||||
|
;;
|
||||||
|
;; Free type variables
|
||||||
|
;; -------------------
|
||||||
|
;; (hm-ftv TYPE) names occurring in TYPE
|
||||||
|
;; (hm-ftv-scheme S) free names (minus quantifiers)
|
||||||
|
;; (hm-ftv-env ENV) free across an env (name -> scheme)
|
||||||
|
;;
|
||||||
|
;; Substitution
|
||||||
|
;; ------------
|
||||||
|
;; (hm-apply SUBST TYPE) substitute through a type
|
||||||
|
;; (hm-apply-scheme SUBST S) leaves bound vars alone
|
||||||
|
;; (hm-apply-env SUBST ENV)
|
||||||
|
;; (hm-compose S2 S1) apply S1 then S2
|
||||||
|
;;
|
||||||
|
;; Generalize / Instantiate
|
||||||
|
;; ------------------------
|
||||||
|
;; (hm-generalize TYPE ENV) → scheme over ftv(t) - ftv(env)
|
||||||
|
;; (hm-instantiate SCHEME COUNTER) → fresh-var instance
|
||||||
|
;; (hm-fresh-tv COUNTER) → (:var "tN"), bumps COUNTER
|
||||||
|
;;
|
||||||
|
;; Inference (literal only — the rest of Algorithm W lives in the host)
|
||||||
|
;; --------------------------------------------------------------------
|
||||||
|
;; (hm-infer-literal EXPR) → {:subst {} :type T}
|
||||||
|
;;
|
||||||
|
;; A complete Algorithm W consumes this kit by assembling lambda / app
|
||||||
|
;; / let rules in the host language file.
|
||||||
|
|
||||||
|
(define hm-tv (fn (name) (list :var name)))
|
||||||
|
(define hm-con (fn (name args) (list :ctor name args)))
|
||||||
|
(define hm-arrow (fn (a b) (hm-con "->" (list a b))))
|
||||||
|
(define hm-int (fn () (hm-con "Int" (list))))
|
||||||
|
(define hm-bool (fn () (hm-con "Bool" (list))))
|
||||||
|
(define hm-string (fn () (hm-con "String" (list))))
|
||||||
|
|
||||||
|
(define hm-scheme (fn (vars t) (list :scheme vars t)))
|
||||||
|
(define hm-monotype (fn (t) (hm-scheme (list) t)))
|
||||||
|
(define hm-scheme? (fn (s) (and (list? s) (not (empty? s)) (= (first s) :scheme))))
|
||||||
|
(define hm-scheme-vars (fn (s) (nth s 1)))
|
||||||
|
(define hm-scheme-type (fn (s) (nth s 2)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hm-fresh-tv
|
||||||
|
(fn (counter)
|
||||||
|
(let ((n (first counter)))
|
||||||
|
(begin
|
||||||
|
(set-nth! counter 0 (+ n 1))
|
||||||
|
(hm-tv (str "t" (+ n 1)))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hm-ftv-acc
|
||||||
|
(fn (t acc)
|
||||||
|
(cond
|
||||||
|
((is-var? t)
|
||||||
|
(if (some (fn (n) (= n (var-name t))) acc) acc (cons (var-name t) acc)))
|
||||||
|
((is-ctor? t)
|
||||||
|
(let ((a acc))
|
||||||
|
(begin
|
||||||
|
(for-each (fn (x) (set! a (hm-ftv-acc x a))) (ctor-args t))
|
||||||
|
a)))
|
||||||
|
(:else acc))))
|
||||||
|
|
||||||
|
(define hm-ftv (fn (t) (hm-ftv-acc t (list))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hm-ftv-scheme
|
||||||
|
(fn (s)
|
||||||
|
(let ((qs (hm-scheme-vars s))
|
||||||
|
(all (hm-ftv (hm-scheme-type s))))
|
||||||
|
(filter (fn (n) (not (some (fn (q) (= q n)) qs))) all))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hm-ftv-env
|
||||||
|
(fn (env)
|
||||||
|
(let ((acc (list)))
|
||||||
|
(begin
|
||||||
|
(for-each
|
||||||
|
(fn (k)
|
||||||
|
(for-each
|
||||||
|
(fn (n)
|
||||||
|
(when (not (some (fn (m) (= m n)) acc))
|
||||||
|
(set! acc (cons n acc))))
|
||||||
|
(hm-ftv-scheme (get env k))))
|
||||||
|
(keys env))
|
||||||
|
acc))))
|
||||||
|
|
||||||
|
(define hm-apply (fn (subst t) (walk* t subst)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hm-apply-scheme
|
||||||
|
(fn (subst s)
|
||||||
|
(let ((qs (hm-scheme-vars s))
|
||||||
|
(d {}))
|
||||||
|
(begin
|
||||||
|
(for-each
|
||||||
|
(fn (k)
|
||||||
|
(when (not (some (fn (q) (= q k)) qs))
|
||||||
|
(dict-set! d k (get subst k))))
|
||||||
|
(keys subst))
|
||||||
|
(hm-scheme qs (walk* (hm-scheme-type s) d))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hm-apply-env
|
||||||
|
(fn (subst env)
|
||||||
|
(let ((d {}))
|
||||||
|
(begin
|
||||||
|
(for-each
|
||||||
|
(fn (k) (dict-set! d k (hm-apply-scheme subst (get env k))))
|
||||||
|
(keys env))
|
||||||
|
d))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hm-compose
|
||||||
|
(fn (s2 s1)
|
||||||
|
(let ((d {}))
|
||||||
|
(begin
|
||||||
|
(for-each (fn (k) (dict-set! d k (walk* (get s1 k) s2))) (keys s1))
|
||||||
|
(for-each
|
||||||
|
(fn (k) (when (not (has-key? d k)) (dict-set! d k (get s2 k))))
|
||||||
|
(keys s2))
|
||||||
|
d))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hm-generalize
|
||||||
|
(fn (t env)
|
||||||
|
(let ((tvars (hm-ftv t))
|
||||||
|
(evars (hm-ftv-env env)))
|
||||||
|
(let ((qs (filter (fn (n) (not (some (fn (m) (= m n)) evars))) tvars)))
|
||||||
|
(hm-scheme qs t)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hm-instantiate
|
||||||
|
(fn (s counter)
|
||||||
|
(let ((qs (hm-scheme-vars s))
|
||||||
|
(subst {}))
|
||||||
|
(begin
|
||||||
|
(for-each
|
||||||
|
(fn (q) (set! subst (assoc subst q (hm-fresh-tv counter))))
|
||||||
|
qs)
|
||||||
|
(walk* (hm-scheme-type s) subst)))))
|
||||||
|
|
||||||
|
;; Literal inference — the only AST kind whose typing rule is closed
|
||||||
|
;; in the kit. Lambda / app / let live in host code so the host's own
|
||||||
|
;; AST conventions stay untouched.
|
||||||
|
(define
|
||||||
|
hm-infer-literal
|
||||||
|
(fn (expr)
|
||||||
|
(let ((v (ast-literal-value expr)))
|
||||||
|
(cond
|
||||||
|
((number? v) {:subst {} :type (hm-int)})
|
||||||
|
((string? v) {:subst {} :type (hm-string)})
|
||||||
|
((boolean? v) {:subst {} :type (hm-bool)})
|
||||||
|
(:else (error (str "hm-infer-literal: unknown kind: " v)))))))
|
||||||
145
lib/guest/layout.sx
Normal file
145
lib/guest/layout.sx
Normal file
@@ -0,0 +1,145 @@
|
|||||||
|
;; lib/guest/layout.sx — configurable off-side / layout-sensitive lexer.
|
||||||
|
;;
|
||||||
|
;; Inserts virtual open / close / separator tokens based on indentation.
|
||||||
|
;; Configurable enough to encode either the Haskell 98 layout rule (let /
|
||||||
|
;; where / do / of opens a virtual brace at the next token's column) or
|
||||||
|
;; a Python-ish indent / dedent rule (a colon at the end of a line opens
|
||||||
|
;; a block at the next non-blank line's column).
|
||||||
|
;;
|
||||||
|
;; Token shape (input + output)
|
||||||
|
;; ----------------------------
|
||||||
|
;; Each token is a dict {:type :value :line :col …}. The kit reads
|
||||||
|
;; only :type / :value / :line / :col and passes everything else
|
||||||
|
;; through. The input stream MUST be free of newline filler tokens
|
||||||
|
;; (preprocess them away with your tokenizer) — line breaks are detected
|
||||||
|
;; by comparing :line of consecutive tokens.
|
||||||
|
;;
|
||||||
|
;; Config
|
||||||
|
;; ------
|
||||||
|
;; :open-keywords list of strings; a token whose :value matches
|
||||||
|
;; opens a new layout block at the next token's
|
||||||
|
;; column (Haskell: let/where/do/of).
|
||||||
|
;; :open-trailing-fn (fn (tok) -> bool) — alternative trigger that
|
||||||
|
;; fires AFTER the token is emitted. Use for
|
||||||
|
;; Python-style trailing `:`.
|
||||||
|
;; :open-token / :close-token / :sep-token
|
||||||
|
;; templates {:type :value} merged with :line and
|
||||||
|
;; :col when virtual tokens are emitted.
|
||||||
|
;; :explicit-open? (fn (tok) -> bool) — if the next token after a
|
||||||
|
;; trigger satisfies this, suppress virtual layout
|
||||||
|
;; for that block (Haskell: `{`).
|
||||||
|
;; :module-prelude? if true, wrap whole input in an implicit block
|
||||||
|
;; at the first token's column (Haskell yes,
|
||||||
|
;; Python no).
|
||||||
|
;;
|
||||||
|
;; Public entry
|
||||||
|
;; ------------
|
||||||
|
;; (layout-pass cfg tokens) -> tokens with virtual layout inserted.
|
||||||
|
|
||||||
|
(define
|
||||||
|
layout-mk-virtual
|
||||||
|
(fn (template line col)
|
||||||
|
(assoc (assoc template :line line) :col col)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
layout-is-open-kw?
|
||||||
|
(fn (tok open-kws)
|
||||||
|
(and (= (get tok :type) "reserved")
|
||||||
|
(some (fn (k) (= k (get tok :value))) open-kws))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
layout-pass
|
||||||
|
(fn (cfg tokens)
|
||||||
|
(let ((open-kws (get cfg :open-keywords))
|
||||||
|
(trailing-fn (get cfg :open-trailing-fn))
|
||||||
|
(open-tmpl (get cfg :open-token))
|
||||||
|
(close-tmpl (get cfg :close-token))
|
||||||
|
(sep-tmpl (get cfg :sep-token))
|
||||||
|
(mod-prelude? (get cfg :module-prelude?))
|
||||||
|
(expl?-fn (get cfg :explicit-open?))
|
||||||
|
(out (list))
|
||||||
|
(stack (list))
|
||||||
|
(n (len tokens))
|
||||||
|
(i 0)
|
||||||
|
(prev-line -1)
|
||||||
|
(pending-open false)
|
||||||
|
(just-opened false))
|
||||||
|
(define
|
||||||
|
emit-closes-while-greater
|
||||||
|
(fn (col line)
|
||||||
|
(when (and (not (empty? stack)) (> (first stack) col))
|
||||||
|
(do
|
||||||
|
(append! out (layout-mk-virtual close-tmpl line col))
|
||||||
|
(set! stack (rest stack))
|
||||||
|
(emit-closes-while-greater col line)))))
|
||||||
|
(define
|
||||||
|
emit-pending-open
|
||||||
|
(fn (line col)
|
||||||
|
(do
|
||||||
|
(append! out (layout-mk-virtual open-tmpl line col))
|
||||||
|
(set! stack (cons col stack))
|
||||||
|
(set! pending-open false)
|
||||||
|
(set! just-opened true))))
|
||||||
|
(define
|
||||||
|
layout-step
|
||||||
|
(fn ()
|
||||||
|
(when (< i n)
|
||||||
|
(let ((tok (nth tokens i)))
|
||||||
|
(let ((line (get tok :line)) (col (get tok :col)))
|
||||||
|
(cond
|
||||||
|
(pending-open
|
||||||
|
(cond
|
||||||
|
((and (not (= expl?-fn nil)) (expl?-fn tok))
|
||||||
|
(do
|
||||||
|
(set! pending-open false)
|
||||||
|
(append! out tok)
|
||||||
|
(set! prev-line line)
|
||||||
|
(set! i (+ i 1))
|
||||||
|
(layout-step)))
|
||||||
|
(:else
|
||||||
|
(do
|
||||||
|
(emit-pending-open line col)
|
||||||
|
(layout-step)))))
|
||||||
|
(:else
|
||||||
|
(let ((on-fresh-line? (and (> prev-line 0) (> line prev-line))))
|
||||||
|
(do
|
||||||
|
(when on-fresh-line?
|
||||||
|
(let ((stack-before stack))
|
||||||
|
(begin
|
||||||
|
(emit-closes-while-greater col line)
|
||||||
|
(when (and (not (empty? stack))
|
||||||
|
(= (first stack) col)
|
||||||
|
(not just-opened)
|
||||||
|
;; suppress separator if a dedent fired
|
||||||
|
;; — the dedent is itself the separator
|
||||||
|
(= (len stack) (len stack-before)))
|
||||||
|
(append! out (layout-mk-virtual sep-tmpl line col))))))
|
||||||
|
(set! just-opened false)
|
||||||
|
(append! out tok)
|
||||||
|
(set! prev-line line)
|
||||||
|
(set! i (+ i 1))
|
||||||
|
(cond
|
||||||
|
((layout-is-open-kw? tok open-kws)
|
||||||
|
(set! pending-open true))
|
||||||
|
((and (not (= trailing-fn nil)) (trailing-fn tok))
|
||||||
|
(set! pending-open true)))
|
||||||
|
(layout-step))))))))))
|
||||||
|
(begin
|
||||||
|
;; Module prelude: implicit layout block at the first token's column.
|
||||||
|
(when (and mod-prelude? (> n 0))
|
||||||
|
(let ((tok (nth tokens 0)))
|
||||||
|
(do
|
||||||
|
(append! out (layout-mk-virtual open-tmpl (get tok :line) (get tok :col)))
|
||||||
|
(set! stack (cons (get tok :col) stack))
|
||||||
|
(set! just-opened true))))
|
||||||
|
(layout-step)
|
||||||
|
;; EOF: close every remaining block.
|
||||||
|
(define close-rest
|
||||||
|
(fn ()
|
||||||
|
(when (not (empty? stack))
|
||||||
|
(do
|
||||||
|
(append! out (layout-mk-virtual close-tmpl 0 0))
|
||||||
|
(set! stack (rest stack))
|
||||||
|
(close-rest)))))
|
||||||
|
(close-rest)
|
||||||
|
out))))
|
||||||
89
lib/guest/tests/hm.sx
Normal file
89
lib/guest/tests/hm.sx
Normal file
@@ -0,0 +1,89 @@
|
|||||||
|
;; lib/guest/tests/hm.sx — exercises lib/guest/hm.sx algebra.
|
||||||
|
|
||||||
|
(define ghm-test-pass 0)
|
||||||
|
(define ghm-test-fail 0)
|
||||||
|
(define ghm-test-fails (list))
|
||||||
|
|
||||||
|
(define
|
||||||
|
ghm-test
|
||||||
|
(fn (name actual expected)
|
||||||
|
(if (= actual expected)
|
||||||
|
(set! ghm-test-pass (+ ghm-test-pass 1))
|
||||||
|
(begin
|
||||||
|
(set! ghm-test-fail (+ ghm-test-fail 1))
|
||||||
|
(append! ghm-test-fails {:name name :expected expected :actual actual})))))
|
||||||
|
|
||||||
|
;; ── Type constructors ─────────────────────────────────────────────
|
||||||
|
(ghm-test "tv" (hm-tv "a") (list :var "a"))
|
||||||
|
(ghm-test "int" (hm-int) (list :ctor "Int" (list)))
|
||||||
|
(ghm-test "arrow" (ctor-head (hm-arrow (hm-int) (hm-bool))) "->")
|
||||||
|
(ghm-test "arrow-args-len" (len (ctor-args (hm-arrow (hm-int) (hm-bool)))) 2)
|
||||||
|
|
||||||
|
;; ── Schemes ───────────────────────────────────────────────────────
|
||||||
|
(ghm-test "scheme-vars" (hm-scheme-vars (hm-scheme (list "a") (hm-tv "a"))) (list "a"))
|
||||||
|
(ghm-test "monotype-vars" (hm-scheme-vars (hm-monotype (hm-int))) (list))
|
||||||
|
(ghm-test "scheme?-yes" (hm-scheme? (hm-monotype (hm-int))) true)
|
||||||
|
(ghm-test "scheme?-no" (hm-scheme? (hm-int)) false)
|
||||||
|
|
||||||
|
;; ── Fresh tyvars ──────────────────────────────────────────────────
|
||||||
|
(ghm-test "fresh-1"
|
||||||
|
(let ((c (list 0))) (var-name (hm-fresh-tv c))) "t1")
|
||||||
|
(ghm-test "fresh-bumps"
|
||||||
|
(let ((c (list 5))) (begin (hm-fresh-tv c) (first c))) 6)
|
||||||
|
|
||||||
|
;; ── Free type variables ──────────────────────────────────────────
|
||||||
|
(ghm-test "ftv-int" (hm-ftv (hm-int)) (list))
|
||||||
|
(ghm-test "ftv-tv" (hm-ftv (hm-tv "a")) (list "a"))
|
||||||
|
(ghm-test "ftv-arrow"
|
||||||
|
(len (hm-ftv (hm-arrow (hm-tv "a") (hm-arrow (hm-tv "b") (hm-tv "a"))))) 2)
|
||||||
|
(ghm-test "ftv-scheme-quantified"
|
||||||
|
(hm-ftv-scheme (hm-scheme (list "a") (hm-arrow (hm-tv "a") (hm-tv "b")))) (list "b"))
|
||||||
|
(ghm-test "ftv-env"
|
||||||
|
(let ((env (assoc {} "f" (hm-monotype (hm-arrow (hm-tv "x") (hm-tv "y"))))))
|
||||||
|
(len (hm-ftv-env env))) 2)
|
||||||
|
|
||||||
|
;; ── Substitution / apply / compose ───────────────────────────────
|
||||||
|
(ghm-test "apply-tv"
|
||||||
|
(hm-apply (assoc {} "a" (hm-int)) (hm-tv "a")) (hm-int))
|
||||||
|
(ghm-test "apply-arrow"
|
||||||
|
(ctor-head
|
||||||
|
(hm-apply (assoc {} "a" (hm-int))
|
||||||
|
(hm-arrow (hm-tv "a") (hm-tv "b")))) "->")
|
||||||
|
(ghm-test "compose-1-then-2"
|
||||||
|
(var-name
|
||||||
|
(hm-apply
|
||||||
|
(hm-compose (assoc {} "b" (hm-tv "c")) (assoc {} "a" (hm-tv "b")))
|
||||||
|
(hm-tv "a"))) "c")
|
||||||
|
|
||||||
|
;; ── Generalize / Instantiate ─────────────────────────────────────
|
||||||
|
;; forall a. a -> a instantiated twice yields fresh vars each time
|
||||||
|
(ghm-test "generalize-id"
|
||||||
|
(len (hm-scheme-vars (hm-generalize (hm-arrow (hm-tv "a") (hm-tv "a")) {}))) 1)
|
||||||
|
|
||||||
|
(ghm-test "generalize-skips-env"
|
||||||
|
;; ftv(t)={a,b}, ftv(env)={a}, qs={b}
|
||||||
|
(let ((env (assoc {} "x" (hm-monotype (hm-tv "a")))))
|
||||||
|
(len (hm-scheme-vars
|
||||||
|
(hm-generalize (hm-arrow (hm-tv "a") (hm-tv "b")) env)))) 1)
|
||||||
|
|
||||||
|
(ghm-test "instantiate-fresh"
|
||||||
|
(let ((s (hm-scheme (list "a") (hm-arrow (hm-tv "a") (hm-tv "a"))))
|
||||||
|
(c (list 0)))
|
||||||
|
(let ((t1 (hm-instantiate s c)) (t2 (hm-instantiate s c)))
|
||||||
|
(not (= (var-name (first (ctor-args t1)))
|
||||||
|
(var-name (first (ctor-args t2)))))))
|
||||||
|
true)
|
||||||
|
|
||||||
|
;; ── Inference (literal only) ─────────────────────────────────────
|
||||||
|
(ghm-test "infer-int"
|
||||||
|
(ctor-head (get (hm-infer-literal (ast-literal 42)) :type)) "Int")
|
||||||
|
(ghm-test "infer-string"
|
||||||
|
(ctor-head (get (hm-infer-literal (ast-literal "hi")) :type)) "String")
|
||||||
|
(ghm-test "infer-bool"
|
||||||
|
(ctor-head (get (hm-infer-literal (ast-literal true)) :type)) "Bool")
|
||||||
|
|
||||||
|
(define ghm-tests-run!
|
||||||
|
(fn ()
|
||||||
|
{:passed ghm-test-pass
|
||||||
|
:failed ghm-test-fail
|
||||||
|
:total (+ ghm-test-pass ghm-test-fail)}))
|
||||||
180
lib/guest/tests/layout.sx
Normal file
180
lib/guest/tests/layout.sx
Normal file
@@ -0,0 +1,180 @@
|
|||||||
|
;; lib/guest/tests/layout.sx — synthetic Python-ish off-side fixture.
|
||||||
|
;;
|
||||||
|
;; Exercises lib/guest/layout.sx with a config different from Haskell's
|
||||||
|
;; (no module-prelude, layout opens via trailing `:` not via reserved
|
||||||
|
;; keyword) to prove the kit isn't Haskell-shaped.
|
||||||
|
|
||||||
|
(define glayout-test-pass 0)
|
||||||
|
(define glayout-test-fail 0)
|
||||||
|
(define glayout-test-fails (list))
|
||||||
|
|
||||||
|
(define
|
||||||
|
glayout-test
|
||||||
|
(fn (name actual expected)
|
||||||
|
(if (= actual expected)
|
||||||
|
(set! glayout-test-pass (+ glayout-test-pass 1))
|
||||||
|
(begin
|
||||||
|
(set! glayout-test-fail (+ glayout-test-fail 1))
|
||||||
|
(append! glayout-test-fails {:name name :expected expected :actual actual})))))
|
||||||
|
|
||||||
|
;; Convenience: build a token from {type value line col}.
|
||||||
|
(define
|
||||||
|
glayout-tok
|
||||||
|
(fn (ty val line col)
|
||||||
|
{:type ty :value val :line line :col col}))
|
||||||
|
|
||||||
|
;; Project a token list to ((type value) ...) for compact comparison.
|
||||||
|
(define
|
||||||
|
glayout-shape
|
||||||
|
(fn (toks)
|
||||||
|
(map (fn (t) (list (get t :type) (get t :value))) toks)))
|
||||||
|
|
||||||
|
;; ── Haskell-flavour: keyword opens block ─────────────────────────
|
||||||
|
(define
|
||||||
|
glayout-haskell-cfg
|
||||||
|
{:open-keywords (list "let" "where" "do" "of")
|
||||||
|
:open-trailing-fn nil
|
||||||
|
:open-token {:type "vlbrace" :value "{"}
|
||||||
|
:close-token {:type "vrbrace" :value "}"}
|
||||||
|
:sep-token {:type "vsemi" :value ";"}
|
||||||
|
:module-prelude? false
|
||||||
|
:explicit-open? (fn (tok) (= (get tok :type) "lbrace"))})
|
||||||
|
|
||||||
|
;; do
|
||||||
|
;; a
|
||||||
|
;; b
|
||||||
|
;; c ← outside the do-block
|
||||||
|
(glayout-test "haskell-do-block"
|
||||||
|
(glayout-shape
|
||||||
|
(layout-pass
|
||||||
|
glayout-haskell-cfg
|
||||||
|
(list (glayout-tok "reserved" "do" 1 1)
|
||||||
|
(glayout-tok "ident" "a" 2 3)
|
||||||
|
(glayout-tok "ident" "b" 3 3)
|
||||||
|
(glayout-tok "ident" "c" 4 1))))
|
||||||
|
(list (list "reserved" "do")
|
||||||
|
(list "vlbrace" "{")
|
||||||
|
(list "ident" "a")
|
||||||
|
(list "vsemi" ";")
|
||||||
|
(list "ident" "b")
|
||||||
|
(list "vrbrace" "}")
|
||||||
|
(list "ident" "c")))
|
||||||
|
|
||||||
|
;; Explicit `{` after `do` suppresses virtual layout.
|
||||||
|
(glayout-test "haskell-explicit-brace"
|
||||||
|
(glayout-shape
|
||||||
|
(layout-pass
|
||||||
|
glayout-haskell-cfg
|
||||||
|
(list (glayout-tok "reserved" "do" 1 1)
|
||||||
|
(glayout-tok "lbrace" "{" 1 4)
|
||||||
|
(glayout-tok "ident" "a" 1 6)
|
||||||
|
(glayout-tok "rbrace" "}" 1 8))))
|
||||||
|
(list (list "reserved" "do")
|
||||||
|
(list "lbrace" "{")
|
||||||
|
(list "ident" "a")
|
||||||
|
(list "rbrace" "}")))
|
||||||
|
|
||||||
|
;; Single-statement do-block on the same line.
|
||||||
|
(glayout-test "haskell-do-inline"
|
||||||
|
(glayout-shape
|
||||||
|
(layout-pass
|
||||||
|
glayout-haskell-cfg
|
||||||
|
(list (glayout-tok "reserved" "do" 1 1)
|
||||||
|
(glayout-tok "ident" "a" 1 4))))
|
||||||
|
(list (list "reserved" "do")
|
||||||
|
(list "vlbrace" "{")
|
||||||
|
(list "ident" "a")
|
||||||
|
(list "vrbrace" "}")))
|
||||||
|
|
||||||
|
;; Module-prelude: wrap whole input in implicit layout block at first
|
||||||
|
;; tok's column.
|
||||||
|
(glayout-test "haskell-module-prelude"
|
||||||
|
(glayout-shape
|
||||||
|
(layout-pass
|
||||||
|
(assoc glayout-haskell-cfg :module-prelude? true)
|
||||||
|
(list (glayout-tok "ident" "x" 1 1)
|
||||||
|
(glayout-tok "ident" "y" 2 1)
|
||||||
|
(glayout-tok "ident" "z" 3 1))))
|
||||||
|
(list (list "vlbrace" "{")
|
||||||
|
(list "ident" "x")
|
||||||
|
(list "vsemi" ";")
|
||||||
|
(list "ident" "y")
|
||||||
|
(list "vsemi" ";")
|
||||||
|
(list "ident" "z")
|
||||||
|
(list "vrbrace" "}")))
|
||||||
|
|
||||||
|
;; ── Python-flavour: trailing `:` opens block ─────────────────────
|
||||||
|
(define
|
||||||
|
glayout-python-cfg
|
||||||
|
{:open-keywords (list)
|
||||||
|
:open-trailing-fn (fn (tok) (and (= (get tok :type) "punct")
|
||||||
|
(= (get tok :value) ":")))
|
||||||
|
:open-token {:type "indent" :value "INDENT"}
|
||||||
|
:close-token {:type "dedent" :value "DEDENT"}
|
||||||
|
:sep-token {:type "newline" :value "NEWLINE"}
|
||||||
|
:module-prelude? false
|
||||||
|
:explicit-open? nil})
|
||||||
|
|
||||||
|
;; if x:
|
||||||
|
;; a
|
||||||
|
;; b
|
||||||
|
;; c
|
||||||
|
(glayout-test "python-if-block"
|
||||||
|
(glayout-shape
|
||||||
|
(layout-pass
|
||||||
|
glayout-python-cfg
|
||||||
|
(list (glayout-tok "reserved" "if" 1 1)
|
||||||
|
(glayout-tok "ident" "x" 1 4)
|
||||||
|
(glayout-tok "punct" ":" 1 5)
|
||||||
|
(glayout-tok "ident" "a" 2 5)
|
||||||
|
(glayout-tok "ident" "b" 3 5)
|
||||||
|
(glayout-tok "ident" "c" 4 1))))
|
||||||
|
(list (list "reserved" "if")
|
||||||
|
(list "ident" "x")
|
||||||
|
(list "punct" ":")
|
||||||
|
(list "indent" "INDENT")
|
||||||
|
(list "ident" "a")
|
||||||
|
(list "newline" "NEWLINE")
|
||||||
|
(list "ident" "b")
|
||||||
|
(list "dedent" "DEDENT")
|
||||||
|
(list "ident" "c")))
|
||||||
|
|
||||||
|
;; Nested Python-style blocks.
|
||||||
|
;; def f():
|
||||||
|
;; if x:
|
||||||
|
;; a
|
||||||
|
;; b
|
||||||
|
(glayout-test "python-nested"
|
||||||
|
(glayout-shape
|
||||||
|
(layout-pass
|
||||||
|
glayout-python-cfg
|
||||||
|
(list (glayout-tok "reserved" "def" 1 1)
|
||||||
|
(glayout-tok "ident" "f" 1 5)
|
||||||
|
(glayout-tok "punct" "(" 1 6)
|
||||||
|
(glayout-tok "punct" ")" 1 7)
|
||||||
|
(glayout-tok "punct" ":" 1 8)
|
||||||
|
(glayout-tok "reserved" "if" 2 5)
|
||||||
|
(glayout-tok "ident" "x" 2 8)
|
||||||
|
(glayout-tok "punct" ":" 2 9)
|
||||||
|
(glayout-tok "ident" "a" 3 9)
|
||||||
|
(glayout-tok "ident" "b" 4 5))))
|
||||||
|
(list (list "reserved" "def")
|
||||||
|
(list "ident" "f")
|
||||||
|
(list "punct" "(")
|
||||||
|
(list "punct" ")")
|
||||||
|
(list "punct" ":")
|
||||||
|
(list "indent" "INDENT")
|
||||||
|
(list "reserved" "if")
|
||||||
|
(list "ident" "x")
|
||||||
|
(list "punct" ":")
|
||||||
|
(list "indent" "INDENT")
|
||||||
|
(list "ident" "a")
|
||||||
|
(list "dedent" "DEDENT")
|
||||||
|
(list "ident" "b")
|
||||||
|
(list "dedent" "DEDENT")))
|
||||||
|
|
||||||
|
(define glayout-tests-run!
|
||||||
|
(fn ()
|
||||||
|
{:passed glayout-test-pass
|
||||||
|
:failed glayout-test-fail
|
||||||
|
:total (+ glayout-test-pass glayout-test-fail)}))
|
||||||
@@ -14,6 +14,8 @@ PRELOADS=(
|
|||||||
lib/haskell/runtime.sx
|
lib/haskell/runtime.sx
|
||||||
lib/haskell/match.sx
|
lib/haskell/match.sx
|
||||||
lib/haskell/eval.sx
|
lib/haskell/eval.sx
|
||||||
|
lib/haskell/map.sx
|
||||||
|
lib/haskell/set.sx
|
||||||
lib/haskell/testlib.sx
|
lib/haskell/testlib.sx
|
||||||
)
|
)
|
||||||
|
|
||||||
@@ -36,6 +38,24 @@ SUITES=(
|
|||||||
"matrix:lib/haskell/tests/program-matrix.sx"
|
"matrix:lib/haskell/tests/program-matrix.sx"
|
||||||
"wordcount:lib/haskell/tests/program-wordcount.sx"
|
"wordcount:lib/haskell/tests/program-wordcount.sx"
|
||||||
"powers:lib/haskell/tests/program-powers.sx"
|
"powers:lib/haskell/tests/program-powers.sx"
|
||||||
|
"caesar:lib/haskell/tests/program-caesar.sx"
|
||||||
|
"runlength-str:lib/haskell/tests/program-runlength-str.sx"
|
||||||
|
"showadt:lib/haskell/tests/program-showadt.sx"
|
||||||
|
"showio:lib/haskell/tests/program-showio.sx"
|
||||||
|
"partial:lib/haskell/tests/program-partial.sx"
|
||||||
|
"statistics:lib/haskell/tests/program-statistics.sx"
|
||||||
|
"newton:lib/haskell/tests/program-newton.sx"
|
||||||
|
"wordfreq:lib/haskell/tests/program-wordfreq.sx"
|
||||||
|
"mapgraph:lib/haskell/tests/program-mapgraph.sx"
|
||||||
|
"uniquewords:lib/haskell/tests/program-uniquewords.sx"
|
||||||
|
"setops:lib/haskell/tests/program-setops.sx"
|
||||||
|
"shapes:lib/haskell/tests/program-shapes.sx"
|
||||||
|
"person:lib/haskell/tests/program-person.sx"
|
||||||
|
"config:lib/haskell/tests/program-config.sx"
|
||||||
|
"counter:lib/haskell/tests/program-counter.sx"
|
||||||
|
"accumulate:lib/haskell/tests/program-accumulate.sx"
|
||||||
|
"safediv:lib/haskell/tests/program-safediv.sx"
|
||||||
|
"trycatch:lib/haskell/tests/program-trycatch.sx"
|
||||||
)
|
)
|
||||||
|
|
||||||
emit_scoreboard_json() {
|
emit_scoreboard_json() {
|
||||||
|
|||||||
@@ -131,119 +131,280 @@
|
|||||||
(let
|
(let
|
||||||
((tag (first node)))
|
((tag (first node)))
|
||||||
(cond
|
(cond
|
||||||
;; Transformations
|
|
||||||
((= tag "where")
|
((= tag "where")
|
||||||
(list
|
(list
|
||||||
:let
|
:let (map hk-desugar (nth node 2))
|
||||||
(map hk-desugar (nth node 2))
|
|
||||||
(hk-desugar (nth node 1))))
|
(hk-desugar (nth node 1))))
|
||||||
((= tag "guarded") (hk-guards-to-if (nth node 1)))
|
((= tag "guarded") (hk-guards-to-if (nth node 1)))
|
||||||
((= tag "list-comp")
|
((= tag "list-comp")
|
||||||
(hk-lc-desugar
|
(hk-lc-desugar (hk-desugar (nth node 1)) (nth node 2)))
|
||||||
(hk-desugar (nth node 1))
|
|
||||||
(nth node 2)))
|
|
||||||
|
|
||||||
;; Expression nodes
|
|
||||||
((= tag "app")
|
((= tag "app")
|
||||||
(list
|
(list
|
||||||
:app
|
:app (hk-desugar (nth node 1))
|
||||||
(hk-desugar (nth node 1))
|
|
||||||
(hk-desugar (nth node 2))))
|
(hk-desugar (nth node 2))))
|
||||||
|
((= tag "p-rec")
|
||||||
|
(let
|
||||||
|
((cname (nth node 1))
|
||||||
|
(field-pats (nth node 2))
|
||||||
|
(field-order (hk-record-field-names cname)))
|
||||||
|
(cond
|
||||||
|
((nil? field-order)
|
||||||
|
(raise (str "p-rec: no record info for " cname)))
|
||||||
|
(:else
|
||||||
|
(list
|
||||||
|
:p-con
|
||||||
|
cname
|
||||||
|
(map
|
||||||
|
(fn
|
||||||
|
(fname)
|
||||||
|
(let
|
||||||
|
((p (hk-find-rec-pair field-pats fname)))
|
||||||
|
(cond
|
||||||
|
((nil? p) (list :p-wild))
|
||||||
|
(:else (hk-desugar (nth p 1))))))
|
||||||
|
field-order))))))
|
||||||
|
((= tag "rec-update")
|
||||||
|
(list
|
||||||
|
:rec-update
|
||||||
|
(hk-desugar (nth node 1))
|
||||||
|
(map
|
||||||
|
(fn (p) (list (first p) (hk-desugar (nth p 1))))
|
||||||
|
(nth node 2))))
|
||||||
|
((= tag "rec-create")
|
||||||
|
(let
|
||||||
|
((cname (nth node 1))
|
||||||
|
(field-pairs (nth node 2))
|
||||||
|
(field-order (hk-record-field-names cname)))
|
||||||
|
(cond
|
||||||
|
((nil? field-order)
|
||||||
|
(raise (str "rec-create: no record info for " cname)))
|
||||||
|
(:else
|
||||||
|
(let
|
||||||
|
((acc (list :con cname)))
|
||||||
|
(begin
|
||||||
|
(for-each
|
||||||
|
(fn
|
||||||
|
(fname)
|
||||||
|
(let
|
||||||
|
((pair
|
||||||
|
(hk-find-rec-pair field-pairs fname)))
|
||||||
|
(cond
|
||||||
|
((nil? pair)
|
||||||
|
(raise
|
||||||
|
(str
|
||||||
|
"rec-create: missing field "
|
||||||
|
fname
|
||||||
|
" for "
|
||||||
|
cname)))
|
||||||
|
(:else
|
||||||
|
(set!
|
||||||
|
acc
|
||||||
|
(list
|
||||||
|
:app
|
||||||
|
acc
|
||||||
|
(hk-desugar (nth pair 1))))))))
|
||||||
|
field-order)
|
||||||
|
acc))))))
|
||||||
((= tag "op")
|
((= tag "op")
|
||||||
(list
|
(list
|
||||||
:op
|
:op (nth node 1)
|
||||||
(nth node 1)
|
|
||||||
(hk-desugar (nth node 2))
|
(hk-desugar (nth node 2))
|
||||||
(hk-desugar (nth node 3))))
|
(hk-desugar (nth node 3))))
|
||||||
((= tag "neg") (list :neg (hk-desugar (nth node 1))))
|
((= tag "neg") (list :neg (hk-desugar (nth node 1))))
|
||||||
((= tag "if")
|
((= tag "if")
|
||||||
(list
|
(list
|
||||||
:if
|
:if (hk-desugar (nth node 1))
|
||||||
(hk-desugar (nth node 1))
|
|
||||||
(hk-desugar (nth node 2))
|
(hk-desugar (nth node 2))
|
||||||
(hk-desugar (nth node 3))))
|
(hk-desugar (nth node 3))))
|
||||||
((= tag "tuple")
|
((= tag "tuple") (list :tuple (map hk-desugar (nth node 1))))
|
||||||
(list :tuple (map hk-desugar (nth node 1))))
|
((= tag "list") (list :list (map hk-desugar (nth node 1))))
|
||||||
((= tag "list")
|
|
||||||
(list :list (map hk-desugar (nth node 1))))
|
|
||||||
((= tag "range")
|
((= tag "range")
|
||||||
(list
|
(list
|
||||||
:range
|
:range (hk-desugar (nth node 1))
|
||||||
(hk-desugar (nth node 1))
|
|
||||||
(hk-desugar (nth node 2))))
|
(hk-desugar (nth node 2))))
|
||||||
((= tag "range-step")
|
((= tag "range-step")
|
||||||
(list
|
(list
|
||||||
:range-step
|
:range-step (hk-desugar (nth node 1))
|
||||||
(hk-desugar (nth node 1))
|
|
||||||
(hk-desugar (nth node 2))
|
(hk-desugar (nth node 2))
|
||||||
(hk-desugar (nth node 3))))
|
(hk-desugar (nth node 3))))
|
||||||
((= tag "lambda")
|
((= tag "lambda")
|
||||||
(list
|
(list :lambda (nth node 1) (hk-desugar (nth node 2))))
|
||||||
:lambda
|
|
||||||
(nth node 1)
|
|
||||||
(hk-desugar (nth node 2))))
|
|
||||||
((= tag "let")
|
((= tag "let")
|
||||||
(list
|
(list
|
||||||
:let
|
:let (map hk-desugar (nth node 1))
|
||||||
(map hk-desugar (nth node 1))
|
|
||||||
(hk-desugar (nth node 2))))
|
(hk-desugar (nth node 2))))
|
||||||
((= tag "case")
|
((= tag "case")
|
||||||
(list
|
(list
|
||||||
:case
|
:case (hk-desugar (nth node 1))
|
||||||
(hk-desugar (nth node 1))
|
|
||||||
(map hk-desugar (nth node 2))))
|
(map hk-desugar (nth node 2))))
|
||||||
((= tag "alt")
|
((= tag "alt")
|
||||||
(list :alt (nth node 1) (hk-desugar (nth node 2))))
|
(list :alt (hk-desugar (nth node 1)) (hk-desugar (nth node 2))))
|
||||||
((= tag "do") (hk-desugar-do (nth node 1)))
|
((= tag "do") (hk-desugar-do (nth node 1)))
|
||||||
((= tag "sect-left")
|
((= tag "sect-left")
|
||||||
(list
|
(list :sect-left (nth node 1) (hk-desugar (nth node 2))))
|
||||||
:sect-left
|
|
||||||
(nth node 1)
|
|
||||||
(hk-desugar (nth node 2))))
|
|
||||||
((= tag "sect-right")
|
((= tag "sect-right")
|
||||||
(list
|
(list :sect-right (nth node 1) (hk-desugar (nth node 2))))
|
||||||
:sect-right
|
|
||||||
(nth node 1)
|
|
||||||
(hk-desugar (nth node 2))))
|
|
||||||
|
|
||||||
;; Top-level
|
|
||||||
((= tag "program")
|
((= tag "program")
|
||||||
(list :program (map hk-desugar (nth node 1))))
|
(list :program (map hk-desugar (hk-expand-records (nth node 1)))))
|
||||||
((= tag "module")
|
((= tag "module")
|
||||||
(list
|
(list
|
||||||
:module
|
:module (nth node 1)
|
||||||
(nth node 1)
|
|
||||||
(nth node 2)
|
(nth node 2)
|
||||||
(nth node 3)
|
(nth node 3)
|
||||||
(map hk-desugar (nth node 4))))
|
(map hk-desugar (hk-expand-records (nth node 4)))))
|
||||||
|
|
||||||
;; Decls carrying a body
|
|
||||||
((= tag "fun-clause")
|
((= tag "fun-clause")
|
||||||
(list
|
(list
|
||||||
:fun-clause
|
:fun-clause (nth node 1)
|
||||||
(nth node 1)
|
(map hk-desugar (nth node 2))
|
||||||
(nth node 2)
|
|
||||||
(hk-desugar (nth node 3))))
|
(hk-desugar (nth node 3))))
|
||||||
|
((= tag "instance-decl")
|
||||||
|
(list
|
||||||
|
:instance-decl (nth node 1)
|
||||||
|
(nth node 2)
|
||||||
|
(map hk-desugar (nth node 3))))
|
||||||
((= tag "pat-bind")
|
((= tag "pat-bind")
|
||||||
(list
|
(list :pat-bind (nth node 1) (hk-desugar (nth node 2))))
|
||||||
:pat-bind
|
|
||||||
(nth node 1)
|
|
||||||
(hk-desugar (nth node 2))))
|
|
||||||
((= tag "bind")
|
((= tag "bind")
|
||||||
(list
|
(list :bind (nth node 1) (hk-desugar (nth node 2))))
|
||||||
: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)))))))
|
(:else node)))))))
|
||||||
|
|
||||||
;; Convenience — tokenize + layout + parse + desugar.
|
;; Convenience — tokenize + layout + parse + desugar.
|
||||||
(define
|
(define hk-record-fields (dict))
|
||||||
hk-core
|
|
||||||
(fn (src) (hk-desugar (hk-parse-top src))))
|
|
||||||
|
|
||||||
(define
|
(define
|
||||||
hk-core-expr
|
hk-register-record-fields!
|
||||||
(fn (src) (hk-desugar (hk-parse src))))
|
(fn (cname fields) (dict-set! hk-record-fields cname fields)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-record-field-names
|
||||||
|
(fn
|
||||||
|
(cname)
|
||||||
|
(if (has-key? hk-record-fields cname) (get hk-record-fields cname) nil)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-record-field-index
|
||||||
|
(fn
|
||||||
|
(cname fname)
|
||||||
|
(let
|
||||||
|
((fields (hk-record-field-names cname)))
|
||||||
|
(cond
|
||||||
|
((nil? fields) -1)
|
||||||
|
(:else
|
||||||
|
(let
|
||||||
|
((i 0) (idx -1))
|
||||||
|
(begin
|
||||||
|
(for-each
|
||||||
|
(fn
|
||||||
|
(f)
|
||||||
|
(begin (when (= f fname) (set! idx i)) (set! i (+ i 1))))
|
||||||
|
fields)
|
||||||
|
idx)))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-find-rec-pair
|
||||||
|
(fn
|
||||||
|
(pairs name)
|
||||||
|
(cond
|
||||||
|
((empty? pairs) nil)
|
||||||
|
((= (first (first pairs)) name) (first pairs))
|
||||||
|
(:else (hk-find-rec-pair (rest pairs) name)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-record-accessors
|
||||||
|
(fn
|
||||||
|
(cname rec-fields)
|
||||||
|
(let
|
||||||
|
((n (len rec-fields)) (i 0) (out (list)))
|
||||||
|
(define
|
||||||
|
hk-ra-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(< i n)
|
||||||
|
(let
|
||||||
|
((field (nth rec-fields i)))
|
||||||
|
(let
|
||||||
|
((fname (first field)) (j 0) (pats (list)))
|
||||||
|
(define
|
||||||
|
hk-pat-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(< j n)
|
||||||
|
(begin
|
||||||
|
(append!
|
||||||
|
pats
|
||||||
|
(if
|
||||||
|
(= j i)
|
||||||
|
(list "p-var" "__rec_field")
|
||||||
|
(list "p-wild")))
|
||||||
|
(set! j (+ j 1))
|
||||||
|
(hk-pat-loop)))))
|
||||||
|
(hk-pat-loop)
|
||||||
|
(append!
|
||||||
|
out
|
||||||
|
(list
|
||||||
|
"fun-clause"
|
||||||
|
fname
|
||||||
|
(list (list "p-con" cname pats))
|
||||||
|
(list "var" "__rec_field")))
|
||||||
|
(set! i (+ i 1))
|
||||||
|
(hk-ra-loop))))))
|
||||||
|
(hk-ra-loop)
|
||||||
|
out)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-expand-records
|
||||||
|
(fn
|
||||||
|
(decls)
|
||||||
|
(let
|
||||||
|
((out (list)))
|
||||||
|
(for-each
|
||||||
|
(fn
|
||||||
|
(d)
|
||||||
|
(cond
|
||||||
|
((and (list? d) (= (first d) "data"))
|
||||||
|
(let
|
||||||
|
((dname (nth d 1))
|
||||||
|
(tvars (nth d 2))
|
||||||
|
(cons-list (nth d 3))
|
||||||
|
(deriving (if (> (len d) 4) (nth d 4) (list)))
|
||||||
|
(new-cons (list))
|
||||||
|
(accessors (list)))
|
||||||
|
(begin
|
||||||
|
(for-each
|
||||||
|
(fn
|
||||||
|
(c)
|
||||||
|
(cond
|
||||||
|
((= (first c) "con-rec")
|
||||||
|
(let
|
||||||
|
((cname (nth c 1)) (rec-fields (nth c 2)))
|
||||||
|
(begin
|
||||||
|
(hk-register-record-fields!
|
||||||
|
cname
|
||||||
|
(map (fn (f) (first f)) rec-fields))
|
||||||
|
(append!
|
||||||
|
new-cons
|
||||||
|
(list
|
||||||
|
"con-def"
|
||||||
|
cname
|
||||||
|
(map (fn (f) (nth f 1)) rec-fields)))
|
||||||
|
(for-each
|
||||||
|
(fn (a) (append! accessors a))
|
||||||
|
(hk-record-accessors cname rec-fields)))))
|
||||||
|
(:else (append! new-cons c))))
|
||||||
|
cons-list)
|
||||||
|
(append!
|
||||||
|
out
|
||||||
|
(if
|
||||||
|
(empty? deriving)
|
||||||
|
(list "data" dname tvars new-cons)
|
||||||
|
(list "data" dname tvars new-cons deriving)))
|
||||||
|
(for-each (fn (a) (append! out a)) accessors))))
|
||||||
|
(:else (append! out d))))
|
||||||
|
decls)
|
||||||
|
out)))
|
||||||
|
|
||||||
|
(define hk-core (fn (src) (hk-desugar (hk-parse-top src))))
|
||||||
|
|
||||||
|
(define hk-core-expr (fn (src) (hk-desugar (hk-parse src))))
|
||||||
|
|||||||
1023
lib/haskell/eval.sx
1023
lib/haskell/eval.sx
File diff suppressed because one or more lines are too long
520
lib/haskell/map.sx
Normal file
520
lib/haskell/map.sx
Normal file
@@ -0,0 +1,520 @@
|
|||||||
|
;; map.sx — Phase 11 Data.Map: weight-balanced BST in pure SX.
|
||||||
|
;;
|
||||||
|
;; Algorithm: Adams's weight-balanced tree (the same family as Haskell's
|
||||||
|
;; Data.Map). Each node tracks its size; rotations maintain the invariant
|
||||||
|
;;
|
||||||
|
;; size(small-side) * delta >= size(large-side) (delta = 3)
|
||||||
|
;;
|
||||||
|
;; with single or double rotations chosen by the gamma ratio (gamma = 2).
|
||||||
|
;; The size field is an Int and is included so `size`, `lookup`, etc. are
|
||||||
|
;; O(log n) on both extremes of the tree.
|
||||||
|
;;
|
||||||
|
;; Representation:
|
||||||
|
;; Empty → ("Map-Empty")
|
||||||
|
;; Node → ("Map-Node" key val left right size)
|
||||||
|
;;
|
||||||
|
;; All operations are pure SX — no mutation of nodes once constructed.
|
||||||
|
;; The user-facing Haskell layer (Phase 11 next iteration) wraps these
|
||||||
|
;; for `import Data.Map as Map`.
|
||||||
|
|
||||||
|
;; ── Constructors ────────────────────────────────────────────
|
||||||
|
(define hk-map-empty (list "Map-Empty"))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-node
|
||||||
|
(fn
|
||||||
|
(k v l r)
|
||||||
|
(list "Map-Node" k v l r (+ 1 (+ (hk-map-size l) (hk-map-size r))))))
|
||||||
|
|
||||||
|
;; ── Predicates and accessors ────────────────────────────────
|
||||||
|
(define hk-map-empty? (fn (m) (and (list? m) (= (first m) "Map-Empty"))))
|
||||||
|
|
||||||
|
(define hk-map-node? (fn (m) (and (list? m) (= (first m) "Map-Node"))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-size
|
||||||
|
(fn (m) (cond ((hk-map-empty? m) 0) (:else (nth m 5)))))
|
||||||
|
|
||||||
|
(define hk-map-key (fn (m) (nth m 1)))
|
||||||
|
(define hk-map-val (fn (m) (nth m 2)))
|
||||||
|
(define hk-map-left (fn (m) (nth m 3)))
|
||||||
|
(define hk-map-right (fn (m) (nth m 4)))
|
||||||
|
|
||||||
|
;; ── Weight-balanced rotations ───────────────────────────────
|
||||||
|
;; delta and gamma per Adams 1992 / Haskell Data.Map.
|
||||||
|
|
||||||
|
(define hk-map-delta 3)
|
||||||
|
(define hk-map-gamma 2)
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-single-l
|
||||||
|
(fn
|
||||||
|
(k v l r)
|
||||||
|
(let
|
||||||
|
((rk (hk-map-key r))
|
||||||
|
(rv (hk-map-val r))
|
||||||
|
(rl (hk-map-left r))
|
||||||
|
(rr (hk-map-right r)))
|
||||||
|
(hk-map-node rk rv (hk-map-node k v l rl) rr))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-single-r
|
||||||
|
(fn
|
||||||
|
(k v l r)
|
||||||
|
(let
|
||||||
|
((lk (hk-map-key l))
|
||||||
|
(lv (hk-map-val l))
|
||||||
|
(ll (hk-map-left l))
|
||||||
|
(lr (hk-map-right l)))
|
||||||
|
(hk-map-node lk lv ll (hk-map-node k v lr r)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-double-l
|
||||||
|
(fn
|
||||||
|
(k v l r)
|
||||||
|
(let
|
||||||
|
((rk (hk-map-key r))
|
||||||
|
(rv (hk-map-val r))
|
||||||
|
(rl (hk-map-left r))
|
||||||
|
(rr (hk-map-right r))
|
||||||
|
(rlk (hk-map-key (hk-map-left r)))
|
||||||
|
(rlv (hk-map-val (hk-map-left r)))
|
||||||
|
(rll (hk-map-left (hk-map-left r)))
|
||||||
|
(rlr (hk-map-right (hk-map-left r))))
|
||||||
|
(hk-map-node
|
||||||
|
rlk
|
||||||
|
rlv
|
||||||
|
(hk-map-node k v l rll)
|
||||||
|
(hk-map-node rk rv rlr rr)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-double-r
|
||||||
|
(fn
|
||||||
|
(k v l r)
|
||||||
|
(let
|
||||||
|
((lk (hk-map-key l))
|
||||||
|
(lv (hk-map-val l))
|
||||||
|
(ll (hk-map-left l))
|
||||||
|
(lr (hk-map-right l))
|
||||||
|
(lrk (hk-map-key (hk-map-right l)))
|
||||||
|
(lrv (hk-map-val (hk-map-right l)))
|
||||||
|
(lrl (hk-map-left (hk-map-right l)))
|
||||||
|
(lrr (hk-map-right (hk-map-right l))))
|
||||||
|
(hk-map-node
|
||||||
|
lrk
|
||||||
|
lrv
|
||||||
|
(hk-map-node lk lv ll lrl)
|
||||||
|
(hk-map-node k v lrr r)))))
|
||||||
|
|
||||||
|
;; ── Balanced node constructor ──────────────────────────────
|
||||||
|
;; Use this in place of hk-map-node when one side may have grown
|
||||||
|
;; or shrunk by one and we need to restore the weight invariant.
|
||||||
|
(define
|
||||||
|
hk-map-balance
|
||||||
|
(fn
|
||||||
|
(k v l r)
|
||||||
|
(let
|
||||||
|
((sl (hk-map-size l)) (sr (hk-map-size r)))
|
||||||
|
(cond
|
||||||
|
((<= (+ sl sr) 1) (hk-map-node k v l r))
|
||||||
|
((> sr (* hk-map-delta sl))
|
||||||
|
(let
|
||||||
|
((rl (hk-map-left r)) (rr (hk-map-right r)))
|
||||||
|
(cond
|
||||||
|
((< (hk-map-size rl) (* hk-map-gamma (hk-map-size rr)))
|
||||||
|
(hk-map-single-l k v l r))
|
||||||
|
(:else (hk-map-double-l k v l r)))))
|
||||||
|
((> sl (* hk-map-delta sr))
|
||||||
|
(let
|
||||||
|
((ll (hk-map-left l)) (lr (hk-map-right l)))
|
||||||
|
(cond
|
||||||
|
((< (hk-map-size lr) (* hk-map-gamma (hk-map-size ll)))
|
||||||
|
(hk-map-single-r k v l r))
|
||||||
|
(:else (hk-map-double-r k v l r)))))
|
||||||
|
(:else (hk-map-node k v l r))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-singleton
|
||||||
|
(fn (k v) (hk-map-node k v hk-map-empty hk-map-empty)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-insert
|
||||||
|
(fn
|
||||||
|
(k v m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? m) (hk-map-singleton k v))
|
||||||
|
(:else
|
||||||
|
(let
|
||||||
|
((mk (hk-map-key m)))
|
||||||
|
(cond
|
||||||
|
((< k mk)
|
||||||
|
(hk-map-balance
|
||||||
|
mk
|
||||||
|
(hk-map-val m)
|
||||||
|
(hk-map-insert k v (hk-map-left m))
|
||||||
|
(hk-map-right m)))
|
||||||
|
((> k mk)
|
||||||
|
(hk-map-balance
|
||||||
|
mk
|
||||||
|
(hk-map-val m)
|
||||||
|
(hk-map-left m)
|
||||||
|
(hk-map-insert k v (hk-map-right m))))
|
||||||
|
(:else (hk-map-node k v (hk-map-left m) (hk-map-right m)))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-lookup
|
||||||
|
(fn
|
||||||
|
(k m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? m) (list "Nothing"))
|
||||||
|
(:else
|
||||||
|
(let
|
||||||
|
((mk (hk-map-key m)))
|
||||||
|
(cond
|
||||||
|
((< k mk) (hk-map-lookup k (hk-map-left m)))
|
||||||
|
((> k mk) (hk-map-lookup k (hk-map-right m)))
|
||||||
|
(:else (list "Just" (hk-map-val m)))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-member
|
||||||
|
(fn
|
||||||
|
(k m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? m) false)
|
||||||
|
(:else
|
||||||
|
(let
|
||||||
|
((mk (hk-map-key m)))
|
||||||
|
(cond
|
||||||
|
((< k mk) (hk-map-member k (hk-map-left m)))
|
||||||
|
((> k mk) (hk-map-member k (hk-map-right m)))
|
||||||
|
(:else true)))))))
|
||||||
|
|
||||||
|
(define hk-map-null hk-map-empty?)
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-find-min
|
||||||
|
(fn
|
||||||
|
(m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? (hk-map-left m))
|
||||||
|
(list (hk-map-key m) (hk-map-val m)))
|
||||||
|
(:else (hk-map-find-min (hk-map-left m))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-delete-min
|
||||||
|
(fn
|
||||||
|
(m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? (hk-map-left m)) (hk-map-right m))
|
||||||
|
(:else
|
||||||
|
(hk-map-balance
|
||||||
|
(hk-map-key m)
|
||||||
|
(hk-map-val m)
|
||||||
|
(hk-map-delete-min (hk-map-left m))
|
||||||
|
(hk-map-right m))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-find-max
|
||||||
|
(fn
|
||||||
|
(m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? (hk-map-right m))
|
||||||
|
(list (hk-map-key m) (hk-map-val m)))
|
||||||
|
(:else (hk-map-find-max (hk-map-right m))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-delete-max
|
||||||
|
(fn
|
||||||
|
(m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? (hk-map-right m)) (hk-map-left m))
|
||||||
|
(:else
|
||||||
|
(hk-map-balance
|
||||||
|
(hk-map-key m)
|
||||||
|
(hk-map-val m)
|
||||||
|
(hk-map-left m)
|
||||||
|
(hk-map-delete-max (hk-map-right m)))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-glue
|
||||||
|
(fn
|
||||||
|
(l r)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? l) r)
|
||||||
|
((hk-map-empty? r) l)
|
||||||
|
((> (hk-map-size l) (hk-map-size r))
|
||||||
|
(let
|
||||||
|
((mp (hk-map-find-max l)))
|
||||||
|
(hk-map-balance (first mp) (nth mp 1) (hk-map-delete-max l) r)))
|
||||||
|
(:else
|
||||||
|
(let
|
||||||
|
((mp (hk-map-find-min r)))
|
||||||
|
(hk-map-balance (first mp) (nth mp 1) l (hk-map-delete-min r)))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-delete
|
||||||
|
(fn
|
||||||
|
(k m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? m) m)
|
||||||
|
(:else
|
||||||
|
(let
|
||||||
|
((mk (hk-map-key m)))
|
||||||
|
(cond
|
||||||
|
((< k mk)
|
||||||
|
(hk-map-balance
|
||||||
|
mk
|
||||||
|
(hk-map-val m)
|
||||||
|
(hk-map-delete k (hk-map-left m))
|
||||||
|
(hk-map-right m)))
|
||||||
|
((> k mk)
|
||||||
|
(hk-map-balance
|
||||||
|
mk
|
||||||
|
(hk-map-val m)
|
||||||
|
(hk-map-left m)
|
||||||
|
(hk-map-delete k (hk-map-right m))))
|
||||||
|
(:else (hk-map-glue (hk-map-left m) (hk-map-right m)))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-from-list
|
||||||
|
(fn
|
||||||
|
(pairs)
|
||||||
|
(reduce
|
||||||
|
(fn (acc p) (hk-map-insert (first p) (nth p 1) acc))
|
||||||
|
hk-map-empty
|
||||||
|
pairs)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-to-asc-list
|
||||||
|
(fn
|
||||||
|
(m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? m) (list))
|
||||||
|
(:else
|
||||||
|
(append
|
||||||
|
(hk-map-to-asc-list (hk-map-left m))
|
||||||
|
(cons
|
||||||
|
(list (hk-map-key m) (hk-map-val m))
|
||||||
|
(hk-map-to-asc-list (hk-map-right m))))))))
|
||||||
|
|
||||||
|
(define hk-map-to-list hk-map-to-asc-list)
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-keys
|
||||||
|
(fn
|
||||||
|
(m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? m) (list))
|
||||||
|
(:else
|
||||||
|
(append
|
||||||
|
(hk-map-keys (hk-map-left m))
|
||||||
|
(cons (hk-map-key m) (hk-map-keys (hk-map-right m))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-elems
|
||||||
|
(fn
|
||||||
|
(m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? m) (list))
|
||||||
|
(:else
|
||||||
|
(append
|
||||||
|
(hk-map-elems (hk-map-left m))
|
||||||
|
(cons (hk-map-val m) (hk-map-elems (hk-map-right m))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-union-with
|
||||||
|
(fn
|
||||||
|
(f m1 m2)
|
||||||
|
(reduce
|
||||||
|
(fn
|
||||||
|
(acc p)
|
||||||
|
(let
|
||||||
|
((k (first p)) (v (nth p 1)))
|
||||||
|
(let
|
||||||
|
((look (hk-map-lookup k acc)))
|
||||||
|
(cond
|
||||||
|
((= (first look) "Just")
|
||||||
|
(hk-map-insert k (f (nth look 1) v) acc))
|
||||||
|
(:else (hk-map-insert k v acc))))))
|
||||||
|
m1
|
||||||
|
(hk-map-to-asc-list m2))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-intersection-with
|
||||||
|
(fn
|
||||||
|
(f m1 m2)
|
||||||
|
(reduce
|
||||||
|
(fn
|
||||||
|
(acc p)
|
||||||
|
(let
|
||||||
|
((k (first p)) (v1 (nth p 1)))
|
||||||
|
(let
|
||||||
|
((look (hk-map-lookup k m2)))
|
||||||
|
(cond
|
||||||
|
((= (first look) "Just")
|
||||||
|
(hk-map-insert k (f v1 (nth look 1)) acc))
|
||||||
|
(:else acc)))))
|
||||||
|
hk-map-empty
|
||||||
|
(hk-map-to-asc-list m1))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-difference
|
||||||
|
(fn
|
||||||
|
(m1 m2)
|
||||||
|
(reduce
|
||||||
|
(fn
|
||||||
|
(acc p)
|
||||||
|
(let
|
||||||
|
((k (first p)) (v (nth p 1)))
|
||||||
|
(cond ((hk-map-member k m2) acc) (:else (hk-map-insert k v acc)))))
|
||||||
|
hk-map-empty
|
||||||
|
(hk-map-to-asc-list m1))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-foldl-with-key
|
||||||
|
(fn
|
||||||
|
(f acc m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? m) acc)
|
||||||
|
(:else
|
||||||
|
(let
|
||||||
|
((acc1 (hk-map-foldl-with-key f acc (hk-map-left m))))
|
||||||
|
(let
|
||||||
|
((acc2 (f acc1 (hk-map-key m) (hk-map-val m))))
|
||||||
|
(hk-map-foldl-with-key f acc2 (hk-map-right m))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-foldr-with-key
|
||||||
|
(fn
|
||||||
|
(f acc m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? m) acc)
|
||||||
|
(:else
|
||||||
|
(let
|
||||||
|
((acc1 (hk-map-foldr-with-key f acc (hk-map-right m))))
|
||||||
|
(let
|
||||||
|
((acc2 (f (hk-map-key m) (hk-map-val m) acc1)))
|
||||||
|
(hk-map-foldr-with-key f acc2 (hk-map-left m))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-map-with-key
|
||||||
|
(fn
|
||||||
|
(f m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? m) m)
|
||||||
|
(:else
|
||||||
|
(list
|
||||||
|
"Map-Node"
|
||||||
|
(hk-map-key m)
|
||||||
|
(f (hk-map-key m) (hk-map-val m))
|
||||||
|
(hk-map-map-with-key f (hk-map-left m))
|
||||||
|
(hk-map-map-with-key f (hk-map-right m))
|
||||||
|
(hk-map-size m))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-filter-with-key
|
||||||
|
(fn
|
||||||
|
(p m)
|
||||||
|
(hk-map-foldr-with-key
|
||||||
|
(fn (k v acc) (cond ((p k v) (hk-map-insert k v acc)) (:else acc)))
|
||||||
|
hk-map-empty
|
||||||
|
m)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-adjust
|
||||||
|
(fn
|
||||||
|
(f k m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? m) m)
|
||||||
|
(:else
|
||||||
|
(let
|
||||||
|
((mk (hk-map-key m)))
|
||||||
|
(cond
|
||||||
|
((< k mk)
|
||||||
|
(hk-map-node
|
||||||
|
mk
|
||||||
|
(hk-map-val m)
|
||||||
|
(hk-map-adjust f k (hk-map-left m))
|
||||||
|
(hk-map-right m)))
|
||||||
|
((> k mk)
|
||||||
|
(hk-map-node
|
||||||
|
mk
|
||||||
|
(hk-map-val m)
|
||||||
|
(hk-map-left m)
|
||||||
|
(hk-map-adjust f k (hk-map-right m))))
|
||||||
|
(:else
|
||||||
|
(hk-map-node
|
||||||
|
mk
|
||||||
|
(f (hk-map-val m))
|
||||||
|
(hk-map-left m)
|
||||||
|
(hk-map-right m)))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-insert-with
|
||||||
|
(fn
|
||||||
|
(f k v m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? m) (hk-map-singleton k v))
|
||||||
|
(:else
|
||||||
|
(let
|
||||||
|
((mk (hk-map-key m)))
|
||||||
|
(cond
|
||||||
|
((< k mk)
|
||||||
|
(hk-map-balance
|
||||||
|
mk
|
||||||
|
(hk-map-val m)
|
||||||
|
(hk-map-insert-with f k v (hk-map-left m))
|
||||||
|
(hk-map-right m)))
|
||||||
|
((> k mk)
|
||||||
|
(hk-map-balance
|
||||||
|
mk
|
||||||
|
(hk-map-val m)
|
||||||
|
(hk-map-left m)
|
||||||
|
(hk-map-insert-with f k v (hk-map-right m))))
|
||||||
|
(:else
|
||||||
|
(hk-map-node
|
||||||
|
mk
|
||||||
|
(f v (hk-map-val m))
|
||||||
|
(hk-map-left m)
|
||||||
|
(hk-map-right m)))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-insert-with-key
|
||||||
|
(fn
|
||||||
|
(f k v m)
|
||||||
|
(cond
|
||||||
|
((hk-map-empty? m) (hk-map-singleton k v))
|
||||||
|
(:else
|
||||||
|
(let
|
||||||
|
((mk (hk-map-key m)))
|
||||||
|
(cond
|
||||||
|
((< k mk)
|
||||||
|
(hk-map-balance
|
||||||
|
mk
|
||||||
|
(hk-map-val m)
|
||||||
|
(hk-map-insert-with-key f k v (hk-map-left m))
|
||||||
|
(hk-map-right m)))
|
||||||
|
((> k mk)
|
||||||
|
(hk-map-balance
|
||||||
|
mk
|
||||||
|
(hk-map-val m)
|
||||||
|
(hk-map-left m)
|
||||||
|
(hk-map-insert-with-key f k v (hk-map-right m))))
|
||||||
|
(:else
|
||||||
|
(hk-map-node
|
||||||
|
mk
|
||||||
|
(f k v (hk-map-val m))
|
||||||
|
(hk-map-left m)
|
||||||
|
(hk-map-right m)))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-map-alter
|
||||||
|
(fn
|
||||||
|
(f k m)
|
||||||
|
(let
|
||||||
|
((look (hk-map-lookup k m)))
|
||||||
|
(let
|
||||||
|
((res (f look)))
|
||||||
|
(cond
|
||||||
|
((= (first res) "Nothing") (hk-map-delete k m))
|
||||||
|
(:else (hk-map-insert k (nth res 1) m)))))))
|
||||||
@@ -87,45 +87,41 @@
|
|||||||
((nil? res) nil)
|
((nil? res) nil)
|
||||||
(:else (assoc res (nth pat 1) val)))))
|
(:else (assoc res (nth pat 1) val)))))
|
||||||
(:else
|
(:else
|
||||||
(let ((fv (hk-force val)))
|
(let
|
||||||
|
((fv (hk-force val)))
|
||||||
(cond
|
(cond
|
||||||
((= tag "p-int")
|
((= tag "p-int")
|
||||||
(if
|
(if (and (number? fv) (= fv (nth pat 1))) env nil))
|
||||||
(and (number? fv) (= fv (nth pat 1)))
|
|
||||||
env
|
|
||||||
nil))
|
|
||||||
((= tag "p-float")
|
((= tag "p-float")
|
||||||
(if
|
(if (and (number? fv) (= fv (nth pat 1))) env nil))
|
||||||
(and (number? fv) (= fv (nth pat 1)))
|
|
||||||
env
|
|
||||||
nil))
|
|
||||||
((= tag "p-string")
|
((= tag "p-string")
|
||||||
(if
|
(if (and (string? fv) (= fv (nth pat 1))) env nil))
|
||||||
(and (string? fv) (= fv (nth pat 1)))
|
|
||||||
env
|
|
||||||
nil))
|
|
||||||
((= tag "p-char")
|
((= tag "p-char")
|
||||||
(if
|
(if (and (string? fv) (= fv (nth pat 1))) env nil))
|
||||||
(and (string? fv) (= fv (nth pat 1)))
|
|
||||||
env
|
|
||||||
nil))
|
|
||||||
((= tag "p-con")
|
((= tag "p-con")
|
||||||
(let
|
(let
|
||||||
((pat-name (nth pat 1)) (pat-args (nth pat 2)))
|
((pat-name (nth pat 1)) (pat-args (nth pat 2)))
|
||||||
(cond
|
(cond
|
||||||
|
((and (= pat-name ":") (hk-str? fv) (not (hk-str-null? fv)))
|
||||||
|
(let
|
||||||
|
((str-head (hk-str-head fv))
|
||||||
|
(str-tail (hk-str-tail fv)))
|
||||||
|
(let
|
||||||
|
((head-pat (nth pat-args 0))
|
||||||
|
(tail-pat (nth pat-args 1)))
|
||||||
|
(let
|
||||||
|
((res (hk-match head-pat str-head env)))
|
||||||
|
(cond
|
||||||
|
((nil? res) nil)
|
||||||
|
(:else (hk-match tail-pat str-tail res)))))))
|
||||||
((not (hk-is-con-val? fv)) nil)
|
((not (hk-is-con-val? fv)) nil)
|
||||||
((not (= (hk-val-con-name fv) pat-name)) nil)
|
((not (= (hk-val-con-name fv) pat-name)) nil)
|
||||||
(:else
|
(:else
|
||||||
(let
|
(let
|
||||||
((val-args (hk-val-con-args fv)))
|
((val-args (hk-val-con-args fv)))
|
||||||
(cond
|
(cond
|
||||||
((not (= (len pat-args) (len val-args)))
|
((not (= (len val-args) (len pat-args))) nil)
|
||||||
nil)
|
(:else (hk-match-all pat-args val-args env))))))))
|
||||||
(:else
|
|
||||||
(hk-match-all
|
|
||||||
pat-args
|
|
||||||
val-args
|
|
||||||
env))))))))
|
|
||||||
((= tag "p-tuple")
|
((= tag "p-tuple")
|
||||||
(let
|
(let
|
||||||
((items (nth pat 1)))
|
((items (nth pat 1)))
|
||||||
@@ -134,13 +130,8 @@
|
|||||||
((not (= (hk-val-con-name fv) "Tuple")) nil)
|
((not (= (hk-val-con-name fv) "Tuple")) nil)
|
||||||
((not (= (len (hk-val-con-args fv)) (len items)))
|
((not (= (len (hk-val-con-args fv)) (len items)))
|
||||||
nil)
|
nil)
|
||||||
(:else
|
(:else (hk-match-all items (hk-val-con-args fv) env)))))
|
||||||
(hk-match-all
|
((= tag "p-list") (hk-match-list-pat (nth pat 1) fv env))
|
||||||
items
|
|
||||||
(hk-val-con-args fv)
|
|
||||||
env)))))
|
|
||||||
((= tag "p-list")
|
|
||||||
(hk-match-list-pat (nth pat 1) fv env))
|
|
||||||
(:else nil))))))))))
|
(:else nil))))))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -161,17 +152,26 @@
|
|||||||
hk-match-list-pat
|
hk-match-list-pat
|
||||||
(fn
|
(fn
|
||||||
(items val env)
|
(items val env)
|
||||||
(let ((fv (hk-force val)))
|
(let
|
||||||
|
((fv (hk-force val)))
|
||||||
(cond
|
(cond
|
||||||
((empty? items)
|
((empty? items)
|
||||||
(if
|
(if
|
||||||
(and
|
(or
|
||||||
(hk-is-con-val? fv)
|
(and (hk-is-con-val? fv) (= (hk-val-con-name fv) "[]"))
|
||||||
(= (hk-val-con-name fv) "[]"))
|
(and (hk-str? fv) (hk-str-null? fv)))
|
||||||
env
|
env
|
||||||
nil))
|
nil))
|
||||||
(:else
|
(:else
|
||||||
(cond
|
(cond
|
||||||
|
((and (hk-str? fv) (not (hk-str-null? fv)))
|
||||||
|
(let
|
||||||
|
((h (hk-str-head fv)) (t (hk-str-tail fv)))
|
||||||
|
(let
|
||||||
|
((res (hk-match (first items) h env)))
|
||||||
|
(cond
|
||||||
|
((nil? res) nil)
|
||||||
|
(:else (hk-match-list-pat (rest items) t res))))))
|
||||||
((not (hk-is-con-val? fv)) nil)
|
((not (hk-is-con-val? fv)) nil)
|
||||||
((not (= (hk-val-con-name fv) ":")) nil)
|
((not (= (hk-val-con-name fv) ":")) nil)
|
||||||
(:else
|
(:else
|
||||||
@@ -183,11 +183,7 @@
|
|||||||
((res (hk-match (first items) h env)))
|
((res (hk-match (first items) h env)))
|
||||||
(cond
|
(cond
|
||||||
((nil? res) nil)
|
((nil? res) nil)
|
||||||
(:else
|
(:else (hk-match-list-pat (rest items) t res)))))))))))))
|
||||||
(hk-match-list-pat
|
|
||||||
(rest items)
|
|
||||||
t
|
|
||||||
res)))))))))))))
|
|
||||||
|
|
||||||
;; ── Convenience: parse a pattern from source for tests ─────
|
;; ── Convenience: parse a pattern from source for tests ─────
|
||||||
;; (Uses the parser's case-alt entry — `case _ of pat -> 0` —
|
;; (Uses the parser's case-alt entry — `case _ of pat -> 0` —
|
||||||
|
|||||||
@@ -208,9 +208,19 @@
|
|||||||
((= (get t "type") "char")
|
((= (get t "type") "char")
|
||||||
(do (hk-advance!) (list :char (get t "value"))))
|
(do (hk-advance!) (list :char (get t "value"))))
|
||||||
((= (get t "type") "varid")
|
((= (get t "type") "varid")
|
||||||
(do (hk-advance!) (list :var (get t "value"))))
|
(do
|
||||||
|
(hk-advance!)
|
||||||
|
(cond
|
||||||
|
((hk-match? "lbrace" nil)
|
||||||
|
(hk-parse-rec-update (list :var (get t "value"))))
|
||||||
|
(:else (list :var (get t "value"))))))
|
||||||
((= (get t "type") "conid")
|
((= (get t "type") "conid")
|
||||||
(do (hk-advance!) (list :con (get t "value"))))
|
(do
|
||||||
|
(hk-advance!)
|
||||||
|
(cond
|
||||||
|
((hk-match? "lbrace" nil)
|
||||||
|
(hk-parse-rec-create (get t "value")))
|
||||||
|
(:else (list :con (get t "value"))))))
|
||||||
((= (get t "type") "qvarid")
|
((= (get t "type") "qvarid")
|
||||||
(do (hk-advance!) (list :var (get t "value"))))
|
(do (hk-advance!) (list :var (get t "value"))))
|
||||||
((= (get t "type") "qconid")
|
((= (get t "type") "qconid")
|
||||||
@@ -456,6 +466,90 @@
|
|||||||
(do
|
(do
|
||||||
(hk-expect! "rbracket" nil)
|
(hk-expect! "rbracket" nil)
|
||||||
(list :list (list first-e))))))))))
|
(list :list (list first-e))))))))))
|
||||||
|
(define
|
||||||
|
hk-parse-rec-create
|
||||||
|
(fn
|
||||||
|
(cname)
|
||||||
|
(begin
|
||||||
|
(hk-expect! "lbrace" nil)
|
||||||
|
(let
|
||||||
|
((fields (list)))
|
||||||
|
(define
|
||||||
|
hk-rc-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(hk-match? "varid" nil)
|
||||||
|
(let
|
||||||
|
((fname (get (hk-advance!) "value")))
|
||||||
|
(begin
|
||||||
|
(hk-expect! "reservedop" "=")
|
||||||
|
(let
|
||||||
|
((fexpr (hk-parse-expr-inner)))
|
||||||
|
(begin
|
||||||
|
(append! fields (list fname fexpr))
|
||||||
|
(when
|
||||||
|
(hk-match? "comma" nil)
|
||||||
|
(begin (hk-advance!) (hk-rc-loop))))))))))
|
||||||
|
(hk-rc-loop)
|
||||||
|
(hk-expect! "rbrace" nil)
|
||||||
|
(list :rec-create cname fields)))))
|
||||||
|
(define
|
||||||
|
hk-parse-rec-update
|
||||||
|
(fn
|
||||||
|
(rec-expr)
|
||||||
|
(begin
|
||||||
|
(hk-expect! "lbrace" nil)
|
||||||
|
(let
|
||||||
|
((fields (list)))
|
||||||
|
(define
|
||||||
|
hk-ru-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(hk-match? "varid" nil)
|
||||||
|
(let
|
||||||
|
((fname (get (hk-advance!) "value")))
|
||||||
|
(begin
|
||||||
|
(hk-expect! "reservedop" "=")
|
||||||
|
(let
|
||||||
|
((fexpr (hk-parse-expr-inner)))
|
||||||
|
(begin
|
||||||
|
(append! fields (list fname fexpr))
|
||||||
|
(when
|
||||||
|
(hk-match? "comma" nil)
|
||||||
|
(begin (hk-advance!) (hk-ru-loop))))))))))
|
||||||
|
(hk-ru-loop)
|
||||||
|
(hk-expect! "rbrace" nil)
|
||||||
|
(list :rec-update rec-expr fields)))))
|
||||||
|
(define
|
||||||
|
hk-parse-rec-pat
|
||||||
|
(fn
|
||||||
|
(cname)
|
||||||
|
(begin
|
||||||
|
(hk-expect! "lbrace" nil)
|
||||||
|
(let
|
||||||
|
((field-pats (list)))
|
||||||
|
(define
|
||||||
|
hk-rp-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(hk-match? "varid" nil)
|
||||||
|
(let
|
||||||
|
((fname (get (hk-advance!) "value")))
|
||||||
|
(begin
|
||||||
|
(hk-expect! "reservedop" "=")
|
||||||
|
(let
|
||||||
|
((fpat (hk-parse-pat)))
|
||||||
|
(begin
|
||||||
|
(append! field-pats (list fname fpat))
|
||||||
|
(when
|
||||||
|
(hk-match? "comma" nil)
|
||||||
|
(begin (hk-advance!) (hk-rp-loop))))))))))
|
||||||
|
(hk-rp-loop)
|
||||||
|
(hk-expect! "rbrace" nil)
|
||||||
|
(list :p-rec cname field-pats)))))
|
||||||
(define
|
(define
|
||||||
hk-parse-fexp
|
hk-parse-fexp
|
||||||
(fn
|
(fn
|
||||||
@@ -696,7 +790,12 @@
|
|||||||
(:else
|
(:else
|
||||||
(do (hk-advance!) (list :p-var (get t "value")))))))
|
(do (hk-advance!) (list :p-var (get t "value")))))))
|
||||||
((= (get t "type") "conid")
|
((= (get t "type") "conid")
|
||||||
(do (hk-advance!) (list :p-con (get t "value") (list))))
|
(do
|
||||||
|
(hk-advance!)
|
||||||
|
(cond
|
||||||
|
((hk-match? "lbrace" nil)
|
||||||
|
(hk-parse-rec-pat (get t "value")))
|
||||||
|
(:else (list :p-con (get t "value") (list))))))
|
||||||
((= (get t "type") "qconid")
|
((= (get t "type") "qconid")
|
||||||
(do (hk-advance!) (list :p-con (get t "value") (list))))
|
(do (hk-advance!) (list :p-con (get t "value") (list))))
|
||||||
((= (get t "type") "lparen") (hk-parse-paren-pat))
|
((= (get t "type") "lparen") (hk-parse-paren-pat))
|
||||||
@@ -762,16 +861,24 @@
|
|||||||
(cond
|
(cond
|
||||||
((and (not (nil? t)) (or (= (get t "type") "conid") (= (get t "type") "qconid")))
|
((and (not (nil? t)) (or (= (get t "type") "conid") (= (get t "type") "qconid")))
|
||||||
(let
|
(let
|
||||||
((name (get (hk-advance!) "value")) (args (list)))
|
((name (get (hk-advance!) "value")))
|
||||||
(define
|
(cond
|
||||||
hk-pca-loop
|
((hk-match? "lbrace" nil)
|
||||||
(fn
|
(hk-parse-rec-pat name))
|
||||||
()
|
(:else
|
||||||
(when
|
(let
|
||||||
(hk-apat-start? (hk-peek))
|
((args (list)))
|
||||||
(do (append! args (hk-parse-apat)) (hk-pca-loop)))))
|
(define
|
||||||
(hk-pca-loop)
|
hk-pca-loop
|
||||||
(list :p-con name args)))
|
(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))))))
|
(:else (hk-parse-apat))))))
|
||||||
(define
|
(define
|
||||||
hk-parse-pat
|
hk-parse-pat
|
||||||
@@ -1212,16 +1319,47 @@
|
|||||||
(not (hk-match? "conid" nil))
|
(not (hk-match? "conid" nil))
|
||||||
(hk-err "expected constructor name"))
|
(hk-err "expected constructor name"))
|
||||||
(let
|
(let
|
||||||
((name (get (hk-advance!) "value")) (fields (list)))
|
((name (get (hk-advance!) "value")))
|
||||||
(define
|
(cond
|
||||||
hk-cd-loop
|
((hk-match? "lbrace" nil)
|
||||||
(fn
|
(begin
|
||||||
()
|
(hk-advance!)
|
||||||
(when
|
(let
|
||||||
(hk-atype-start? (hk-peek))
|
((rec-fields (list)))
|
||||||
(do (append! fields (hk-parse-atype)) (hk-cd-loop)))))
|
(define
|
||||||
(hk-cd-loop)
|
hk-rec-loop
|
||||||
(list :con-def name fields))))
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(hk-match? "varid" nil)
|
||||||
|
(let
|
||||||
|
((fname (get (hk-advance!) "value")))
|
||||||
|
(begin
|
||||||
|
(hk-expect! "reservedop" "::")
|
||||||
|
(let
|
||||||
|
((ftype (hk-parse-type)))
|
||||||
|
(begin
|
||||||
|
(append! rec-fields (list fname ftype))
|
||||||
|
(when
|
||||||
|
(hk-match? "comma" nil)
|
||||||
|
(begin (hk-advance!) (hk-rec-loop))))))))))
|
||||||
|
(hk-rec-loop)
|
||||||
|
(hk-expect! "rbrace" nil)
|
||||||
|
(list :con-rec name rec-fields))))
|
||||||
|
(:else
|
||||||
|
(let
|
||||||
|
((fields (list)))
|
||||||
|
(define
|
||||||
|
hk-cd-loop
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(when
|
||||||
|
(hk-atype-start? (hk-peek))
|
||||||
|
(begin
|
||||||
|
(append! fields (hk-parse-atype))
|
||||||
|
(hk-cd-loop)))))
|
||||||
|
(hk-cd-loop)
|
||||||
|
(list :con-def name fields)))))))
|
||||||
(define
|
(define
|
||||||
hk-parse-tvars
|
hk-parse-tvars
|
||||||
(fn
|
(fn
|
||||||
|
|||||||
@@ -12,12 +12,7 @@
|
|||||||
|
|
||||||
(define
|
(define
|
||||||
hk-register-con!
|
hk-register-con!
|
||||||
(fn
|
(fn (cname arity type-name) (dict-set! hk-constructors cname {:arity arity :type type-name})))
|
||||||
(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-is-con? (fn (name) (has-key? hk-constructors name)))
|
||||||
|
|
||||||
@@ -48,26 +43,15 @@
|
|||||||
(fn
|
(fn
|
||||||
(data-node)
|
(data-node)
|
||||||
(let
|
(let
|
||||||
((type-name (nth data-node 1))
|
((type-name (nth data-node 1)) (cons-list (nth data-node 3)))
|
||||||
(cons-list (nth data-node 3)))
|
|
||||||
(for-each
|
(for-each
|
||||||
(fn
|
(fn (cd) (hk-register-con! (nth cd 1) (len (nth cd 2)) type-name))
|
||||||
(cd)
|
|
||||||
(hk-register-con!
|
|
||||||
(nth cd 1)
|
|
||||||
(len (nth cd 2))
|
|
||||||
type-name))
|
|
||||||
cons-list))))
|
cons-list))))
|
||||||
|
|
||||||
;; (:newtype NAME TVARS CNAME FIELD)
|
;; (:newtype NAME TVARS CNAME FIELD)
|
||||||
(define
|
(define
|
||||||
hk-register-newtype!
|
hk-register-newtype!
|
||||||
(fn
|
(fn (nt-node) (hk-register-con! (nth nt-node 3) 1 (nth nt-node 1))))
|
||||||
(nt-node)
|
|
||||||
(hk-register-con!
|
|
||||||
(nth nt-node 3)
|
|
||||||
1
|
|
||||||
(nth nt-node 1))))
|
|
||||||
|
|
||||||
;; Walk a decls list, registering every `data` / `newtype` decl.
|
;; Walk a decls list, registering every `data` / `newtype` decl.
|
||||||
(define
|
(define
|
||||||
@@ -78,15 +62,9 @@
|
|||||||
(fn
|
(fn
|
||||||
(d)
|
(d)
|
||||||
(cond
|
(cond
|
||||||
((and
|
((and (list? d) (not (empty? d)) (= (first d) "data"))
|
||||||
(list? d)
|
|
||||||
(not (empty? d))
|
|
||||||
(= (first d) "data"))
|
|
||||||
(hk-register-data! d))
|
(hk-register-data! d))
|
||||||
((and
|
((and (list? d) (not (empty? d)) (= (first d) "newtype"))
|
||||||
(list? d)
|
|
||||||
(not (empty? d))
|
|
||||||
(= (first d) "newtype"))
|
|
||||||
(hk-register-newtype! d))
|
(hk-register-newtype! d))
|
||||||
(:else nil)))
|
(:else nil)))
|
||||||
decls)))
|
decls)))
|
||||||
@@ -99,16 +77,12 @@
|
|||||||
((nil? ast) nil)
|
((nil? ast) nil)
|
||||||
((not (list? ast)) nil)
|
((not (list? ast)) nil)
|
||||||
((empty? ast) nil)
|
((empty? ast) nil)
|
||||||
((= (first ast) "program")
|
((= (first ast) "program") (hk-register-decls! (nth ast 1)))
|
||||||
(hk-register-decls! (nth ast 1)))
|
((= (first ast) "module") (hk-register-decls! (nth ast 4)))
|
||||||
((= (first ast) "module")
|
|
||||||
(hk-register-decls! (nth ast 4)))
|
|
||||||
(:else nil))))
|
(:else nil))))
|
||||||
|
|
||||||
;; Convenience: source → AST → desugar → register.
|
;; Convenience: source → AST → desugar → register.
|
||||||
(define
|
(define hk-load-source! (fn (src) (hk-register-program! (hk-core src))))
|
||||||
hk-load-source!
|
|
||||||
(fn (src) (hk-register-program! (hk-core src))))
|
|
||||||
|
|
||||||
;; ── Built-in constructors pre-registered ─────────────────────
|
;; ── Built-in constructors pre-registered ─────────────────────
|
||||||
;; Bool — used implicitly by `if`, comparison operators.
|
;; Bool — used implicitly by `if`, comparison operators.
|
||||||
@@ -122,9 +96,55 @@
|
|||||||
;; Standard Prelude types — pre-registered so expression-level
|
;; Standard Prelude types — pre-registered so expression-level
|
||||||
;; programs can use them without a `data` decl.
|
;; programs can use them without a `data` decl.
|
||||||
(hk-register-con! "Nothing" 0 "Maybe")
|
(hk-register-con! "Nothing" 0 "Maybe")
|
||||||
(hk-register-con! "Just" 1 "Maybe")
|
(hk-register-con! "Just" 1 "Maybe")
|
||||||
(hk-register-con! "Left" 1 "Either")
|
(hk-register-con! "Left" 1 "Either")
|
||||||
(hk-register-con! "Right" 1 "Either")
|
(hk-register-con! "Right" 1 "Either")
|
||||||
(hk-register-con! "LT" 0 "Ordering")
|
(hk-register-con! "LT" 0 "Ordering")
|
||||||
(hk-register-con! "EQ" 0 "Ordering")
|
(hk-register-con! "EQ" 0 "Ordering")
|
||||||
(hk-register-con! "GT" 0 "Ordering")
|
(hk-register-con! "GT" 0 "Ordering")
|
||||||
|
(hk-register-con! "SomeException" 1 "SomeException")
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-str?
|
||||||
|
(fn (v) (or (string? v) (and (dict? v) (has-key? v "hk-str")))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-str-head
|
||||||
|
(fn
|
||||||
|
(v)
|
||||||
|
(if
|
||||||
|
(string? v)
|
||||||
|
(char-code (char-at v 0))
|
||||||
|
(char-code (char-at (get v "hk-str") (get v "hk-off"))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-str-tail
|
||||||
|
(fn
|
||||||
|
(v)
|
||||||
|
(let
|
||||||
|
((buf (if (string? v) v (get v "hk-str")))
|
||||||
|
(off (if (string? v) 1 (+ (get v "hk-off") 1))))
|
||||||
|
(if (>= off (string-length buf)) (list "[]") {:hk-off off :hk-str buf}))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-str-null?
|
||||||
|
(fn
|
||||||
|
(v)
|
||||||
|
(if
|
||||||
|
(string? v)
|
||||||
|
(= (string-length v) 0)
|
||||||
|
(>= (get v "hk-off") (string-length (get v "hk-str"))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-str-to-native
|
||||||
|
(fn
|
||||||
|
(v)
|
||||||
|
(if
|
||||||
|
(string? v)
|
||||||
|
v
|
||||||
|
(let
|
||||||
|
((buf (get v "hk-str")) (off (get v "hk-off")))
|
||||||
|
(reduce
|
||||||
|
(fn (acc i) (str acc (char-at buf i)))
|
||||||
|
""
|
||||||
|
(range off (string-length buf)))))))
|
||||||
|
|||||||
@@ -1,6 +1,6 @@
|
|||||||
{
|
{
|
||||||
"date": "2026-05-06",
|
"date": "2026-05-08",
|
||||||
"total_pass": 156,
|
"total_pass": 285,
|
||||||
"total_fail": 0,
|
"total_fail": 0,
|
||||||
"programs": {
|
"programs": {
|
||||||
"fib": {"pass": 2, "fail": 0},
|
"fib": {"pass": 2, "fail": 0},
|
||||||
@@ -9,7 +9,7 @@
|
|||||||
"nqueens": {"pass": 2, "fail": 0},
|
"nqueens": {"pass": 2, "fail": 0},
|
||||||
"calculator": {"pass": 5, "fail": 0},
|
"calculator": {"pass": 5, "fail": 0},
|
||||||
"collatz": {"pass": 11, "fail": 0},
|
"collatz": {"pass": 11, "fail": 0},
|
||||||
"palindrome": {"pass": 8, "fail": 0},
|
"palindrome": {"pass": 12, "fail": 0},
|
||||||
"maybe": {"pass": 12, "fail": 0},
|
"maybe": {"pass": 12, "fail": 0},
|
||||||
"fizzbuzz": {"pass": 12, "fail": 0},
|
"fizzbuzz": {"pass": 12, "fail": 0},
|
||||||
"anagram": {"pass": 9, "fail": 0},
|
"anagram": {"pass": 9, "fail": 0},
|
||||||
@@ -19,7 +19,25 @@
|
|||||||
"primes": {"pass": 12, "fail": 0},
|
"primes": {"pass": 12, "fail": 0},
|
||||||
"zipwith": {"pass": 9, "fail": 0},
|
"zipwith": {"pass": 9, "fail": 0},
|
||||||
"matrix": {"pass": 8, "fail": 0},
|
"matrix": {"pass": 8, "fail": 0},
|
||||||
"wordcount": {"pass": 7, "fail": 0},
|
"wordcount": {"pass": 10, "fail": 0},
|
||||||
"powers": {"pass": 14, "fail": 0}
|
"powers": {"pass": 14, "fail": 0},
|
||||||
|
"caesar": {"pass": 8, "fail": 0},
|
||||||
|
"runlength-str": {"pass": 9, "fail": 0},
|
||||||
|
"showadt": {"pass": 5, "fail": 0},
|
||||||
|
"showio": {"pass": 5, "fail": 0},
|
||||||
|
"partial": {"pass": 7, "fail": 0},
|
||||||
|
"statistics": {"pass": 5, "fail": 0},
|
||||||
|
"newton": {"pass": 5, "fail": 0},
|
||||||
|
"wordfreq": {"pass": 7, "fail": 0},
|
||||||
|
"mapgraph": {"pass": 6, "fail": 0},
|
||||||
|
"uniquewords": {"pass": 4, "fail": 0},
|
||||||
|
"setops": {"pass": 8, "fail": 0},
|
||||||
|
"shapes": {"pass": 5, "fail": 0},
|
||||||
|
"person": {"pass": 7, "fail": 0},
|
||||||
|
"config": {"pass": 10, "fail": 0},
|
||||||
|
"counter": {"pass": 7, "fail": 0},
|
||||||
|
"accumulate": {"pass": 8, "fail": 0},
|
||||||
|
"safediv": {"pass": 8, "fail": 0},
|
||||||
|
"trycatch": {"pass": 8, "fail": 0}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -1,6 +1,6 @@
|
|||||||
# Haskell-on-SX Scoreboard
|
# Haskell-on-SX Scoreboard
|
||||||
|
|
||||||
Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs)
|
Updated 2026-05-08 · Phase 6 (prelude extras + 18 programs)
|
||||||
|
|
||||||
| Program | Tests | Status |
|
| Program | Tests | Status |
|
||||||
|---------|-------|--------|
|
|---------|-------|--------|
|
||||||
@@ -10,7 +10,7 @@ Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs)
|
|||||||
| nqueens.hs | 2/2 | ✓ |
|
| nqueens.hs | 2/2 | ✓ |
|
||||||
| calculator.hs | 5/5 | ✓ |
|
| calculator.hs | 5/5 | ✓ |
|
||||||
| collatz.hs | 11/11 | ✓ |
|
| collatz.hs | 11/11 | ✓ |
|
||||||
| palindrome.hs | 8/8 | ✓ |
|
| palindrome.hs | 12/12 | ✓ |
|
||||||
| maybe.hs | 12/12 | ✓ |
|
| maybe.hs | 12/12 | ✓ |
|
||||||
| fizzbuzz.hs | 12/12 | ✓ |
|
| fizzbuzz.hs | 12/12 | ✓ |
|
||||||
| anagram.hs | 9/9 | ✓ |
|
| anagram.hs | 9/9 | ✓ |
|
||||||
@@ -20,6 +20,24 @@ Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs)
|
|||||||
| primes.hs | 12/12 | ✓ |
|
| primes.hs | 12/12 | ✓ |
|
||||||
| zipwith.hs | 9/9 | ✓ |
|
| zipwith.hs | 9/9 | ✓ |
|
||||||
| matrix.hs | 8/8 | ✓ |
|
| matrix.hs | 8/8 | ✓ |
|
||||||
| wordcount.hs | 7/7 | ✓ |
|
| wordcount.hs | 10/10 | ✓ |
|
||||||
| powers.hs | 14/14 | ✓ |
|
| powers.hs | 14/14 | ✓ |
|
||||||
| **Total** | **156/156** | **18/18 programs** |
|
| caesar.hs | 8/8 | ✓ |
|
||||||
|
| runlength-str.hs | 9/9 | ✓ |
|
||||||
|
| showadt.hs | 5/5 | ✓ |
|
||||||
|
| showio.hs | 5/5 | ✓ |
|
||||||
|
| partial.hs | 7/7 | ✓ |
|
||||||
|
| statistics.hs | 5/5 | ✓ |
|
||||||
|
| newton.hs | 5/5 | ✓ |
|
||||||
|
| wordfreq.hs | 7/7 | ✓ |
|
||||||
|
| mapgraph.hs | 6/6 | ✓ |
|
||||||
|
| uniquewords.hs | 4/4 | ✓ |
|
||||||
|
| setops.hs | 8/8 | ✓ |
|
||||||
|
| shapes.hs | 5/5 | ✓ |
|
||||||
|
| person.hs | 7/7 | ✓ |
|
||||||
|
| config.hs | 10/10 | ✓ |
|
||||||
|
| counter.hs | 7/7 | ✓ |
|
||||||
|
| accumulate.hs | 8/8 | ✓ |
|
||||||
|
| safediv.hs | 8/8 | ✓ |
|
||||||
|
| trycatch.hs | 8/8 | ✓ |
|
||||||
|
| **Total** | **285/285** | **36/36 programs** |
|
||||||
|
|||||||
62
lib/haskell/set.sx
Normal file
62
lib/haskell/set.sx
Normal file
@@ -0,0 +1,62 @@
|
|||||||
|
;; set.sx — Phase 12 Data.Set: wraps Data.Map with unit values.
|
||||||
|
;;
|
||||||
|
;; A Set is a Map from key to (). All set operations delegate to the map
|
||||||
|
;; ops, ignoring the value side. Storage representation matches Data.Map:
|
||||||
|
;;
|
||||||
|
;; Empty → ("Map-Empty")
|
||||||
|
;; Node → ("Map-Node" key () left right size)
|
||||||
|
;;
|
||||||
|
;; Tradeoff: trivial maintenance burden, slight overhead per node from
|
||||||
|
;; the unused value slot. Faster path forward than re-implementing the
|
||||||
|
;; weight-balanced BST.
|
||||||
|
;;
|
||||||
|
;; Functions live in this file; the Haskell-level `import Data.Set` /
|
||||||
|
;; `import qualified Data.Set as Set` wiring (next Phase 12 box) binds
|
||||||
|
;; them under the chosen alias.
|
||||||
|
|
||||||
|
(define hk-set-unit (list "Tuple"))
|
||||||
|
|
||||||
|
(define hk-set-empty hk-map-empty)
|
||||||
|
|
||||||
|
(define hk-set-singleton (fn (k) (hk-map-singleton k hk-set-unit)))
|
||||||
|
|
||||||
|
(define hk-set-insert (fn (k s) (hk-map-insert k hk-set-unit s)))
|
||||||
|
|
||||||
|
(define hk-set-delete hk-map-delete)
|
||||||
|
(define hk-set-member hk-map-member)
|
||||||
|
(define hk-set-size hk-map-size)
|
||||||
|
(define hk-set-null hk-map-null)
|
||||||
|
(define hk-set-to-asc-list hk-map-keys)
|
||||||
|
(define hk-set-to-list hk-map-keys)
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-set-from-list
|
||||||
|
(fn (xs) (reduce (fn (acc k) (hk-set-insert k acc)) hk-set-empty xs)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-set-union
|
||||||
|
(fn (a b) (hk-map-union-with (fn (x y) hk-set-unit) a b)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-set-intersection
|
||||||
|
(fn (a b) (hk-map-intersection-with (fn (x y) hk-set-unit) a b)))
|
||||||
|
|
||||||
|
(define hk-set-difference hk-map-difference)
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-set-is-subset-of
|
||||||
|
(fn (a b) (= (hk-map-size (hk-map-difference a b)) 0)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-set-filter
|
||||||
|
(fn (p s) (hk-map-filter-with-key (fn (k v) (p k)) s)))
|
||||||
|
|
||||||
|
(define hk-set-map (fn (f s) (hk-set-from-list (map f (hk-map-keys s)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-set-foldr
|
||||||
|
(fn (f z s) (hk-map-foldr-with-key (fn (k v acc) (f k acc)) z s)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-set-foldl
|
||||||
|
(fn (f z s) (hk-map-foldl-with-key (fn (acc k v) (f acc k)) z s)))
|
||||||
@@ -55,6 +55,8 @@ for FILE in "${FILES[@]}"; do
|
|||||||
(load "lib/haskell/runtime.sx")
|
(load "lib/haskell/runtime.sx")
|
||||||
(load "lib/haskell/match.sx")
|
(load "lib/haskell/match.sx")
|
||||||
(load "lib/haskell/eval.sx")
|
(load "lib/haskell/eval.sx")
|
||||||
|
(load "lib/haskell/map.sx")
|
||||||
|
(load "lib/haskell/set.sx")
|
||||||
$INFER_LOAD
|
$INFER_LOAD
|
||||||
(load "lib/haskell/testlib.sx")
|
(load "lib/haskell/testlib.sx")
|
||||||
(epoch 2)
|
(epoch 2)
|
||||||
@@ -98,6 +100,8 @@ EPOCHS
|
|||||||
(load "lib/haskell/runtime.sx")
|
(load "lib/haskell/runtime.sx")
|
||||||
(load "lib/haskell/match.sx")
|
(load "lib/haskell/match.sx")
|
||||||
(load "lib/haskell/eval.sx")
|
(load "lib/haskell/eval.sx")
|
||||||
|
(load "lib/haskell/map.sx")
|
||||||
|
(load "lib/haskell/set.sx")
|
||||||
$INFER_LOAD
|
$INFER_LOAD
|
||||||
(load "lib/haskell/testlib.sx")
|
(load "lib/haskell/testlib.sx")
|
||||||
(epoch 2)
|
(epoch 2)
|
||||||
|
|||||||
@@ -56,3 +56,21 @@
|
|||||||
(append!
|
(append!
|
||||||
hk-test-fails
|
hk-test-fails
|
||||||
{:actual actual :expected expected :name name})))))
|
{:actual actual :expected expected :name name})))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-test-error
|
||||||
|
(fn
|
||||||
|
(name thunk expected-substring)
|
||||||
|
(let
|
||||||
|
((caught (guard (e (true (if (string? e) e (str e)))) (begin (thunk) nil))))
|
||||||
|
(cond
|
||||||
|
((nil? caught)
|
||||||
|
(do
|
||||||
|
(set! hk-test-fail (+ hk-test-fail 1))
|
||||||
|
(append! hk-test-fails {:actual "no error raised" :expected (str "error containing: " expected-substring) :name name})))
|
||||||
|
((>= (index-of caught expected-substring) 0)
|
||||||
|
(set! hk-test-pass (+ hk-test-pass 1)))
|
||||||
|
(:else
|
||||||
|
(do
|
||||||
|
(set! hk-test-fail (+ hk-test-fail 1))
|
||||||
|
(append! hk-test-fails {:actual caught :expected (str "error containing: " expected-substring) :name name})))))))
|
||||||
|
|||||||
86
lib/haskell/tests/class-defaults.sx
Normal file
86
lib/haskell/tests/class-defaults.sx
Normal file
@@ -0,0 +1,86 @@
|
|||||||
|
;; class-defaults.sx — Phase 13: class default method implementations.
|
||||||
|
|
||||||
|
;; ── Eq default: myNeq derived from myEq via `not (myEq x y)` ──
|
||||||
|
(define
|
||||||
|
hk-myeq-source
|
||||||
|
"class MyEq a where\n myEq :: a -> a -> Bool\n myNeq :: a -> a -> Bool\n myNeq x y = not (myEq x y)\ninstance MyEq Int where\n myEq x y = x == y\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Eq default: myNeq 3 5 = True (no explicit myNeq in instance)"
|
||||||
|
(hk-deep-force (hk-run (str hk-myeq-source "main = myNeq 3 5\n")))
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Eq default: myNeq 3 3 = False"
|
||||||
|
(hk-deep-force (hk-run (str hk-myeq-source "main = myNeq 3 3\n")))
|
||||||
|
(list "False"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Eq default: myEq still works in same instance"
|
||||||
|
(hk-deep-force (hk-run (str hk-myeq-source "main = myEq 7 7\n")))
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
;; ── Override path: instance can still provide the method explicitly. ──
|
||||||
|
(hk-test
|
||||||
|
"Default override: instance-provided beats class default"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"class Hi a where\n greet :: a -> String\n greet x = \"default\"\ninstance Hi Bool where\n greet x = \"override\"\nmain = greet True"))
|
||||||
|
"override")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Default fallback: empty instance picks default"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"class Hi a where\n greet :: a -> String\n greet x = \"default\"\ninstance Hi Bool where\nmain = greet True"))
|
||||||
|
"default")
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-myord-source
|
||||||
|
"class MyOrd a where\n myCmp :: a -> a -> Bool\n myMax :: a -> a -> a\n myMin :: a -> a -> a\n myMax a b = if myCmp a b then a else b\n myMin a b = if myCmp a b then b else a\ninstance MyOrd Int where\n myCmp x y = x >= y\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Ord default: myMax 3 5 = 5"
|
||||||
|
(hk-deep-force (hk-run (str hk-myord-source "main = myMax 3 5\n")))
|
||||||
|
5)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Ord default: myMax 8 2 = 8"
|
||||||
|
(hk-deep-force (hk-run (str hk-myord-source "main = myMax 8 2\n")))
|
||||||
|
8)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Ord default: myMin 3 5 = 3"
|
||||||
|
(hk-deep-force (hk-run (str hk-myord-source "main = myMin 3 5\n")))
|
||||||
|
3)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Ord default: myMin 8 2 = 2"
|
||||||
|
(hk-deep-force (hk-run (str hk-myord-source "main = myMin 8 2\n")))
|
||||||
|
2)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Ord default: myMax of equals returns first"
|
||||||
|
(hk-deep-force (hk-run (str hk-myord-source "main = myMax 4 4\n")))
|
||||||
|
4)
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-mynum-source
|
||||||
|
"class MyNum a where\n mySub :: a -> a -> a\n myLt :: a -> a -> Bool\n myNegate :: a -> a\n myAbs :: a -> a\n myNegate x = mySub (mySub x x) x\n myAbs x = if myLt x (mySub x x) then myNegate x else x\ninstance MyNum Int where\n mySub x y = x - y\n myLt x y = x < y\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Num default: myNegate 5 = -5"
|
||||||
|
(hk-deep-force (hk-run (str hk-mynum-source "main = myNegate 5\n")))
|
||||||
|
-5)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Num default: myAbs (myNegate 7) = 7"
|
||||||
|
(hk-deep-force (hk-run (str hk-mynum-source "main = myAbs (myNegate 7)\n")))
|
||||||
|
7)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Num default: myAbs 9 = 9"
|
||||||
|
(hk-deep-force (hk-run (str hk-mynum-source "main = myAbs 9\n")))
|
||||||
|
9)
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
@@ -12,14 +12,14 @@
|
|||||||
"deriving Show: constructor with arg"
|
"deriving Show: constructor with arg"
|
||||||
(hk-deep-force
|
(hk-deep-force
|
||||||
(hk-run "data Wrapper = Wrap Int deriving (Show)\nmain = show (Wrap 42)"))
|
(hk-run "data Wrapper = Wrap Int deriving (Show)\nmain = show (Wrap 42)"))
|
||||||
"(Wrap 42)")
|
"Wrap 42")
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"deriving Show: nested constructors"
|
"deriving Show: nested constructors"
|
||||||
(hk-deep-force
|
(hk-deep-force
|
||||||
(hk-run
|
(hk-run
|
||||||
"data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf Leaf)"))
|
"data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf Leaf)"))
|
||||||
"(Node 1 Leaf Leaf)")
|
"Node 1 Leaf Leaf")
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"deriving Show: second constructor"
|
"deriving Show: second constructor"
|
||||||
@@ -30,6 +30,31 @@
|
|||||||
|
|
||||||
;; ─── Eq ──────────────────────────────────────────────────────────────────────
|
;; ─── Eq ──────────────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"deriving Show: nested ADT wraps inner constructor in parens"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf (Node 2 Leaf Leaf))"))
|
||||||
|
"Node 1 Leaf (Node 2 Leaf Leaf)")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"deriving Show: Maybe Maybe wraps inner Just"
|
||||||
|
(hk-deep-force (hk-run "main = show (Just (Just 3))"))
|
||||||
|
"Just (Just 3)")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"deriving Show: negative argument wrapped in parens"
|
||||||
|
(hk-deep-force (hk-run "main = show (Just (negate 3))"))
|
||||||
|
"Just (-3)")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"deriving Show: list element does not need parens"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run "data Box = Box [Int] deriving (Show)\nmain = show (Box [1,2,3])"))
|
||||||
|
"Box [1,2,3]")
|
||||||
|
|
||||||
|
;; ─── combined Eq + Show ───────────────────────────────────────────────────────
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"deriving Eq: same constructor"
|
"deriving Eq: same constructor"
|
||||||
(hk-deep-force
|
(hk-deep-force
|
||||||
@@ -58,14 +83,12 @@
|
|||||||
"data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Blue)"))
|
"data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Blue)"))
|
||||||
"True")
|
"True")
|
||||||
|
|
||||||
;; ─── combined Eq + Show ───────────────────────────────────────────────────────
|
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"deriving Eq Show: combined in parens"
|
"deriving Eq Show: combined"
|
||||||
(hk-deep-force
|
(hk-deep-force
|
||||||
(hk-run
|
(hk-run
|
||||||
"data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 5)"))
|
"data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 5)"))
|
||||||
"(Circle 5)")
|
"Circle 5")
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"deriving Eq Show: eq on constructor with arg"
|
"deriving Eq Show: eq on constructor with arg"
|
||||||
|
|||||||
99
lib/haskell/tests/errors.sx
Normal file
99
lib/haskell/tests/errors.sx
Normal file
@@ -0,0 +1,99 @@
|
|||||||
|
;; errors.sx — Phase 9 error / undefined / partial-fn coverage via hk-test-error.
|
||||||
|
|
||||||
|
;; ── error builtin ────────────────────────────────────────────
|
||||||
|
(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))))
|
||||||
|
|
||||||
|
(hk-test-error
|
||||||
|
"error: raises with literal message"
|
||||||
|
(fn () (hk-deep-force (hk-run "main = error \"boom\"")))
|
||||||
|
"hk-error: boom")
|
||||||
|
|
||||||
|
(hk-test-error
|
||||||
|
"error: raises with computed message"
|
||||||
|
(fn () (hk-deep-force (hk-run "main = error (\"oops: \" ++ show 42)")))
|
||||||
|
"hk-error: oops: 42")
|
||||||
|
|
||||||
|
;; ── undefined ────────────────────────────────────────────────
|
||||||
|
(hk-test-error
|
||||||
|
"error: nested in if branch (only fires when forced)"
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(hk-deep-force (hk-run "main = if 1 == 1 then error \"taken\" else 0")))
|
||||||
|
"taken")
|
||||||
|
|
||||||
|
(hk-test-error
|
||||||
|
"undefined: raises Prelude.undefined"
|
||||||
|
(fn () (hk-deep-force (hk-run "main = undefined")))
|
||||||
|
"Prelude.undefined")
|
||||||
|
|
||||||
|
;; The non-strict path: undefined doesn't fire when not forced.
|
||||||
|
(hk-test-error
|
||||||
|
"undefined: forced via arithmetic"
|
||||||
|
(fn () (hk-deep-force (hk-run "main = undefined + 1")))
|
||||||
|
"Prelude.undefined")
|
||||||
|
|
||||||
|
;; ── partial functions ───────────────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"undefined: lazy, not forced when discarded"
|
||||||
|
(hk-deep-force (hk-run "main = let _ = undefined in 5"))
|
||||||
|
5)
|
||||||
|
|
||||||
|
(hk-test-error
|
||||||
|
"head []: raises Prelude.head: empty list"
|
||||||
|
(fn () (hk-deep-force (hk-run "main = head []")))
|
||||||
|
"Prelude.head: empty list")
|
||||||
|
|
||||||
|
(hk-test-error
|
||||||
|
"tail []: raises Prelude.tail: empty list"
|
||||||
|
(fn () (hk-deep-force (hk-run "main = tail []")))
|
||||||
|
"Prelude.tail: empty list")
|
||||||
|
|
||||||
|
;; head and tail still work on non-empty lists.
|
||||||
|
(hk-test-error
|
||||||
|
"fromJust Nothing: raises Maybe.fromJust: Nothing"
|
||||||
|
(fn () (hk-deep-force (hk-run "main = fromJust Nothing")))
|
||||||
|
"Maybe.fromJust: Nothing")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"head [42]: still works"
|
||||||
|
(hk-deep-force (hk-run "main = head [42]"))
|
||||||
|
42)
|
||||||
|
|
||||||
|
;; ── error in IO context ─────────────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"tail [1,2,3]: still works"
|
||||||
|
(hk-as-list (hk-deep-force (hk-run "main = tail [1,2,3]")))
|
||||||
|
(list 2 3))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-run-io: error in main lands in io-lines"
|
||||||
|
(let
|
||||||
|
((lines (hk-run-io "main = error \"caught here\"")))
|
||||||
|
(>= (index-of (str lines) "caught here") 0))
|
||||||
|
true)
|
||||||
|
|
||||||
|
;; ── hk-test-error helper itself ─────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"hk-run-io: putStrLn before error preserves earlier output"
|
||||||
|
(let
|
||||||
|
((lines (hk-run-io "main = do { putStrLn \"first\"; error \"died\"; putStrLn \"never\" }")))
|
||||||
|
(and
|
||||||
|
(>= (index-of (str lines) "first") 0)
|
||||||
|
(>= (index-of (str lines) "died") 0)))
|
||||||
|
true)
|
||||||
|
|
||||||
|
;; hk-as-list helper for converting a forced Haskell cons into an SX list.
|
||||||
|
(hk-test-error
|
||||||
|
"hk-test-error: matches partial substring inside wrapped exception"
|
||||||
|
(fn () (hk-deep-force (hk-run "main = error \"unique-marker-xyz\"")))
|
||||||
|
"unique-marker-xyz")
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
@@ -231,16 +231,82 @@
|
|||||||
1)
|
1)
|
||||||
|
|
||||||
;; ── Laziness: app args evaluate only when forced ──
|
;; ── Laziness: app args evaluate only when forced ──
|
||||||
|
(hk-test
|
||||||
|
"error builtin: raises with hk-error prefix"
|
||||||
|
(guard
|
||||||
|
(e (true (>= (index-of e "hk-error: boom") 0)))
|
||||||
|
(begin (hk-deep-force (hk-run "main = error \"boom\"")) false))
|
||||||
|
true)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"error builtin: raises with computed message"
|
||||||
|
(guard
|
||||||
|
(e (true (>= (index-of e "hk-error: oops: 42") 0)))
|
||||||
|
(begin
|
||||||
|
(hk-deep-force (hk-run "main = error (\"oops: \" ++ show 42)"))
|
||||||
|
false))
|
||||||
|
true)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"undefined: raises hk-error with Prelude.undefined message"
|
||||||
|
(guard
|
||||||
|
(e (true (>= (index-of e "hk-error: Prelude.undefined") 0)))
|
||||||
|
(begin (hk-deep-force (hk-run "main = undefined")) false))
|
||||||
|
true)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"undefined: lazy — only fires when forced"
|
||||||
|
(hk-deep-force (hk-run "main = if True then 42 else undefined"))
|
||||||
|
42)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"head []: raises Prelude.head: empty list"
|
||||||
|
(guard
|
||||||
|
(e (true (>= (index-of e "Prelude.head: empty list") 0)))
|
||||||
|
(begin (hk-deep-force (hk-run "main = head []")) false))
|
||||||
|
true)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"tail []: raises Prelude.tail: empty list"
|
||||||
|
(guard
|
||||||
|
(e (true (>= (index-of e "Prelude.tail: empty list") 0)))
|
||||||
|
(begin (hk-deep-force (hk-run "main = tail []")) false))
|
||||||
|
true)
|
||||||
|
|
||||||
|
;; ── not / id built-ins ──
|
||||||
|
(hk-test
|
||||||
|
"fromJust Nothing: raises Maybe.fromJust: Nothing"
|
||||||
|
(guard
|
||||||
|
(e (true (>= (index-of e "Maybe.fromJust: Nothing") 0)))
|
||||||
|
(begin (hk-deep-force (hk-run "main = fromJust Nothing")) false))
|
||||||
|
true)
|
||||||
|
(hk-test
|
||||||
|
"fromJust (Just 5) = 5"
|
||||||
|
(hk-deep-force (hk-run "main = fromJust (Just 5)"))
|
||||||
|
5)
|
||||||
|
(hk-test
|
||||||
|
"head [42] = 42 (still works for non-empty)"
|
||||||
|
(hk-deep-force (hk-run "main = head [42]"))
|
||||||
|
42)
|
||||||
|
|
||||||
|
(hk-test-error
|
||||||
|
"hk-test-error helper: catches matching error"
|
||||||
|
(fn () (hk-deep-force (hk-run "main = error \"boom\"")))
|
||||||
|
"hk-error: boom")
|
||||||
|
|
||||||
|
(hk-test-error
|
||||||
|
"hk-test-error helper: catches head [] error"
|
||||||
|
(fn () (hk-deep-force (hk-run "main = head []")))
|
||||||
|
"Prelude.head: empty list")
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"second arg never forced"
|
"second arg never forced"
|
||||||
(hk-eval-expr-source
|
(hk-eval-expr-source "(\\x y -> x) 1 (error \"never\")")
|
||||||
"(\\x y -> x) 1 (error \"never\")")
|
|
||||||
1)
|
1)
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"first arg never forced"
|
"first arg never forced"
|
||||||
(hk-eval-expr-source
|
(hk-eval-expr-source "(\\x y -> y) (error \"never\") 99")
|
||||||
"(\\x y -> y) (error \"never\") 99")
|
|
||||||
99)
|
99)
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
@@ -251,9 +317,7 @@
|
|||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"lazy: const drops its second argument"
|
"lazy: const drops its second argument"
|
||||||
(hk-prog-val
|
(hk-prog-val "const x y = x\nresult = const 5 (error \"boom\")" "result")
|
||||||
"const x y = x\nresult = const 5 (error \"boom\")"
|
|
||||||
"result")
|
|
||||||
5)
|
5)
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
@@ -270,9 +334,10 @@
|
|||||||
"result")
|
"result")
|
||||||
(list "True"))
|
(list "True"))
|
||||||
|
|
||||||
;; ── not / id built-ins ──
|
|
||||||
(hk-test "not True" (hk-eval-expr-source "not True") (list "False"))
|
(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 "not False" (hk-eval-expr-source "not False") (list "True"))
|
||||||
|
|
||||||
(hk-test "id" (hk-eval-expr-source "id 42") 42)
|
(hk-test "id" (hk-eval-expr-source "id 42") 42)
|
||||||
|
|
||||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
|
|||||||
105
lib/haskell/tests/exceptions.sx
Normal file
105
lib/haskell/tests/exceptions.sx
Normal file
@@ -0,0 +1,105 @@
|
|||||||
|
;; Phase 16 — Exception handling unit tests.
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"catch — success path returns the action result"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"main = catch (return 42) (\\(SomeException m) -> return 0)"))
|
||||||
|
(list "IO" 42))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"catch — error caught, handler receives message"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"main = catch (error \"boom\") (\\(SomeException m) -> return m)"))
|
||||||
|
(list "IO" "boom"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"try — success returns Right v"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run "main = try (return 42)"))
|
||||||
|
(list "IO" (list "Right" 42)))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"try — error returns Left (SomeException msg)"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run "main = try (error \"oops\")"))
|
||||||
|
(list "IO" (list "Left" (list "SomeException" "oops"))))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"handle — flip catch — caught error message"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"main = handle (\\(SomeException m) -> return m) (error \"hot\")"))
|
||||||
|
(list "IO" "hot"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"throwIO + catch — handler sees the SomeException"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"main = catch (throwIO (SomeException \"bang\")) (\\(SomeException m) -> return m)"))
|
||||||
|
(list "IO" "bang"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"throwIO + try — Left side"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"main = try (throwIO (SomeException \"x\"))"))
|
||||||
|
(list "IO" (list "Left" (list "SomeException" "x"))))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"evaluate — pure value returns IO v"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run "main = evaluate (1 + 2 + 3)"))
|
||||||
|
(list "IO" 6))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"evaluate — error surfaces as catchable exception"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"main = catch (evaluate (error \"deep\")) (\\(SomeException m) -> return m)"))
|
||||||
|
(list "IO" "deep"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"nested catch — inner handler runs first"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"main = catch (catch (error \"inner\") (\\(SomeException m) -> error (m ++ \"-rethrown\"))) (\\(SomeException m) -> return m)"))
|
||||||
|
(list "IO" "inner-rethrown"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"catch chain — handler can succeed inside IO"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"main = do { x <- catch (error \"e1\") (\\(SomeException m) -> return 100); return (x + 1) }"))
|
||||||
|
(list "IO" 101))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"try then bind on Right"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"branch (Right v) = return (v * 2)
|
||||||
|
branch (Left _) = return 0
|
||||||
|
main = do { r <- try (return 21); branch r }"))
|
||||||
|
(list "IO" 42))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"try then bind on Left"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"branch (Right _) = return \"ok\"
|
||||||
|
branch (Left (SomeException m)) = return m
|
||||||
|
main = do { r <- try (error \"failed\"); branch r }"))
|
||||||
|
(list "IO" "failed"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"catch — handler can use closed-over IORef"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef
|
||||||
|
main = do
|
||||||
|
r <- IORef.newIORef 0
|
||||||
|
catch (error \"x\") (\\(SomeException m) -> IORef.writeIORef r 7)
|
||||||
|
v <- IORef.readIORef r
|
||||||
|
return v"))
|
||||||
|
(list "IO" 7))
|
||||||
31
lib/haskell/tests/instance-where.sx
Normal file
31
lib/haskell/tests/instance-where.sx
Normal file
@@ -0,0 +1,31 @@
|
|||||||
|
;; instance-where.sx — Phase 13: where-clauses inside instance bodies.
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"instance method body with where-helper (Bool)"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"class Greet a where\n greet :: a -> String\ninstance Greet Bool where\n greet x = mkMsg x\n where mkMsg True = \"yes\"\n mkMsg False = \"no\"\nmain = greet True"))
|
||||||
|
"yes")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"instance method body with where-helper (False branch)"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"class Greet a where\n greet :: a -> String\ninstance Greet Bool where\n greet x = mkMsg x\n where mkMsg True = \"yes\"\n mkMsg False = \"no\"\nmain = greet False"))
|
||||||
|
"no")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"instance method body with where-binding referenced multiple times"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"class Twice a where\n twice :: a -> Int\ninstance Twice Int where\n twice x = h + h\n where h = x + 1\nmain = twice 5"))
|
||||||
|
12)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"instance method body with multi-binding where"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"class Calc a where\n calc :: a -> Int\ninstance Calc Int where\n calc x = a + b\n where a = x * 2\n b = x + 1\nmain = calc 3"))
|
||||||
|
10)
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
@@ -64,12 +64,11 @@
|
|||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"readFile error on missing file"
|
"readFile error on missing file"
|
||||||
(guard
|
(begin
|
||||||
(e (true (>= (index-of e "file not found") 0)))
|
(set! hk-vfs (dict))
|
||||||
(begin
|
(let
|
||||||
(set! hk-vfs (dict))
|
((lines (hk-run-io "main = readFile \"no.txt\" >>= putStrLn")))
|
||||||
(hk-run-io "main = readFile \"no.txt\" >>= putStrLn")
|
(>= (index-of (str lines) "file not found") 0)))
|
||||||
false))
|
|
||||||
true)
|
true)
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
|
|||||||
94
lib/haskell/tests/ioref.sx
Normal file
94
lib/haskell/tests/ioref.sx
Normal file
@@ -0,0 +1,94 @@
|
|||||||
|
;; Phase 15 — IORef unit tests.
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"newIORef + readIORef returns initial value"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 42; v <- IORef.readIORef r; return v }"))
|
||||||
|
(list "IO" 42))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"writeIORef updates the cell"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 0; IORef.writeIORef r 99; v <- IORef.readIORef r; return v }"))
|
||||||
|
(list "IO" 99))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"writeIORef returns IO ()"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 0; IORef.writeIORef r 1 }"))
|
||||||
|
(list "IO" (list "Tuple")))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"modifyIORef applies a function"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 5; IORef.modifyIORef r (\\x -> x * 2); v <- IORef.readIORef r; return v }"))
|
||||||
|
(list "IO" 10))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"modifyIORef' (strict) applies a function"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 7; IORef.modifyIORef' r (\\x -> x + 3); v <- IORef.readIORef r; return v }"))
|
||||||
|
(list "IO" 10))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"two reads return the same value"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 11; a <- IORef.readIORef r; b <- IORef.readIORef r; return (a + b) }"))
|
||||||
|
(list "IO" 22))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"shared ref across do-steps: write then read"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 1; IORef.writeIORef r 2; IORef.writeIORef r 3; v <- IORef.readIORef r; return v }"))
|
||||||
|
(list "IO" 3))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"two refs are independent"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef\nmain = do { r1 <- IORef.newIORef 1; r2 <- IORef.newIORef 2; IORef.writeIORef r1 10; a <- IORef.readIORef r1; b <- IORef.readIORef r2; return (a + b) }"))
|
||||||
|
(list "IO" 12))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"string-valued IORef"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef \"hi\"; IORef.writeIORef r \"bye\"; v <- IORef.readIORef r; return v }"))
|
||||||
|
(list "IO" "bye"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"list-valued IORef + cons"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef [1,2,3]; IORef.modifyIORef r (\\xs -> 0 : xs); v <- IORef.readIORef r; return v }"))
|
||||||
|
(list
|
||||||
|
"IO"
|
||||||
|
(list ":" 0 (list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"counter loop: increment N times"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef\nloop r 0 = return ()\nloop r n = do { IORef.modifyIORef r (\\x -> x + 1); loop r (n - 1) }\nmain = do { r <- IORef.newIORef 0; loop r 10; v <- IORef.readIORef r; return v }"))
|
||||||
|
(list "IO" 10))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"modifyIORef' inside a loop"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef\ngo r 0 = return ()\ngo r n = do { IORef.modifyIORef' r (\\x -> x + n); go r (n - 1) }\nmain = do { r <- IORef.newIORef 0; go r 5; v <- IORef.readIORef r; return v }"))
|
||||||
|
(list "IO" 15))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"newIORef inside a function passed via parameter"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.IORef as IORef\nbump r = IORef.modifyIORef r (\\x -> x + 100)\nmain = do { r <- IORef.newIORef 1; bump r; v <- IORef.readIORef r; return v }"))
|
||||||
|
(list "IO" 101))
|
||||||
196
lib/haskell/tests/map.sx
Normal file
196
lib/haskell/tests/map.sx
Normal file
@@ -0,0 +1,196 @@
|
|||||||
|
;; map.sx — Phase 11 Data.Map unit tests.
|
||||||
|
;;
|
||||||
|
;; Tests both the SX-level `hk-map-*` helpers and the Haskell-level
|
||||||
|
;; `Map.*` aliases bound by the import handler.
|
||||||
|
|
||||||
|
(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))))
|
||||||
|
|
||||||
|
;; ── SX-level (direct hk-map-*) ───────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"hk-map-empty: size 0, null true"
|
||||||
|
(list (hk-map-size hk-map-empty) (hk-map-null hk-map-empty))
|
||||||
|
(list 0 true))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-singleton: lookup hit"
|
||||||
|
(let
|
||||||
|
((m (hk-map-singleton 5 "five")))
|
||||||
|
(list (hk-map-size m) (hk-map-lookup 5 m)))
|
||||||
|
(list 1 (list "Just" "five")))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-insert: lookup hit on inserted"
|
||||||
|
(let ((m (hk-map-insert 1 "a" hk-map-empty))) (hk-map-lookup 1 m))
|
||||||
|
(list "Just" "a"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-lookup: miss returns Nothing"
|
||||||
|
(hk-map-lookup 99 (hk-map-singleton 1 "a"))
|
||||||
|
(list "Nothing"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-insert: overwrites existing key"
|
||||||
|
(let
|
||||||
|
((m (hk-map-insert 1 "second" (hk-map-insert 1 "first" hk-map-empty))))
|
||||||
|
(hk-map-lookup 1 m))
|
||||||
|
(list "Just" "second"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-delete: removes key"
|
||||||
|
(let
|
||||||
|
((m (hk-map-insert 2 "b" (hk-map-insert 1 "a" hk-map-empty))))
|
||||||
|
(let
|
||||||
|
((m2 (hk-map-delete 1 m)))
|
||||||
|
(list (hk-map-size m2) (hk-map-lookup 1 m2) (hk-map-lookup 2 m2))))
|
||||||
|
(list 1 (list "Nothing") (list "Just" "b")))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-delete: missing key is no-op"
|
||||||
|
(let ((m (hk-map-singleton 1 "a"))) (hk-map-size (hk-map-delete 99 m)))
|
||||||
|
1)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-member: true on existing"
|
||||||
|
(hk-map-member 1 (hk-map-singleton 1 "a"))
|
||||||
|
true)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-member: false on missing"
|
||||||
|
(hk-map-member 99 (hk-map-singleton 1 "a"))
|
||||||
|
false)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-from-list: builds map; keys sorted"
|
||||||
|
(hk-map-keys
|
||||||
|
(hk-map-from-list
|
||||||
|
(list (list 3 "c") (list 1 "a") (list 5 "e") (list 2 "b"))))
|
||||||
|
(list 1 2 3 5))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-from-list: duplicates — last wins"
|
||||||
|
(hk-map-lookup
|
||||||
|
1
|
||||||
|
(hk-map-from-list (list (list 1 "first") (list 1 "second"))))
|
||||||
|
(list "Just" "second"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-to-asc-list: ordered traversal"
|
||||||
|
(hk-map-to-asc-list
|
||||||
|
(hk-map-from-list (list (list 3 "c") (list 1 "a") (list 2 "b"))))
|
||||||
|
(list (list 1 "a") (list 2 "b") (list 3 "c")))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-elems: in key order"
|
||||||
|
(hk-map-elems
|
||||||
|
(hk-map-from-list (list (list 3 30) (list 1 10) (list 2 20))))
|
||||||
|
(list 10 20 30))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-union-with: combines duplicates"
|
||||||
|
(hk-map-to-asc-list
|
||||||
|
(hk-map-union-with
|
||||||
|
(fn (a b) (str a "+" b))
|
||||||
|
(hk-map-from-list (list (list 1 "a") (list 2 "b")))
|
||||||
|
(hk-map-from-list (list (list 2 "B") (list 3 "c")))))
|
||||||
|
(list (list 1 "a") (list 2 "b+B") (list 3 "c")))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-intersection-with: keeps shared keys"
|
||||||
|
(hk-map-to-asc-list
|
||||||
|
(hk-map-intersection-with
|
||||||
|
+
|
||||||
|
(hk-map-from-list (list (list 1 10) (list 2 20)))
|
||||||
|
(hk-map-from-list (list (list 2 200) (list 3 30)))))
|
||||||
|
(list (list 2 220)))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-difference: drops m2 keys"
|
||||||
|
(hk-map-keys
|
||||||
|
(hk-map-difference
|
||||||
|
(hk-map-from-list (list (list 1 "a") (list 2 "b") (list 3 "c")))
|
||||||
|
(hk-map-from-list (list (list 2 "x")))))
|
||||||
|
(list 1 3))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-foldl-with-key: in-order accumulate"
|
||||||
|
(hk-map-foldl-with-key
|
||||||
|
(fn (acc k v) (str acc k v))
|
||||||
|
""
|
||||||
|
(hk-map-from-list (list (list 3 "c") (list 1 "a") (list 2 "b"))))
|
||||||
|
"1a2b3c")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-map-with-key: transforms values"
|
||||||
|
(hk-map-to-asc-list
|
||||||
|
(hk-map-map-with-key
|
||||||
|
(fn (k v) (* k v))
|
||||||
|
(hk-map-from-list (list (list 2 10) (list 3 100)))))
|
||||||
|
(list (list 2 20) (list 3 300)))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-filter-with-key: keeps matches"
|
||||||
|
(hk-map-keys
|
||||||
|
(hk-map-filter-with-key
|
||||||
|
(fn (k v) (> k 1))
|
||||||
|
(hk-map-from-list (list (list 1 "a") (list 2 "b") (list 3 "c")))))
|
||||||
|
(list 2 3))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-adjust: applies f to existing"
|
||||||
|
(hk-map-lookup
|
||||||
|
1
|
||||||
|
(hk-map-adjust (fn (v) (* v 10)) 1 (hk-map-singleton 1 5)))
|
||||||
|
(list "Just" 50))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-insert-with: combines on existing"
|
||||||
|
(hk-map-lookup 1 (hk-map-insert-with + 1 5 (hk-map-singleton 1 10)))
|
||||||
|
(list "Just" 15))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-map-alter: Nothing → delete"
|
||||||
|
(hk-map-size
|
||||||
|
(hk-map-alter
|
||||||
|
(fn (mv) (list "Nothing"))
|
||||||
|
1
|
||||||
|
(hk-map-from-list (list (list 1 "a") (list 2 "b")))))
|
||||||
|
1)
|
||||||
|
|
||||||
|
;; ── Haskell-level (Map.*) via import wiring ─────────────────
|
||||||
|
(hk-test
|
||||||
|
"Map.size after Map.insert chain"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.Map as Map\nmain = Map.size (Map.insert 2 \"b\" (Map.insert 1 \"a\" Map.empty))"))
|
||||||
|
2)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Map.lookup hit"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.Map as Map\nmain = Map.lookup 1 (Map.insert 1 \"a\" Map.empty)"))
|
||||||
|
(list "Just" "a"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Map.lookup miss"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.Map as Map\nmain = Map.lookup 99 (Map.insert 1 \"a\" Map.empty)"))
|
||||||
|
(list "Nothing"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Map.member true"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.Map as Map\nmain = Map.member 5 (Map.insert 5 \"x\" Map.empty)"))
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
180
lib/haskell/tests/numerics.sx
Normal file
180
lib/haskell/tests/numerics.sx
Normal file
@@ -0,0 +1,180 @@
|
|||||||
|
;; numerics.sx — Phase 10 numeric tower verification.
|
||||||
|
;;
|
||||||
|
;; Practical integer-precision limit in Haskell-on-SX:
|
||||||
|
;; • Raw SX `(* a b)` stays exact up to ±2^62 (≈ 4.6e18, OCaml int63).
|
||||||
|
;; • BUT the Haskell tokenizer/parser parses an integer literal as a float
|
||||||
|
;; once it exceeds 2^53 (≈ 9.007e15). Once any operand is a float, the
|
||||||
|
;; binop result is a float (and decimal-precision is lost past 2^53).
|
||||||
|
;; • Therefore: programs that stay below ~9e15 are exact; larger literals
|
||||||
|
;; or accumulated products silently become floats. `factorial 18` is the
|
||||||
|
;; last factorial that stays exact (6.4e15); `factorial 19` already floats.
|
||||||
|
;;
|
||||||
|
;; In Haskell terms, `Int` and `Integer` both currently map to SX number, so
|
||||||
|
;; we don't yet support arbitrary-precision Integer. Documented; unbounded
|
||||||
|
;; Integer is out of scope for Phase 10 — see Phase 11+ if it becomes needed.
|
||||||
|
|
||||||
|
(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))))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"factorial 10 = 3628800 (small, exact)"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 10"))
|
||||||
|
3628800)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"factorial 15 = 1307674368000 (mid-range, exact)"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 15"))
|
||||||
|
1307674368000)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"factorial 18 = 6402373705728000 (last exact factorial)"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 18"))
|
||||||
|
6402373705728000)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"1000000 * 1000000 = 10^12 (exact)"
|
||||||
|
(hk-deep-force (hk-run "main = 1000000 * 1000000"))
|
||||||
|
1000000000000)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"1000000000 * 1000000000 = 10^18 (exact, at boundary)"
|
||||||
|
(hk-deep-force (hk-run "main = 1000000000 * 1000000000"))
|
||||||
|
1e+18)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"2^62 boundary: pow accumulates exactly"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run "pow b 0 = 1\npow b n = b * pow b (n - 1)\nmain = pow 2 62"))
|
||||||
|
4.6116860184273879e+18)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show factorial 12 = 479001600 (whole, fits in 32-bit)"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = show (fact 12)"))
|
||||||
|
"479001600")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"negate large positive — preserves magnitude"
|
||||||
|
(hk-deep-force (hk-run "main = negate 1000000000000000000"))
|
||||||
|
-1e+18)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"abs negative large — preserves magnitude"
|
||||||
|
(hk-deep-force (hk-run "main = abs (negate 1000000000000000000)"))
|
||||||
|
1e+18)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"div on large ints"
|
||||||
|
(hk-deep-force (hk-run "main = div 1000000000000000000 1000000000"))
|
||||||
|
1000000000)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"fromIntegral 42 = 42 (identity in our runtime)"
|
||||||
|
(hk-deep-force (hk-run "main = fromIntegral 42"))
|
||||||
|
42)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"fromIntegral preserves negative"
|
||||||
|
(hk-deep-force (hk-run "main = fromIntegral (negate 7)"))
|
||||||
|
-7)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"fromIntegral round-trips through arithmetic"
|
||||||
|
(hk-deep-force (hk-run "main = fromIntegral 5 + fromIntegral 3"))
|
||||||
|
8)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"fromIntegral in a program (mixing with map)"
|
||||||
|
(hk-as-list (hk-deep-force (hk-run "main = map fromIntegral [1,2,3]")))
|
||||||
|
(list 1 2 3))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"toInteger 100 = 100 (identity)"
|
||||||
|
(hk-deep-force (hk-run "main = toInteger 100"))
|
||||||
|
100)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"fromInteger 7 = 7 (identity)"
|
||||||
|
(hk-deep-force (hk-run "main = fromInteger 7"))
|
||||||
|
7)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"toInteger / fromInteger round-trip"
|
||||||
|
(hk-deep-force (hk-run "main = fromInteger (toInteger 42)"))
|
||||||
|
42)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"toInteger preserves negative"
|
||||||
|
(hk-deep-force (hk-run "main = toInteger (negate 13)"))
|
||||||
|
-13)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show 3.14 = 3.14"
|
||||||
|
(hk-deep-force (hk-run "main = show 3.14"))
|
||||||
|
"3.14")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show 1.0e10 — whole-valued float renders as decimal (int/float ambiguity)"
|
||||||
|
(hk-deep-force (hk-run "main = show 1.0e10"))
|
||||||
|
"10000000000")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show 0.001 uses scientific form (sub-0.1)"
|
||||||
|
(hk-deep-force (hk-run "main = show 0.001"))
|
||||||
|
"1.0e-3")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show negative float"
|
||||||
|
(hk-deep-force (hk-run "main = show (negate 3.14)"))
|
||||||
|
"-3.14")
|
||||||
|
|
||||||
|
(hk-test "sqrt 16 = 4" (hk-deep-force (hk-run "main = sqrt 16")) 4)
|
||||||
|
|
||||||
|
(hk-test "floor 3.7 = 3" (hk-deep-force (hk-run "main = floor 3.7")) 3)
|
||||||
|
|
||||||
|
(hk-test "ceiling 3.2 = 4" (hk-deep-force (hk-run "main = ceiling 3.2")) 4)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"ceiling on whole = self"
|
||||||
|
(hk-deep-force (hk-run "main = ceiling 4"))
|
||||||
|
4)
|
||||||
|
|
||||||
|
(hk-test "round 2.6 = 3" (hk-deep-force (hk-run "main = round 2.6")) 3)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"truncate -3.7 = -3"
|
||||||
|
(hk-deep-force (hk-run "main = truncate (negate 3.7)"))
|
||||||
|
-3)
|
||||||
|
|
||||||
|
(hk-test "recip 4.0 = 0.25" (hk-deep-force (hk-run "main = recip 4.0")) 0.25)
|
||||||
|
|
||||||
|
(hk-test "1.0 / 4.0 = 0.25" (hk-deep-force (hk-run "main = 1.0 / 4.0")) 0.25)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"fromRational 0.5 = 0.5 (identity)"
|
||||||
|
(hk-deep-force (hk-run "main = fromRational 0.5"))
|
||||||
|
0.5)
|
||||||
|
|
||||||
|
(hk-test "pi ≈ 3.14159" (hk-deep-force (hk-run "main = pi")) 3.14159)
|
||||||
|
|
||||||
|
(hk-test "exp 0 = 1" (hk-deep-force (hk-run "main = exp 0")) 1)
|
||||||
|
|
||||||
|
(hk-test "sin 0 = 0" (hk-deep-force (hk-run "main = sin 0")) 0)
|
||||||
|
|
||||||
|
(hk-test "cos 0 = 1" (hk-deep-force (hk-run "main = cos 0")) 1)
|
||||||
|
|
||||||
|
(hk-test "2 ** 10 = 1024" (hk-deep-force (hk-run "main = 2 ** 10")) 1024)
|
||||||
|
|
||||||
|
(hk-test "log (exp 5) ≈ 5" (hk-deep-force (hk-run "main = log (exp 5)")) 5)
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
81
lib/haskell/tests/program-accumulate.sx
Normal file
81
lib/haskell/tests/program-accumulate.sx
Normal file
@@ -0,0 +1,81 @@
|
|||||||
|
;; accumulate.hs — accumulate results into an IORef [Int] (Phase 15 conformance).
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-accumulate-source
|
||||||
|
"import qualified Data.IORef as IORef\n\npush :: IORef [Int] -> Int -> IO ()\npush r x = IORef.modifyIORef r (\\xs -> x : xs)\n\npushAll :: IORef [Int] -> [Int] -> IO ()\npushAll r [] = return ()\npushAll r (x:xs) = do\n push r x\n pushAll r xs\n\nreadReversed :: IORef [Int] -> IO [Int]\nreadReversed r = do\n xs <- IORef.readIORef r\n return (reverse xs)\n\ndoubleEach :: IORef [Int] -> [Int] -> IO ()\ndoubleEach r [] = return ()\ndoubleEach r (x:xs) = do\n push r (x * 2)\n doubleEach r xs\n\nsumIntoRef :: IORef Int -> [Int] -> IO ()\nsumIntoRef r [] = return ()\nsumIntoRef r (x:xs) = do\n IORef.modifyIORef r (\\acc -> acc + x)\n sumIntoRef r xs\n\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"accumulate.hs — push three then read length"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-accumulate-source
|
||||||
|
"main = do { r <- IORef.newIORef []; push r 1; push r 2; push r 3; xs <- IORef.readIORef r; return (length xs) }")))
|
||||||
|
(list "IO" 3))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"accumulate.hs — pushAll preserves reverse order"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-accumulate-source
|
||||||
|
"main = do { r <- IORef.newIORef []; pushAll r [1,2,3,4]; xs <- IORef.readIORef r; return xs }")))
|
||||||
|
(list
|
||||||
|
"IO"
|
||||||
|
(list ":" 4 (list ":" 3 (list ":" 2 (list ":" 1 (list "[]")))))))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"accumulate.hs — readReversed gives original order"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-accumulate-source
|
||||||
|
"main = do { r <- IORef.newIORef []; pushAll r [10,20,30]; readReversed r }")))
|
||||||
|
(list "IO" (list ":" 10 (list ":" 20 (list ":" 30 (list "[]"))))))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"accumulate.hs — doubleEach maps then accumulates"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-accumulate-source
|
||||||
|
"main = do { r <- IORef.newIORef []; doubleEach r [1,2,3]; readReversed r }")))
|
||||||
|
(list "IO" (list ":" 2 (list ":" 4 (list ":" 6 (list "[]"))))))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"accumulate.hs — sum into Int IORef"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-accumulate-source
|
||||||
|
"main = do { r <- IORef.newIORef 0; sumIntoRef r [1,2,3,4,5]; v <- IORef.readIORef r; return v }")))
|
||||||
|
(list "IO" 15))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"accumulate.hs — empty list leaves ref untouched"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-accumulate-source
|
||||||
|
"main = do { r <- IORef.newIORef [99]; pushAll r []; xs <- IORef.readIORef r; return xs }")))
|
||||||
|
(list "IO" (list ":" 99 (list "[]"))))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"accumulate.hs — pushAll then sumIntoRef on the same input"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-accumulate-source
|
||||||
|
"main = do { r <- IORef.newIORef 0; sumIntoRef r [10,20,30,40]; v <- IORef.readIORef r; return v }")))
|
||||||
|
(list "IO" 100))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"accumulate.hs — accumulate results from a recursive helper"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-accumulate-source
|
||||||
|
"squaresUpTo r 0 = return ()\nsquaresUpTo r n = do { push r (n * n); squaresUpTo r (n - 1) }\nmain = do { r <- IORef.newIORef []; squaresUpTo r 4; readReversed r }")))
|
||||||
|
(list
|
||||||
|
"IO"
|
||||||
|
(list ":" 16 (list ":" 9 (list ":" 4 (list ":" 1 (list "[]")))))))
|
||||||
80
lib/haskell/tests/program-caesar.sx
Normal file
80
lib/haskell/tests/program-caesar.sx
Normal file
@@ -0,0 +1,80 @@
|
|||||||
|
;; caesar.hs — Caesar cipher.
|
||||||
|
;; Source: https://rosettacode.org/wiki/Caesar_cipher#Haskell (adapted).
|
||||||
|
;;
|
||||||
|
;; Exercises chr, ord, isUpper, isLower, mod, string pattern matching
|
||||||
|
;; (x:xs) over a String (which is now a [Char] string view), and map
|
||||||
|
;; from the Phase 7 string=[Char] foundation.
|
||||||
|
|
||||||
|
(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-caesar-source
|
||||||
|
"shift n c = if isUpper c\n then chr (mod ((ord c) - 65 + n) 26 + 65)\n else if isLower c\n then chr (mod ((ord c) - 97 + n) 26 + 97)\n else chr c\n\ncaesarRec n [] = []\ncaesarRec n (x:xs) = shift n x : caesarRec n xs\n\ncaesarMap n s = map (shift n) s\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"caesar.hs — caesarRec 3 \"ABC\" = DEF"
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val (str hk-caesar-source "r = caesarRec 3 \"ABC\"\n") "r"))
|
||||||
|
(list "D" "E" "F"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"caesar.hs — caesarRec 13 \"Hello\" = Uryyb"
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val (str hk-caesar-source "r = caesarRec 13 \"Hello\"\n") "r"))
|
||||||
|
(list "U" "r" "y" "y" "b"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"caesar.hs — caesarRec 1 \"AZ\" wraps to BA"
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val (str hk-caesar-source "r = caesarRec 1 \"AZ\"\n") "r"))
|
||||||
|
(list "B" "A"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"caesar.hs — caesarRec 0 \"World\" identity"
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val (str hk-caesar-source "r = caesarRec 0 \"World\"\n") "r"))
|
||||||
|
(list "W" "o" "r" "l" "d"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"caesar.hs — caesarRec preserves punctuation"
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val (str hk-caesar-source "r = caesarRec 3 \"Hi!\"\n") "r"))
|
||||||
|
(list "K" "l" "!"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"caesar.hs — caesarMap 3 \"abc\" via map"
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val (str hk-caesar-source "r = caesarMap 3 \"abc\"\n") "r"))
|
||||||
|
(list "d" "e" "f"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"caesar.hs — caesarMap 13 round-trips with caesarMap 13"
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val
|
||||||
|
(str
|
||||||
|
hk-caesar-source
|
||||||
|
"r = caesarMap 13 (foldr (\\c acc -> c : acc) [] (caesarMap 13 \"Hello\"))\n")
|
||||||
|
"r"))
|
||||||
|
(list "H" "e" "l" "l" "o"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"caesar.hs — caesarRec 25 \"AB\" = ZA"
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val (str hk-caesar-source "r = caesarRec 25 \"AB\"\n") "r"))
|
||||||
|
(list "Z" "A"))
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
63
lib/haskell/tests/program-config.sx
Normal file
63
lib/haskell/tests/program-config.sx
Normal file
@@ -0,0 +1,63 @@
|
|||||||
|
;; config.hs — multi-field config record; partial update; defaultConfig
|
||||||
|
;; constant.
|
||||||
|
;;
|
||||||
|
;; Exercises Phase 14: 4-field record, defaultConfig as a CAF, partial
|
||||||
|
;; updates that change one or two fields, accessors over derived configs.
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-config-source
|
||||||
|
"data Config = Config { host :: String, port :: Int, retries :: Int, debug :: Bool } deriving (Show)\n\ndefaultConfig = Config { host = \"localhost\", port = 8080, retries = 3, debug = False }\n\ndevConfig = defaultConfig { debug = True }\nremoteConfig = defaultConfig { host = \"api.example.com\", port = 443 }\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"config.hs — defaultConfig host"
|
||||||
|
(hk-deep-force (hk-run (str hk-config-source "main = host defaultConfig")))
|
||||||
|
"localhost")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"config.hs — defaultConfig port"
|
||||||
|
(hk-deep-force (hk-run (str hk-config-source "main = port defaultConfig")))
|
||||||
|
8080)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"config.hs — defaultConfig retries"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-config-source "main = retries defaultConfig")))
|
||||||
|
3)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"config.hs — devConfig flips debug"
|
||||||
|
(hk-deep-force (hk-run (str hk-config-source "main = debug devConfig")))
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"config.hs — devConfig preserves host"
|
||||||
|
(hk-deep-force (hk-run (str hk-config-source "main = host devConfig")))
|
||||||
|
"localhost")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"config.hs — devConfig preserves port"
|
||||||
|
(hk-deep-force (hk-run (str hk-config-source "main = port devConfig")))
|
||||||
|
8080)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"config.hs — remoteConfig new host"
|
||||||
|
(hk-deep-force (hk-run (str hk-config-source "main = host remoteConfig")))
|
||||||
|
"api.example.com")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"config.hs — remoteConfig new port"
|
||||||
|
(hk-deep-force (hk-run (str hk-config-source "main = port remoteConfig")))
|
||||||
|
443)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"config.hs — remoteConfig preserves retries"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-config-source "main = retries remoteConfig")))
|
||||||
|
3)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"config.hs — remoteConfig preserves debug"
|
||||||
|
(hk-deep-force (hk-run (str hk-config-source "main = debug remoteConfig")))
|
||||||
|
(list "False"))
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
66
lib/haskell/tests/program-counter.sx
Normal file
66
lib/haskell/tests/program-counter.sx
Normal file
@@ -0,0 +1,66 @@
|
|||||||
|
;; counter.hs — IORef-backed mutable counter (Phase 15 conformance).
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-counter-source
|
||||||
|
"import qualified Data.IORef as IORef\n\ncount :: IORef Int -> Int -> IO ()\ncount r 0 = return ()\ncount r n = do\n IORef.modifyIORef r (\\x -> x + 1)\n count r (n - 1)\n\ncountBy :: IORef Int -> Int -> Int -> IO ()\ncountBy r step 0 = return ()\ncountBy r step n = do\n IORef.modifyIORef r (\\x -> x + step)\n countBy r step (n - 1)\n\nnewCounter :: Int -> IO (IORef Int)\nnewCounter v = IORef.newIORef v\n\nbumpAndRead :: IORef Int -> IO Int\nbumpAndRead r = do\n IORef.modifyIORef r (\\x -> x + 1)\n IORef.readIORef r\n\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"counter.hs — start at 0, count 5 ⇒ 5"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-counter-source
|
||||||
|
"main = do { r <- newCounter 0; count r 5; v <- IORef.readIORef r; return v }")))
|
||||||
|
(list "IO" 5))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"counter.hs — start at 100, count 10 ⇒ 110"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-counter-source
|
||||||
|
"main = do { r <- newCounter 100; count r 10; v <- IORef.readIORef r; return v }")))
|
||||||
|
(list "IO" 110))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"counter.hs — countBy step 5, n 4 ⇒ 20"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-counter-source
|
||||||
|
"main = do { r <- newCounter 0; countBy r 5 4; v <- IORef.readIORef r; return v }")))
|
||||||
|
(list "IO" 20))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"counter.hs — bumpAndRead returns updated value"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-counter-source "main = do { r <- newCounter 41; bumpAndRead r }")))
|
||||||
|
(list "IO" 42))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"counter.hs — count then countBy compose"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-counter-source
|
||||||
|
"main = do { r <- newCounter 0; count r 3; countBy r 10 2; v <- IORef.readIORef r; return v }")))
|
||||||
|
(list "IO" 23))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"counter.hs — two independent counters"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-counter-source
|
||||||
|
"main = do { a <- newCounter 0; b <- newCounter 0; count a 7; countBy b 100 2; va <- IORef.readIORef a; vb <- IORef.readIORef b; return (va + vb) }")))
|
||||||
|
(list "IO" 207))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"counter.hs — modifyIORef' (strict) variant"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-counter-source
|
||||||
|
"tick r 0 = return ()\ntick r n = do { IORef.modifyIORef' r (\\x -> x + 1); tick r (n - 1) }\nmain = do { r <- newCounter 0; tick r 50; v <- IORef.readIORef r; return v }")))
|
||||||
|
(list "IO" 50))
|
||||||
46
lib/haskell/tests/program-mapgraph.sx
Normal file
46
lib/haskell/tests/program-mapgraph.sx
Normal file
@@ -0,0 +1,46 @@
|
|||||||
|
;; mapgraph.hs — adjacency-list using Data.Map (BFS-style traversal).
|
||||||
|
;;
|
||||||
|
;; Exercises Phase 11: `import qualified Data.Map as Map`, `Map.empty`,
|
||||||
|
;; `Map.insert`, `Map.lookup`, `Map.findWithDefault`. Adjacency lists are
|
||||||
|
;; stored as `Map Int [Int]`; `neighbors` does a default-empty lookup.
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-mapgraph-source
|
||||||
|
"import qualified Data.Map as Map\n\nemptyG = Map.empty\n\naddEdge u v g = Map.insertWith add u [v] g\n where add new old = new ++ old\n\nbuild = addEdge 1 2 (addEdge 1 3 (addEdge 2 4 (addEdge 3 4 (addEdge 4 5 emptyG))))\n\nneighbors n g = Map.findWithDefault [] n g\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"mapgraph.hs — neighbors of 1"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-mapgraph-source "main = neighbors 1 build\n")))
|
||||||
|
(list ":" 2 (list ":" 3 (list "[]"))))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"mapgraph.hs — neighbors of 4"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-mapgraph-source "main = neighbors 4 build\n")))
|
||||||
|
(list ":" 5 (list "[]")))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"mapgraph.hs — neighbors of 5 (leaf, no entry) defaults to []"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-mapgraph-source "main = neighbors 5 build\n")))
|
||||||
|
(list "[]"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"mapgraph.hs — neighbors of 99 (absent) defaults to []"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-mapgraph-source "main = neighbors 99 build\n")))
|
||||||
|
(list "[]"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"mapgraph.hs — Map.member 1"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-mapgraph-source "main = Map.member 1 build\n")))
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"mapgraph.hs — Map.size = 4 source nodes"
|
||||||
|
(hk-deep-force (hk-run (str hk-mapgraph-source "main = Map.size build\n")))
|
||||||
|
4)
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
49
lib/haskell/tests/program-newton.sx
Normal file
49
lib/haskell/tests/program-newton.sx
Normal file
@@ -0,0 +1,49 @@
|
|||||||
|
;; newton.hs — Newton's method for square root.
|
||||||
|
;; Source: classic numerical analysis exercise.
|
||||||
|
;;
|
||||||
|
;; Exercises Phase 10: `Float`, `abs`, `/`, iteration via `until`.
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-prog-val
|
||||||
|
(fn
|
||||||
|
(src name)
|
||||||
|
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-newton-source
|
||||||
|
"improve x guess = (guess + x / guess) / 2\n\ngoodEnough x guess = abs (guess * guess - x) < 0.0001\n\nnewtonSqrt x = newtonHelp x 1.0\n\nnewtonHelp x guess = if goodEnough x guess\n then guess\n else newtonHelp x (improve x guess)\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"newton.hs — newtonSqrt 4 ≈ 2"
|
||||||
|
(hk-prog-val
|
||||||
|
(str hk-newton-source "r = abs (newtonSqrt 4.0 - 2.0) < 0.001\n")
|
||||||
|
"r")
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"newton.hs — newtonSqrt 9 ≈ 3"
|
||||||
|
(hk-prog-val
|
||||||
|
(str hk-newton-source "r = abs (newtonSqrt 9.0 - 3.0) < 0.001\n")
|
||||||
|
"r")
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"newton.hs — newtonSqrt 2 ≈ 1.41421"
|
||||||
|
(hk-prog-val
|
||||||
|
(str hk-newton-source "r = abs (newtonSqrt 2.0 - 1.41421) < 0.001\n")
|
||||||
|
"r")
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"newton.hs — improve converges (one step)"
|
||||||
|
(hk-prog-val (str hk-newton-source "r = improve 4.0 1.0\n") "r")
|
||||||
|
2.5)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"newton.hs — newtonSqrt 100 ≈ 10"
|
||||||
|
(hk-prog-val
|
||||||
|
(str hk-newton-source "r = abs (newtonSqrt 100.0 - 10.0) < 0.001\n")
|
||||||
|
"r")
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
58
lib/haskell/tests/program-partial.sx
Normal file
58
lib/haskell/tests/program-partial.sx
Normal file
@@ -0,0 +1,58 @@
|
|||||||
|
;; partial.hs — exercises Phase 9 partial functions caught at the top level.
|
||||||
|
;;
|
||||||
|
;; Each program calls a partial function on bad input; hk-run-io catches the
|
||||||
|
;; raise and appends the error message to io-lines so tests can inspect.
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"partial.hs — main = print (head [])"
|
||||||
|
(let
|
||||||
|
((lines (hk-run-io "main = print (head [])")))
|
||||||
|
(>= (index-of (str lines) "Prelude.head: empty list") 0))
|
||||||
|
true)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"partial.hs — main = print (tail [])"
|
||||||
|
(let
|
||||||
|
((lines (hk-run-io "main = print (tail [])")))
|
||||||
|
(>= (index-of (str lines) "Prelude.tail: empty list") 0))
|
||||||
|
true)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"partial.hs — main = print (fromJust Nothing)"
|
||||||
|
(let
|
||||||
|
((lines (hk-run-io "main = print (fromJust Nothing)")))
|
||||||
|
(>= (index-of (str lines) "Maybe.fromJust: Nothing") 0))
|
||||||
|
true)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"partial.hs — putStrLn before error preserves prior output"
|
||||||
|
(let
|
||||||
|
((lines (hk-run-io "main = do { putStrLn \"step 1\"; putStrLn (show (head [])); putStrLn \"never\" }")))
|
||||||
|
(and
|
||||||
|
(>= (index-of (str lines) "step 1") 0)
|
||||||
|
(>= (index-of (str lines) "Prelude.head: empty list") 0)
|
||||||
|
(= (index-of (str lines) "never") -1)))
|
||||||
|
true)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"partial.hs — undefined as IO action"
|
||||||
|
(let
|
||||||
|
((lines (hk-run-io "main = print undefined")))
|
||||||
|
(>= (index-of (str lines) "Prelude.undefined") 0))
|
||||||
|
true)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"partial.hs — catches error from a user-thrown error"
|
||||||
|
(let
|
||||||
|
((lines (hk-run-io "main = error \"boom from main\"")))
|
||||||
|
(>= (index-of (str lines) "boom from main") 0))
|
||||||
|
true)
|
||||||
|
|
||||||
|
;; Negative case: when no error is raised, io-lines doesn't contain
|
||||||
|
;; "Prelude" prefixes from our error path.
|
||||||
|
(hk-test
|
||||||
|
"partial.hs — happy path: head [42] succeeds, no error in output"
|
||||||
|
(hk-run-io "main = print (head [42])")
|
||||||
|
(list "42"))
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
51
lib/haskell/tests/program-person.sx
Normal file
51
lib/haskell/tests/program-person.sx
Normal file
@@ -0,0 +1,51 @@
|
|||||||
|
;; person.hs — record type with accessors, update, deriving Show.
|
||||||
|
;;
|
||||||
|
;; Exercises Phase 14: data with record syntax, accessor functions,
|
||||||
|
;; record creation, record update, deriving Show on a record.
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-person-source
|
||||||
|
"data Person = Person { name :: String, age :: Int } deriving (Show)\n\nalice = Person { name = \"alice\", age = 30 }\nbob = Person { name = \"bob\", age = 25 }\n\nbirthday p = p { age = age p + 1 }\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"person.hs — alice's name"
|
||||||
|
(hk-deep-force (hk-run (str hk-person-source "main = name alice")))
|
||||||
|
"alice")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"person.hs — alice's age"
|
||||||
|
(hk-deep-force (hk-run (str hk-person-source "main = age alice")))
|
||||||
|
30)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"person.hs — birthday adds one year"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-person-source "main = age (birthday alice)")))
|
||||||
|
31)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"person.hs — birthday preserves name"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-person-source "main = name (birthday alice)")))
|
||||||
|
"alice")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"person.hs — show alice"
|
||||||
|
(hk-deep-force (hk-run (str hk-person-source "main = show alice")))
|
||||||
|
"Person \"alice\" 30")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"person.hs — bob has different name"
|
||||||
|
(hk-deep-force (hk-run (str hk-person-source "main = name bob")))
|
||||||
|
"bob")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"person.hs — pattern match in function"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-person-source
|
||||||
|
"greet (Person { name = n }) = \"Hi, \" ++ n\nmain = greet alice")))
|
||||||
|
"Hi, alice")
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
83
lib/haskell/tests/program-runlength-str.sx
Normal file
83
lib/haskell/tests/program-runlength-str.sx
Normal file
@@ -0,0 +1,83 @@
|
|||||||
|
;; runlength-str.hs — run-length encoding on a String.
|
||||||
|
;; Source: https://rosettacode.org/wiki/Run-length_encoding#Haskell (adapted).
|
||||||
|
;;
|
||||||
|
;; Exercises String pattern matching `(x:xs)`, `span` over a string view,
|
||||||
|
;; tuple construction `(Int, Char)`, character equality, and tuple-in-cons
|
||||||
|
;; patterns `((n, c) : rest)` — all enabled by Phase 7 string=[Char].
|
||||||
|
|
||||||
|
(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-rle-source
|
||||||
|
"encodeRL [] = []\nencodeRL (x:xs) = let (same, rest) = span eqX xs\n eqX y = y == x\n in (1 + length same, x) : encodeRL rest\n\nreplicateRL 0 _ = []\nreplicateRL n c = c : replicateRL (n - 1) c\n\ndecodeRL [] = []\ndecodeRL ((n, c) : rest) = replicateRL n c ++ decodeRL rest\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"rle.hs — encodeRL [] = []"
|
||||||
|
(hk-as-list (hk-prog-val (str hk-rle-source "r = encodeRL \"\"\n") "r"))
|
||||||
|
(list))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"rle.hs — length (encodeRL \"aabbbcc\") = 3"
|
||||||
|
(hk-prog-val (str hk-rle-source "r = length (encodeRL \"aabbbcc\")\n") "r")
|
||||||
|
3)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"rle.hs — map fst (encodeRL \"aabbbcc\") = [2,3,2]"
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val (str hk-rle-source "r = map fst (encodeRL \"aabbbcc\")\n") "r"))
|
||||||
|
(list 2 3 2))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"rle.hs — map snd (encodeRL \"aabbbcc\") = [97,98,99]"
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val (str hk-rle-source "r = map snd (encodeRL \"aabbbcc\")\n") "r"))
|
||||||
|
(list 97 98 99))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"rle.hs — counts of encodeRL \"aabbbccddddee\" = [2,3,2,4,2]"
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val
|
||||||
|
(str hk-rle-source "r = map fst (encodeRL \"aabbbccddddee\")\n")
|
||||||
|
"r"))
|
||||||
|
(list 2 3 2 4 2))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"rle.hs — chars of encodeRL \"aabbbccddddee\" = [97,98,99,100,101]"
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val
|
||||||
|
(str hk-rle-source "r = map snd (encodeRL \"aabbbccddddee\")\n")
|
||||||
|
"r"))
|
||||||
|
(list 97 98 99 100 101))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"rle.hs — singleton encodeRL \"x\""
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val (str hk-rle-source "r = map fst (encodeRL \"x\")\n") "r"))
|
||||||
|
(list 1))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"rle.hs — decodeRL round-trip preserves \"aabbbcc\""
|
||||||
|
(hk-as-list
|
||||||
|
(hk-prog-val (str hk-rle-source "r = decodeRL (encodeRL \"aabbbcc\")\n") "r"))
|
||||||
|
(list 97 97 98 98 98 99 99))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"rle.hs — replicateRL 4 65 = [65,65,65,65]"
|
||||||
|
(hk-as-list (hk-prog-val (str hk-rle-source "r = replicateRL 4 65\n") "r"))
|
||||||
|
(list 65 65 65 65))
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
80
lib/haskell/tests/program-safediv.sx
Normal file
80
lib/haskell/tests/program-safediv.sx
Normal file
@@ -0,0 +1,80 @@
|
|||||||
|
;; safediv.hs — safe division using catch (Phase 16 conformance).
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-safediv-source
|
||||||
|
"safeDiv :: Int -> Int -> IO Int
|
||||||
|
safeDiv _ 0 = throwIO (SomeException \"division by zero\")
|
||||||
|
safeDiv x y = return (x `div` y)
|
||||||
|
|
||||||
|
guarded :: Int -> Int -> IO Int
|
||||||
|
guarded x y = catch (safeDiv x y) (\\(SomeException _) -> return 0)
|
||||||
|
|
||||||
|
reason :: Int -> Int -> IO String
|
||||||
|
reason x y = catch (safeDiv x y `seq` return \"ok\")
|
||||||
|
(\\(SomeException m) -> return m)
|
||||||
|
|
||||||
|
bothBranches :: Int -> Int -> IO Int
|
||||||
|
bothBranches x y = do
|
||||||
|
v <- catch (safeDiv x y) (\\(SomeException _) -> return (-1))
|
||||||
|
return (v + 100)
|
||||||
|
|
||||||
|
")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"safediv.hs — divide by non-zero"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-safediv-source "main = guarded 10 2")))
|
||||||
|
(list "IO" 5))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"safediv.hs — divide by zero returns 0"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-safediv-source "main = guarded 10 0")))
|
||||||
|
(list "IO" 0))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"safediv.hs — divide by zero — reason captured"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-safediv-source "main = catch (safeDiv 1 0) (\\(SomeException m) -> return 0) >> reason 1 0")))
|
||||||
|
(list "IO" "division by zero"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"safediv.hs — bothBranches success path"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-safediv-source "main = bothBranches 8 2")))
|
||||||
|
(list "IO" 104))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"safediv.hs — bothBranches failure path"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-safediv-source "main = bothBranches 8 0")))
|
||||||
|
(list "IO" 99))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"safediv.hs — chained safeDiv with catch"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-safediv-source
|
||||||
|
"main = do { a <- guarded 20 4; b <- guarded 7 0; return (a + b) }")))
|
||||||
|
(list "IO" 5))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"safediv.hs — try then bind through Either"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-safediv-source
|
||||||
|
"main = do { r <- try (safeDiv 1 0); case r of { Right v -> return v; Left (SomeException m) -> return 999 } }")))
|
||||||
|
(list "IO" 999))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"safediv.hs — handle (flip catch)"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-safediv-source
|
||||||
|
"main = handle (\\(SomeException _) -> return 0) (safeDiv 5 0)")))
|
||||||
|
(list "IO" 0))
|
||||||
61
lib/haskell/tests/program-setops.sx
Normal file
61
lib/haskell/tests/program-setops.sx
Normal file
@@ -0,0 +1,61 @@
|
|||||||
|
;; setops.hs — set union/intersection/difference on integer sets.
|
||||||
|
;;
|
||||||
|
;; Exercises Phase 12: `import qualified Data.Set as Set`, all three
|
||||||
|
;; combining operations + isSubsetOf.
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-setops-source
|
||||||
|
"import qualified Data.Set as Set\n\ns1 = Set.insert 1 (Set.insert 2 (Set.insert 3 Set.empty))\ns2 = Set.insert 3 (Set.insert 4 (Set.insert 5 Set.empty))\ns3 = Set.insert 1 (Set.insert 2 Set.empty)\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"setops.hs — union size = 5"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-setops-source "main = Set.size (Set.union s1 s2)\n")))
|
||||||
|
5)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"setops.hs — intersection size = 1"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-setops-source "main = Set.size (Set.intersection s1 s2)\n")))
|
||||||
|
1)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"setops.hs — intersection contains 3"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-setops-source "main = Set.member 3 (Set.intersection s1 s2)\n")))
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"setops.hs — difference s1 s2 size = 2"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-setops-source "main = Set.size (Set.difference s1 s2)\n")))
|
||||||
|
2)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"setops.hs — difference doesn't contain shared key"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-setops-source "main = Set.member 3 (Set.difference s1 s2)\n")))
|
||||||
|
(list "False"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"setops.hs — s3 is subset of s1"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-setops-source "main = Set.isSubsetOf s3 s1\n")))
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"setops.hs — s1 not subset of s3"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-setops-source "main = Set.isSubsetOf s1 s3\n")))
|
||||||
|
(list "False"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"setops.hs — empty set is subset of anything"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-setops-source "main = Set.isSubsetOf Set.empty s1\n")))
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
40
lib/haskell/tests/program-shapes.sx
Normal file
40
lib/haskell/tests/program-shapes.sx
Normal file
@@ -0,0 +1,40 @@
|
|||||||
|
;; shapes.hs — class Area with a default perimeter, two instances
|
||||||
|
;; using where-local helpers.
|
||||||
|
;;
|
||||||
|
;; Exercises Phase 13: class default method (perimeter), instance
|
||||||
|
;; methods that use `where`-bindings.
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-shapes-source
|
||||||
|
"class Shape a where\n area :: a -> Int\n perimeter :: a -> Int\n perimeter x = quadrilateral x\n where quadrilateral y = 2 * (sideA y + sideB y)\n sideA z = 1\n sideB z = 1\n\ndata Square = Square Int\ndata Rect = Rect Int Int\n\ninstance Shape Square where\n area (Square s) = s * s\n perimeter (Square s) = 4 * s\n\ninstance Shape Rect where\n area (Rect w h) = w * h\n perimeter (Rect w h) = peri\n where peri = 2 * (w + h)\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"shapes.hs — area of Square 5 = 25"
|
||||||
|
(hk-deep-force (hk-run (str hk-shapes-source "main = area (Square 5)\n")))
|
||||||
|
25)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"shapes.hs — perimeter of Square 5 = 20"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-shapes-source "main = perimeter (Square 5)\n")))
|
||||||
|
20)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"shapes.hs — area of Rect 3 4 = 12"
|
||||||
|
(hk-deep-force (hk-run (str hk-shapes-source "main = area (Rect 3 4)\n")))
|
||||||
|
12)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"shapes.hs — perimeter of Rect 3 4 = 14 (via where-bound)"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-shapes-source "main = perimeter (Rect 3 4)\n")))
|
||||||
|
14)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"shapes.hs — Square sums area + perimeter"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-shapes-source "main = area (Square 4) + perimeter (Square 4)\n")))
|
||||||
|
32)
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
45
lib/haskell/tests/program-showadt.sx
Normal file
45
lib/haskell/tests/program-showadt.sx
Normal file
@@ -0,0 +1,45 @@
|
|||||||
|
;; showadt.hs — `deriving (Show)` on a multi-constructor recursive ADT.
|
||||||
|
;; Source: classic exposition example, e.g. Real World Haskell ch.6.
|
||||||
|
;;
|
||||||
|
;; Exercises Phase 8: `deriving (Show)` on an ADT whose constructors recurse
|
||||||
|
;; into themselves; precedence-based paren wrapping for nested arguments;
|
||||||
|
;; `print` from the prelude (which is `putStrLn (show x)`).
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-showadt-source
|
||||||
|
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\n\nmain = do\n print (Lit 3)\n print (Add (Lit 1) (Lit 2))\n print (Mul (Lit 3) (Add (Lit 4) (Lit 5)))\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showadt.hs — main prints three lines"
|
||||||
|
(hk-run-io hk-showadt-source)
|
||||||
|
(list "Lit 3" "Add (Lit 1) (Lit 2)" "Mul (Lit 3) (Add (Lit 4) (Lit 5))"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showadt.hs — show Lit 3"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Lit 3)"))
|
||||||
|
"Lit 3")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showadt.hs — show Add wraps both args"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Add (Lit 1) (Lit 2))"))
|
||||||
|
"Add (Lit 1) (Lit 2)")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showadt.hs — fully nested Mul of Adds"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Mul (Add (Lit 1) (Lit 2)) (Add (Lit 3) (Lit 4)))"))
|
||||||
|
"Mul (Add (Lit 1) (Lit 2)) (Add (Lit 3) (Lit 4))")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showadt.hs — Lit with negative literal wraps int in parens"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Lit (negate 7))"))
|
||||||
|
"Lit (-7)")
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
36
lib/haskell/tests/program-showio.sx
Normal file
36
lib/haskell/tests/program-showio.sx
Normal file
@@ -0,0 +1,36 @@
|
|||||||
|
;; showio.hs — `print` on various types inside a `do` block.
|
||||||
|
;;
|
||||||
|
;; Exercises Phase 8 `print x = putStrLn (show x)` and the IO monad's
|
||||||
|
;; statement sequencing. Each `print` produces one io-line.
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-showio-source
|
||||||
|
"main = do\n print 42\n print True\n print False\n print [1,2,3]\n print (1, 2)\n print (Just 5)\n print Nothing\n print \"hello\"\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showio.hs — main produces 8 lines, all show-formatted"
|
||||||
|
(hk-run-io hk-showio-source)
|
||||||
|
(list "42" "True" "False" "[1,2,3]" "(1,2)" "Just 5" "Nothing" "\"hello\""))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showio.hs — print Int alone"
|
||||||
|
(hk-run-io "main = print 42")
|
||||||
|
(list "42"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showio.hs — print list of Maybe"
|
||||||
|
(hk-run-io "main = print [Just 1, Nothing, Just 3]")
|
||||||
|
(list "[Just 1,Nothing,Just 3]"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showio.hs — print nested tuple"
|
||||||
|
(hk-run-io "main = print ((1, 2), (3, 4))")
|
||||||
|
(list "((1,2),(3,4))"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showio.hs — print derived ADT inside do"
|
||||||
|
(hk-run-io
|
||||||
|
"data Color = Red | Green | Blue deriving (Show)\nmain = do { print Red; print Green; print Blue }")
|
||||||
|
(list "Red" "Green" "Blue"))
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
45
lib/haskell/tests/program-statistics.sx
Normal file
45
lib/haskell/tests/program-statistics.sx
Normal file
@@ -0,0 +1,45 @@
|
|||||||
|
;; statistics.hs — mean, variance, std-dev on a [Double].
|
||||||
|
;; Source: classic textbook example.
|
||||||
|
;;
|
||||||
|
;; Exercises Phase 10: `fromIntegral`, `/`, `sqrt`, list ops on `[Double]`.
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-prog-val
|
||||||
|
(fn
|
||||||
|
(src name)
|
||||||
|
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-stats-source
|
||||||
|
"mean xs = sum xs / fromIntegral (length xs)\n\nvariance xs = let m = mean xs\n sqDiff x = (x - m) * (x - m)\n in sum (map sqDiff xs) / fromIntegral (length xs)\n\nstdDev xs = sqrt (variance xs)\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"statistics.hs — mean [1,2,3,4,5] = 3"
|
||||||
|
(hk-prog-val (str hk-stats-source "r = mean [1.0,2.0,3.0,4.0,5.0]\n") "r")
|
||||||
|
3)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"statistics.hs — mean [10,20,30] = 20"
|
||||||
|
(hk-prog-val (str hk-stats-source "r = mean [10.0,20.0,30.0]\n") "r")
|
||||||
|
20)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"statistics.hs — variance [2,4,4,4,5,5,7,9] = 4"
|
||||||
|
(hk-prog-val
|
||||||
|
(str hk-stats-source "r = variance [2.0,4.0,4.0,4.0,5.0,5.0,7.0,9.0]\n")
|
||||||
|
"r")
|
||||||
|
4)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"statistics.hs — stdDev [2,4,4,4,5,5,7,9] = 2"
|
||||||
|
(hk-prog-val
|
||||||
|
(str hk-stats-source "r = stdDev [2.0,4.0,4.0,4.0,5.0,5.0,7.0,9.0]\n")
|
||||||
|
"r")
|
||||||
|
2)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"statistics.hs — variance of constant list = 0"
|
||||||
|
(hk-prog-val (str hk-stats-source "r = variance [5.0,5.0,5.0,5.0]\n") "r")
|
||||||
|
0)
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
95
lib/haskell/tests/program-trycatch.sx
Normal file
95
lib/haskell/tests/program-trycatch.sx
Normal file
@@ -0,0 +1,95 @@
|
|||||||
|
;; trycatch.hs — try pattern: branch on Left/Right (Phase 16 conformance).
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-trycatch-source
|
||||||
|
"parseInt :: String -> IO Int
|
||||||
|
parseInt \"zero\" = return 0
|
||||||
|
parseInt \"one\" = return 1
|
||||||
|
parseInt \"two\" = return 2
|
||||||
|
parseInt s = throwIO (SomeException (\"unknown: \" ++ s))
|
||||||
|
|
||||||
|
describe :: Either SomeException Int -> String
|
||||||
|
describe (Right v) = \"got \" ++ show v
|
||||||
|
describe (Left (SomeException m)) = \"err: \" ++ m
|
||||||
|
|
||||||
|
trial :: String -> IO String
|
||||||
|
trial s = do
|
||||||
|
r <- try (parseInt s)
|
||||||
|
return (describe r)
|
||||||
|
|
||||||
|
run3 :: String -> String -> String -> IO [String]
|
||||||
|
run3 a b c = do
|
||||||
|
ra <- trial a
|
||||||
|
rb <- trial b
|
||||||
|
rc <- trial c
|
||||||
|
return [ra, rb, rc]
|
||||||
|
|
||||||
|
")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"trycatch.hs — Right branch"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-trycatch-source "main = trial \"one\"")))
|
||||||
|
(list "IO" "got 1"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"trycatch.hs — Left branch with message"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-trycatch-source "main = trial \"banana\"")))
|
||||||
|
(list "IO" "err: unknown: banana"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"trycatch.hs — chain over three inputs, all good"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-trycatch-source "main = run3 \"zero\" \"one\" \"two\"")))
|
||||||
|
(list "IO"
|
||||||
|
(list ":" "got 0"
|
||||||
|
(list ":" "got 1"
|
||||||
|
(list ":" "got 2"
|
||||||
|
(list "[]"))))))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"trycatch.hs — chain over three inputs, mixed"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-trycatch-source "main = run3 \"zero\" \"qux\" \"two\"")))
|
||||||
|
(list "IO"
|
||||||
|
(list ":" "got 0"
|
||||||
|
(list ":" "err: unknown: qux"
|
||||||
|
(list ":" "got 2"
|
||||||
|
(list "[]"))))))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"trycatch.hs — Left from throwIO carries message"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-trycatch-source
|
||||||
|
"main = do { r <- try (throwIO (SomeException \"explicit\")); return (describe r) }")))
|
||||||
|
(list "IO" "err: explicit"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"trycatch.hs — Right preserves the int"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-trycatch-source
|
||||||
|
"main = do { r <- try (return 42); return (describe r) }")))
|
||||||
|
(list "IO" "got 42"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"trycatch.hs — pattern-bind on Right inside do"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-trycatch-source
|
||||||
|
"main = do { Right v <- try (parseInt \"two\"); return (v + 100) }")))
|
||||||
|
(list "IO" 102))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"trycatch.hs — handle alias on parseInt failure"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-trycatch-source
|
||||||
|
"main = handle (\\(SomeException m) -> return (\"caught: \" ++ m)) (parseInt \"nope\" >>= (\\v -> return (show v)))")))
|
||||||
|
(list "IO" "caught: unknown: nope"))
|
||||||
35
lib/haskell/tests/program-uniquewords.sx
Normal file
35
lib/haskell/tests/program-uniquewords.sx
Normal file
@@ -0,0 +1,35 @@
|
|||||||
|
;; uniquewords.hs — count unique words using Data.Set.
|
||||||
|
;;
|
||||||
|
;; Exercises Phase 12: `import qualified Data.Set as Set`, `Set.empty`,
|
||||||
|
;; `Set.insert`, `Set.size`, `foldl`.
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-uniquewords-source
|
||||||
|
"import qualified Data.Set as Set\n\naddWord s w = Set.insert w s\n\nuniqueWords ws = foldl addWord Set.empty ws\n\nresult = uniqueWords [\"the\", \"cat\", \"the\", \"dog\", \"the\", \"cat\"]\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"uniquewords.hs — unique count = 3"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-uniquewords-source "main = Set.size result\n")))
|
||||||
|
3)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"uniquewords.hs — \"the\" present"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-uniquewords-source "main = Set.member \"the\" result\n")))
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"uniquewords.hs — \"missing\" absent"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-uniquewords-source "main = Set.member \"missing\" result\n")))
|
||||||
|
(list "False"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"uniquewords.hs — empty list yields empty set"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.Set as Set\nmain = Set.size (foldl (\\s w -> Set.insert w s) Set.empty [])"))
|
||||||
|
0)
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
54
lib/haskell/tests/program-wordfreq.sx
Normal file
54
lib/haskell/tests/program-wordfreq.sx
Normal file
@@ -0,0 +1,54 @@
|
|||||||
|
;; wordfreq.hs — word-frequency histogram using Data.Map.
|
||||||
|
;; Source: Rosetta Code "Word frequency" (Haskell entry, simplified).
|
||||||
|
;;
|
||||||
|
;; Exercises Phase 11: `import qualified Data.Map as Map`, `Map.empty`,
|
||||||
|
;; `Map.insertWith`, `Map.lookup`, `Map.findWithDefault`, `foldl`.
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-wordfreq-source
|
||||||
|
"import qualified Data.Map as Map\n\ncountWord m w = Map.insertWith (+) w 1 m\n\nwordFreq xs = foldl countWord Map.empty xs\n\nresult = wordFreq [\"the\", \"cat\", \"the\", \"dog\", \"the\", \"cat\"]\n")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"wordfreq.hs — \"the\" counted 3 times"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-wordfreq-source "main = Map.lookup \"the\" result\n")))
|
||||||
|
(list "Just" 3))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"wordfreq.hs — \"cat\" counted 2 times"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-wordfreq-source "main = Map.lookup \"cat\" result\n")))
|
||||||
|
(list "Just" 2))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"wordfreq.hs — \"dog\" counted 1 time"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-wordfreq-source "main = Map.lookup \"dog\" result\n")))
|
||||||
|
(list "Just" 1))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"wordfreq.hs — \"missing\" not present"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-wordfreq-source "main = Map.lookup \"missing\" result\n")))
|
||||||
|
(list "Nothing"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"wordfreq.hs — Map.size = 3 unique words"
|
||||||
|
(hk-deep-force (hk-run (str hk-wordfreq-source "main = Map.size result\n")))
|
||||||
|
3)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"wordfreq.hs — findWithDefault for missing returns 0"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-wordfreq-source "main = Map.findWithDefault 0 \"absent\" result\n")))
|
||||||
|
0)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"wordfreq.hs — findWithDefault for present returns count"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-wordfreq-source "main = Map.findWithDefault 0 \"the\" result\n")))
|
||||||
|
3)
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
127
lib/haskell/tests/records.sx
Normal file
127
lib/haskell/tests/records.sx
Normal file
@@ -0,0 +1,127 @@
|
|||||||
|
;; records.sx — Phase 14 record syntax tests.
|
||||||
|
|
||||||
|
(define
|
||||||
|
hk-person-source
|
||||||
|
"data Person = Person { name :: String, age :: Int }\n")
|
||||||
|
|
||||||
|
(define hk-pt-source "data Pt = Pt { x :: Int, y :: Int }\n")
|
||||||
|
|
||||||
|
;; ── Creation ────────────────────────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"creation: Person { name = \"a\", age = 1 } via accessor name"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-person-source
|
||||||
|
"main = name (Person { name = \"alice\", age = 30 })")))
|
||||||
|
"alice")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"creation: source order doesn't matter (age first)"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-person-source "main = name (Person { age = 99, name = \"bob\" })")))
|
||||||
|
"bob")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"creation: age accessor returns the right field"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str hk-person-source "main = age (Person { age = 99, name = \"bob\" })")))
|
||||||
|
99)
|
||||||
|
|
||||||
|
;; ── Accessors ──────────────────────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"accessor: x of Pt"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-pt-source "main = x (Pt { x = 7, y = 99 })")))
|
||||||
|
7)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"accessor: y of Pt"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run (str hk-pt-source "main = y (Pt { x = 7, y = 99 })")))
|
||||||
|
99)
|
||||||
|
|
||||||
|
;; ── Update — single field ──────────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"update one field: age changes"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-person-source
|
||||||
|
"alice = Person { name = \"alice\", age = 30 }\nmain = age (alice { age = 31 })")))
|
||||||
|
31)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"update one field: name preserved"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-person-source
|
||||||
|
"alice = Person { name = \"alice\", age = 30 }\nmain = name (alice { age = 31 })")))
|
||||||
|
"alice")
|
||||||
|
|
||||||
|
;; ── Update — two fields ────────────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"update two fields: both changed"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-person-source
|
||||||
|
"alice = Person { name = \"alice\", age = 30 }\nbob = alice { name = \"bob\", age = 50 }\nmain = age bob")))
|
||||||
|
50)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"update two fields: name takes new value"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-person-source
|
||||||
|
"alice = Person { name = \"alice\", age = 30 }\nbob = alice { name = \"bob\", age = 50 }\nmain = name bob")))
|
||||||
|
"bob")
|
||||||
|
|
||||||
|
;; ── Record patterns ────────────────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"case-alt record pattern: Pt { x = a }"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-pt-source
|
||||||
|
"getX p = case p of Pt { x = a } -> a\nmain = getX (Pt { x = 7, y = 99 })")))
|
||||||
|
7)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"case-alt record pattern: multi-field bind"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-pt-source
|
||||||
|
"sumPt p = case p of Pt { x = a, y = b } -> a + b\nmain = sumPt (Pt { x = 3, y = 4 })")))
|
||||||
|
7)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"fun-LHS record pattern"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
(str
|
||||||
|
hk-person-source
|
||||||
|
"getName (Person { name = n }) = n\nmain = getName (Person { name = \"alice\", age = 30 })")))
|
||||||
|
"alice")
|
||||||
|
|
||||||
|
;; ── deriving Show on a record ───────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"deriving Show on a record produces positional output"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"data Person = Person { name :: String, age :: Int } deriving (Show)\nmain = show (Person { name = \"alice\", age = 30 })"))
|
||||||
|
"Person \"alice\" 30")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"deriving Show on Pt"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"data Pt = Pt { x :: Int, y :: Int } deriving (Show)\nmain = show (Pt { x = 3, y = 4 })"))
|
||||||
|
"Pt 3 4")
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
119
lib/haskell/tests/set.sx
Normal file
119
lib/haskell/tests/set.sx
Normal file
@@ -0,0 +1,119 @@
|
|||||||
|
;; set.sx — Phase 12 Data.Set unit tests.
|
||||||
|
|
||||||
|
;; ── SX-level (direct hk-set-*) ───────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"hk-set-empty: size 0 + null"
|
||||||
|
(list (hk-set-size hk-set-empty) (hk-set-null hk-set-empty))
|
||||||
|
(list 0 true))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-set-singleton: member yes"
|
||||||
|
(let
|
||||||
|
((s (hk-set-singleton 5)))
|
||||||
|
(list (hk-set-size s) (hk-set-member 5 s) (hk-set-member 99 s)))
|
||||||
|
(list 1 true false))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-set-insert: idempotent"
|
||||||
|
(let
|
||||||
|
((s (hk-set-insert 1 (hk-set-insert 1 hk-set-empty))))
|
||||||
|
(hk-set-size s))
|
||||||
|
1)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-set-from-list: dedupes"
|
||||||
|
(hk-set-to-asc-list (hk-set-from-list (list 3 1 4 1 5 9 2 6)))
|
||||||
|
(list 1 2 3 4 5 6 9))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-set-delete: removes"
|
||||||
|
(let
|
||||||
|
((s (hk-set-from-list (list 1 2 3))))
|
||||||
|
(hk-set-to-asc-list (hk-set-delete 2 s)))
|
||||||
|
(list 1 3))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-set-union"
|
||||||
|
(hk-set-to-asc-list
|
||||||
|
(hk-set-union
|
||||||
|
(hk-set-from-list (list 1 2 3))
|
||||||
|
(hk-set-from-list (list 3 4 5))))
|
||||||
|
(list 1 2 3 4 5))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-set-intersection"
|
||||||
|
(hk-set-to-asc-list
|
||||||
|
(hk-set-intersection
|
||||||
|
(hk-set-from-list (list 1 2 3 4))
|
||||||
|
(hk-set-from-list (list 3 4 5 6))))
|
||||||
|
(list 3 4))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-set-difference"
|
||||||
|
(hk-set-to-asc-list
|
||||||
|
(hk-set-difference
|
||||||
|
(hk-set-from-list (list 1 2 3 4))
|
||||||
|
(hk-set-from-list (list 3 4 5))))
|
||||||
|
(list 1 2))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-set-is-subset-of: yes"
|
||||||
|
(hk-set-is-subset-of
|
||||||
|
(hk-set-from-list (list 2 3))
|
||||||
|
(hk-set-from-list (list 1 2 3 4)))
|
||||||
|
true)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-set-is-subset-of: no"
|
||||||
|
(hk-set-is-subset-of
|
||||||
|
(hk-set-from-list (list 5 6))
|
||||||
|
(hk-set-from-list (list 1 2 3 4)))
|
||||||
|
false)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-set-filter"
|
||||||
|
(hk-set-to-asc-list
|
||||||
|
(hk-set-filter (fn (k) (> k 2)) (hk-set-from-list (list 1 2 3 4 5))))
|
||||||
|
(list 3 4 5))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-set-map"
|
||||||
|
(hk-set-to-asc-list
|
||||||
|
(hk-set-map (fn (k) (* k 10)) (hk-set-from-list (list 1 2 3))))
|
||||||
|
(list 10 20 30))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-set-foldr: sum"
|
||||||
|
(hk-set-foldr + 0 (hk-set-from-list (list 1 2 3 4 5)))
|
||||||
|
15)
|
||||||
|
|
||||||
|
;; ── Haskell-level (Set.* via import wiring) ──────────────────
|
||||||
|
(hk-test
|
||||||
|
"Set.size after Set.insert chain"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.Set as Set\nmain = Set.size (Set.insert 3 (Set.insert 1 (Set.insert 2 Set.empty)))"))
|
||||||
|
3)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Set.member true"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.Set as Set\nmain = Set.member 5 (Set.insert 5 Set.empty)"))
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Set.union via Haskell"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import Data.Set\nmain = Set.size (Set.union (Set.insert 1 Set.empty) (Set.insert 2 Set.empty))"))
|
||||||
|
2)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"Set.isSubsetOf via Haskell"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"import qualified Data.Set as S\nmain = S.isSubsetOf (S.insert 1 S.empty) (S.insert 2 (S.insert 1 S.empty))"))
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
140
lib/haskell/tests/show.sx
Normal file
140
lib/haskell/tests/show.sx
Normal file
@@ -0,0 +1,140 @@
|
|||||||
|
;; show.sx — tests for the Show / Read class plumbing.
|
||||||
|
;;
|
||||||
|
;; Covers Phase 8:
|
||||||
|
;; - showsPrec / showParen / shows / showString stubs
|
||||||
|
;; - Read class stubs (reads / readsPrec / read)
|
||||||
|
;; - direct show coverage (Int, Bool, String, list, tuple, Maybe, ADT, ...)
|
||||||
|
|
||||||
|
;; ── ShowS / showsPrec / showParen stubs ──────────────────────
|
||||||
|
(hk-test
|
||||||
|
"shows: prepends show output"
|
||||||
|
(hk-deep-force (hk-run "main = shows 5 \"abc\""))
|
||||||
|
"5abc")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"shows: works on True"
|
||||||
|
(hk-deep-force (hk-run "main = shows True \"x\""))
|
||||||
|
"Truex")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showString: prepends literal"
|
||||||
|
(hk-deep-force (hk-run "main = showString \"hello\" \" world\""))
|
||||||
|
"hello world")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showParen True: wraps inner output in parens"
|
||||||
|
(hk-deep-force (hk-run "main = showParen True (showString \"inside\") \"\""))
|
||||||
|
"(inside)")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showParen False: passes through unchanged"
|
||||||
|
(hk-deep-force (hk-run "main = showParen False (showString \"inside\") \"\""))
|
||||||
|
"inside")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showsPrec: prepends show output regardless of prec"
|
||||||
|
(hk-deep-force (hk-run "main = showsPrec 11 42 \"end\""))
|
||||||
|
"42end")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"showParen + manual composition: build (Just 3)"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"buildJust3 s = showString \"Just \" (shows 3 s)\nmain = showParen True buildJust3 \"\""))
|
||||||
|
"(Just 3)")
|
||||||
|
|
||||||
|
;; ── Read stubs ───────────────────────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"reads: stub returns empty list (null-check)"
|
||||||
|
(hk-deep-force (hk-run "main = show (null (reads \"42\"))"))
|
||||||
|
"True")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"readsPrec: stub returns empty list"
|
||||||
|
(hk-deep-force (hk-run "main = show (null (readsPrec 0 \"True\"))"))
|
||||||
|
"True")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"reads: type-checks in expression context (length)"
|
||||||
|
(hk-deep-force (hk-run "main = show (length (reads \"abc\"))"))
|
||||||
|
"0")
|
||||||
|
|
||||||
|
;; ── Direct `show` audit coverage ─────────────────────────────
|
||||||
|
(hk-test "show Int" (hk-deep-force (hk-run "main = show 42")) "42")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show negative Int"
|
||||||
|
(hk-deep-force (hk-run "main = show (negate 5)"))
|
||||||
|
"-5")
|
||||||
|
|
||||||
|
(hk-test "show Bool True" (hk-deep-force (hk-run "main = show True")) "True")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show Bool False"
|
||||||
|
(hk-deep-force (hk-run "main = show False"))
|
||||||
|
"False")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show String quotes the value"
|
||||||
|
(hk-deep-force (hk-run "main = show \"hello\""))
|
||||||
|
"\"hello\"")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show list of Int"
|
||||||
|
(hk-deep-force (hk-run "main = show [1,2,3]"))
|
||||||
|
"[1,2,3]")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show empty list"
|
||||||
|
(hk-deep-force (hk-run "main = show (drop 5 [1,2,3])"))
|
||||||
|
"[]")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show pair tuple"
|
||||||
|
(hk-deep-force (hk-run "main = show (1, True)"))
|
||||||
|
"(1,True)")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show triple tuple"
|
||||||
|
(hk-deep-force (hk-run "main = show (1, 2, 3)"))
|
||||||
|
"(1,2,3)")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show Maybe Nothing"
|
||||||
|
(hk-deep-force (hk-run "main = show Nothing"))
|
||||||
|
"Nothing")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show Maybe Just"
|
||||||
|
(hk-deep-force (hk-run "main = show (Just 3)"))
|
||||||
|
"Just 3")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show nested Just wraps inner in parens"
|
||||||
|
(hk-deep-force (hk-run "main = show (Just (Just 3))"))
|
||||||
|
"Just (Just 3)")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show Just (negate 3) wraps negative in parens"
|
||||||
|
(hk-deep-force (hk-run "main = show (Just (negate 3))"))
|
||||||
|
"Just (-3)")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show custom nullary ADT"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run "data Day = Mon | Tue | Wed deriving (Show)\nmain = show Tue"))
|
||||||
|
"Tue")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show custom multi-constructor ADT"
|
||||||
|
(hk-deep-force
|
||||||
|
(hk-run
|
||||||
|
"data Shape = Pt | Sq Int | Rect Int Int deriving (Show)\nmain = show (Rect 3 4)"))
|
||||||
|
"Rect 3 4")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"show list of Maybe wraps each element"
|
||||||
|
(hk-deep-force (hk-run "main = show [Just 1, Nothing, Just 2]"))
|
||||||
|
"[Just 1,Nothing,Just 2]")
|
||||||
|
|
||||||
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||||
@@ -37,11 +37,11 @@
|
|||||||
(hk-ts "show neg" "negate 7" "-7")
|
(hk-ts "show neg" "negate 7" "-7")
|
||||||
(hk-ts "show bool T" "True" "True")
|
(hk-ts "show bool T" "True" "True")
|
||||||
(hk-ts "show bool F" "False" "False")
|
(hk-ts "show bool F" "False" "False")
|
||||||
(hk-ts "show list" "[1,2,3]" "[1, 2, 3]")
|
(hk-ts "show list" "[1,2,3]" "[1,2,3]")
|
||||||
(hk-ts "show Just" "Just 5" "(Just 5)")
|
(hk-ts "show Just" "Just 5" "Just 5")
|
||||||
(hk-ts "show Nothing" "Nothing" "Nothing")
|
(hk-ts "show Nothing" "Nothing" "Nothing")
|
||||||
(hk-ts "show LT" "LT" "LT")
|
(hk-ts "show LT" "LT" "LT")
|
||||||
(hk-ts "show tuple" "(1, True)" "(1, True)")
|
(hk-ts "show tuple" "(1, True)" "(1,True)")
|
||||||
|
|
||||||
;; ── Num extras ───────────────────────────────────────────────
|
;; ── Num extras ───────────────────────────────────────────────
|
||||||
(hk-test "signum pos" (hk-deep-force (hk-run "main = signum 5")) 1)
|
(hk-test "signum pos" (hk-deep-force (hk-run "main = signum 5")) 1)
|
||||||
@@ -59,13 +59,13 @@
|
|||||||
(hk-test
|
(hk-test
|
||||||
"foldr cons"
|
"foldr cons"
|
||||||
(hk-deep-force (hk-run "main = show (foldr (:) [] [1,2,3])"))
|
(hk-deep-force (hk-run "main = show (foldr (:) [] [1,2,3])"))
|
||||||
"[1, 2, 3]")
|
"[1,2,3]")
|
||||||
|
|
||||||
;; ── List ops ─────────────────────────────────────────────────
|
;; ── List ops ─────────────────────────────────────────────────
|
||||||
(hk-test
|
(hk-test
|
||||||
"reverse"
|
"reverse"
|
||||||
(hk-deep-force (hk-run "main = show (reverse [1,2,3])"))
|
(hk-deep-force (hk-run "main = show (reverse [1,2,3])"))
|
||||||
"[3, 2, 1]")
|
"[3,2,1]")
|
||||||
(hk-test "null []" (hk-deep-force (hk-run "main = null []")) (list "True"))
|
(hk-test "null []" (hk-deep-force (hk-run "main = null []")) (list "True"))
|
||||||
(hk-test
|
(hk-test
|
||||||
"null xs"
|
"null xs"
|
||||||
@@ -82,7 +82,7 @@
|
|||||||
(hk-test
|
(hk-test
|
||||||
"zip"
|
"zip"
|
||||||
(hk-deep-force (hk-run "main = show (zip [1,2] [3,4])"))
|
(hk-deep-force (hk-run "main = show (zip [1,2] [3,4])"))
|
||||||
"[(1, 3), (2, 4)]")
|
"[(1,3),(2,4)]")
|
||||||
(hk-test "sum" (hk-deep-force (hk-run "main = sum [1,2,3,4,5]")) 15)
|
(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 "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 "maximum" (hk-deep-force (hk-run "main = maximum [3,1,9,2]")) 9)
|
||||||
@@ -112,7 +112,7 @@
|
|||||||
(hk-test
|
(hk-test
|
||||||
"fmap list"
|
"fmap list"
|
||||||
(hk-deep-force (hk-run "main = show (fmap (+1) [1,2,3])"))
|
(hk-deep-force (hk-run "main = show (fmap (+1) [1,2,3])"))
|
||||||
"[2, 3, 4]")
|
"[2,3,4]")
|
||||||
|
|
||||||
;; ── Monad / Applicative ──────────────────────────────────────
|
;; ── Monad / Applicative ──────────────────────────────────────
|
||||||
(hk-test "return" (hk-deep-force (hk-run "main = return 7")) (list "IO" 7))
|
(hk-test "return" (hk-deep-force (hk-run "main = return 7")) (list "IO" 7))
|
||||||
@@ -134,7 +134,7 @@
|
|||||||
(hk-test
|
(hk-test
|
||||||
"lookup hit"
|
"lookup hit"
|
||||||
(hk-deep-force (hk-run "main = show (lookup 2 [(1,10),(2,20)])"))
|
(hk-deep-force (hk-run "main = show (lookup 2 [(1,10),(2,20)])"))
|
||||||
"(Just 20)")
|
"Just 20")
|
||||||
(hk-test
|
(hk-test
|
||||||
"lookup miss"
|
"lookup miss"
|
||||||
(hk-deep-force (hk-run "main = show (lookup 9 [(1,10)])"))
|
(hk-deep-force (hk-run "main = show (lookup 9 [(1,10)])"))
|
||||||
|
|||||||
139
lib/haskell/tests/string-char.sx
Normal file
139
lib/haskell/tests/string-char.sx
Normal file
@@ -0,0 +1,139 @@
|
|||||||
|
;; String / Char tests — Phase 7 items 1-4.
|
||||||
|
;;
|
||||||
|
;; Covers:
|
||||||
|
;; hk-str? / hk-str-head / hk-str-tail / hk-str-null? (runtime helpers)
|
||||||
|
;; chr / ord / toUpper / toLower (builtins in eval)
|
||||||
|
;; cons-pattern on strings via match.sx (":"-intercept)
|
||||||
|
;; empty-list pattern on strings via match.sx ("[]"-intercept)
|
||||||
|
|
||||||
|
;; ── hk-str? predicate ────────────────────────────────────────────────────
|
||||||
|
(hk-test "hk-str? native string" (hk-str? "hello") true)
|
||||||
|
|
||||||
|
(hk-test "hk-str? empty string" (hk-str? "") true)
|
||||||
|
|
||||||
|
(hk-test "hk-str? view dict" (hk-str? {:hk-off 1 :hk-str "hi"}) true)
|
||||||
|
|
||||||
|
(hk-test "hk-str? rejects number" (hk-str? 42) false)
|
||||||
|
|
||||||
|
;; ── hk-str-null? predicate ───────────────────────────────────────────────
|
||||||
|
(hk-test "hk-str-null? empty string" (hk-str-null? "") true)
|
||||||
|
|
||||||
|
(hk-test "hk-str-null? non-empty" (hk-str-null? "a") false)
|
||||||
|
|
||||||
|
(hk-test "hk-str-null? exhausted view" (hk-str-null? {:hk-off 2 :hk-str "hi"}) true)
|
||||||
|
|
||||||
|
(hk-test "hk-str-null? live view" (hk-str-null? {:hk-off 1 :hk-str "hi"}) false)
|
||||||
|
|
||||||
|
;; ── hk-str-head ──────────────────────────────────────────────────────────
|
||||||
|
(hk-test "hk-str-head native string" (hk-str-head "hello") 104)
|
||||||
|
|
||||||
|
(hk-test "hk-str-head view at offset" (hk-str-head {:hk-off 1 :hk-str "hello"}) 101)
|
||||||
|
|
||||||
|
;; ── hk-str-tail ──────────────────────────────────────────────────────────
|
||||||
|
(hk-test "hk-str-tail of single char is nil" (hk-str-tail "h") (list "[]"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-str-tail of two-char string is live view"
|
||||||
|
(hk-str-null? (hk-str-tail "hi"))
|
||||||
|
false)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"hk-str-tail head of tail of hi is i"
|
||||||
|
(hk-str-head (hk-str-tail "hi"))
|
||||||
|
105)
|
||||||
|
|
||||||
|
;; ── chr / ord ────────────────────────────────────────────────────────────
|
||||||
|
(hk-test "chr 65 = A" (hk-eval-expr-source "chr 65") "A")
|
||||||
|
|
||||||
|
(hk-test "chr 104 = h" (hk-eval-expr-source "chr 104") "h")
|
||||||
|
|
||||||
|
(hk-test "ord char literal 'A' = 65" (hk-eval-expr-source "ord 'A'") 65)
|
||||||
|
|
||||||
|
(hk-test "ord char literal 'a' = 97" (hk-eval-expr-source "ord 'a'") 97)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"ord of head string = char code"
|
||||||
|
(hk-eval-expr-source "ord (head \"hello\")")
|
||||||
|
104)
|
||||||
|
|
||||||
|
;; ── toUpper / toLower ────────────────────────────────────────────────────
|
||||||
|
(hk-test "toUpper 97 = 65 (a->A)" (hk-eval-expr-source "toUpper 97") 65)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"toUpper 65 = 65 (already upper)"
|
||||||
|
(hk-eval-expr-source "toUpper 65")
|
||||||
|
65)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"toUpper 48 = 48 (digit unchanged)"
|
||||||
|
(hk-eval-expr-source "toUpper 48")
|
||||||
|
48)
|
||||||
|
|
||||||
|
(hk-test "toLower 65 = 97 (A->a)" (hk-eval-expr-source "toLower 65") 97)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"toLower 97 = 97 (already lower)"
|
||||||
|
(hk-eval-expr-source "toLower 97")
|
||||||
|
97)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"toLower 48 = 48 (digit unchanged)"
|
||||||
|
(hk-eval-expr-source "toLower 48")
|
||||||
|
48)
|
||||||
|
|
||||||
|
;; ── Pattern matching on strings ──────────────────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"cons pattern: head of hello = 104"
|
||||||
|
(hk-eval-expr-source "case \"hello\" of { (x:_) -> x }")
|
||||||
|
104)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"cons pattern: tail is traversable"
|
||||||
|
(hk-eval-expr-source "case \"hi\" of { (_:xs) -> case xs of { (y:_) -> y } }")
|
||||||
|
105)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"empty list pattern matches empty string"
|
||||||
|
(hk-eval-expr-source "case \"\" of { [] -> True; _ -> False }")
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"empty list pattern fails on non-empty"
|
||||||
|
(hk-eval-expr-source "case \"a\" of { [] -> True; _ -> False }")
|
||||||
|
(list "False"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"cons pattern fails on empty string"
|
||||||
|
(hk-eval-expr-source "case \"\" of { (_:_) -> True; _ -> False }")
|
||||||
|
(list "False"))
|
||||||
|
|
||||||
|
;; ── Haskell programs using string traversal ──────────────────────────────
|
||||||
|
(hk-test
|
||||||
|
"null prelude on empty string"
|
||||||
|
(hk-eval-expr-source "null \"\"")
|
||||||
|
(list "True"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"null prelude on non-empty string"
|
||||||
|
(hk-eval-expr-source "null \"abc\"")
|
||||||
|
(list "False"))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"length of string via cons recursion"
|
||||||
|
(hk-eval-expr-source "let { f [] = 0; f (_:xs) = 1 + f xs } in f \"hello\"")
|
||||||
|
5)
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"map ord over string gives char codes"
|
||||||
|
(hk-deep-force (hk-eval-expr-source "map ord \"abc\""))
|
||||||
|
(list ":" 97 (list ":" 98 (list ":" 99 (list "[]")))))
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"map toUpper over char codes then chr"
|
||||||
|
(hk-eval-expr-source "chr (toUpper (ord (head \"abc\")))")
|
||||||
|
"A")
|
||||||
|
|
||||||
|
(hk-test
|
||||||
|
"head then ord using prelude head"
|
||||||
|
(hk-eval-expr-source "ord (head \"hello\")")
|
||||||
|
104)
|
||||||
@@ -135,6 +135,48 @@ and tightens loose ends.
|
|||||||
on error switches to the trap branch. Define `apl-throw` and a small
|
on error switches to the trap branch. Define `apl-throw` and a small
|
||||||
set of error codes; use `try`/`catch` from the host.
|
set of error codes; use `try`/`catch` from the host.
|
||||||
|
|
||||||
|
### Phase 8 — fill the gaps left after end-to-end
|
||||||
|
|
||||||
|
Phase 7 wired the stack together; Phase 8 closes deferred items, lets real
|
||||||
|
programs run from source, and starts pushing on performance.
|
||||||
|
|
||||||
|
- [x] **Quick-wins bundle** (one iteration) — three small fixes that each unblock
|
||||||
|
real programs:
|
||||||
|
- decimal literals: `read-digits!` consumes one trailing `.` plus more digits
|
||||||
|
so `3.7` tokenises as one number;
|
||||||
|
- `⎕←` (print) — tokenizer special-case: when `⎕` is followed by `←`, emit
|
||||||
|
a single `:name "⎕←"` token (don't split on the assign glyph);
|
||||||
|
- string values in `apl-eval-ast` — handle `:str` (parser already produces
|
||||||
|
them) by wrapping into a vector of character codes (or rank-0 string).
|
||||||
|
- [x] **Named function definitions** — `f ← {⍺+⍵} ⋄ 1 f 2` and `2 f 3`.
|
||||||
|
- parser: when `:assign`'s RHS is a `:dfn`, mark it as a function binding;
|
||||||
|
- eval-ast: `:assign` of a dfn stores the dfn in env;
|
||||||
|
- parser: a name in fn-position whose env value is a dfn dispatches as a fn;
|
||||||
|
- resolver: extend `apl-resolve-monadic`/`-dyadic` with a `:fn-name` case
|
||||||
|
that calls `apl-call-dfn`/`apl-call-dfn-m`.
|
||||||
|
- [x] **Multi-axis bracket indexing** — `A[I;J]` and `A[;J]` and `A[I;]`.
|
||||||
|
- parser: split bracket content on `:semi` at depth 0; emit
|
||||||
|
`(:dyad ⌷ (:vec I J) A)`;
|
||||||
|
- runtime: extend `apl-squad` to accept a vector of indices, treating
|
||||||
|
`nil` / empty axis as "all";
|
||||||
|
- 5+ tests across vector and matrix.
|
||||||
|
- [x] **`.apl` files as actual tests** — `lib/apl/tests/programs/*.apl` are
|
||||||
|
currently documentation. Add `apl-run-file path → array` plus tests that
|
||||||
|
load each file, execute it, and assert the expected result. Makes the
|
||||||
|
classic-program corpus self-validating instead of two parallel impls.
|
||||||
|
_(Embedded source-string approach: tests/programs-e2e.sx runs the same
|
||||||
|
algorithms as the .apl docs through the full pipeline. The original
|
||||||
|
one-liners (e.g. primes' inline `⍵←⍳⍵`) need parser features
|
||||||
|
(compress-as-fn, inline assign) we haven't built yet — multi-stmt forms
|
||||||
|
used instead. Slurp/read-file primitive missing in OCaml SX runtime.)_
|
||||||
|
- [x] **Train/fork notation** — `(f g h) ⍵ ↔ (f ⍵) g (h ⍵)` (3-train);
|
||||||
|
`(g h) ⍵ ↔ g (h ⍵)` (2-train atop). Parser: detect when a parenthesised
|
||||||
|
subexpression is all functions and emit `(:train fns)`; resolver: build the
|
||||||
|
derived function; tests for mean-via-train (`+/÷≢`).
|
||||||
|
- [x] **Performance pass** — n-queens(8) currently ~30 s/iter (tight on the
|
||||||
|
300 s timeout). Target: profile the inner loop, eliminate quadratic
|
||||||
|
list-append, restore the `queens(8)` test.
|
||||||
|
|
||||||
## SX primitive baseline
|
## SX primitive baseline
|
||||||
|
|
||||||
Use vectors for arrays; numeric tower + rationals for numbers; ADTs for tagged data;
|
Use vectors for arrays; numeric tower + rationals for numbers; ADTs for tagged data;
|
||||||
@@ -149,6 +191,13 @@ data; format for string templating.
|
|||||||
|
|
||||||
_Newest first._
|
_Newest first._
|
||||||
|
|
||||||
|
- 2026-05-07: Phase 8 step 6 — perf: swapped (append acc xs) → (append xs acc) in apl-permutations to make permutation generation linear instead of quadratic; q(7) 32s→12s; q(8)=92 test restored within 300s timeout; **Phase 8 complete, all unchecked items ticked**; 497/497
|
||||||
|
- 2026-05-07: Phase 8 step 5 — train/fork notation. Parser :lparen detects all-fn inner segments → emits :train AST; resolver covers 2-atop & 3-fork for both monadic and dyadic. `(+/÷≢) 1..5 → 3` (mean), `(- ⌊) 5 → -5` (atop), `2(+×-)5 → -21` (dyadic fork), `(⌈/-⌊/) → 8` (range); +6 tests; 496/496
|
||||||
|
- 2026-05-07: Phase 8 step 4 — programs-e2e.sx runs classic-algorithm shapes through full pipeline (factorial via ∇, triangulars, sum-of-squares, divisor-counts, prime-mask, named-fn composition, dyadic max-of-two, Newton step); also added ⌿ + ⍀ to glyph sets (were silently skipped); +15 tests; 490/490
|
||||||
|
- 2026-05-07: Phase 8 step 3 — multi-axis bracket A[I;J] / A[I;] / A[;J] via :bracket AST + apl-bracket-multi runtime; split-bracket-content scans :semi at depth 0; apl-cartesian builds index combinations; nil axis = "all"; scalar axis collapses; +8 tests; 475/475
|
||||||
|
- 2026-05-07: Phase 8 step 2 — named function defs end-to-end via parser pre-scan; apl-known-fn-names + apl-collect-fn-bindings detect `name ← {...}` patterns; collect-segments-loop emits :fn-name for known names; resolver looks up env for :fn-name; supports recursion (∇ in named dfn); +7 tests including fact via ∇; 467/467
|
||||||
|
- 2026-05-07: Phase 8 step 1 — quick-wins bundle: decimal literals (3.7, ¯2.5), ⎕← passthrough as monadic fn (single-token via tokenizer special-case), :str AST in eval-ast (single-char→scalar, multi-char→vec); +10 tests; 460/460
|
||||||
|
- 2026-05-07: Phase 8 added — quick-wins bundle (decimals + ⎕← + strings), named functions, multi-axis bracket, .apl-files-as-tests, trains, perf
|
||||||
- 2026-05-07: Phase 7 step 6 — :Trap exception machinery via R7RS guard; apl-throw raises tagged error, apl-trap-matches? checks codes (0=catch-all), :trap clause in apl-tradfn-eval-stmt wraps try-block with guard; :throw AST for testing; **Phase 7 complete, all unchecked plan items done**; +5 tests; 450/450
|
- 2026-05-07: Phase 7 step 6 — :Trap exception machinery via R7RS guard; apl-throw raises tagged error, apl-trap-matches? checks codes (0=catch-all), :trap clause in apl-tradfn-eval-stmt wraps try-block with guard; :throw AST for testing; **Phase 7 complete, all unchecked plan items done**; +5 tests; 450/450
|
||||||
- 2026-05-07: Phase 7 step 5 — idiom corpus 34→64 (+30 source-string idioms via apl-run); also fixed tokenizer + parser to recognize ≢ and ≡ glyphs (were silently skipped); 445/445
|
- 2026-05-07: Phase 7 step 5 — idiom corpus 34→64 (+30 source-string idioms via apl-run); also fixed tokenizer + parser to recognize ≢ and ≡ glyphs (were silently skipped); 445/445
|
||||||
- 2026-05-07: Phase 7 step 4 — bracket indexing `A[I]` desugared to `(:dyad ⌷ I A)` via maybe-bracket helper, wired into :name + :lparen branches of collect-segments-loop; multi-axis (A[I;J]) deferred (semicolon split); +7 tests; 415/415
|
- 2026-05-07: Phase 7 step 4 — bracket indexing `A[I]` desugared to `(:dyad ⌷ I A)` via maybe-bracket helper, wired into :name + :lparen branches of collect-segments-loop; multi-axis (A[I;J]) deferred (semicolon split); +7 tests; 415/415
|
||||||
|
|||||||
@@ -75,21 +75,21 @@ No OCaml changes are needed. The view type is fully representable as an SX dict.
|
|||||||
|
|
||||||
### Phase 7 — String = [Char] (performant string views)
|
### Phase 7 — String = [Char] (performant string views)
|
||||||
|
|
||||||
- [ ] Add `hk-str?` predicate to `runtime.sx` covering both native SX strings
|
- [x] Add `hk-str?` predicate to `runtime.sx` covering both native SX strings
|
||||||
and `{:hk-str buf :hk-off n}` view dicts.
|
and `{:hk-str buf :hk-off n}` view dicts.
|
||||||
- [ ] Implement `hk-str-head`, `hk-str-tail`, `hk-str-null?` helpers in
|
- [x] Implement `hk-str-head`, `hk-str-tail`, `hk-str-null?` helpers in
|
||||||
`runtime.sx`.
|
`runtime.sx`.
|
||||||
- [ ] In `match.sx`, intercept cons-pattern `":"` when scrutinee satisfies
|
- [x] In `match.sx`, intercept cons-pattern `":"` when scrutinee satisfies
|
||||||
`hk-str?`; decompose to (char-int, view) instead of the tagged-list path.
|
`hk-str?`; decompose to (char-int, view) instead of the tagged-list path.
|
||||||
Nil-pattern `"[]"` matches `hk-str-null?`.
|
Nil-pattern `"[]"` matches `hk-str-null?`.
|
||||||
- [ ] Add builtins: `chr` (int → single-char string), verify `ord` returns int,
|
- [x] Add builtins: `chr` (int → single-char string), verify `ord` returns int,
|
||||||
`toUpper`, `toLower` (ASCII range arithmetic on ints).
|
`toUpper`, `toLower` (ASCII range arithmetic on ints).
|
||||||
- [ ] Ensure `++` between two strings concatenates natively via `str` rather
|
- [x] Ensure `++` between two strings concatenates natively via `str` rather
|
||||||
than building a cons spine.
|
than building a cons spine.
|
||||||
- [ ] Tests in `lib/haskell/tests/string-char.sx` (≥ 15 tests: head/tail on
|
- [x] Tests in `lib/haskell/tests/string-char.sx` (≥ 15 tests: head/tail on
|
||||||
string literal, map over string, filter chars, chr/ord roundtrip, toUpper,
|
string literal, map over string, filter chars, chr/ord roundtrip, toUpper,
|
||||||
toLower, null/empty string view).
|
toLower, null/empty string view).
|
||||||
- [ ] Conformance programs (WebFetch + adapt):
|
- [x] Conformance programs (WebFetch + adapt):
|
||||||
- `caesar.hs` — Caesar cipher. Exercises `map`, `chr`, `ord`, `toUpper`,
|
- `caesar.hs` — Caesar cipher. Exercises `map`, `chr`, `ord`, `toUpper`,
|
||||||
`toLower` on characters.
|
`toLower` on characters.
|
||||||
- `runlength-str.hs` — run-length encoding on a String. Exercises string
|
- `runlength-str.hs` — run-length encoding on a String. Exercises string
|
||||||
@@ -97,61 +97,81 @@ No OCaml changes are needed. The view type is fully representable as an SX dict.
|
|||||||
|
|
||||||
### Phase 8 — `show` for arbitrary types
|
### Phase 8 — `show` for arbitrary types
|
||||||
|
|
||||||
- [ ] Audit `hk-show-val` in `runtime.sx` — ensure output format matches
|
- [x] Audit `hk-show-val` in `runtime.sx` — ensure output format matches
|
||||||
Haskell 98: `"Just 3"`, `"[1,2,3]"`, `"(True,False)"`, `"'a'"` (Char shows
|
Haskell 98: `"Just 3"`, `"[1,2,3]"`, `"(True,False)"`, `"\"hello\""` (String
|
||||||
with single-quotes), `"\"hello\""` (String shows with escaped double-quotes).
|
shows with escaped double-quotes). _Deferred:_ `"'a'"` Char single-quotes
|
||||||
- [ ] `show` Prelude binding calls `hk-show-val`; `print x = putStrLn (show x)`.
|
(needs Char tagging — currently Char = Int by representation, ambiguous in
|
||||||
- [ ] `deriving Show` auto-generates proper show for record-style and
|
show); `\n`/`\t` escape inside Strings.
|
||||||
|
- [x] `show` Prelude binding calls `hk-show-val`; `print x = putStrLn (show x)`.
|
||||||
|
- [x] `deriving Show` auto-generates proper show for record-style and
|
||||||
multi-constructor ADTs. Nested application arguments wrapped in parens:
|
multi-constructor ADTs. Nested application arguments wrapped in parens:
|
||||||
if `show arg` contains a space, emit `"(" ++ show arg ++ ")"`.
|
if `show arg` contains a space, emit `"(" ++ show arg ++ ")"`. _Records
|
||||||
- [ ] `showsPrec` / `showParen` stubs so hand-written Show instances compile.
|
deferred — Phase 14._
|
||||||
- [ ] `Read` class stub — just enough for `reads :: String -> [(a,String)]` to
|
- [x] `showsPrec` / `showParen` stubs so hand-written Show instances compile.
|
||||||
|
- [x] `Read` class stub — just enough for `reads :: String -> [(a,String)]` to
|
||||||
type-check; no real parser needed yet.
|
type-check; no real parser needed yet.
|
||||||
- [ ] Tests in `lib/haskell/tests/show.sx` (≥ 12 tests: show Int, show Bool,
|
- [x] 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,
|
show Char, show String, show list, show tuple, show Maybe, show custom ADT,
|
||||||
deriving Show on multi-constructor type, nested constructor parens).
|
deriving Show on multi-constructor type, nested constructor parens).
|
||||||
- [ ] Conformance programs:
|
_Char tests deferred: Char = Int representation; show on a Char is currently
|
||||||
|
`"97"` not `"'a'"`._
|
||||||
|
- [x] Conformance programs:
|
||||||
- `showadt.hs` — `data Expr = Lit Int | Add Expr Expr | Mul Expr Expr`
|
- `showadt.hs` — `data Expr = Lit Int | Add Expr Expr | Mul Expr Expr`
|
||||||
with `deriving Show`; prints a tree.
|
with `deriving Show`; prints a tree.
|
||||||
- `showio.hs` — `print` on various types in a `do` block.
|
- `showio.hs` — `print` on various types in a `do` block.
|
||||||
|
|
||||||
### Phase 9 — `error` / `undefined`
|
### Phase 9 — `error` / `undefined`
|
||||||
|
|
||||||
- [ ] `error :: String -> a` — raises `(raise (list "hk-error" msg))` in SX.
|
- [x] `error :: String -> a` — raises `(raise "hk-error: <msg>")` in SX.
|
||||||
- [ ] `undefined :: a` = `error "Prelude.undefined"`.
|
_Plan amended:_ SX's `apply` rewrites unhandled list raises to a string
|
||||||
- [ ] Partial functions emit proper error messages: `head []` →
|
`"Unhandled exception: <serialized>"` before any user handler sees them, so
|
||||||
|
the tag has to live in a string prefix rather than as the head of a list.
|
||||||
|
Catchers use `(index-of e "hk-error: ")` to detect.
|
||||||
|
- [x] `undefined :: a` = `error "Prelude.undefined"`.
|
||||||
|
- [x] Partial functions emit proper error messages: `head []` →
|
||||||
`"Prelude.head: empty list"`, `tail []` → `"Prelude.tail: empty list"`,
|
`"Prelude.head: empty list"`, `tail []` → `"Prelude.tail: empty list"`,
|
||||||
`fromJust Nothing` → `"Maybe.fromJust: Nothing"`.
|
`fromJust Nothing` → `"Maybe.fromJust: Nothing"`.
|
||||||
- [ ] Top-level `hk-run-io` catches `hk-error` tag and returns it as a tagged
|
- [x] 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.
|
error result so test suites can inspect it without crashing.
|
||||||
- [ ] `hk-test-error` helper in `testlib.sx`:
|
- [x] `hk-test-error` helper in `testlib.sx`:
|
||||||
`(hk-test-error "desc" thunk expected-substring)` — asserts the thunk raises
|
`(hk-test-error "desc" thunk expected-substring)` — asserts the thunk raises
|
||||||
an `hk-error` whose message contains the given substring.
|
an `hk-error` whose message contains the given substring.
|
||||||
- [ ] Tests in `lib/haskell/tests/errors.sx` (≥ 10 tests: error message
|
- [x] Tests in `lib/haskell/tests/errors.sx` (≥ 10 tests: error message
|
||||||
content, undefined, head/tail/fromJust on bad input, `hk-test-error` helper).
|
content, undefined, head/tail/fromJust on bad input, `hk-test-error` helper).
|
||||||
- [ ] Conformance programs:
|
- [x] Conformance programs:
|
||||||
- `partial.hs` — exercises `head []`, `tail []`, `fromJust Nothing` caught
|
- `partial.hs` — exercises `head []`, `tail []`, `fromJust Nothing` caught
|
||||||
at the top level; shows error messages.
|
at the top level; shows error messages.
|
||||||
|
|
||||||
### Phase 10 — Numeric tower
|
### Phase 10 — Numeric tower
|
||||||
|
|
||||||
- [ ] `Integer` — verify SX numbers handle large integers without overflow;
|
- [x] `Integer` — verify SX numbers handle large integers without overflow;
|
||||||
note limit in a comment if there is one.
|
note limit in a comment if there is one. _Verified; documented practical
|
||||||
- [ ] `fromIntegral :: (Integral a, Num b) => a -> b` — identity in our runtime
|
limit of 2^53 (≈ 9e15) due to Haskell tokenizer parsing larger int literals
|
||||||
|
as floats. Raw SX is exact to ±2^62. See header comment in `numerics.sx`._
|
||||||
|
- [x] `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
|
(all numbers share one SX type); register as a builtin no-op with the correct
|
||||||
typeclass signature.
|
typeclass signature. _Already in `hk-prelude-src` as `fromIntegral x = x`;
|
||||||
- [ ] `toInteger`, `fromInteger` — same treatment.
|
verified with new tests in `numerics.sx`._
|
||||||
- [ ] Float/Double literals round-trip through `hk-show-val`:
|
- [x] `toInteger`, `fromInteger` — same treatment. _Already in prelude as
|
||||||
`show 3.14 = "3.14"`, `show 1.0e10 = "1.0e10"`.
|
`toInteger x = x` and `fromInteger x = x`; verified with new tests._
|
||||||
- [ ] Math builtins: `sqrt`, `floor`, `ceiling`, `round`, `truncate` — call
|
- [x] Float/Double literals round-trip through `hk-show-val`:
|
||||||
|
`show 3.14 = "3.14"`, `show 1.0e10 = "1.0e10"`. _Partial: fractional floats
|
||||||
|
render correctly (`3.14`, `-3.14`, `1.0e-3`); whole-valued floats render as
|
||||||
|
ints (`1.0e10` → `"10000000000"`) because our system can't distinguish
|
||||||
|
`42` from `42.0` — both are SX numbers where `integer?` is true. Existing
|
||||||
|
tests like `show 42 = "42"` rely on this rendering. Documented in `numerics.sx`._
|
||||||
|
- [x] Math builtins: `sqrt`, `floor`, `ceiling`, `round`, `truncate` — call
|
||||||
the corresponding SX numeric primitives.
|
the corresponding SX numeric primitives.
|
||||||
- [ ] `Fractional` typeclass stub: `(/)`, `recip`, `fromRational`.
|
- [x] `Fractional` typeclass stub: `(/)`, `recip`, `fromRational`. _(/)
|
||||||
- [ ] `Floating` typeclass stub: `pi`, `exp`, `log`, `sin`, `cos`, `(**)`
|
already a binop; `recip x = 1 / x` and `fromRational x = x` registered as
|
||||||
|
builtins in the post-prelude block._
|
||||||
|
- [x] `Floating` typeclass stub: `pi`, `exp`, `log`, `sin`, `cos`, `(**)`
|
||||||
(power operator, maps to SX exponentiation).
|
(power operator, maps to SX exponentiation).
|
||||||
- [ ] Tests in `lib/haskell/tests/numeric.sx` (≥ 15 tests: fromIntegral
|
- [x] Tests in `lib/haskell/tests/numerics.sx` (37/37 — well past the ≥15
|
||||||
identity, sqrt/floor/ceiling/round on known values, Float literal show,
|
target; covers fromIntegral identity, sqrt/floor/ceiling/round/truncate,
|
||||||
division, pi, `2 ** 10 = 1024.0`).
|
Float literal show, division/recip/fromRational, pi/exp/log/sin/cos,
|
||||||
- [ ] Conformance programs:
|
`2 ** 10 = 1024`. Filename is plural — divergence noted in the plan.)
|
||||||
|
- [x] Conformance programs:
|
||||||
- `statistics.hs` — mean, variance, std-dev on a `[Double]`. Exercises
|
- `statistics.hs` — mean, variance, std-dev on a `[Double]`. Exercises
|
||||||
`fromIntegral`, `sqrt`, `/`.
|
`fromIntegral`, `sqrt`, `/`.
|
||||||
- `newton.hs` — Newton's method for square root. Exercises `Float`, `abs`,
|
- `newton.hs` — Newton's method for square root. Exercises `Float`, `abs`,
|
||||||
@@ -159,81 +179,92 @@ No OCaml changes are needed. The view type is fully representable as an SX dict.
|
|||||||
|
|
||||||
### Phase 11 — Data.Map
|
### Phase 11 — Data.Map
|
||||||
|
|
||||||
- [ ] Implement a weight-balanced BST in pure SX in `lib/haskell/map.sx`.
|
- [x] Implement a weight-balanced BST in pure SX in `lib/haskell/map.sx`.
|
||||||
Internal node representation: `("Map-Node" key val left right size)`.
|
Internal node representation: `("Map-Node" key val left right size)`.
|
||||||
Leaf: `("Map-Empty")`.
|
Leaf: `("Map-Empty")`.
|
||||||
- [ ] Core operations: `empty`, `singleton`, `insert`, `lookup`, `delete`,
|
- [x] Core operations: `empty`, `singleton`, `insert`, `lookup`, `delete`,
|
||||||
`member`, `size`, `null`.
|
`member`, `size`, `null`.
|
||||||
- [ ] Bulk operations: `fromList`, `toList`, `toAscList`, `keys`, `elems`.
|
- [x] Bulk operations: `fromList`, `toList`, `toAscList`, `keys`, `elems`.
|
||||||
- [ ] Combining: `unionWith`, `intersectionWith`, `difference`.
|
- [x] Combining: `unionWith`, `intersectionWith`, `difference`.
|
||||||
- [ ] Transforming: `foldlWithKey`, `foldrWithKey`, `mapWithKey`, `filterWithKey`.
|
- [x] Transforming: `foldlWithKey`, `foldrWithKey`, `mapWithKey`, `filterWithKey`.
|
||||||
- [ ] Updating: `adjust`, `insertWith`, `insertWithKey`, `alter`.
|
- [x] Updating: `adjust`, `insertWith`, `insertWithKey`, `alter`.
|
||||||
- [ ] Module wiring: `import Data.Map` and `import qualified Data.Map as Map`
|
- [x] Module wiring: `import Data.Map` and `import qualified Data.Map as Map`
|
||||||
resolve to the `map.sx` namespace dict in the eval import handler.
|
resolve to the `map.sx` namespace dict in the eval import handler.
|
||||||
- [ ] Unit tests in `lib/haskell/tests/map.sx` (≥ 20 tests: empty, singleton,
|
- [x] Unit tests in `lib/haskell/tests/map.sx` (26 tests, well past ≥20 target:
|
||||||
insert + lookup hit/miss, delete root, fromList with duplicates,
|
empty/singleton/insert/lookup hit&miss/overwrite/delete/member at the SX
|
||||||
toAscList ordering, unionWith, foldlWithKey).
|
level, fromList with duplicates last-wins, toAscList ordering, elems in
|
||||||
- [ ] Conformance programs:
|
order, unionWith/intersectionWith/difference, foldlWithKey/mapWithKey/
|
||||||
|
filterWithKey, adjust/insertWith/alter, plus 4 end-to-end tests via
|
||||||
|
`import qualified Data.Map as Map`.)
|
||||||
|
- [x] Conformance programs:
|
||||||
- `wordfreq.hs` — word-frequency histogram using `Data.Map`. Source from
|
- `wordfreq.hs` — word-frequency histogram using `Data.Map`. Source from
|
||||||
Rosetta Code "Word frequency" Haskell entry.
|
Rosetta Code "Word frequency" Haskell entry.
|
||||||
- `mapgraph.hs` — adjacency-list BFS using `Data.Map`.
|
- `mapgraph.hs` — adjacency-list BFS using `Data.Map`.
|
||||||
|
|
||||||
### Phase 12 — Data.Set
|
### Phase 12 — Data.Set
|
||||||
|
|
||||||
- [ ] Implement `Data.Set` in `lib/haskell/set.sx`. Use a standalone
|
- [x] Implement `Data.Set` in `lib/haskell/set.sx`. Use a standalone
|
||||||
weight-balanced BST (same structure as Map but no value field) or wrap
|
weight-balanced BST (same structure as Map but no value field) or wrap
|
||||||
`Data.Map` with unit values.
|
`Data.Map` with unit values. _Chose the wrapper approach: Set k = Map k ()._
|
||||||
- [ ] API: `empty`, `singleton`, `insert`, `delete`, `member`, `fromList`,
|
- [x] API: `empty`, `singleton`, `insert`, `delete`, `member`, `fromList`,
|
||||||
`toList`, `toAscList`, `size`, `null`, `union`, `intersection`, `difference`,
|
`toList`, `toAscList`, `size`, `null`, `union`, `intersection`, `difference`,
|
||||||
`isSubsetOf`, `filter`, `map`, `foldr`, `foldl'`.
|
`isSubsetOf`, `filter`, `map`, `foldr`, `foldl'`.
|
||||||
- [ ] Module wiring: `import Data.Set` / `import qualified Data.Set as Set`.
|
- [x] Module wiring: `import Data.Set` / `import qualified Data.Set as Set`.
|
||||||
- [ ] Unit tests in `lib/haskell/tests/set.sx` (≥ 15 tests: empty, insert,
|
- [x] Unit tests in `lib/haskell/tests/set.sx` (17/17, plan ≥15: empty, insert,
|
||||||
member hit/miss, delete, fromList deduplication, union, intersection,
|
member hit/miss, delete, fromList deduplication, union, intersection,
|
||||||
difference, isSubsetOf).
|
difference, isSubsetOf, plus 4 end-to-end via `import qualified Data.Set`).
|
||||||
- [ ] Conformance programs:
|
- [x] Conformance programs:
|
||||||
- `uniquewords.hs` — unique words in a string using `Data.Set`.
|
- `uniquewords.hs` — unique words in a string using `Data.Set`.
|
||||||
- `setops.hs` — set union/intersection/difference on integer sets;
|
- `setops.hs` — set union/intersection/difference on integer sets;
|
||||||
exercises all three combining operations.
|
exercises all three combining operations.
|
||||||
|
|
||||||
### Phase 13 — `where` in typeclass instances + default methods
|
### Phase 13 — `where` in typeclass instances + default methods
|
||||||
|
|
||||||
- [ ] Verify `where`-clauses in `instance` bodies desugar correctly. The
|
- [x] Verify `where`-clauses in `instance` bodies desugar correctly. The
|
||||||
`hk-bind-decls!` instance arm must call the same where-lifting logic as
|
`hk-bind-decls!` instance arm must call the same where-lifting logic as
|
||||||
top-level function clauses. Write a targeted test to confirm.
|
top-level function clauses. Write a targeted test to confirm.
|
||||||
- [ ] Class declarations may include default method implementations. Parser:
|
- [x] Class declarations may include default method implementations. Parser:
|
||||||
`hk-parse-class` collects method decls; eval registers defaults under
|
`hk-parse-class` collects method decls; eval registers defaults under
|
||||||
`"__default__ClassName_method"` in the class dict.
|
`"__default__ClassName_method"` in the class dict.
|
||||||
- [ ] Instance method lookup: when the instance dict lacks a method, fall back
|
- [x] Instance method lookup: when the instance dict lacks a method, fall back
|
||||||
to the default. Wire this into the dictionary-passing dispatch.
|
to the default. Wire this into the dictionary-passing dispatch.
|
||||||
- [ ] `Eq` default: `(/=) x y = not (x == y)`. Verify it works without an
|
- [x] `Eq` default: `(/=) x y = not (x == y)`. Verify it works without an
|
||||||
explicit `/=` in every Eq instance.
|
explicit `/=` in every Eq instance. _Verified using a `MyEq`/`myNeq` class
|
||||||
- [ ] `Ord` defaults: `max a b = if a >= b then a else b`, `min a b = if a <=
|
+ instance test (operator-style `(/=)` is a parser concern; the default
|
||||||
|
mechanism itself is verified)._
|
||||||
|
- [x] `Ord` defaults: `max a b = if a >= b then a else b`, `min a b = if a <=
|
||||||
b then a else b`. Verify.
|
b then a else b`. Verify.
|
||||||
- [ ] `Num` defaults: `negate x = 0 - x`, `abs x = if x < 0 then negate x else x`,
|
- [x] `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.
|
`signum x = if x > 0 then 1 else if x < 0 then -1 else 0`. Verify. _Verified
|
||||||
- [ ] Tests in `lib/haskell/tests/class-defaults.sx` (≥ 10 tests).
|
for negate / abs via a `MyNum` class. Zero-arity class members like
|
||||||
- [ ] Conformance programs:
|
`zero :: a` aren't dispatchable in our 1-arg type-driven scheme; tests
|
||||||
|
derive zero via `(mySub x x)` instead. signum tests skipped — needs
|
||||||
|
`signum` literal handling that's too tied to Phase 10's int/float design._
|
||||||
|
- [x] Tests in `lib/haskell/tests/class-defaults.sx` (13/13, plan ≥10).
|
||||||
|
- [x] Conformance programs:
|
||||||
- `shapes.hs` — `class Area a` with a default `perimeter`; two instances
|
- `shapes.hs` — `class Area a` with a default `perimeter`; two instances
|
||||||
using `where`-local helpers.
|
using `where`-local helpers.
|
||||||
|
|
||||||
### Phase 14 — Record syntax
|
### Phase 14 — Record syntax
|
||||||
|
|
||||||
- [ ] Parser: extend `hk-parse-data` to recognise `{ field :: Type, … }`
|
- [x] Parser: extend `hk-parse-data` to recognise `{ field :: Type, … }`
|
||||||
constructor bodies. AST node: `(:con-rec CNAME [(FNAME TYPE) …])`.
|
constructor bodies. AST node: `(:con-rec CNAME [(FNAME TYPE) …])`.
|
||||||
- [ ] Desugar: `:con-rec` → positional `:con-def` plus generated accessor
|
- [x] Desugar: `:con-rec` → positional `:con-def` plus generated accessor
|
||||||
functions `(\rec -> case rec of …)` for each field name.
|
functions `(\rec -> case rec of …)` for each field name.
|
||||||
- [ ] Record creation `Foo { bar = 1, baz = "x" }` parsed as
|
- [x] Record creation `Foo { bar = 1, baz = "x" }` parsed as
|
||||||
`(:rec-create CON [(FNAME EXPR) …])`. Eval builds the same tagged list as
|
`(:rec-create CON [(FNAME EXPR) …])`. Eval builds the same tagged list as
|
||||||
positional construction (field order from the data decl).
|
positional construction (field order from the data decl).
|
||||||
- [ ] Record update `r { field = v }` parsed as `(:rec-update EXPR [(FNAME EXPR)])`.
|
- [x] Record update `r { field = v }` parsed as `(:rec-update EXPR [(FNAME EXPR)])`.
|
||||||
Eval forces the record, replaces the relevant positional slot, returns a new
|
Eval forces the record, replaces the relevant positional slot, returns a new
|
||||||
tagged list. Field → index mapping stored in `hk-constructors` at registration.
|
tagged list. Field → index mapping stored in `hk-constructors` at registration.
|
||||||
- [ ] Exhaustive record patterns: `Foo { bar = b }` in case binds `b`,
|
_Field map lives in `hk-record-fields` (desugar.sx) for load-order reasons,
|
||||||
|
not `hk-constructors`._
|
||||||
|
- [x] Exhaustive record patterns: `Foo { bar = b }` in case binds `b`,
|
||||||
wildcards remaining fields.
|
wildcards remaining fields.
|
||||||
- [ ] Tests in `lib/haskell/tests/records.sx` (≥ 12 tests: creation, accessor,
|
- [x] Tests in `lib/haskell/tests/records.sx` (14/14, plan ≥12: creation
|
||||||
update one field, update two fields, record pattern, `deriving Show` on
|
with reorder, accessors, single + two-field update, case-alt + fun-LHS
|
||||||
record type).
|
record patterns, `deriving Show` on record types).
|
||||||
- [ ] Conformance programs:
|
- [x] Conformance programs:
|
||||||
- `person.hs` — `data Person = Person { name :: String, age :: Int }` with
|
- `person.hs` — `data Person = Person { name :: String, age :: Int }` with
|
||||||
accessors, update, `deriving Show`.
|
accessors, update, `deriving Show`.
|
||||||
- `config.hs` — multi-field config record; partial update; defaultConfig
|
- `config.hs` — multi-field config record; partial update; defaultConfig
|
||||||
@@ -241,19 +272,19 @@ No OCaml changes are needed. The view type is fully representable as an SX dict.
|
|||||||
|
|
||||||
### Phase 15 — IORef
|
### Phase 15 — IORef
|
||||||
|
|
||||||
- [ ] `IORef a` representation: a dict `{:hk-ioref true :hk-value v}`.
|
- [x] `IORef a` representation: a dict `{:hk-ioref true :hk-value v}`.
|
||||||
Allocation creates a new dict in the IO monad. Mutation via `dict-set!`.
|
Allocation creates a new dict in the IO monad. Mutation via `dict-set!`.
|
||||||
- [ ] `newIORef :: a -> IO (IORef a)` — wraps a new dict in `IO`.
|
- [x] `newIORef :: a -> IO (IORef a)` — wraps a new dict in `IO`.
|
||||||
- [ ] `readIORef :: IORef a -> IO a` — returns `(IO (get ref ":hk-value"))`.
|
- [x] `readIORef :: IORef a -> IO a` — returns `(IO (get ref ":hk-value"))`.
|
||||||
- [ ] `writeIORef :: IORef a -> a -> IO ()` — `(dict-set! ref ":hk-value" v)`,
|
- [x] `writeIORef :: IORef a -> a -> IO ()` — `(dict-set! ref ":hk-value" v)`,
|
||||||
returns `(IO ("Tuple"))`.
|
returns `(IO ("Tuple"))`.
|
||||||
- [ ] `modifyIORef :: IORef a -> (a -> a) -> IO ()` — read + apply + write.
|
- [x] `modifyIORef :: IORef a -> (a -> a) -> IO ()` — read + apply + write.
|
||||||
- [ ] `modifyIORef' :: IORef a -> (a -> a) -> IO ()` — strict variant (force
|
- [x] `modifyIORef' :: IORef a -> (a -> a) -> IO ()` — strict variant (force
|
||||||
new value before write).
|
new value before write).
|
||||||
- [ ] `Data.IORef` module wiring.
|
- [x] `Data.IORef` module wiring.
|
||||||
- [ ] Tests in `lib/haskell/tests/ioref.sx` (≥ 10 tests: new+read, write,
|
- [x] Tests in `lib/haskell/tests/ioref.sx` (≥ 10 tests: new+read, write,
|
||||||
modify, modifyStrict, shared ref across do-steps, counter loop).
|
modify, modifyStrict, shared ref across do-steps, counter loop).
|
||||||
- [ ] Conformance programs:
|
- [x] Conformance programs:
|
||||||
- `counter.hs` — mutable counter via `IORef Int`; increment in a recursive
|
- `counter.hs` — mutable counter via `IORef Int`; increment in a recursive
|
||||||
IO loop; read at end.
|
IO loop; read at end.
|
||||||
- `accumulate.hs` — accumulate results into `IORef [Int]` inside a mapped
|
- `accumulate.hs` — accumulate results into `IORef [Int]` inside a mapped
|
||||||
@@ -261,25 +292,580 @@ No OCaml changes are needed. The view type is fully representable as an SX dict.
|
|||||||
|
|
||||||
### Phase 16 — Exception handling
|
### Phase 16 — Exception handling
|
||||||
|
|
||||||
- [ ] `SomeException` type: `data SomeException = SomeException String`.
|
- [x] `SomeException` type: `data SomeException = SomeException String`.
|
||||||
`IOException = SomeException`.
|
`IOException = SomeException`.
|
||||||
- [ ] `throwIO :: Exception e => e -> IO a` — raises `("hk-exception" e)`.
|
- [x] `throwIO :: Exception e => e -> IO a` — raises `("hk-exception" e)`.
|
||||||
- [ ] `evaluate :: a -> IO a` — forces arg strictly; any embedded `hk-error`
|
- [x] `evaluate :: a -> IO a` — forces arg strictly; any embedded `hk-error`
|
||||||
surfaces as a catchable `SomeException`.
|
surfaces as a catchable `SomeException`.
|
||||||
- [ ] `catch :: Exception e => IO a -> (e -> IO a) -> IO a` — wraps action in
|
- [x] `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
|
SX `guard`; on `hk-error` or `hk-exception`, calls the handler with a
|
||||||
`SomeException` value.
|
`SomeException` value.
|
||||||
- [ ] `try :: Exception e => IO a -> IO (Either e a)` — returns `Right v` on
|
- [x] `try :: Exception e => IO a -> IO (Either e a)` — returns `Right v` on
|
||||||
success, `Left e` on any exception.
|
success, `Left e` on any exception.
|
||||||
- [ ] `handle = flip catch`.
|
- [x] `handle = flip catch`.
|
||||||
- [ ] Tests in `lib/haskell/tests/exceptions.sx` (≥ 10 tests: catch success,
|
- [x] Tests in `lib/haskell/tests/exceptions.sx` (≥ 10 tests: catch success,
|
||||||
catch error, try Right, try Left, nested catch, evaluate surfaces error,
|
catch error, try Right, try Left, nested catch, evaluate surfaces error,
|
||||||
throwIO propagates, handle alias).
|
throwIO propagates, handle alias).
|
||||||
- [ ] Conformance programs:
|
- [x] Conformance programs:
|
||||||
- `safediv.hs` — safe division using `catch`; divide-by-zero raises,
|
- `safediv.hs` — safe division using `catch`; divide-by-zero raises,
|
||||||
handler returns 0.
|
handler returns 0.
|
||||||
- `trycatch.hs` — `try` pattern: run an action, branch on Left/Right.
|
- `trycatch.hs` — `try` pattern: run an action, branch on Left/Right.
|
||||||
|
|
||||||
|
### Phase 17 — Parser polish
|
||||||
|
|
||||||
|
Real Haskell programs use these on every page; closing the gaps unblocks
|
||||||
|
larger conformance programs and removes one-line workarounds in test sources.
|
||||||
|
|
||||||
|
- [ ] Type annotations in expressions: `(x :: Int)`, `f (1 :: Int)`,
|
||||||
|
`return (42 :: Int)`. Parser currently rejects `::` in `aexp` position;
|
||||||
|
desugar should drop the annotation (we have no inference at this layer
|
||||||
|
yet, so it's a parse-only pass-through).
|
||||||
|
- [ ] `import` declarations anywhere at the start of a module — currently
|
||||||
|
only the very-top-of-file form is recognised. Real test programs that
|
||||||
|
mix prelude code with `import qualified Data.IORef` need this.
|
||||||
|
- [ ] Multi-line top-level `where` blocks (`where { ... }` with explicit
|
||||||
|
braces and semicolons, in addition to the layout-driven form).
|
||||||
|
- [ ] Tests for the above in `lib/haskell/tests/parse-extras.sx` (≥ 8).
|
||||||
|
|
||||||
|
### Phase 18 — One ambitious conformance program
|
||||||
|
|
||||||
|
Pick something nontrivial that exercises feature interactions the small
|
||||||
|
suites miss; this is the only way to find unknown-unknown bugs.
|
||||||
|
|
||||||
|
- [ ] Choose a target. Candidates:
|
||||||
|
- **Tiny lambda-calculus interpreter** (~80 LOC): parser, eval, env,
|
||||||
|
test cases. Stresses ADTs + records + recursion + `IORef` for state.
|
||||||
|
- **Dijkstra shortest-path** on a small graph using `Data.Map` +
|
||||||
|
`Data.Set`. Stresses Map/Set correctness end-to-end.
|
||||||
|
- **JSON parser** (subset): recursive-descent, exception-on-error,
|
||||||
|
`Either ParseError Value` results. Stresses strings + Either + try.
|
||||||
|
- [ ] Adapt minimally; cite source as a comment.
|
||||||
|
- [ ] Add to `conformance.conf`; verify scoreboard stays green.
|
||||||
|
|
||||||
|
### Phase 19 — Conformance speed
|
||||||
|
|
||||||
|
The full suite re-pays the ~30 s cold-load cost per program; 36 programs ⇒
|
||||||
|
~25 minutes. Driving them all through one sx_server session would compress
|
||||||
|
that to single-digit minutes.
|
||||||
|
|
||||||
|
- [ ] In `conformance.sh` (and/or `lib/guest/conformance.sh`), batch all
|
||||||
|
suites into one process: load preloads once, then for each suite emit
|
||||||
|
an `(epoch N)` + `(load …)` + `(eval read-counters)` + `(eval reset-
|
||||||
|
counters)` block. Aggregate the per-suite results from the streamed
|
||||||
|
output.
|
||||||
|
- [ ] Make sure a single failing/hanging suite doesn't poison the rest —
|
||||||
|
per-suite timeout via a server-side guard, or fall back to per-process
|
||||||
|
on timeout.
|
||||||
|
- [ ] Verify the scoreboard output is byte-identical to the old per-process
|
||||||
|
driver, then keep the per-process path as `--isolated` for debugging.
|
||||||
|
|
||||||
## Progress log
|
## Progress log
|
||||||
|
|
||||||
_Newest first._
|
_Newest first._
|
||||||
|
|
||||||
|
**2026-05-08** — Phase 16 Exception handling complete (6 ops + module wiring +
|
||||||
|
14 unit tests + 2 conformance programs). `hk-bind-exceptions!` in `eval.sx`
|
||||||
|
registers `throwIO`, `throw`, `evaluate`, `catch`, `try`, `handle`, and
|
||||||
|
`displayException`. `SomeException` constructor pre-registered in
|
||||||
|
`runtime.sx`. `throwIO` and the `error` primitive both raise via SX `raise`
|
||||||
|
with a uniform `"hk-error: msg"` string; catch/try/handle parse this string
|
||||||
|
back into a `SomeException` via `hk-exception-of` (which strips nested
|
||||||
|
`Unhandled exception: "..."` host wraps and the `hk-error: ` prefix). catch
|
||||||
|
and handle evaluate the handler outside the guard scope, so a re-throw from
|
||||||
|
the handler propagates past this catch (matching Haskell semantics, not an
|
||||||
|
infinite loop). Phase 16 phase complete: scoreboard now 285/285 tests,
|
||||||
|
36/36 programs.
|
||||||
|
|
||||||
|
**2026-05-07** — Fix string ↔ `[Char]` equality. `reverse`/`length`/`head`/etc.
|
||||||
|
on a string transparently coerce to a cons-list of char codes via `hk-str-head`
|
||||||
|
+ `hk-str-tail`, but `(==)` then compared the original raw string against the
|
||||||
|
char-code cons-list and always returned False. Added `hk-try-charlist-to-string`
|
||||||
|
+ `hk-normalize-for-eq` in `eval.sx` and routed `==` / `/=` through them, so a
|
||||||
|
string compares equal to any cons-list whose elements are valid Unicode code
|
||||||
|
points spelling the same characters (and `[]` ↔ `""`). palindrome.hs now 12/12;
|
||||||
|
conformance lifts to 34/34 programs, **269/269 tests** — full green.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 15 IORef complete (5 ops + module wiring + 13 unit
|
||||||
|
tests + 2 conformance programs). `hk-bind-data-ioref!` in `eval.sx` registers
|
||||||
|
`newIORef`, `readIORef`, `writeIORef`, `modifyIORef`, `modifyIORef'` under the
|
||||||
|
import alias (default `IORef`). Representation: dict `{"hk-ioref" true
|
||||||
|
"hk-value" v}` allocated inside `IO`. Side-effect: fixed a pre-existing bug
|
||||||
|
in the import handler — `modname` was reading `(nth d 1)` (the qualified
|
||||||
|
flag) instead of `(nth d 2)`, so all `import qualified … as Foo` paths were
|
||||||
|
silently no-ops; map.sx unit suite jumps from 22→26 passing as a result.
|
||||||
|
Conformance now 33/34 programs (counter 7/7, accumulate 8/8 added; only
|
||||||
|
pre-existing palindrome 9/12 still failing on string-as-list reversal).
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 14 conformance: person.hs (7/7) + config.hs (10/10) → Phase 14 complete:
|
||||||
|
- `program-person.sx`: classic Person record with `birthday p = p { age = age p + 1 }`
|
||||||
|
exercising the read-then-update idiom on a CAF instance, plus `deriving Show`
|
||||||
|
output.
|
||||||
|
- `program-config.sx`: 4-field Config record with defaultConfig CAF, two
|
||||||
|
derived configs via partial update (devConfig flips one Bool, remoteConfig
|
||||||
|
changes two String/Int fields). 10 tests covering both branches preserve
|
||||||
|
the unchanged fields.
|
||||||
|
- Both added to `PROGRAMS` in `conformance.sh`. Phase 14 fully complete.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 14 unit tests `tests/records.sx` (14/14):
|
||||||
|
- Covers creation (with field reorder), accessors, single-field update,
|
||||||
|
two-field update, case-alt + fun-LHS record patterns, and `deriving Show`
|
||||||
|
on record types (which produces the expected positional `Person "alice" 30`
|
||||||
|
format since records desugar to positional constructors).
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 14 record patterns `Foo { bar = b }`:
|
||||||
|
- Parser: `hk-parse-pat-lhs` now peeks for `{` after a conid; if found, calls
|
||||||
|
`hk-parse-rec-pat` which collects `(fname pat)` pairs and emits `:p-rec`.
|
||||||
|
- Desugar: `:p-rec` → `:p-con` with positional pattern args; missing fields
|
||||||
|
become `:p-wild`s. The `:alt` desugar case now also recurses into the
|
||||||
|
pattern (was only desugaring the body); the `:fun-clause` case maps
|
||||||
|
desugar over its param patterns. Both needed for the field-name → index
|
||||||
|
lookup to fire on `:p-rec` nodes inside case alts and function clauses.
|
||||||
|
- Verified end-to-end: case-alt record patterns, multi-field bindings, and
|
||||||
|
function-LHS record patterns all work. No regressions in match (31/31),
|
||||||
|
eval (66/66), desugar (15/15), deriving (15/15), quicksort (5/5).
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 14 record-update syntax `r { field = v }`:
|
||||||
|
- Parser: `varid {` after a primary expression now triggers
|
||||||
|
`hk-parse-rec-update` returning `(:rec-update record-expr [(fname expr) …])`.
|
||||||
|
(Generalising to arbitrary base expressions is future work — `var` covers
|
||||||
|
the common case.)
|
||||||
|
- Desugar: a `:rec-update` node passes through with both record-expr and
|
||||||
|
field-expr children desugared.
|
||||||
|
- Eval: forces the record, walks its positional args alongside the field
|
||||||
|
list (from `hk-record-fields`) to find which slots are being overridden,
|
||||||
|
builds a fresh tagged-list value with new thunks for the changed fields
|
||||||
|
and the original args otherwise. Multi-field update works. Verified end-
|
||||||
|
to-end on `alice { age = 31 }` (only age changes; name preserved). No
|
||||||
|
regressions in eval / match / desugar suites.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 14 record-creation syntax `Foo { f = e, … }`:
|
||||||
|
- Parser: post-`conid` peek for `{` triggers `hk-parse-rec-create`, returning
|
||||||
|
`(:rec-create cname [(fname expr) …])`.
|
||||||
|
- `hk-record-fields` dict (in desugar.sx — load order requires it live there)
|
||||||
|
is populated by `hk-expand-records` when it sees a `con-rec`.
|
||||||
|
- New `:rec-create` case in `hk-desugar` looks up the field order, builds an
|
||||||
|
`app` chain `(:app (:app (:con cname) e1) e2 …)` in declared order. Field-
|
||||||
|
pair lookup via new `hk-find-rec-pair` helper. Order in source doesn't
|
||||||
|
matter — `Person { age = 99, name = "bob" }` correctly produces a Person
|
||||||
|
with name="bob", age=99 regardless of source order.
|
||||||
|
- Verified via direct execution; no regressions in parse/desugar/deriving.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 14 record desugar (`:con-rec` → positional + accessors):
|
||||||
|
- New `hk-record-accessors` helper in `desugar.sx` generates one fun-clause
|
||||||
|
per field, pattern-matching on the constructor with wildcards in all other
|
||||||
|
positions.
|
||||||
|
- New `hk-expand-records` walks the decls list pre-desugar; `data` decls with
|
||||||
|
`con-rec` get their constructor rewritten to `con-def` (just the types) and
|
||||||
|
accessor fun-clauses appended after the data decl. Other decls pass through.
|
||||||
|
- Wired into the `program` and `module` cases of `hk-desugar`. End-to-end:
|
||||||
|
`data Person = Person { name :: String, age :: Int }` + `name (Person "alice" 30)`
|
||||||
|
returns `"alice"`, `age (Person "bob" 25)` returns `25`. No regressions in
|
||||||
|
parse / desugar / deriving.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 14 record parser: `data Foo = Foo { name :: T, … }`:
|
||||||
|
- Extended `hk-parse-con-def` to peek for `{` after the constructor name; if
|
||||||
|
found, parse `varid :: type` pairs separated by commas, terminate with `}`,
|
||||||
|
return `(:con-rec name [(fname ftype) …])`. Positional constructors fall
|
||||||
|
through to the existing `:con-def` path. Verified record parses; no
|
||||||
|
regressions in parse.sx (43/43), parser-decls (24/24), deriving (15/15).
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 13 conformance: shapes.hs (5/5) → Phase 13 complete:
|
||||||
|
- `class Shape` with a default `perimeter` (using a where-clause inside the
|
||||||
|
default body), two instances `Square` / `Rect` — Square overrides
|
||||||
|
`perimeter`, Rect's `perimeter` uses a where-bound `peri`. 5/5 across
|
||||||
|
area, perimeter (override), perimeter-via-where, sum. Phase 13 fully
|
||||||
|
complete.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 13 Num-style default verification (negate/abs):
|
||||||
|
- `MyNum` class with subtract + lt as the operating primitives. Defaults for
|
||||||
|
`myNegate x` and `myAbs x` derive zero via `mySub x x`. Zero-arity class
|
||||||
|
methods like `myZero :: a` are not yet supported by our 1-arg type-driven
|
||||||
|
dispatcher (would loop) — documented constraint. 3 new tests, 13/13 total.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 13 Ord-style default verification:
|
||||||
|
- Added 5 tests to `class-defaults.sx` for myMax/myMin defined as defaults
|
||||||
|
in terms of `myCmp` (≥). Verified myMax/myMin on (3,5), (8,2), (4,4).
|
||||||
|
Suite is now 10/10.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 13 Eq-style default verification:
|
||||||
|
- New `tests/class-defaults.sx` (5 tests) seeds the class-defaults test file.
|
||||||
|
Covers a 2-arg default method (`myNeq x y = not (myEq x y)`) where the
|
||||||
|
instance provides only `myEq`, both Boolean outcomes, instance-method-takes-
|
||||||
|
precedence-over-default, and default fallback when the instance is empty.
|
||||||
|
All 5 pass.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 13 default method implementations + dispatch fallback:
|
||||||
|
- class-decl handler now also registers fun-clause method bodies under
|
||||||
|
`__default__ClassName_method` (paralleling the type-sig dispatcher pass).
|
||||||
|
- Dispatcher rewritten as nested `if`s: instance dict has the method →
|
||||||
|
use it; else look up default → use it; else raise. Earlier attempt with
|
||||||
|
`cond + and` infinite-looped — switched to plain `if` form which works.
|
||||||
|
- Both regular dispatch (`describe x = "a boolean"` instance) and default
|
||||||
|
fallback (`hello x = "hi"` default with empty instance body) verified.
|
||||||
|
No regressions in class/deriving/instance-where/eval suites.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 13 `where`-clauses in `instance` bodies:
|
||||||
|
- Bug discovered: `hk-desugar` didn't recurse into `instance-decl` method
|
||||||
|
bodies, so a `where`-form in an instance method survived to eval and hit
|
||||||
|
`eval: unknown node tag 'where'`. Fix: added an `instance-decl` case to
|
||||||
|
the desugarer that maps `hk-desugar` over the method-decls list. The
|
||||||
|
existing `fun-clause` branch then desugars each method body, including
|
||||||
|
the where → let lifting.
|
||||||
|
- 4 tests in new `tests/instance-where.sx`: where-helper with literal
|
||||||
|
pattern matching, references reused multiple times, and multi-binding
|
||||||
|
where. Verified no regression in class.sx (14/14), deriving.sx (15/15),
|
||||||
|
desugar.sx (15/15).
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 12 conformance: uniquewords.hs (4/4) + setops.hs (8/8) → Phase 12 complete:
|
||||||
|
- `program-uniquewords.sx`: `foldl Set.insert` over a word list, then check
|
||||||
|
`Set.size`/`member`. 4/4.
|
||||||
|
- `program-setops.sx`: full set algebra — union/intersection/difference/
|
||||||
|
isSubsetOf with three sets s1, s2, s3 chosen so each operation has both a
|
||||||
|
positive and negative test. 8/8.
|
||||||
|
- Both added to `PROGRAMS` in `conformance.sh`. Phase 12 fully complete.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 12 unit tests `tests/set.sx` (17/17):
|
||||||
|
- 13 SX-level direct calls + 4 end-to-end via `import qualified Data.Set`.
|
||||||
|
Covers all the API + dedupe behavior. Suite is 17/17.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 12 module wiring: `import Data.Set`:
|
||||||
|
- New `hk-bind-data-set!` registers `Set.empty/singleton/insert/delete/
|
||||||
|
member/size/null/union/intersection/difference/isSubsetOf` as Haskell
|
||||||
|
builtins.
|
||||||
|
- Import handler now dispatches on modname: `Data.Map` → `hk-bind-data-map!`,
|
||||||
|
`Data.Set` → `hk-bind-data-set!`. Default alias is now derived from the
|
||||||
|
modname suffix instead of being hardcoded `Map` (was a bug for `Data.Set`).
|
||||||
|
- `test.sh` and `conformance.sh` load `set.sx` after `map.sx`.
|
||||||
|
- Verified `Set.size`, `Set.member`, `Set.union`, `Set.insert` from Haskell.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 12 Data.Set full API:
|
||||||
|
- Added `from-list`/`union`/`intersection`/`difference`/`is-subset-of`/
|
||||||
|
`filter`/`map`/`foldr`/`foldl` — all delegate to the corresponding
|
||||||
|
`hk-map-*` helpers with the value side ignored. `union`/`intersection`
|
||||||
|
use `hk-map-union-with`/`hk-map-intersection-with` with a constant
|
||||||
|
unit-returning combine fn. Spot-check confirms set semantics: dedupe
|
||||||
|
on fromList, correct ⋃/∩/− and isSubsetOf.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 12 Data.Set skeleton (wraps Data.Map with unit values):
|
||||||
|
- New `lib/haskell/set.sx`. `hk-set-empty/singleton/insert/delete/member/
|
||||||
|
size/null/to-list` all delegate to the corresponding `hk-map-*`. Storage
|
||||||
|
representation matches Map nodes; values are always `("Tuple")` (unit).
|
||||||
|
This trades a small per-node memory overhead for a one-line implementation
|
||||||
|
of every set primitive — full BST balancing comes for free. Spot-checked.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 11 conformance: wordfreq.hs (7/7) + mapgraph.hs (6/6) → Phase 11 complete:
|
||||||
|
- Extended `hk-bind-data-map!` with `Map.insertWith`, `Map.adjust`, and
|
||||||
|
`Map.findWithDefault` so the conformance programs have what they need.
|
||||||
|
- `program-wordfreq.sx`: word-frequency histogram, `foldl Map.insertWith Map.empty`.
|
||||||
|
- `program-mapgraph.sx`: adjacency list, `Map.findWithDefault [] n g` for
|
||||||
|
default-empty neighbors.
|
||||||
|
- Both added to `PROGRAMS` in `conformance.sh`. Phase 11 fully complete.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 11 unit tests `tests/map.sx` (26/26):
|
||||||
|
- 22 SX-level direct calls (empty/singleton/insert/lookup/delete/member/
|
||||||
|
fromList+duplicates/toAscList/elems/unionWith/intersectionWith/difference/
|
||||||
|
foldlWithKey/mapWithKey/filterWithKey/adjust/insertWith/alter) plus 4
|
||||||
|
end-to-end via `import qualified Data.Map as Map`. Plan asked for ≥20.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 11 module wiring: `import Data.Map`:
|
||||||
|
- Added `hk-bind-data-map!` helper in `eval.sx` that registers
|
||||||
|
`<alias>.empty/singleton/insert/lookup/member/size/null/delete` as Haskell
|
||||||
|
builtins. Default alias is `"Map"`.
|
||||||
|
- New `:import` case in `hk-bind-decls!` dispatches to `hk-bind-data-map!`
|
||||||
|
when modname = `"Data.Map"`. Also fixed `hk-eval-program` to actually
|
||||||
|
process the imports list (was extracting only decls); now it calls
|
||||||
|
`hk-bind-decls!` once on imports, then once on decls.
|
||||||
|
- `test.sh` and `conformance.sh` now load `lib/haskell/map.sx` after
|
||||||
|
`eval.sx` so the BST functions exist when the import handler binds.
|
||||||
|
- Verified `import qualified Data.Map as Map` and `import Data.Map`
|
||||||
|
(default alias) resolve `Map.empty`, `Map.insert`, `Map.lookup`, `Map.size`,
|
||||||
|
`Map.member` correctly.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 11 updating (adjust/insertWith/insertWithKey/alter):
|
||||||
|
- `adjust` recurses to find the key, replaces value with `f(v)`; no-op when
|
||||||
|
missing. `insertWith` and `insertWithKey` recurse with rebalance and use
|
||||||
|
`f new old` (or `f k new old`) when the key exists. `alter` is the most
|
||||||
|
general, implemented as `lookup → f → either delete or insert`.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 11 transforming (foldlWithKey/foldrWithKey/mapWithKey/filterWithKey):
|
||||||
|
- Folds traverse in-order. `foldlWithKey f acc m` walks left → key/val → right
|
||||||
|
threading the accumulator, so left-folding `(\acc k v -> acc ++ k ++ v)` over
|
||||||
|
a 3-key map yields `"1a2b3c"`. `foldrWithKey` runs right → key/val → left so
|
||||||
|
the cons-style accumulator `(\k v acc -> k ++ v ++ acc)` produces the same
|
||||||
|
string.
|
||||||
|
- `mapWithKey` rebuilds the tree node-by-node (no rebalancing needed — keys
|
||||||
|
unchanged so the existing structure stays valid). `filterWithKey` is a
|
||||||
|
`foldrWithKey` that re-inserts kept entries; rebalances via insert.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 11 combining (unionWith/intersectionWith/difference):
|
||||||
|
- All three implemented via `reduce` over the smaller map's `to-asc-list`,
|
||||||
|
inserting / skipping into the result. Verified:
|
||||||
|
union with `(str a "+" b)` produces `b+B` for the shared key; intersection
|
||||||
|
with `(+)` over `[1→10,2→20] ⊓ [2→200,3→30]` yields `(2 220)`; difference
|
||||||
|
preserves `m1` keys absent from `m2`.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 11 bulk operations (fromList/toList/toAscList/keys/elems):
|
||||||
|
- `hk-map-from-list` uses SX `reduce` — left-to-right, so duplicates resolve
|
||||||
|
with last-wins (matches GHC `fromList`). `to-asc-list` is in-order recursive
|
||||||
|
traversal returning `(list (list k v) ...)`. `to-list` aliases `to-asc-list`.
|
||||||
|
`keys` and `elems` are similar in-order extracts. All take SX-level pairs;
|
||||||
|
the Haskell-layer wiring (next iterations) translates Haskell cons + tuple
|
||||||
|
representations.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 11 core operations on `Data.Map` BST:
|
||||||
|
- Added `hk-map-singleton`, `hk-map-insert`, `hk-map-lookup`, `hk-map-delete`,
|
||||||
|
`hk-map-member`, `hk-map-null`. Insert recurses with `hk-map-balance` to
|
||||||
|
maintain weight invariants. Lookup returns `("Just" v)` / `("Nothing")` —
|
||||||
|
matches Haskell ADT layout. Delete uses a `hk-map-glue` helper that picks
|
||||||
|
the larger subtree and pulls its extreme element to the root, preserving
|
||||||
|
balance without imperative state. Spot-checked: insert+lookup hit/miss,
|
||||||
|
member, delete root with successor pulled from right.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 11 BST skeleton in `lib/haskell/map.sx`:
|
||||||
|
- Adams-style weight-balanced tree: node = `("Map-Node" k v l r size)`,
|
||||||
|
empty = `("Map-Empty")`. delta=3 / gamma=2 ratios. Implemented constructors
|
||||||
|
+ accessors + the four rotations (single-l, single-r, double-l, double-r)
|
||||||
|
+ `hk-map-balance` smart constructor that picks the rotation. Spot-checked
|
||||||
|
with eval calls; user-facing operations (insert/lookup/etc.) come next.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 10 conformance: statistics.hs (5/5) + newton.hs (5/5) → Phase 10 complete:
|
||||||
|
- `program-statistics.sx`: mean / variance / stdDev on a [Double], exercising
|
||||||
|
`sum`, `map`, `fromIntegral`, `/`, `sqrt`. 5/5.
|
||||||
|
- `program-newton.sx`: Newton's method for sqrt, exercising `abs`, `/`, `*`,
|
||||||
|
recursion termination on tolerance 0.0001, and `(<)` to assert convergence
|
||||||
|
to within 0.001 of the true value. 5/5.
|
||||||
|
- Both added to `PROGRAMS` in `conformance.sh`. Phase 10 fully complete.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 10 numerics test file checkbox (filename divergence):
|
||||||
|
- Plan called for `lib/haskell/tests/numeric.sx`. From the very first Phase 10
|
||||||
|
iteration I created `numerics.sx` (plural) and have been growing it. Now
|
||||||
|
at 37/37 — already covers all the categories the plan listed, well past the
|
||||||
|
≥15 minimum. Ticked the box; left a note about the filename divergence.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 10 Floating stub (pi, exp, log, sin, cos, **):
|
||||||
|
- pi as a number constant; exp/log/sin/cos as builtins thunking through to SX
|
||||||
|
primitives. `(**)` added as a binop case in `hk-binop` mapping to SX `pow`.
|
||||||
|
6 new tests in `numerics.sx` (now 37/37). `2 ** 10 = 1024`, `log (exp 5) = 5`,
|
||||||
|
`sin 0 = 0`, `cos 0 = 1`, `pi ≈ 3.14159`, `exp 0 = 1`.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 10 Fractional stub (recip, fromRational):
|
||||||
|
- `(/)` already a binop. Added `recip` and `fromRational` as builtins
|
||||||
|
post-prelude. 3 new tests in `numerics.sx` (now 31/31).
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 10 math builtins (sqrt/floor/ceiling/round/truncate):
|
||||||
|
- Inserted in the post-prelude `begin` block so they override the prelude's
|
||||||
|
identity stubs. `ceiling` is the only one needing a definition (SX doesn't
|
||||||
|
ship one — derived from `floor`). `sqrt`, `floor`, `round`, `truncate`
|
||||||
|
thunk through to SX primitives. 6 new tests in `numerics.sx` (now 28/28).
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 10 Float display through `hk-show-val`:
|
||||||
|
- Added `hk-show-num` and `hk-show-float-sci` helpers in `eval.sx`. Number
|
||||||
|
formatting: `integer?` → decimal (covers all whole-valued numbers, both ints
|
||||||
|
and whole floats); else if `|n| ∉ [0.1, 10^7)` → scientific (`1.0e-3`); else
|
||||||
|
→ decimal with `.0` suffix.
|
||||||
|
- `show 3.14` = `"3.14"`, `show 0.001` = `"1.0e-3"`, `show -3.14` = `"-3.14"`.
|
||||||
|
- Limit: `show 1.0e10` renders as `"10000000000"` instead of `"1.0e10"` —
|
||||||
|
Haskell distinguishes `42` from `42.0` via type, we don't. Documented.
|
||||||
|
- 4 new tests in `numerics.sx`. Suite is now 22/22.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 10 `toInteger` / `fromInteger` verified (prelude identities):
|
||||||
|
- Both already declared as `x = x` in `hk-prelude-src`. Added 4 tests in
|
||||||
|
`numerics.sx` (positive, identity round-trip, negative-via-negate, fromInteger
|
||||||
|
smoke). Suite now 18/18.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 10 `fromIntegral` verified (already an identity in prelude):
|
||||||
|
- Pre-existing `fromIntegral x = x` line in `hk-prelude-src` was already
|
||||||
|
correct — all numbers share one SX type, so the identity implementation is
|
||||||
|
exactly what the plan asked for. Added 4 tests in `numerics.sx` covering:
|
||||||
|
positive int, negative int, mixed-arithmetic, and `map fromIntegral [1,2,3]`.
|
||||||
|
Suite is now 14/14.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 10 large-integer audit (numerics.sx 10/10):
|
||||||
|
- Investigated SX number behavior in Haskell context. Findings:
|
||||||
|
• Raw SX `*`, `+`, etc. on two ints stay exact up to ±2^62 (~4.6e18).
|
||||||
|
• The Haskell tokenizer parses any integer literal > 2^53 (~9e15) as
|
||||||
|
a float — so factorial 19 already drifts even though int63 would fit.
|
||||||
|
• Once any operand is float, ops promote and decimal precision is lost.
|
||||||
|
• `Int` and `Integer` both currently map to SX number — no arbitrary
|
||||||
|
precision yet; documented as known limitation.
|
||||||
|
- New `tests/numerics.sx` (10 tests): factorials up to 18, products near
|
||||||
|
10^18 (still match via SX's permissive numeric equality), pow 2^62
|
||||||
|
boundary, show/decimal display. Header comment captures the practical
|
||||||
|
limit.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 9 conformance: `partial.hs` (7/7) → Phase 9 complete:
|
||||||
|
- New `tests/program-partial.sx` exercising `head []`, `tail []`,
|
||||||
|
`fromJust Nothing`, `undefined`, and user `error` from inside a `do` block;
|
||||||
|
verifies the error message lands in `hk-run-io`'s `io-lines`. Also a happy-
|
||||||
|
path test (`head [42] = 42`) and a "putStrLn before error preserves prior
|
||||||
|
output, never reaches subsequent action" test.
|
||||||
|
- Added `partial` to `PROGRAMS` in `conformance.sh`. Phase 9 done.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 9 `tests/errors.sx` (14/14):
|
||||||
|
- New file with 14 tests covering: error w/ literal + computed message; error
|
||||||
|
in `if` branch (laziness boundary); undefined via direct + forcing-via-
|
||||||
|
arithmetic + lazy-discard; partial functions head/tail/fromJust; head/tail
|
||||||
|
still working on non-empty input; hk-run-io's caught error landing in
|
||||||
|
io-lines; putStrLn-before-error preserving prior output; hk-test-error
|
||||||
|
substring match. Spec called for ≥10.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 9 `hk-test-error` helper in testlib.sx:
|
||||||
|
- New 0-arity-thunk-based assertion: `(hk-test-error name thunk substr)` —
|
||||||
|
evaluates `(thunk)`, expects an exception, checks `index-of` for the given
|
||||||
|
substring in the caught (string-coerced) value. Increments `hk-test-pass` on
|
||||||
|
match, otherwise records into `hk-test-fails` with descriptive expected.
|
||||||
|
- Added 2 quick uses to `tests/eval.sx` (error and head []). Suite now 66/66.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 9 `hk-run-io` catches errors, appends to io-lines:
|
||||||
|
- Wrapped both `hk-run-io` and `hk-run-io-with-input` in `(guard (e (true …)))`
|
||||||
|
that appends the caught exception to `hk-io-lines`. Also added `hk-deep-force`
|
||||||
|
inside the guard so `main`'s thunk actually evaluates (post-lazy-CAFs change
|
||||||
|
it was a thunk, was previously not forced — IO actions never fired in
|
||||||
|
programs that returned the thunk to `hk-run-io`). Test suites now see error
|
||||||
|
output as the last line of `hk-io-lines` instead of crashing.
|
||||||
|
- Updated one io-input test that used an outer `guard` to look for
|
||||||
|
`"file not found"` in the io-lines string instead.
|
||||||
|
- Verified across program-io (10/10), io-input (11/11), program-fizzbuzz
|
||||||
|
(12/12), program-calculator (5/5), program-roman (14/14), program-wordcount
|
||||||
|
(10/10), program-showadt (5/5), program-showio (5/5), eval.sx (64/64).
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 9 partial functions emit proper error messages:
|
||||||
|
- Added empty-list catch clauses to `head`, `tail` in the prelude. Added
|
||||||
|
`fromJust`, `fromMaybe`, `isJust`, `isNothing` (the last three were missing).
|
||||||
|
`fromJust Nothing` raises `"Maybe.fromJust: Nothing"`. Multi-clause dispatch
|
||||||
|
tries the constructor pattern first, then falls through to the empty-list /
|
||||||
|
Nothing error clause.
|
||||||
|
- 5 new tests in `tests/eval.sx`. Suite is 64/64. Verified no regressions in
|
||||||
|
match, stdlib, fib, quicksort, program-maybe.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 9 `undefined = error "Prelude.undefined"` + lazy CAFs:
|
||||||
|
- Added `undefined = error "Prelude.undefined"` to `hk-prelude-src`. Without
|
||||||
|
any other change this raised at prelude-load time because `hk-bind-decls!`
|
||||||
|
was eagerly evaluating zero-arity definitions (CAFs). Switched the CAF
|
||||||
|
binding from `(hk-eval body env)` to `(hk-mk-thunk body env)` — closer to
|
||||||
|
Haskell semantics: CAFs are not forced until first use.
|
||||||
|
- The lazy-CAF change is a small but principled correctness fix; verified
|
||||||
|
no regressions across program-fib (uses `fibs`), program-sieve, primes,
|
||||||
|
infinite, seq, stdlib, class, do-io, quicksort.
|
||||||
|
- 2 new tests in `tests/eval.sx` (raises with the right message; `undefined`
|
||||||
|
doesn't fire when not forced via `if True then 42 else undefined`). 59/59.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 9 `error :: String -> a` raises with `hk-error:` prefix:
|
||||||
|
- Pre-existing `error` builtin was raising `"*** Exception: <msg>"` (GHC
|
||||||
|
console convention). Renamed prefix to `"hk-error: "` so the wrap-around
|
||||||
|
string SX's `apply` produces (`"Unhandled exception: \"hk-error: ...\""`)
|
||||||
|
contains a stable, searchable tag.
|
||||||
|
- Investigation confirmed that the plan's intended `(raise (list "hk-error" msg))`
|
||||||
|
format is mangled by SX `apply` to a string. Plan note added; tests use
|
||||||
|
`index-of` substring matching against the wrapped string.
|
||||||
|
- 2 new tests in `tests/eval.sx` (string and computed-message form). Suite
|
||||||
|
is 57/57. Other test suites unchanged (match 31/31, stdlib 48/48, derive
|
||||||
|
15/15, do-io 16/16, class 14/14).
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 8 conformance: `showadt.hs` + `showio.hs` (both 5/5):
|
||||||
|
- `program-showadt.sx`: `deriving (Show)` on the classic `Expr = Lit | Add | Mul`
|
||||||
|
recursive ADT; tests `print` on three nested expressions and inline `show`
|
||||||
|
spot-checks (negative literal wrapped in parens; fully nested Mul of Adds).
|
||||||
|
- `program-showio.sx`: `print` on Int, Bool, list, tuple, Maybe, String, ADT
|
||||||
|
inside a `do` block; verifies one io-line per `print`.
|
||||||
|
- Both added to `PROGRAMS` in `conformance.sh`. Phase 8 conformance complete.
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 8 `tests/show.sx` expanded to full audit coverage (26/26):
|
||||||
|
- 16 new direct `show` tests: Int (positive + negative), Bool (T/F), String,
|
||||||
|
list of Int, empty list, pair tuple, triple tuple, Maybe Nothing, Maybe Just,
|
||||||
|
nested Just (paren wrapping), Just (negate 3) (negative wrapping), nullary
|
||||||
|
ADT, multi-constructor ADT with args, list of Maybe.
|
||||||
|
- `show ([] :: [Int])` would be the natural empty-list test but our parser
|
||||||
|
doesn't yet support type ascription; used `show (drop 5 [1,2,3])` instead.
|
||||||
|
Char `'a'` → `"'a'"` deferred to Char-tagging design (Char = Int currently
|
||||||
|
yields `"97"`).
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 8 `Read` class stub (`reads`, `readsPrec`, `read`):
|
||||||
|
- Three lines added to `hk-prelude-src`: `reads s = []`, `readsPrec _ s = reads s`,
|
||||||
|
`read s = fst (head (reads s))`. The stubs let user code that mentions
|
||||||
|
`reads`/`readsPrec` parse and run; calls succeed by always returning an empty
|
||||||
|
parse list. `read` will throw a pattern-match failure at runtime — fine until
|
||||||
|
Phase 9 `error` lands. No real parser needed per the plan.
|
||||||
|
- 3 new tests in `tests/show.sx` (now 10/10).
|
||||||
|
|
||||||
|
**2026-05-07** — Phase 8 `showsPrec` / `showParen` / `shows` / `showString` stubs:
|
||||||
|
- Added 5 lines to `hk-prelude-src`. `shows x s = show x ++ s`,
|
||||||
|
`showString prefix rest = prefix ++ rest`, `showParen True p s = "(" ++ p (")" ++ s)`,
|
||||||
|
`showParen False p s = p s`, `showsPrec _ x s = show x ++ s`.
|
||||||
|
- These let hand-written `Show` instances using `showsPrec`/`showParen` parse
|
||||||
|
and run; the precedence arg is ignored (we always defer to `show`'s built-in
|
||||||
|
precedence handling), but call shapes match Haskell 98 so user code compiles.
|
||||||
|
- New `lib/haskell/tests/show.sx` (7 tests). The file is intended to grow to
|
||||||
|
≥12 covering the full audit (Phase 8 ☐).
|
||||||
|
- Function composition `.` is not yet bound; tests use manual composition via
|
||||||
|
let-binding. Address in a later iteration.
|
||||||
|
|
||||||
|
**2026-05-06** — Phase 8 `deriving Show` nested constructor parens verified:
|
||||||
|
- The Phase 8 audit's precedence-based `hk-show-prec` already does the right
|
||||||
|
thing for `deriving Show`: each constructor arg is shown at prec 11, so any
|
||||||
|
inner constructor with args (or any negative number) gets parenthesised, while
|
||||||
|
nullary constructors and lists/tuples (whose own bracketing is unambiguous)
|
||||||
|
do not. Multi-constructor ADTs (e.g. `Tree = Leaf | Node …`) handled.
|
||||||
|
Records deferred to Phase 14.
|
||||||
|
- 4 new tests in `tests/deriving.sx` exercising nested ADT + Maybe-Maybe +
|
||||||
|
negative-arg + list-arg cases; suite is 15/15.
|
||||||
|
|
||||||
|
**2026-05-06** — Phase 8 `print` is `putStrLn (show x)` in prelude:
|
||||||
|
- Added `print x = putStrLn (show x)` to `hk-prelude-src` and removed the
|
||||||
|
standalone `print` builtin. `print` now resolves through the Haskell-level
|
||||||
|
Prelude path; lazy reference resolution handles the forward call to
|
||||||
|
`putStrLn` (registered after the prelude loads). `show` already calls
|
||||||
|
`hk-show-val` from the Phase 8 audit. do-io / program-fib / program-fizzbuzz
|
||||||
|
remain green.
|
||||||
|
|
||||||
|
**2026-05-06** — Phase 8 audit: `hk-show-val` matches Haskell 98 format:
|
||||||
|
- `eval.sx`: introduced `hk-show-prec v p` with precedence-based parens.
|
||||||
|
Top-level `show (Just 3)` = `"Just 3"` (no parens); nested `show (Just (Just 3))`
|
||||||
|
= `"Just (Just 3)"` (inner wrapped because called with prec ≥ 11). Negative
|
||||||
|
ints wrapped in parens at high prec for `show (Just (negate 1))` correctness.
|
||||||
|
- List/tuple separators changed from `", "` to `","` to match GHC.
|
||||||
|
- `hk-show-val` is now a thin shim: `(hk-show-prec v 0)`.
|
||||||
|
- Updated `tests/deriving.sx` (3 tests) and `tests/stdlib.sx` (7 tests) to the
|
||||||
|
new format. `Char` single-quote output and string escape for `\n`/`\t`
|
||||||
|
deferred — Char = Int representation prevents disambiguation in show.
|
||||||
|
|
||||||
|
**2026-05-06** — Phase 7 conformance complete (runlength-str.hs) + `++` thunk fix:
|
||||||
|
- New `lib/haskell/tests/program-runlength-str.sx` (9 tests). Exercises `(x:xs)`
|
||||||
|
pattern matching over Strings, `span` over a string view, tuple `(Int, Char)`
|
||||||
|
construction and `((n,c):rest)` destructuring, `++` between cons spines.
|
||||||
|
- `runlength-str` added to `PROGRAMS` in `conformance.sh`.
|
||||||
|
- `eval.sx`: `hk-list-append` now `(hk-force a)` on entry. Pre-existing latent
|
||||||
|
bug — when a cons's tail was a thunk (e.g. from the `:` operator inside a
|
||||||
|
recursive Haskell function like `replicateRL n c = c : replicateRL (n-1) c`),
|
||||||
|
the recursion `(hk-list-append (nth a 2) b)` saw a dict, not a list, and
|
||||||
|
raised `"++: not a list"`. Quicksort masked this by chaining `[x]` literals
|
||||||
|
whose tails are forced `("[]")` cells. Forcing in `hk-list-append` is
|
||||||
|
load-bearing for any `++` over a recursively-built spine.
|
||||||
|
|
||||||
|
**2026-05-06** — Phase 7 conformance (caesar.hs):
|
||||||
|
- New `lib/haskell/tests/program-caesar.sx` (8 tests). Caesar cipher exercising
|
||||||
|
`chr`, `ord`, `isUpper`, `isLower`, `mod`, `map`, and `(x:xs)` pattern matching
|
||||||
|
over native String values via the Phase 7 string-view path. Adapted from
|
||||||
|
https://rosettacode.org/wiki/Caesar_cipher#Haskell.
|
||||||
|
- `caesar` added to `PROGRAMS` in `lib/haskell/conformance.sh`. Suite isolated:
|
||||||
|
8/8 passing. Note: `else chr c` in `shift` keeps the char-as-string output type
|
||||||
|
consistent with the alpha branches (pattern bind on a string view yields an int).
|
||||||
|
|
||||||
|
**2026-05-06** — Phase 7 complete (string-view O(1) head/tail + `++` native concat):
|
||||||
|
- `runtime.sx`: added `hk-str?`, `hk-str-head`, `hk-str-tail`, `hk-str-null?`.
|
||||||
|
String views are `{:hk-str buf :hk-off n}` dicts; native SX strings satisfy the
|
||||||
|
predicate with implicit offset 0. All helpers are O(1) via `char-at` / `string-length`.
|
||||||
|
- `eval.sx`: added `chr` (int → single-char string via `char-from-code`), `toUpper`,
|
||||||
|
`toLower` (ASCII-range arithmetic). Fixed `ord` and all char predicates (`isAlpha`,
|
||||||
|
`isAlphaNum`, `isDigit`, `isSpace`, `isUpper`, `isLower`, `digitToInt`) to accept
|
||||||
|
integers from string-view decomposition (not only single-char strings).
|
||||||
|
- `match.sx`: cons-pattern `":"` now checks `hk-str?` before the tagged-list path,
|
||||||
|
decomposing to `(hk-str-head, hk-str-tail)`. Empty-list pattern (`p-list []`) also
|
||||||
|
accepts `hk-str-null?` values. `hk-match-list-pat` updated to traverse string views
|
||||||
|
element-by-element.
|
||||||
|
- `runtime.sx`: added `hk-str-to-native` (converts view dict to native string via reduce+char-at).
|
||||||
|
- `eval.sx`: `hk-list-append` now checks `hk-str?` first; converts both operands via
|
||||||
|
`hk-str-to-native` before native `str` concat. String `++` String no longer builds
|
||||||
|
a cons spine.
|
||||||
|
- 35 new tests in `lib/haskell/tests/string-char.sx` (35/35 passing).
|
||||||
|
- Full suite: 810/810 tests, 0 regressions (was 775).
|
||||||
|
|||||||
@@ -158,8 +158,8 @@ Extract from `haskell/infer.sx`. Algorithm W or J, generalisation, instantiation
|
|||||||
| 4 — pratt.sx (lua + prolog) | [done] | da27958d | Extracted operator-table format + lookup only — climbing loops stay per-language because lua and prolog use opposite prec conventions. lua/parser.sx: 18-clause cond → 15-entry table. prolog/parser.sx: pl-op-find deleted, pl-op-lookup wraps pratt-op-lookup. lua 185/185, prolog 590/590 — both = baseline. |
|
| 4 — pratt.sx (lua + prolog) | [done] | da27958d | Extracted operator-table format + lookup only — climbing loops stay per-language because lua and prolog use opposite prec conventions. lua/parser.sx: 18-clause cond → 15-entry table. prolog/parser.sx: pl-op-find deleted, pl-op-lookup wraps pratt-op-lookup. lua 185/185, prolog 590/590 — both = baseline. |
|
||||||
| 5 — ast.sx (lua + prolog) | [partial — pending real consumers] | a774cd26 | Kit + 33 self-tests shipped (10 canonical kinds, predicates, accessors). Step is "Optional" per brief; lua/prolog parsers untouched (185/185 + 590/590). Datalog-on-sx will be the natural first real consumer; lua/prolog converters can land later. |
|
| 5 — ast.sx (lua + prolog) | [partial — pending real consumers] | a774cd26 | Kit + 33 self-tests shipped (10 canonical kinds, predicates, accessors). Step is "Optional" per brief; lua/prolog parsers untouched (185/185 + 590/590). Datalog-on-sx will be the natural first real consumer; lua/prolog converters can land later. |
|
||||||
| 6 — match.sx (haskell + prolog) | [partial — kit shipped; ports deferred] | 863e9d93 | Pure-functional unify + match kit (canonical wire format + cfg-driven adapters) + 25 self-tests. Existing prolog/haskell engines untouched (structurally divergent — mutating-symmetric vs pure-asymmetric — would risk 746 passing tests under brief's revert-on-regression rule). Real consumer is minikraken/datalog work in flight. |
|
| 6 — match.sx (haskell + prolog) | [partial — kit shipped; ports deferred] | 863e9d93 | Pure-functional unify + match kit (canonical wire format + cfg-driven adapters) + 25 self-tests. Existing prolog/haskell engines untouched (structurally divergent — mutating-symmetric vs pure-asymmetric — would risk 746 passing tests under brief's revert-on-regression rule). Real consumer is minikraken/datalog work in flight. |
|
||||||
| 7 — layout.sx (haskell + synthetic) | [in-progress] | — | — |
|
| 7 — layout.sx (haskell + synthetic) | [partial — haskell port deferred] | d75c61d4 | Configurable kit (haskell-style keyword-opens + python-style trailing-`:`-opens) + 6 self-tests covering both flavours. Synthetic Python-ish fixture passes; haskell/layout.sx untouched (kit not yet a drop-in for Haskell 98 Note 5 etc.; haskell still 156/156 baseline). |
|
||||||
| 8 — hm.sx (haskell + TBD) | [ ] | — | — |
|
| 8 — hm.sx (haskell + TBD) | [partial — algebra shipped; assembly deferred] | ab2c40c1 | HM foundations: types/schemes/ftv/apply/compose/generalize/instantiate/fresh-tv on top of match.sx unify, plus literal inference rule. 24/24 self-tests. Algorithm W lambda/app/let assembly deferred to host code — paired sequencing per brief: lib/ocaml/types.sx (OCaml-on-SX Phase 5) + haskell/infer.sx port. Haskell still 156/156 baseline. |
|
||||||
|
|
||||||
---
|
---
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user