diff --git a/lib/haskell/eval.sx b/lib/haskell/eval.sx index 8c460b6c..2ead3e1e 100644 --- a/lib/haskell/eval.sx +++ b/lib/haskell/eval.sx @@ -527,36 +527,7 @@ ;; the recursive list-building functions. (define hk-prelude-src - "head (x:_) = x -tail (_:xs) = xs -fst (a, _) = a -snd (_, b) = b -take 0 _ = [] -take _ [] = [] -take n (x:xs) = x : take (n - 1) xs -drop 0 xs = xs -drop _ [] = [] -drop n (_:xs) = drop (n - 1) xs -repeat x = x : repeat x -iterate f x = x : iterate f (f x) -length [] = 0 -length (_:xs) = 1 + length xs -map _ [] = [] -map f (x:xs) = f x : map f xs -filter _ [] = [] -filter p (x:xs) = if p x then x : filter p xs else filter p xs -zipWith _ [] _ = [] -zipWith _ _ [] = [] -zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys -fibs = 0 : 1 : zipWith plus fibs (tail fibs) -plus a b = a + b -concat [] = [] -concat (xs:xss) = xs ++ concat xss -concatMap f [] = [] -concatMap f (x:xs) = f x ++ concatMap f xs -abs x = if x < 0 then 0 - x else x -negate x = 0 - x -") + "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\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\ninteract f = getContents >>= \\s -> putStr (f s)\n") (define hk-load-into! @@ -572,11 +543,70 @@ negate x = 0 - x (:else (list))))) (hk-bind-decls! env decls))))) +(define + hk-join-strs + (fn + (strs sep) + (cond + ((empty? strs) "") + ((= (len strs) 1) (first strs)) + (:else + (let + ((acc (first strs))) + (for-each (fn (s) (set! acc (str acc sep s))) (rest strs)) + acc))))) + +(define + hk-collect-hk-list + (fn + (v) + (let + ((result (list))) + (let + ((loop (fn (node) (let ((fnode (hk-force node))) (cond ((and (list? fnode) (= (first fnode) "[]")) result) ((and (list? fnode) (= (first fnode) ":")) (do (append! result (nth fnode 1)) (loop (nth fnode 2)))) (:else (do (append! result fnode) result))))))) + (loop v) + result)))) + +(define + hk-show-val + (fn + (v) + (let + ((fv (hk-force v))) + (cond + ((= (type-of fv) "number") (str fv)) + ((= (type-of fv) "string") (str "\"" fv "\"")) + ((= (type-of fv) "boolean") (if fv "True" "False")) + ((not (list? fv)) (str fv)) + ((empty? fv) "()") + ((= (first fv) "[]") "[]") + ((= (first fv) ":") + (let + ((elems (hk-collect-hk-list fv))) + (str "[" (hk-join-strs (map hk-show-val elems) ", ") "]"))) + ((= (first fv) "Tuple") + (str "(" (hk-join-strs (map hk-show-val (rest fv)) ", ") ")")) + ((= (first fv) "()") "()") + (:else + (let + ((cname (first fv)) (args (rest fv))) + (if + (empty? args) + cname + (str + "(" + cname + " " + (hk-join-strs (map hk-show-val args) " ") + ")")))))))) + +;; ── Source-level convenience ──────────────────────────────── (define hk-init-env (fn () - (let ((env (dict))) + (let + ((env (dict))) (dict-set! env "otherwise" hk-true) (dict-set! env @@ -588,24 +618,12 @@ negate x = 0 - x (dict-set! env "not" - (hk-mk-builtin - "not" - (fn (b) (hk-of-bool (not (hk-truthy? b)))) - 1)) - (dict-set! - env - "id" - (hk-mk-builtin "id" (fn (x) x) 1)) - ;; `seq a b` — strict in `a`, lazy in `b`. Forces `a` to WHNF - ;; and returns `b` unchanged (still a thunk if it was one). + (hk-mk-builtin "not" (fn (b) (hk-of-bool (not (hk-truthy? b)))) 1)) + (dict-set! env "id" (hk-mk-builtin "id" (fn (x) x) 1)) (dict-set! env "seq" - (hk-mk-lazy-builtin - "seq" - (fn (a b) (do (hk-force a) b)) - 2)) - ;; `deepseq a b` — like seq but forces `a` to normal form. + (hk-mk-lazy-builtin "seq" (fn (a b) (do (hk-force a) b)) 2)) (dict-set! env "deepseq" @@ -613,49 +631,38 @@ negate x = 0 - x "deepseq" (fn (a b) (do (hk-deep-force a) b)) 2)) - ;; ── Stub IO monad ───────────────────────────────────── - ;; IO actions are tagged values `("IO" payload)`; `>>=` and - ;; `>>` chain them. Lazy in the action arguments so do-blocks - ;; can be deeply structured without forcing the whole chain - ;; up front. (dict-set! env "return" - (hk-mk-lazy-builtin - "return" - (fn (x) (list "IO" x)) - 1)) + (hk-mk-lazy-builtin "return" (fn (x) (list "IO" x)) 1)) (dict-set! env ">>=" (hk-mk-lazy-builtin ">>=" - (fn (m f) - (let ((io-val (hk-force m))) + (fn + (m f) + (let + ((io-val (hk-force m))) (cond - ((and - (list? io-val) - (= (first io-val) "IO")) + ((and (list? io-val) (= (first io-val) "IO")) (hk-apply (hk-force f) (nth io-val 1))) - (:else - (raise "(>>=): left side is not an IO action"))))) + (:else (raise "(>>=): left side is not an IO action"))))) 2)) (dict-set! env ">>" (hk-mk-lazy-builtin ">>" - (fn (m n) - (let ((io-val (hk-force m))) + (fn + (m n) + (let + ((io-val (hk-force m))) (cond - ((and - (list? io-val) - (= (first io-val) "IO")) + ((and (list? io-val) (= (first io-val) "IO")) (hk-force n)) - (:else - (raise "(>>): left side is not an IO action"))))) + (:else (raise "(>>): left side is not an IO action"))))) 2)) - ;; Operators as first-class values (dict-set! env "+" (hk-make-binop-builtin "+" "+")) (dict-set! env "-" (hk-make-binop-builtin "-" "-")) (dict-set! env "*" (hk-make-binop-builtin "*" "*")) @@ -673,9 +680,12 @@ negate x = 0 - x (dict-set! env "div" (hk-make-binop-builtin "div" "div")) (dict-set! env "rem" (hk-make-binop-builtin "rem" "rem")) (dict-set! env "quot" (hk-make-binop-builtin "quot" "quot")) + (dict-set! env "show" (hk-mk-lazy-builtin "show" hk-show-val 1)) (hk-load-into! env hk-prelude-src) env))) +;; Eagerly build the Prelude env once at load time; each call to +;; hk-eval-expr-source copies it instead of re-parsing the whole Prelude. (define hk-bind-decls! (fn @@ -819,27 +829,20 @@ negate x = 0 - x (:else (do (hk-register-program! ast) - (let ((env (hk-init-env))) + (let + ((env (hk-dict-copy hk-env0))) (let - ((decls - (cond - ((= (first ast) "program") (nth ast 1)) - ((= (first ast) "module") (nth ast 4)) - (:else (raise "eval-program: bad shape"))))) + ((decls (cond ((= (first ast) "program") (nth ast 1)) ((= (first ast) "module") (nth ast 4)) (:else (raise "eval-program: bad shape"))))) (hk-bind-decls! env decls)))))))) -;; ── Source-level convenience ──────────────────────────────── (define hk-run (fn (src) - (let ((env (hk-eval-program (hk-core src)))) - (cond - ((has-key? env "main") (get env "main")) - (:else env))))) + (let + ((env (hk-eval-program (hk-core src)))) + (cond ((has-key? env "main") (get env "main")) (:else env))))) -;; Eagerly build the Prelude env once at load time; each call to -;; hk-eval-expr-source copies it instead of re-parsing the whole Prelude. (define hk-env0 (hk-init-env)) (define diff --git a/lib/haskell/test.sh b/lib/haskell/test.sh index 320335a4..ea72c8e0 100755 --- a/lib/haskell/test.sh +++ b/lib/haskell/test.sh @@ -63,7 +63,7 @@ $INFER_LOAD (eval "(list hk-test-pass hk-test-fail)") EPOCHS - OUTPUT=$(timeout 240 "$SX_SERVER" < "$TMPFILE" 2>&1 || true) + OUTPUT=$(timeout 360 "$SX_SERVER" < "$TMPFILE" 2>&1 || true) rm -f "$TMPFILE" # Output format: either "(ok 3 (P F))" on one line (short result) or @@ -105,7 +105,7 @@ $INFER_LOAD (epoch 3) (eval "(map (fn (f) (get f \"name\")) hk-test-fails)") EPOCHS - FAILS=$(timeout 240 "$SX_SERVER" < "$TMPFILE2" 2>&1 | grep -E '^\(ok 3 ' || true) + FAILS=$(timeout 360 "$SX_SERVER" < "$TMPFILE2" 2>&1 | grep -E '^\(ok 3 ' || true) rm -f "$TMPFILE2" echo " $FAILS" elif [ "$VERBOSE" = "1" ]; then diff --git a/lib/haskell/tests/stdlib.sx b/lib/haskell/tests/stdlib.sx new file mode 100644 index 00000000..4be0db57 --- /dev/null +++ b/lib/haskell/tests/stdlib.sx @@ -0,0 +1,151 @@ +;; stdlib.sx — tests for standard-library functions added in Phase 5: +;; Eq/Ord, Show, Num, Functor, Monad, Applicative, plus common Prelude. + +(define + hk-t + (fn + (lbl src expected) + (hk-test lbl (hk-deep-force (hk-run src)) expected))) + +(define + hk-ts + (fn + (lbl src expected) + (hk-test + lbl + (hk-deep-force (hk-run (str "main = show (" src ")"))) + expected))) + +;; ── Ord ────────────────────────────────────────────────────── +(hk-test + "compare lt" + (hk-deep-force (hk-run "main = compare 1 2")) + (list "LT")) +(hk-test + "compare eq" + (hk-deep-force (hk-run "main = compare 3 3")) + (list "EQ")) +(hk-test + "compare gt" + (hk-deep-force (hk-run "main = compare 9 5")) + (list "GT")) +(hk-test "min" (hk-deep-force (hk-run "main = min 3 5")) 3) +(hk-test "max" (hk-deep-force (hk-run "main = max 3 5")) 5) + +;; ── Show ───────────────────────────────────────────────────── +(hk-ts "show int" "42" "42") +(hk-ts "show neg" "negate 7" "-7") +(hk-ts "show bool T" "True" "True") +(hk-ts "show bool F" "False" "False") +(hk-ts "show list" "[1,2,3]" "[1, 2, 3]") +(hk-ts "show Just" "Just 5" "(Just 5)") +(hk-ts "show Nothing" "Nothing" "Nothing") +(hk-ts "show LT" "LT" "LT") +(hk-ts "show tuple" "(1, True)" "(1, True)") + +;; ── Num extras ─────────────────────────────────────────────── +(hk-test "signum pos" (hk-deep-force (hk-run "main = signum 5")) 1) +(hk-test + "signum neg" + (hk-deep-force (hk-run "main = signum (negate 3)")) + (- 0 1)) +(hk-test "signum zero" (hk-deep-force (hk-run "main = signum 0")) 0) +(hk-test "fromIntegral" (hk-deep-force (hk-run "main = fromIntegral 7")) 7) + +;; ── foldr / foldl ──────────────────────────────────────────── +(hk-test "foldr sum" (hk-deep-force (hk-run "main = foldr (+) 0 [1,2,3]")) 6) +(hk-test "foldl sum" (hk-deep-force (hk-run "main = foldl (+) 0 [1,2,3]")) 6) +(hk-test "foldl1" (hk-deep-force (hk-run "main = foldl1 (+) [1,2,3,4]")) 10) +(hk-test + "foldr cons" + (hk-deep-force (hk-run "main = show (foldr (:) [] [1,2,3])")) + "[1, 2, 3]") + +;; ── List ops ───────────────────────────────────────────────── +(hk-test + "reverse" + (hk-deep-force (hk-run "main = show (reverse [1,2,3])")) + "[3, 2, 1]") +(hk-test "null []" (hk-deep-force (hk-run "main = null []")) (list "True")) +(hk-test + "null xs" + (hk-deep-force (hk-run "main = null [1]")) + (list "False")) +(hk-test + "elem yes" + (hk-deep-force (hk-run "main = elem 2 [1,2,3]")) + (list "True")) +(hk-test + "elem no" + (hk-deep-force (hk-run "main = elem 9 [1,2,3]")) + (list "False")) +(hk-test + "zip" + (hk-deep-force (hk-run "main = show (zip [1,2] [3,4])")) + "[(1, 3), (2, 4)]") +(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 "maximum" (hk-deep-force (hk-run "main = maximum [3,1,9,2]")) 9) +(hk-test "minimum" (hk-deep-force (hk-run "main = minimum [3,1,9,2]")) 1) +(hk-test + "any yes" + (hk-deep-force (hk-run "main = any (\\x -> x > 3) [1,2,5]")) + (list "True")) +(hk-test + "any no" + (hk-deep-force (hk-run "main = any (\\x -> x > 9) [1,2,5]")) + (list "False")) +(hk-test + "all yes" + (hk-deep-force (hk-run "main = all (\\x -> x > 0) [1,2,5]")) + (list "True")) +(hk-test + "all no" + (hk-deep-force (hk-run "main = all (\\x -> x > 3) [1,2,5]")) + (list "False")) + +;; ── Higher-order ───────────────────────────────────────────── +(hk-test "flip" (hk-deep-force (hk-run "main = flip (-) 3 10")) 7) +(hk-test "const" (hk-deep-force (hk-run "main = const 42 True")) 42) + +;; ── Functor ────────────────────────────────────────────────── +(hk-test + "fmap list" + (hk-deep-force (hk-run "main = show (fmap (+1) [1,2,3])")) + "[2, 3, 4]") + +;; ── Monad / Applicative ────────────────────────────────────── +(hk-test "return" (hk-deep-force (hk-run "main = return 7")) (list "IO" 7)) +(hk-test "pure" (hk-deep-force (hk-run "main = pure 7")) (list "IO" 7)) +(hk-test + "when T" + (hk-deep-force (hk-run "main = when True (return 1)")) + (list "IO" 1)) +(hk-test + "when F" + (hk-deep-force (hk-run "main = when False (return 1)")) + (list "IO" (list "()"))) +(hk-test + "unless F" + (hk-deep-force (hk-run "main = unless False (return 2)")) + (list "IO" 2)) + +;; ── lookup / maybe / either ───────────────────────────────── +(hk-test + "lookup hit" + (hk-deep-force (hk-run "main = show (lookup 2 [(1,10),(2,20)])")) + "(Just 20)") +(hk-test + "lookup miss" + (hk-deep-force (hk-run "main = show (lookup 9 [(1,10)])")) + "Nothing") +(hk-test + "maybe def" + (hk-deep-force (hk-run "main = maybe 0 (+1) Nothing")) + 0) +(hk-test + "maybe just" + (hk-deep-force (hk-run "main = maybe 0 (+1) (Just 5)")) + 6) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}