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

haskell: deriving (Eq, Show) for ADTs (+11 tests, 565/565)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 34s
Details

Browse Source 
Parser parses optional deriving clause; only appended to AST when non-empty.
hk-bind-decls! data arm generates dictShow_Con / dictEq_Con per constructor.
hk-binop == and /= now deep-force both sides (SX dict equality is by
reference — two thunks wrapping the same value compared as not-equal without
this). Three token-type fixes in the deriving parser (lparen/rparen/comma,
not "special").

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-06 12:25:51 +00:00
parent 6c1a953c80
commit 1c45262577
4 changed files with 195 additions and 5 deletions
Download Patch File Download Diff File Expand all files Collapse all files

66
lib/haskell/eval.sx
View File

@@ -459,8 +459,9 @@
((= op "-") (- lv rv))
((= op "*") (* lv rv))
((= op "/") (/ lv rv))
((= op "==") (hk-of-bool (= lv rv)))
((= op "/=") (hk-of-bool (not (= lv rv))))
((= op "==") (hk-of-bool (= (hk-deep-force lv) (hk-deep-force rv))))
((= op "/=")
(hk-of-bool (not (= (hk-deep-force lv) (hk-deep-force rv)))))
((= op "<") (hk-of-bool (< lv rv)))
((= op "<=") (hk-of-bool (<= lv rv)))
((= op ">") (hk-of-bool (> lv rv)))
@@ -778,6 +779,67 @@
env
(str "dict" cls "_" (hk-type-to-runtime-key type-str))
inst-dict))))
((= (first d) "data")
(let
((deriving-list (if (> (len d) 4) (nth d 4) (list))))
(when
(not (empty? deriving-list))
(let
((cons-list (nth d 3)))
(for-each
(fn
(cls)
(for-each
(fn
(cdef)
(let
((con-name (nth cdef 1)))
(cond
((= cls "Show")
(let
((inst-dict (dict)))
(dict-set!
inst-dict
"show"
(hk-mk-lazy-builtin "show" hk-show-val 1))
(dict-set!
env
(str "dictShow_" con-name)
inst-dict)))
((= cls "Eq")
(let
((inst-dict (dict)))
(dict-set!
inst-dict
"=="
(hk-mk-builtin
"=="
(fn
(x y)
(hk-of-bool
(=
(hk-deep-force x)
(hk-deep-force y))))
2))
(dict-set!
inst-dict
"/="
(hk-mk-builtin
"/="
(fn
(x y)
(hk-of-bool
(not
(=
(hk-deep-force x)
(hk-deep-force y)))))
2))
(dict-set!
env
(str "dictEq_" con-name)
inst-dict))))))
cons-list))
deriving-list)))))
(:else nil)))
decls)
(let

32
lib/haskell/parser.sx
View File

@@ -1250,7 +1250,8 @@
(let
((name (get (hk-advance!) "value"))
(tvars (hk-parse-tvars))
(cons-list (list)))
(cons-list (list))
(deriving-list (list)))
(when
(hk-match? "reservedop" "=")
(do
@@ -1267,7 +1268,34 @@
(append! cons-list (hk-parse-con-def))
(hk-dc-loop)))))
(hk-dc-loop)))
(list :data name tvars cons-list))))
(when
(hk-match? "reserved" "deriving")
(do
(hk-advance!)
(cond
((hk-match? "lparen" nil)
(do
(hk-advance!)
(define
hk-der-loop
(fn
()
(when
(hk-match? "conid" nil)
(do
(append!
deriving-list
(get (hk-advance!) "value"))
(when (hk-match? "comma" nil) (hk-advance!))
(hk-der-loop)))))
(hk-der-loop)
(hk-expect! "rparen" nil)))
((hk-match? "conid" nil)
(append! deriving-list (get (hk-advance!) "value"))))))
(if
(empty? deriving-list)
(list :data name tvars cons-list)
(list :data name tvars cons-list deriving-list)))))
(define
hk-parse-class
(fn

84
lib/haskell/tests/deriving.sx Normal file
View File

@@ -0,0 +1,84 @@
;; deriving.sx — tests for deriving (Eq, Show) on ADTs.
;; ─── Show ────────────────────────────────────────────────────────────────────
(hk-test
"deriving Show: nullary constructor"
(hk-deep-force
(hk-run "data Color = Red | Green | Blue deriving (Show)\nmain = show Red"))
"Red")
(hk-test
"deriving Show: constructor with arg"
(hk-deep-force
(hk-run "data Wrapper = Wrap Int deriving (Show)\nmain = show (Wrap 42)"))
"(Wrap 42)")
(hk-test
"deriving Show: nested constructors"
(hk-deep-force
(hk-run
"data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf Leaf)"))
"(Node 1 Leaf Leaf)")
(hk-test
"deriving Show: second constructor"
(hk-deep-force
(hk-run
"data Color = Red | Green | Blue deriving (Show)\nmain = show Green"))
"Green")
;; ─── Eq ──────────────────────────────────────────────────────────────────────
(hk-test
"deriving Eq: same constructor"
(hk-deep-force
(hk-run
"data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red == Red)"))
"True")
(hk-test
"deriving Eq: different constructors"
(hk-deep-force
(hk-run
"data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red == Blue)"))
"False")
(hk-test
"deriving Eq: /= same"
(hk-deep-force
(hk-run
"data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Red)"))
"False")
(hk-test
"deriving Eq: /= different"
(hk-deep-force
(hk-run
"data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Blue)"))
"True")
;; ─── combined Eq + Show ───────────────────────────────────────────────────────
(hk-test
"deriving Eq Show: combined in parens"
(hk-deep-force
(hk-run
"data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 5)"))
"(Circle 5)")
(hk-test
"deriving Eq Show: eq on constructor with arg"
(hk-deep-force
(hk-run
"data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 3 == Circle 3)"))
"True")
(hk-test
"deriving Eq Show: different constructors with args"
(hk-deep-force
(hk-run
"data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 3 == Square 3)"))
"False")
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}