giles
ef81fffb6f
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
306 lines
7.0 KiB
Plaintext
306 lines
7.0 KiB
Plaintext
;; Desugar tests — surface AST → core AST.
|
|
;; :guarded → nested :if
|
|
;; :where → :let
|
|
;; :list-comp → concatMap-based tree
|
|
|
|
(define
|
|
hk-prog
|
|
(fn (&rest decls) (list :program decls)))
|
|
|
|
;; ── Guards → if ──
|
|
(hk-test
|
|
"two-way guarded rhs"
|
|
(hk-desugar (hk-parse-top "abs x | x < 0 = - x\n | otherwise = x"))
|
|
(hk-prog
|
|
(list
|
|
:fun-clause
|
|
"abs"
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:if
|
|
(list :op "<" (list :var "x") (list :int 0))
|
|
(list :neg (list :var "x"))
|
|
(list
|
|
:if
|
|
(list :var "otherwise")
|
|
(list :var "x")
|
|
(list
|
|
:app
|
|
(list :var "error")
|
|
(list :string "Non-exhaustive guards")))))))
|
|
|
|
(hk-test
|
|
"three-way guarded rhs"
|
|
(hk-desugar
|
|
(hk-parse-top "sign n | n > 0 = 1\n | n < 0 = -1\n | otherwise = 0"))
|
|
(hk-prog
|
|
(list
|
|
:fun-clause
|
|
"sign"
|
|
(list (list :p-var "n"))
|
|
(list
|
|
:if
|
|
(list :op ">" (list :var "n") (list :int 0))
|
|
(list :int 1)
|
|
(list
|
|
:if
|
|
(list :op "<" (list :var "n") (list :int 0))
|
|
(list :neg (list :int 1))
|
|
(list
|
|
:if
|
|
(list :var "otherwise")
|
|
(list :int 0)
|
|
(list
|
|
:app
|
|
(list :var "error")
|
|
(list :string "Non-exhaustive guards"))))))))
|
|
|
|
(hk-test
|
|
"case-alt guards desugared too"
|
|
(hk-desugar
|
|
(hk-parse "case x of\n Just y | y > 0 -> y\n | otherwise -> 0\n Nothing -> -1"))
|
|
(list
|
|
:case
|
|
(list :var "x")
|
|
(list
|
|
(list
|
|
:alt
|
|
(list :p-con "Just" (list (list :p-var "y")))
|
|
(list
|
|
:if
|
|
(list :op ">" (list :var "y") (list :int 0))
|
|
(list :var "y")
|
|
(list
|
|
:if
|
|
(list :var "otherwise")
|
|
(list :int 0)
|
|
(list
|
|
:app
|
|
(list :var "error")
|
|
(list :string "Non-exhaustive guards")))))
|
|
(list
|
|
:alt
|
|
(list :p-con "Nothing" (list))
|
|
(list :neg (list :int 1))))))
|
|
|
|
;; ── Where → let ──
|
|
(hk-test
|
|
"where with single binding"
|
|
(hk-desugar (hk-parse-top "f x = y\n where y = x + 1"))
|
|
(hk-prog
|
|
(list
|
|
:fun-clause
|
|
"f"
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:let
|
|
(list
|
|
(list
|
|
:fun-clause
|
|
"y"
|
|
(list)
|
|
(list :op "+" (list :var "x") (list :int 1))))
|
|
(list :var "y")))))
|
|
|
|
(hk-test
|
|
"where with two bindings"
|
|
(hk-desugar
|
|
(hk-parse-top "f x = y + z\n where y = x + 1\n z = x - 1"))
|
|
(hk-prog
|
|
(list
|
|
:fun-clause
|
|
"f"
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:let
|
|
(list
|
|
(list
|
|
:fun-clause
|
|
"y"
|
|
(list)
|
|
(list :op "+" (list :var "x") (list :int 1)))
|
|
(list
|
|
:fun-clause
|
|
"z"
|
|
(list)
|
|
(list :op "-" (list :var "x") (list :int 1))))
|
|
(list :op "+" (list :var "y") (list :var "z"))))))
|
|
|
|
(hk-test
|
|
"guards + where — guarded body inside let"
|
|
(hk-desugar
|
|
(hk-parse-top "f x | x > 0 = y\n | otherwise = 0\n where y = 99"))
|
|
(hk-prog
|
|
(list
|
|
:fun-clause
|
|
"f"
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:let
|
|
(list (list :fun-clause "y" (list) (list :int 99)))
|
|
(list
|
|
:if
|
|
(list :op ">" (list :var "x") (list :int 0))
|
|
(list :var "y")
|
|
(list
|
|
:if
|
|
(list :var "otherwise")
|
|
(list :int 0)
|
|
(list
|
|
:app
|
|
(list :var "error")
|
|
(list :string "Non-exhaustive guards"))))))))
|
|
|
|
;; ── List comprehensions → concatMap / if / let ──
|
|
(hk-test
|
|
"list-comp: single generator"
|
|
(hk-core-expr "[x | x <- xs]")
|
|
(list
|
|
:app
|
|
(list
|
|
:app
|
|
(list :var "concatMap")
|
|
(list
|
|
:lambda
|
|
(list (list :p-var "x"))
|
|
(list :list (list (list :var "x")))))
|
|
(list :var "xs")))
|
|
|
|
(hk-test
|
|
"list-comp: generator then guard"
|
|
(hk-core-expr "[x * 2 | x <- xs, x > 0]")
|
|
(list
|
|
:app
|
|
(list
|
|
:app
|
|
(list :var "concatMap")
|
|
(list
|
|
:lambda
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:if
|
|
(list :op ">" (list :var "x") (list :int 0))
|
|
(list
|
|
:list
|
|
(list (list :op "*" (list :var "x") (list :int 2))))
|
|
(list :list (list)))))
|
|
(list :var "xs")))
|
|
|
|
(hk-test
|
|
"list-comp: generator then let"
|
|
(hk-core-expr "[y | x <- xs, let y = x + 1]")
|
|
(list
|
|
:app
|
|
(list
|
|
:app
|
|
(list :var "concatMap")
|
|
(list
|
|
:lambda
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:let
|
|
(list
|
|
(list
|
|
:bind
|
|
(list :p-var "y")
|
|
(list :op "+" (list :var "x") (list :int 1))))
|
|
(list :list (list (list :var "y"))))))
|
|
(list :var "xs")))
|
|
|
|
(hk-test
|
|
"list-comp: two generators (nested concatMap)"
|
|
(hk-core-expr "[(x, y) | x <- xs, y <- ys]")
|
|
(list
|
|
:app
|
|
(list
|
|
:app
|
|
(list :var "concatMap")
|
|
(list
|
|
:lambda
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:app
|
|
(list
|
|
:app
|
|
(list :var "concatMap")
|
|
(list
|
|
:lambda
|
|
(list (list :p-var "y"))
|
|
(list
|
|
:list
|
|
(list
|
|
(list
|
|
:tuple
|
|
(list (list :var "x") (list :var "y")))))))
|
|
(list :var "ys"))))
|
|
(list :var "xs")))
|
|
|
|
;; ── Pass-through cases ──
|
|
(hk-test
|
|
"plain int literal unchanged"
|
|
(hk-core-expr "42")
|
|
(list :int 42))
|
|
|
|
(hk-test
|
|
"lambda + if passes through"
|
|
(hk-core-expr "\\x -> if x > 0 then x else - x")
|
|
(list
|
|
:lambda
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:if
|
|
(list :op ">" (list :var "x") (list :int 0))
|
|
(list :var "x")
|
|
(list :neg (list :var "x")))))
|
|
|
|
(hk-test
|
|
"simple fun-clause (no guards/where) passes through"
|
|
(hk-desugar (hk-parse-top "id x = x"))
|
|
(hk-prog
|
|
(list
|
|
:fun-clause
|
|
"id"
|
|
(list (list :p-var "x"))
|
|
(list :var "x"))))
|
|
|
|
(hk-test
|
|
"data decl passes through"
|
|
(hk-desugar (hk-parse-top "data Maybe a = Nothing | Just a"))
|
|
(hk-prog
|
|
(list
|
|
:data
|
|
"Maybe"
|
|
(list "a")
|
|
(list
|
|
(list :con-def "Nothing" (list))
|
|
(list :con-def "Just" (list (list :t-var "a")))))))
|
|
|
|
(hk-test
|
|
"module header passes through, body desugared"
|
|
(hk-desugar
|
|
(hk-parse-top "module M where\nf x | x > 0 = 1\n | otherwise = 0"))
|
|
(list
|
|
:module
|
|
"M"
|
|
nil
|
|
(list)
|
|
(list
|
|
(list
|
|
:fun-clause
|
|
"f"
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:if
|
|
(list :op ">" (list :var "x") (list :int 0))
|
|
(list :int 1)
|
|
(list
|
|
:if
|
|
(list :var "otherwise")
|
|
(list :int 0)
|
|
(list
|
|
:app
|
|
(list :var "error")
|
|
(list :string "Non-exhaustive guards"))))))))
|
|
|
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|