haskell: deriving (Eq, Show) for ADTs (+11 tests, 565/565)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 34s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 34s
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:
@@ -459,8 +459,9 @@
|
|||||||
((= op "-") (- lv rv))
|
((= op "-") (- lv rv))
|
||||||
((= op "*") (* lv rv))
|
((= op "*") (* lv rv))
|
||||||
((= op "/") (/ lv rv))
|
((= op "/") (/ lv rv))
|
||||||
((= op "==") (hk-of-bool (= lv rv)))
|
((= op "==") (hk-of-bool (= (hk-deep-force lv) (hk-deep-force rv))))
|
||||||
((= op "/=") (hk-of-bool (not (= lv rv))))
|
((= op "/=")
|
||||||
|
(hk-of-bool (not (= (hk-deep-force lv) (hk-deep-force rv)))))
|
||||||
((= op "<") (hk-of-bool (< lv rv)))
|
((= op "<") (hk-of-bool (< lv rv)))
|
||||||
((= op "<=") (hk-of-bool (<= lv rv)))
|
((= op "<=") (hk-of-bool (<= lv rv)))
|
||||||
((= op ">") (hk-of-bool (> lv rv)))
|
((= op ">") (hk-of-bool (> lv rv)))
|
||||||
@@ -778,6 +779,67 @@
|
|||||||
env
|
env
|
||||||
(str "dict" cls "_" (hk-type-to-runtime-key type-str))
|
(str "dict" cls "_" (hk-type-to-runtime-key type-str))
|
||||||
inst-dict))))
|
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)))
|
(:else nil)))
|
||||||
decls)
|
decls)
|
||||||
(let
|
(let
|
||||||
|
|||||||
@@ -1250,7 +1250,8 @@
|
|||||||
(let
|
(let
|
||||||
((name (get (hk-advance!) "value"))
|
((name (get (hk-advance!) "value"))
|
||||||
(tvars (hk-parse-tvars))
|
(tvars (hk-parse-tvars))
|
||||||
(cons-list (list)))
|
(cons-list (list))
|
||||||
|
(deriving-list (list)))
|
||||||
(when
|
(when
|
||||||
(hk-match? "reservedop" "=")
|
(hk-match? "reservedop" "=")
|
||||||
(do
|
(do
|
||||||
@@ -1267,7 +1268,34 @@
|
|||||||
(append! cons-list (hk-parse-con-def))
|
(append! cons-list (hk-parse-con-def))
|
||||||
(hk-dc-loop)))))
|
(hk-dc-loop)))))
|
||||||
(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
|
(define
|
||||||
hk-parse-class
|
hk-parse-class
|
||||||
(fn
|
(fn
|
||||||
|
|||||||
84
lib/haskell/tests/deriving.sx
Normal file
84
lib/haskell/tests/deriving.sx
Normal 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}
|
||||||
@@ -102,7 +102,7 @@ Key mappings:
|
|||||||
- [x] `class` / `instance` declarations
|
- [x] `class` / `instance` declarations
|
||||||
- [x] Dictionary-passing elaborator: inserts dict args at call sites
|
- [x] Dictionary-passing elaborator: inserts dict args at call sites
|
||||||
- [x] Standard classes: `Eq`, `Ord`, `Show`, `Num`, `Functor`, `Monad`, `Applicative`
|
- [x] Standard classes: `Eq`, `Ord`, `Show`, `Num`, `Functor`, `Monad`, `Applicative`
|
||||||
- [ ] `deriving (Eq, Show)` for ADTs
|
- [x] `deriving (Eq, Show)` for ADTs
|
||||||
|
|
||||||
### Phase 6 — real IO + Prelude completion
|
### Phase 6 — real IO + Prelude completion
|
||||||
- [ ] Real `IO` monad backed by `perform`/`resume`
|
- [ ] Real `IO` monad backed by `perform`/`resume`
|
||||||
@@ -114,6 +114,22 @@ Key mappings:
|
|||||||
|
|
||||||
_Newest first._
|
_Newest first._
|
||||||
|
|
||||||
|
- **2026-05-06** — Phase 5 `deriving (Eq, Show)`. Parser: `hk-parse-data` now
|
||||||
|
optionally parses a `deriving (Class1, Class2)` or `deriving Class` clause
|
||||||
|
after constructor definitions; result appended as 5th element only when
|
||||||
|
non-empty (no AST churn for existing decls). Three token-type fixes: the
|
||||||
|
deriving clause used `"special"` for `(`, `)`, `,` but the tokenizer
|
||||||
|
produces `"lparen"`, `"rparen"`, `"comma"`. Eval: `hk-bind-decls!` `data`
|
||||||
|
arm generates `dictShow_{Con}` and `dictEq_{Con}` dicts for each constructor
|
||||||
|
that appears in a `deriving` list. `Show` delegates to `hk-show-val` (lazy).
|
||||||
|
`Eq` needed structural equality — `hk-binop "=="` and `/=` now call
|
||||||
|
`hk-deep-force` on both sides before `=` (SX dict equality is by reference,
|
||||||
|
so two thunks wrapping the same number compared as not-equal without this).
|
||||||
|
11 new tests in `lib/haskell/tests/deriving.sx`: nullary Show, constructor
|
||||||
|
with arg, nested, second constructor, Eq same/different constructor, `/=`
|
||||||
|
same/different, combined `(Eq, Show)`, Eq with args, different constructors
|
||||||
|
with args. 565/565 green.
|
||||||
|
|
||||||
- **2026-05-06** — Phase 5 standard classes. Prelude extended: `foldr`, `foldl`,
|
- **2026-05-06** — Phase 5 standard classes. Prelude extended: `foldr`, `foldl`,
|
||||||
`foldl1`, `foldr1`, `zip`, `reverse`, `elem`, `notElem`, `any`, `all`, `and`,
|
`foldl1`, `foldr1`, `zip`, `reverse`, `elem`, `notElem`, `any`, `all`, `and`,
|
||||||
`or`, `sum`, `product`, `maximum`, `minimum`, `compare`, `min`, `max`,
|
`or`, `sum`, `product`, `maximum`, `minimum`, `compare`, `min`, `max`,
|
||||||
|
|||||||
Reference in New Issue
Block a user