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