giles
e9c8f803b5
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
128 lines
3.5 KiB
Plaintext
128 lines
3.5 KiB
Plaintext
;; Runtime constructor-registry tests. Built-ins are pre-registered
|
|
;; when lib/haskell/runtime.sx loads; user types are registered by
|
|
;; walking a parsed+desugared AST with hk-register-program! (or the
|
|
;; `hk-load-source!` convenience).
|
|
|
|
;; ── Pre-registered built-ins ──
|
|
(hk-test "True is a con" (hk-is-con? "True") true)
|
|
(hk-test "False is a con" (hk-is-con? "False") true)
|
|
(hk-test "[] is a con" (hk-is-con? "[]") true)
|
|
(hk-test ": (cons) is a con" (hk-is-con? ":") true)
|
|
(hk-test "() is a con" (hk-is-con? "()") true)
|
|
|
|
(hk-test "True arity 0" (hk-con-arity "True") 0)
|
|
(hk-test ": arity 2" (hk-con-arity ":") 2)
|
|
(hk-test "[] arity 0" (hk-con-arity "[]") 0)
|
|
(hk-test "True type Bool" (hk-con-type "True") "Bool")
|
|
(hk-test "False type Bool" (hk-con-type "False") "Bool")
|
|
(hk-test ": type List" (hk-con-type ":") "List")
|
|
(hk-test "() type Unit" (hk-con-type "()") "Unit")
|
|
|
|
;; ── Unknown names ──
|
|
(hk-test "is-con? false for varid" (hk-is-con? "foo") false)
|
|
(hk-test "arity nil for unknown" (hk-con-arity "NotACon") nil)
|
|
(hk-test "type nil for unknown" (hk-con-type "NotACon") nil)
|
|
|
|
;; ── data MyBool = Yes | No ──
|
|
(hk-test
|
|
"register simple data"
|
|
(do
|
|
(hk-load-source! "data MyBool = Yes | No")
|
|
(list
|
|
(hk-con-arity "Yes")
|
|
(hk-con-arity "No")
|
|
(hk-con-type "Yes")
|
|
(hk-con-type "No")))
|
|
(list 0 0 "MyBool" "MyBool"))
|
|
|
|
;; ── data Maybe a = Nothing | Just a ──
|
|
(hk-test
|
|
"register Maybe"
|
|
(do
|
|
(hk-load-source! "data Maybe a = Nothing | Just a")
|
|
(list
|
|
(hk-con-arity "Nothing")
|
|
(hk-con-arity "Just")
|
|
(hk-con-type "Nothing")
|
|
(hk-con-type "Just")))
|
|
(list 0 1 "Maybe" "Maybe"))
|
|
|
|
;; ── data Either a b = Left a | Right b ──
|
|
(hk-test
|
|
"register Either"
|
|
(do
|
|
(hk-load-source! "data Either a b = Left a | Right b")
|
|
(list
|
|
(hk-con-arity "Left")
|
|
(hk-con-arity "Right")
|
|
(hk-con-type "Left")
|
|
(hk-con-type "Right")))
|
|
(list 1 1 "Either" "Either"))
|
|
|
|
;; ── Recursive data ──
|
|
(hk-test
|
|
"register recursive Tree"
|
|
(do
|
|
(hk-load-source!
|
|
"data Tree a = Leaf | Node (Tree a) a (Tree a)")
|
|
(list
|
|
(hk-con-arity "Leaf")
|
|
(hk-con-arity "Node")
|
|
(hk-con-type "Leaf")
|
|
(hk-con-type "Node")))
|
|
(list 0 3 "Tree" "Tree"))
|
|
|
|
;; ── newtype ──
|
|
(hk-test
|
|
"register newtype"
|
|
(do
|
|
(hk-load-source! "newtype Age = MkAge Int")
|
|
(list
|
|
(hk-con-arity "MkAge")
|
|
(hk-con-type "MkAge")))
|
|
(list 1 "Age"))
|
|
|
|
;; ── Multiple data decls in one program ──
|
|
(hk-test
|
|
"multiple data decls"
|
|
(do
|
|
(hk-load-source!
|
|
"data Color = Red | Green | Blue\ndata Shape = Circle | Square\nf x = x")
|
|
(list
|
|
(hk-con-type "Red")
|
|
(hk-con-type "Green")
|
|
(hk-con-type "Blue")
|
|
(hk-con-type "Circle")
|
|
(hk-con-type "Square")))
|
|
(list "Color" "Color" "Color" "Shape" "Shape"))
|
|
|
|
;; ── Inside a module header ──
|
|
(hk-test
|
|
"register from module body"
|
|
(do
|
|
(hk-load-source!
|
|
"module M where\ndata Pair a = Pair a a")
|
|
(list
|
|
(hk-con-arity "Pair")
|
|
(hk-con-type "Pair")))
|
|
(list 2 "Pair"))
|
|
|
|
;; ── Non-data decls are ignored ──
|
|
(hk-test
|
|
"program with only fun-decl leaves registry unchanged for that name"
|
|
(do
|
|
(hk-load-source! "myFunctionNotACon x = x + 1")
|
|
(hk-is-con? "myFunctionNotACon"))
|
|
false)
|
|
|
|
;; ── Re-registering overwrites (last wins) ──
|
|
(hk-test
|
|
"re-registration overwrites the entry"
|
|
(do
|
|
(hk-load-source! "data Foo = Bar Int")
|
|
(hk-load-source! "data Foo = Bar Int Int")
|
|
(hk-con-arity "Bar"))
|
|
2)
|
|
|
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|