haskell: guards + where clauses (+11 tests, 173/173)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
This commit is contained in:
@@ -419,17 +419,141 @@
|
||||
(hk-expect! "reserved" "in")
|
||||
(list :let binds (hk-parse-expr-inner))))))
|
||||
|
||||
;; Binding LHS is a pattern. Simple `x = e` parses as
|
||||
;; (:bind (:p-var "x") e); pattern bindings like
|
||||
;; `(x, y) = pair` parse with a p-tuple LHS.
|
||||
;; ── RHS: guards + optional where ─────────────────────────
|
||||
;; A rhs is either a plain body after `=`/`->`, or a list of
|
||||
;; guarded bodies (`| cond = e | cond = e …`), optionally
|
||||
;; followed by a `where` block of local decls. Shapes:
|
||||
;; plain: <expr>
|
||||
;; guards: (:guarded ((:guard C1 E1) (:guard C2 E2) …))
|
||||
;; where: (:where <plain|guarded> DECLS)
|
||||
;; Used by fun-clauses, let/do-let bindings, and case alts.
|
||||
(define
|
||||
hk-parse-where-decls
|
||||
(fn
|
||||
()
|
||||
(let ((explicit (hk-match? "lbrace" nil)))
|
||||
(if
|
||||
explicit
|
||||
(hk-advance!)
|
||||
(hk-expect! "vlbrace" nil))
|
||||
(let ((decls (list)))
|
||||
(when
|
||||
(not
|
||||
(if
|
||||
explicit
|
||||
(hk-match? "rbrace" nil)
|
||||
(hk-match? "vrbrace" nil)))
|
||||
(do
|
||||
(append! decls (hk-parse-decl))
|
||||
(define
|
||||
hk-wd-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(or
|
||||
(hk-match? "vsemi" nil)
|
||||
(hk-match? "semi" nil))
|
||||
(do
|
||||
(hk-advance!)
|
||||
(when
|
||||
(not
|
||||
(if
|
||||
explicit
|
||||
(hk-match? "rbrace" nil)
|
||||
(hk-match? "vrbrace" nil)))
|
||||
(append! decls (hk-parse-decl)))
|
||||
(hk-wd-loop)))))
|
||||
(hk-wd-loop)))
|
||||
(if
|
||||
explicit
|
||||
(hk-expect! "rbrace" nil)
|
||||
(hk-expect! "vrbrace" nil))
|
||||
decls))))
|
||||
|
||||
(define
|
||||
hk-parse-guarded
|
||||
(fn
|
||||
(sep)
|
||||
(let ((guards (list)))
|
||||
(define
|
||||
hk-g-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "reservedop" "|")
|
||||
(do
|
||||
(hk-advance!)
|
||||
(let
|
||||
((cond-e (hk-parse-expr-inner)))
|
||||
(hk-expect! "reservedop" sep)
|
||||
(let
|
||||
((expr-e (hk-parse-expr-inner)))
|
||||
(append! guards (list :guard cond-e expr-e))
|
||||
(hk-g-loop)))))))
|
||||
(hk-g-loop)
|
||||
(list :guarded guards))))
|
||||
|
||||
(define
|
||||
hk-parse-rhs
|
||||
(fn
|
||||
(sep)
|
||||
(let
|
||||
((body
|
||||
(cond
|
||||
((hk-match? "reservedop" "|")
|
||||
(hk-parse-guarded sep))
|
||||
(:else
|
||||
(do
|
||||
(hk-expect! "reservedop" sep)
|
||||
(hk-parse-expr-inner))))))
|
||||
(cond
|
||||
((hk-match? "reserved" "where")
|
||||
(do
|
||||
(hk-advance!)
|
||||
(list :where body (hk-parse-where-decls))))
|
||||
(:else body)))))
|
||||
|
||||
;; Binding LHS is a pattern (for pat-binds), a varid alone
|
||||
;; (simple `x = e`), or a varid followed by apats (the
|
||||
;; `let f x = …` / `let f x | g = … | g = …` funclause form).
|
||||
(define
|
||||
hk-parse-bind
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((pat (hk-parse-pat)))
|
||||
(hk-expect! "reservedop" "=")
|
||||
(list :bind pat (hk-parse-expr-inner)))))
|
||||
((t (hk-peek)))
|
||||
(cond
|
||||
((and
|
||||
(not (nil? t))
|
||||
(= (get t "type") "varid"))
|
||||
(let
|
||||
((name (get (hk-advance!) "value"))
|
||||
(pats (list)))
|
||||
(define
|
||||
hk-b-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-apat-start? (hk-peek))
|
||||
(do
|
||||
(append! pats (hk-parse-apat))
|
||||
(hk-b-loop)))))
|
||||
(hk-b-loop)
|
||||
(if
|
||||
(= (len pats) 0)
|
||||
(list
|
||||
:bind
|
||||
(list :p-var name)
|
||||
(hk-parse-rhs "="))
|
||||
(list
|
||||
:fun-clause
|
||||
name
|
||||
pats
|
||||
(hk-parse-rhs "=")))))
|
||||
(:else
|
||||
(let
|
||||
((pat (hk-parse-pat)))
|
||||
(list :bind pat (hk-parse-rhs "="))))))))
|
||||
|
||||
;; ── Patterns ─────────────────────────────────────────────
|
||||
(define
|
||||
@@ -613,8 +737,7 @@
|
||||
()
|
||||
(let
|
||||
((pat (hk-parse-pat)))
|
||||
(hk-expect! "reservedop" "->")
|
||||
(list :alt pat (hk-parse-expr-inner)))))
|
||||
(list :alt pat (hk-parse-rhs "->")))))
|
||||
|
||||
(define
|
||||
hk-parse-case
|
||||
@@ -1120,13 +1243,11 @@
|
||||
(append! pats (hk-parse-apat))
|
||||
(hk-fc-loop)))))
|
||||
(hk-fc-loop)
|
||||
(hk-expect! "reservedop" "=")
|
||||
(list :fun-clause name pats (hk-parse-expr-inner))))
|
||||
(list :fun-clause name pats (hk-parse-rhs "="))))
|
||||
(:else
|
||||
(let
|
||||
((pat (hk-parse-pat)))
|
||||
(hk-expect! "reservedop" "=")
|
||||
(list :pat-bind pat (hk-parse-expr-inner))))))))
|
||||
(list :pat-bind pat (hk-parse-rhs "="))))))))
|
||||
|
||||
(define
|
||||
hk-parse-con-def
|
||||
|
||||
261
lib/haskell/tests/parser-guards-where.sx
Normal file
261
lib/haskell/tests/parser-guards-where.sx
Normal file
@@ -0,0 +1,261 @@
|
||||
;; 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}
|
||||
Reference in New Issue
Block a user