giles
defbe0a612
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
262 lines
6.3 KiB
Plaintext
262 lines
6.3 KiB
Plaintext
;; Guards and where-clauses — on fun-clauses, case alts, and
|
|
;; let-bindings (which now also accept funclause-style LHS like
|
|
;; `let f x = e` or `let f x | g = e | g = e`).
|
|
|
|
(define
|
|
hk-prog
|
|
(fn (&rest decls) (list :program decls)))
|
|
|
|
;; ── Guarded fun-clauses ──
|
|
(hk-test
|
|
"simple guards (two branches)"
|
|
(hk-parse-top "abs x | x < 0 = - x\n | otherwise = x")
|
|
(hk-prog
|
|
(list
|
|
:fun-clause
|
|
"abs"
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:guarded
|
|
(list
|
|
(list
|
|
:guard
|
|
(list :op "<" (list :var "x") (list :int 0))
|
|
(list :neg (list :var "x")))
|
|
(list :guard (list :var "otherwise") (list :var "x")))))))
|
|
|
|
(hk-test
|
|
"three-way guard"
|
|
(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
|
|
:guarded
|
|
(list
|
|
(list
|
|
:guard
|
|
(list :op ">" (list :var "n") (list :int 0))
|
|
(list :int 1))
|
|
(list
|
|
:guard
|
|
(list :op "<" (list :var "n") (list :int 0))
|
|
(list :neg (list :int 1)))
|
|
(list
|
|
:guard
|
|
(list :var "otherwise")
|
|
(list :int 0)))))))
|
|
|
|
(hk-test
|
|
"mixed: one eq clause plus one guarded clause"
|
|
(hk-parse-top "sign 0 = 0\nsign n | n > 0 = 1\n | otherwise = -1")
|
|
(hk-prog
|
|
(list
|
|
:fun-clause
|
|
"sign"
|
|
(list (list :p-int 0))
|
|
(list :int 0))
|
|
(list
|
|
:fun-clause
|
|
"sign"
|
|
(list (list :p-var "n"))
|
|
(list
|
|
:guarded
|
|
(list
|
|
(list
|
|
:guard
|
|
(list :op ">" (list :var "n") (list :int 0))
|
|
(list :int 1))
|
|
(list
|
|
:guard
|
|
(list :var "otherwise")
|
|
(list :neg (list :int 1))))))))
|
|
|
|
;; ── where on fun-clauses ──
|
|
(hk-test
|
|
"where with one binding"
|
|
(hk-parse-top "f x = y + y\n where y = x + 1")
|
|
(hk-prog
|
|
(list
|
|
:fun-clause
|
|
"f"
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:where
|
|
(list :op "+" (list :var "y") (list :var "y"))
|
|
(list
|
|
(list
|
|
:fun-clause
|
|
"y"
|
|
(list)
|
|
(list :op "+" (list :var "x") (list :int 1))))))))
|
|
|
|
(hk-test
|
|
"where with multiple bindings"
|
|
(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
|
|
:where
|
|
(list :op "*" (list :var "y") (list :var "z"))
|
|
(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))))))))
|
|
|
|
(hk-test
|
|
"guards + where"
|
|
(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
|
|
:where
|
|
(list
|
|
:guarded
|
|
(list
|
|
(list
|
|
:guard
|
|
(list :op ">" (list :var "x") (list :int 0))
|
|
(list :var "y"))
|
|
(list
|
|
:guard
|
|
(list :var "otherwise")
|
|
(list :int 0))))
|
|
(list
|
|
(list :fun-clause "y" (list) (list :int 99)))))))
|
|
|
|
;; ── Guards in case alts ──
|
|
(hk-test
|
|
"case alt with guards"
|
|
(hk-parse "case x of\n Just y | y > 0 -> y\n | otherwise -> 0\n Nothing -> 0")
|
|
(list
|
|
:case
|
|
(list :var "x")
|
|
(list
|
|
(list
|
|
:alt
|
|
(list :p-con "Just" (list (list :p-var "y")))
|
|
(list
|
|
:guarded
|
|
(list
|
|
(list
|
|
:guard
|
|
(list :op ">" (list :var "y") (list :int 0))
|
|
(list :var "y"))
|
|
(list
|
|
:guard
|
|
(list :var "otherwise")
|
|
(list :int 0)))))
|
|
(list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
|
|
|
|
(hk-test
|
|
"case alt with where"
|
|
(hk-parse "case x of\n Just y -> y + z where z = 5\n Nothing -> 0")
|
|
(list
|
|
:case
|
|
(list :var "x")
|
|
(list
|
|
(list
|
|
:alt
|
|
(list :p-con "Just" (list (list :p-var "y")))
|
|
(list
|
|
:where
|
|
(list :op "+" (list :var "y") (list :var "z"))
|
|
(list
|
|
(list :fun-clause "z" (list) (list :int 5)))))
|
|
(list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
|
|
|
|
;; ── let-bindings: funclause form, guards, where ──
|
|
(hk-test
|
|
"let with funclause shorthand"
|
|
(hk-parse "let f x = x + 1 in f 5")
|
|
(list
|
|
:let
|
|
(list
|
|
(list
|
|
:fun-clause
|
|
"f"
|
|
(list (list :p-var "x"))
|
|
(list :op "+" (list :var "x") (list :int 1))))
|
|
(list :app (list :var "f") (list :int 5))))
|
|
|
|
(hk-test
|
|
"let with guards"
|
|
(hk-parse "let f x | x > 0 = x\n | otherwise = 0\nin f 3")
|
|
(list
|
|
:let
|
|
(list
|
|
(list
|
|
:fun-clause
|
|
"f"
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:guarded
|
|
(list
|
|
(list
|
|
:guard
|
|
(list :op ">" (list :var "x") (list :int 0))
|
|
(list :var "x"))
|
|
(list
|
|
:guard
|
|
(list :var "otherwise")
|
|
(list :int 0))))))
|
|
(list :app (list :var "f") (list :int 3))))
|
|
|
|
(hk-test
|
|
"let funclause + where"
|
|
(hk-parse "let f x = y where y = x + 1\nin f 7")
|
|
(list
|
|
:let
|
|
(list
|
|
(list
|
|
:fun-clause
|
|
"f"
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:where
|
|
(list :var "y")
|
|
(list
|
|
(list
|
|
:fun-clause
|
|
"y"
|
|
(list)
|
|
(list :op "+" (list :var "x") (list :int 1)))))))
|
|
(list :app (list :var "f") (list :int 7))))
|
|
|
|
;; ── Nested: where inside where (via recursive hk-parse-decl) ──
|
|
(hk-test
|
|
"where block can contain a type signature"
|
|
(hk-parse-top "f x = y\n where y :: Int\n y = x")
|
|
(hk-prog
|
|
(list
|
|
:fun-clause
|
|
"f"
|
|
(list (list :p-var "x"))
|
|
(list
|
|
:where
|
|
(list :var "y")
|
|
(list
|
|
(list :type-sig (list "y") (list :t-con "Int"))
|
|
(list
|
|
:fun-clause
|
|
"y"
|
|
(list)
|
|
(list :var "x")))))))
|
|
|
|
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|