From 1c452625778ecb9f160b28c63826229ba2e2a3cf Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 6 May 2026 12:25:51 +0000 Subject: [PATCH] haskell: deriving (Eq, Show) for ADTs (+11 tests, 565/565) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 --- lib/haskell/eval.sx | 66 ++++++++++++++++++++++++++- lib/haskell/parser.sx | 32 ++++++++++++- lib/haskell/tests/deriving.sx | 84 +++++++++++++++++++++++++++++++++++ plans/haskell-on-sx.md | 18 +++++++- 4 files changed, 195 insertions(+), 5 deletions(-) create mode 100644 lib/haskell/tests/deriving.sx diff --git a/lib/haskell/eval.sx b/lib/haskell/eval.sx index 2ead3e1e..c74a7b6b 100644 --- a/lib/haskell/eval.sx +++ b/lib/haskell/eval.sx @@ -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 diff --git a/lib/haskell/parser.sx b/lib/haskell/parser.sx index 5fc0fe4d..fcaefbd8 100644 --- a/lib/haskell/parser.sx +++ b/lib/haskell/parser.sx @@ -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 diff --git a/lib/haskell/tests/deriving.sx b/lib/haskell/tests/deriving.sx new file mode 100644 index 00000000..db120900 --- /dev/null +++ b/lib/haskell/tests/deriving.sx @@ -0,0 +1,84 @@ +;; deriving.sx — tests for deriving (Eq, Show) on ADTs. + +;; ─── Show ──────────────────────────────────────────────────────────────────── + +(hk-test + "deriving Show: nullary constructor" + (hk-deep-force + (hk-run "data Color = Red | Green | Blue deriving (Show)\nmain = show Red")) + "Red") + +(hk-test + "deriving Show: constructor with arg" + (hk-deep-force + (hk-run "data Wrapper = Wrap Int deriving (Show)\nmain = show (Wrap 42)")) + "(Wrap 42)") + +(hk-test + "deriving Show: nested constructors" + (hk-deep-force + (hk-run + "data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf Leaf)")) + "(Node 1 Leaf Leaf)") + +(hk-test + "deriving Show: second constructor" + (hk-deep-force + (hk-run + "data Color = Red | Green | Blue deriving (Show)\nmain = show Green")) + "Green") + +;; ─── Eq ────────────────────────────────────────────────────────────────────── + +(hk-test + "deriving Eq: same constructor" + (hk-deep-force + (hk-run + "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red == Red)")) + "True") + +(hk-test + "deriving Eq: different constructors" + (hk-deep-force + (hk-run + "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red == Blue)")) + "False") + +(hk-test + "deriving Eq: /= same" + (hk-deep-force + (hk-run + "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Red)")) + "False") + +(hk-test + "deriving Eq: /= different" + (hk-deep-force + (hk-run + "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Blue)")) + "True") + +;; ─── combined Eq + Show ─────────────────────────────────────────────────────── + +(hk-test + "deriving Eq Show: combined in parens" + (hk-deep-force + (hk-run + "data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 5)")) + "(Circle 5)") + +(hk-test + "deriving Eq Show: eq on constructor with arg" + (hk-deep-force + (hk-run + "data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 3 == Circle 3)")) + "True") + +(hk-test + "deriving Eq Show: different constructors with args" + (hk-deep-force + (hk-run + "data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 3 == Square 3)")) + "False") + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/plans/haskell-on-sx.md b/plans/haskell-on-sx.md index f8a3c214..05592d86 100644 --- a/plans/haskell-on-sx.md +++ b/plans/haskell-on-sx.md @@ -102,7 +102,7 @@ Key mappings: - [x] `class` / `instance` declarations - [x] Dictionary-passing elaborator: inserts dict args at call sites - [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 - [ ] Real `IO` monad backed by `perform`/`resume` @@ -114,6 +114,22 @@ Key mappings: _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`, `foldl1`, `foldr1`, `zip`, `reverse`, `elem`, `notElem`, `any`, `all`, `and`, `or`, `sum`, `product`, `maximum`, `minimum`, `compare`, `min`, `max`,