haskell: standard classes — show, Ord, Num, Functor, Monad prelude (+48 tests, 554/554)

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

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

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}