From 39c7baa44c04856e452b943305bfbf10060ff298 Mon Sep 17 00:00:00 2001 From: giles Date: Thu, 7 May 2026 00:02:55 +0000 Subject: [PATCH] =?UTF-8?q?haskell:=20Phase=208=20=E2=80=94=20showsPrec/sh?= =?UTF-8?q?owParen/shows/showString=20stubs=20(+7=20tests,=207/7)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored-By: Claude Sonnet 4.6 --- lib/haskell/eval.sx | 2 +- lib/haskell/tests/show.sx | 44 +++++++++++++++++++++++++++++++++++ plans/haskell-completeness.md | 14 ++++++++++- 3 files changed, 58 insertions(+), 2 deletions(-) create mode 100644 lib/haskell/tests/show.sx diff --git a/lib/haskell/eval.sx b/lib/haskell/eval.sx index 6332f158..95387b24 100644 --- a/lib/haskell/eval.sx +++ b/lib/haskell/eval.sx @@ -543,7 +543,7 @@ ;; the recursive list-building functions. (define hk-prelude-src - "head (x:_) = x\ntail (_:xs) = xs\nfst (a, _) = a\nsnd (_, b) = b\ntake 0 _ = []\ntake _ [] = []\ntake n (x:xs) = x : take (n - 1) xs\ndrop 0 xs = xs\ndrop _ [] = []\ndrop n (_:xs) = drop (n - 1) xs\nrepeat x = x : repeat x\niterate f x = x : iterate f (f x)\nlength [] = 0\nlength (_:xs) = 1 + length xs\nmap _ [] = []\nmap f (x:xs) = f x : map f xs\nfilter _ [] = []\nfilter p (x:xs) = if p x then x : filter p xs else filter p xs\nzipWith _ [] _ = []\nzipWith _ _ [] = []\nzipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\nfibs = 0 : 1 : zipWith plus fibs (tail fibs)\nplus a b = a + b\nconcat [] = []\nconcat (xs:xss) = xs ++ concat xss\nconcatMap f [] = []\nconcatMap f (x:xs) = f x ++ concatMap f xs\nabs x = if x < 0 then 0 - x else x\nnegate x = 0 - x\nnull [] = True\nnull _ = False\nflip f x y = f y x\nconst x _ = x\nid x = x\ncurry f x y = f (x, y)\nuncurry f p = f (fst p) (snd p)\nfoldr f z [] = z\nfoldr f z (x:xs) = f x (foldr f z xs)\nfoldl f z [] = z\nfoldl f z (x:xs) = foldl f (f z x) xs\nfoldl1 f (x:xs) = foldl f x xs\nfoldr1 f [x] = x\nfoldr1 f (x:xs) = f x (foldr1 f xs)\nzip [] _ = []\nzip _ [] = []\nzip (x:xs) (y:ys) = (x, y) : zip xs ys\nreverse [] = []\nreverse (x:xs) = reverse xs ++ [x]\nelem _ [] = False\nelem x (y:ys) = if x == y then True else elem x ys\nnotElem x xs = not (elem x xs)\nany _ [] = False\nany f (x:xs) = if f x then True else any f xs\nall _ [] = True\nall f (x:xs) = if f x then all f xs else False\nand [] = True\nand (x:xs) = if x then and xs else False\nor [] = False\nor (x:xs) = if x then True else or xs\nsum [] = 0\nsum (x:xs) = x + sum xs\nproduct [] = 1\nproduct (x:xs) = x * product xs\nmaximum [x] = x\nmaximum (x:xs) = let m = maximum xs in if x >= m then x else m\nminimum [x] = x\nminimum (x:xs) = let m = minimum xs in if x <= m then x else m\ncompare x y = if x < y then LT else if x == y then EQ else GT\nmin x y = if x <= y then x else y\nmax x y = if x >= y then x else y\nsignum x = if x < 0 then negate 1 else if x == 0 then 0 else 1\nfromIntegral x = x\nfromInteger x = x\ntoInteger x = x\nceiling x = x\nfloor x = x\nround x = x\ntruncate x = x\nlookup _ [] = Nothing\nlookup k ((k2,v):rest) = if k == k2 then Just v else lookup k rest\nmaybe d _ Nothing = d\nmaybe _ f (Just x) = f x\neither f _ (Left x) = f x\neither _ g (Right y) = g y\nmapMaybe _ [] = []\nmapMaybe f (x:xs) = case f x of { Nothing -> mapMaybe f xs; Just y -> y : mapMaybe f xs }\nfmap = map\npure = return\nwhen b m = if b then m else return ()\nunless b m = if b then return () else m\nmapM_ _ [] = return ()\nmapM_ f (x:xs) = f x >> mapM_ f xs\nsequence_ [] = return ()\nsequence_ (m:ms) = m >> sequence_ ms\ninteractApply f s = putStr (f s)\ninteract f = getContents >>= interactApply f\nnub [] = []\nnub (x:xs) = x : nub (filter notEqX xs)\n where notEqX y = y /= x\nsort [] = []\nsort (x:xs) = sort (filter ltX xs) ++ [x] ++ sort (filter geX xs)\n where ltX y = y < x\n geX y = y >= x\nsortBy _ [] = []\nsortBy cmp (x:xs) = sortBy cmp smaller ++ [x] ++ sortBy cmp bigger\n where smaller = filter ltCmp xs\n bigger = filter geCmp xs\n ltCmp y = cmp y x /= GT\n geCmp y = cmp y x == GT\nsortOnCmpFst p1 p2 = compare (fst p1) (fst p2)\nsortOn f xs = map snd (sortBy sortOnCmpFst (zip (map f xs) xs))\nsplitAt 0 xs = ([], xs)\nsplitAt _ [] = ([], [])\nsplitAt n (x:xs) = (x : a, b) where (a, b) = splitAt (n - 1) xs\nspan _ [] = ([], [])\nspan p (x:xs) = if p x then (x : a, b) else ([], x : xs) where (a, b) = span p xs\nbreak p xs = span notP xs\n where notP y = not (p y)\npartition _ [] = ([], [])\npartition p (x:xs) = if p x then (x : a, b) else (a, x : b) where (a, b) = partition p xs\nunzip [] = ([], [])\nunzip ((a, b) : rest) = (a : as, b : bs) where (as, bs) = unzip rest\ntails [] = [[]]\ntails (x:xs) = (x:xs) : tails xs\ninits [] = [[]]\ninits (x:xs) = [] : map (x:) (inits xs)\nisPrefixOf [] _ = True\nisPrefixOf _ [] = False\nisPrefixOf (x:xs) (y:ys) = if x == y then isPrefixOf xs ys else False\nisSuffixOf xs ys = isPrefixOf (reverse xs) (reverse ys)\nisInfixOf [] _ = True\nisInfixOf _ [] = False\nisInfixOf xs ys = if isPrefixOf xs ys then True else isInfixOf xs (tail ys)\nintercalate _ [] = []\nintercalate _ [x] = x\nintercalate sep (x:xs) = x ++ sep ++ intercalate sep xs\nintersperse _ [] = []\nintersperse _ [x] = [x]\nintersperse sep (x:xs) = x : sep : intersperse sep xs\nunwords [] = \"\"\nunwords [w] = w\nunwords (w:ws) = w ++ \" \" ++ unwords ws\nunlines [] = \"\"\nunlines (l:ls) = l ++ \"\\n\" ++ unlines ls\nprint x = putStrLn (show x)\n") + "head (x:_) = x\ntail (_:xs) = xs\nfst (a, _) = a\nsnd (_, b) = b\ntake 0 _ = []\ntake _ [] = []\ntake n (x:xs) = x : take (n - 1) xs\ndrop 0 xs = xs\ndrop _ [] = []\ndrop n (_:xs) = drop (n - 1) xs\nrepeat x = x : repeat x\niterate f x = x : iterate f (f x)\nlength [] = 0\nlength (_:xs) = 1 + length xs\nmap _ [] = []\nmap f (x:xs) = f x : map f xs\nfilter _ [] = []\nfilter p (x:xs) = if p x then x : filter p xs else filter p xs\nzipWith _ [] _ = []\nzipWith _ _ [] = []\nzipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\nfibs = 0 : 1 : zipWith plus fibs (tail fibs)\nplus a b = a + b\nconcat [] = []\nconcat (xs:xss) = xs ++ concat xss\nconcatMap f [] = []\nconcatMap f (x:xs) = f x ++ concatMap f xs\nabs x = if x < 0 then 0 - x else x\nnegate x = 0 - x\nnull [] = True\nnull _ = False\nflip f x y = f y x\nconst x _ = x\nid x = x\ncurry f x y = f (x, y)\nuncurry f p = f (fst p) (snd p)\nfoldr f z [] = z\nfoldr f z (x:xs) = f x (foldr f z xs)\nfoldl f z [] = z\nfoldl f z (x:xs) = foldl f (f z x) xs\nfoldl1 f (x:xs) = foldl f x xs\nfoldr1 f [x] = x\nfoldr1 f (x:xs) = f x (foldr1 f xs)\nzip [] _ = []\nzip _ [] = []\nzip (x:xs) (y:ys) = (x, y) : zip xs ys\nreverse [] = []\nreverse (x:xs) = reverse xs ++ [x]\nelem _ [] = False\nelem x (y:ys) = if x == y then True else elem x ys\nnotElem x xs = not (elem x xs)\nany _ [] = False\nany f (x:xs) = if f x then True else any f xs\nall _ [] = True\nall f (x:xs) = if f x then all f xs else False\nand [] = True\nand (x:xs) = if x then and xs else False\nor [] = False\nor (x:xs) = if x then True else or xs\nsum [] = 0\nsum (x:xs) = x + sum xs\nproduct [] = 1\nproduct (x:xs) = x * product xs\nmaximum [x] = x\nmaximum (x:xs) = let m = maximum xs in if x >= m then x else m\nminimum [x] = x\nminimum (x:xs) = let m = minimum xs in if x <= m then x else m\ncompare x y = if x < y then LT else if x == y then EQ else GT\nmin x y = if x <= y then x else y\nmax x y = if x >= y then x else y\nsignum x = if x < 0 then negate 1 else if x == 0 then 0 else 1\nfromIntegral x = x\nfromInteger x = x\ntoInteger x = x\nceiling x = x\nfloor x = x\nround x = x\ntruncate x = x\nlookup _ [] = Nothing\nlookup k ((k2,v):rest) = if k == k2 then Just v else lookup k rest\nmaybe d _ Nothing = d\nmaybe _ f (Just x) = f x\neither f _ (Left x) = f x\neither _ g (Right y) = g y\nmapMaybe _ [] = []\nmapMaybe f (x:xs) = case f x of { Nothing -> mapMaybe f xs; Just y -> y : mapMaybe f xs }\nfmap = map\npure = return\nwhen b m = if b then m else return ()\nunless b m = if b then return () else m\nmapM_ _ [] = return ()\nmapM_ f (x:xs) = f x >> mapM_ f xs\nsequence_ [] = return ()\nsequence_ (m:ms) = m >> sequence_ ms\ninteractApply f s = putStr (f s)\ninteract f = getContents >>= interactApply f\nnub [] = []\nnub (x:xs) = x : nub (filter notEqX xs)\n where notEqX y = y /= x\nsort [] = []\nsort (x:xs) = sort (filter ltX xs) ++ [x] ++ sort (filter geX xs)\n where ltX y = y < x\n geX y = y >= x\nsortBy _ [] = []\nsortBy cmp (x:xs) = sortBy cmp smaller ++ [x] ++ sortBy cmp bigger\n where smaller = filter ltCmp xs\n bigger = filter geCmp xs\n ltCmp y = cmp y x /= GT\n geCmp y = cmp y x == GT\nsortOnCmpFst p1 p2 = compare (fst p1) (fst p2)\nsortOn f xs = map snd (sortBy sortOnCmpFst (zip (map f xs) xs))\nsplitAt 0 xs = ([], xs)\nsplitAt _ [] = ([], [])\nsplitAt n (x:xs) = (x : a, b) where (a, b) = splitAt (n - 1) xs\nspan _ [] = ([], [])\nspan p (x:xs) = if p x then (x : a, b) else ([], x : xs) where (a, b) = span p xs\nbreak p xs = span notP xs\n where notP y = not (p y)\npartition _ [] = ([], [])\npartition p (x:xs) = if p x then (x : a, b) else (a, x : b) where (a, b) = partition p xs\nunzip [] = ([], [])\nunzip ((a, b) : rest) = (a : as, b : bs) where (as, bs) = unzip rest\ntails [] = [[]]\ntails (x:xs) = (x:xs) : tails xs\ninits [] = [[]]\ninits (x:xs) = [] : map (x:) (inits xs)\nisPrefixOf [] _ = True\nisPrefixOf _ [] = False\nisPrefixOf (x:xs) (y:ys) = if x == y then isPrefixOf xs ys else False\nisSuffixOf xs ys = isPrefixOf (reverse xs) (reverse ys)\nisInfixOf [] _ = True\nisInfixOf _ [] = False\nisInfixOf xs ys = if isPrefixOf xs ys then True else isInfixOf xs (tail ys)\nintercalate _ [] = []\nintercalate _ [x] = x\nintercalate sep (x:xs) = x ++ sep ++ intercalate sep xs\nintersperse _ [] = []\nintersperse _ [x] = [x]\nintersperse sep (x:xs) = x : sep : intersperse sep xs\nunwords [] = \"\"\nunwords [w] = w\nunwords (w:ws) = w ++ \" \" ++ unwords ws\nunlines [] = \"\"\nunlines (l:ls) = l ++ \"\\n\" ++ unlines ls\nprint x = putStrLn (show x)\nshows x s = show x ++ s\nshowString prefix rest = prefix ++ rest\nshowParen True p s = \"(\" ++ p (\")\" ++ s)\nshowParen False p s = p s\nshowsPrec _ x s = show x ++ s\n") (define hk-load-into! diff --git a/lib/haskell/tests/show.sx b/lib/haskell/tests/show.sx new file mode 100644 index 00000000..04ba2b53 --- /dev/null +++ b/lib/haskell/tests/show.sx @@ -0,0 +1,44 @@ +;; show.sx — tests for the Show class plumbing. +;; +;; Covers: +;; - showsPrec / showParen / shows / showString stubs (Phase 8) +;; - Eventually expanded to ≥12 tests covering the full audit (Phase 8 ☐). + +(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)") + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/plans/haskell-completeness.md b/plans/haskell-completeness.md index 6b13dd38..2ab06693 100644 --- a/plans/haskell-completeness.md +++ b/plans/haskell-completeness.md @@ -107,7 +107,7 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. multi-constructor ADTs. Nested application arguments wrapped in parens: if `show arg` contains a space, emit `"(" ++ show arg ++ ")"`. _Records deferred — Phase 14._ -- [ ] `showsPrec` / `showParen` stubs so hand-written Show instances compile. +- [x] `showsPrec` / `showParen` stubs so hand-written Show instances compile. - [ ] `Read` class stub — just enough for `reads :: String -> [(a,String)]` to type-check; no real parser needed yet. - [ ] Tests in `lib/haskell/tests/show.sx` (≥ 12 tests: show Int, show Bool, @@ -287,6 +287,18 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. _Newest first._ +**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