Compare commits
7 Commits
loops/prol
...
loops/hask
| Author | SHA1 | Date | |
|---|---|---|---|
| bf0d72fd2f | |||
| defbe0a612 | |||
| 869b0b552d | |||
| 58dbbc5d8b | |||
| 36234f0132 | |||
| 6ccef45ce4 | |||
| c07ff90f6b |
329
lib/haskell/layout.sx
Normal file
329
lib/haskell/layout.sx
Normal file
@@ -0,0 +1,329 @@
|
||||
;; Haskell 98 layout algorithm (§10.3).
|
||||
;;
|
||||
;; Consumes the raw token stream produced by hk-tokenize and inserts
|
||||
;; virtual braces / semicolons (types vlbrace / vrbrace / vsemi) based
|
||||
;; on indentation. Newline tokens are consumed and stripped.
|
||||
;;
|
||||
;; (hk-layout (hk-tokenize src)) → tokens-with-virtual-layout
|
||||
|
||||
;; ── Pre-pass ──────────────────────────────────────────────────────
|
||||
;;
|
||||
;; Walks the raw token list and emits an augmented stream containing
|
||||
;; two fresh pseudo-tokens:
|
||||
;;
|
||||
;; {:type "layout-open" :col N :keyword K}
|
||||
;; At stream start (K = "<module>") unless the first real token is
|
||||
;; `module` or `{`. Also immediately after every `let` / `where` /
|
||||
;; `do` / `of` whose following token is NOT `{`. N is the column
|
||||
;; of the token that follows.
|
||||
;;
|
||||
;; {:type "layout-indent" :col N}
|
||||
;; Before any token whose line is strictly greater than the line
|
||||
;; of the previously emitted real token, EXCEPT when that token
|
||||
;; is already preceded by a layout-open (Haskell 98 §10.3 note 3).
|
||||
;;
|
||||
;; Raw newline tokens are dropped.
|
||||
|
||||
(define
|
||||
hk-layout-keyword?
|
||||
(fn
|
||||
(tok)
|
||||
(and
|
||||
(= (get tok "type") "reserved")
|
||||
(or
|
||||
(= (get tok "value") "let")
|
||||
(= (get tok "value") "where")
|
||||
(= (get tok "value") "do")
|
||||
(= (get tok "value") "of")))))
|
||||
|
||||
(define
|
||||
hk-layout-pre
|
||||
(fn
|
||||
(tokens)
|
||||
(let
|
||||
((result (list))
|
||||
(n (len tokens))
|
||||
(i 0)
|
||||
(prev-line -1)
|
||||
(first-real-emitted false)
|
||||
(suppress-next-indent false))
|
||||
(define
|
||||
hk-next-real-idx
|
||||
(fn
|
||||
(start)
|
||||
(let
|
||||
((j start))
|
||||
(define
|
||||
hk-nri-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< j n)
|
||||
(= (get (nth tokens j) "type") "newline"))
|
||||
(do (set! j (+ j 1)) (hk-nri-loop)))))
|
||||
(hk-nri-loop)
|
||||
j)))
|
||||
(define
|
||||
hk-pre-step
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i n)
|
||||
(let
|
||||
((tok (nth tokens i)) (ty (get tok "type")))
|
||||
(cond
|
||||
((= ty "newline") (do (set! i (+ i 1)) (hk-pre-step)))
|
||||
(:else
|
||||
(do
|
||||
(when
|
||||
(not first-real-emitted)
|
||||
(do
|
||||
(set! first-real-emitted true)
|
||||
(when
|
||||
(not
|
||||
(or
|
||||
(and
|
||||
(= ty "reserved")
|
||||
(= (get tok "value") "module"))
|
||||
(= ty "lbrace")))
|
||||
(do
|
||||
(append!
|
||||
result
|
||||
{:type "layout-open"
|
||||
:col (get tok "col")
|
||||
:keyword "<module>"
|
||||
:line (get tok "line")})
|
||||
(set! suppress-next-indent true)))))
|
||||
(when
|
||||
(and
|
||||
(>= prev-line 0)
|
||||
(> (get tok "line") prev-line)
|
||||
(not suppress-next-indent))
|
||||
(append!
|
||||
result
|
||||
{:type "layout-indent"
|
||||
:col (get tok "col")
|
||||
:line (get tok "line")}))
|
||||
(set! suppress-next-indent false)
|
||||
(set! prev-line (get tok "line"))
|
||||
(append! result tok)
|
||||
(when
|
||||
(hk-layout-keyword? tok)
|
||||
(let
|
||||
((j (hk-next-real-idx (+ i 1))))
|
||||
(cond
|
||||
((>= j n)
|
||||
(do
|
||||
(append!
|
||||
result
|
||||
{:type "layout-open"
|
||||
:col 0
|
||||
:keyword (get tok "value")
|
||||
:line (get tok "line")})
|
||||
(set! suppress-next-indent true)))
|
||||
((= (get (nth tokens j) "type") "lbrace") nil)
|
||||
(:else
|
||||
(do
|
||||
(append!
|
||||
result
|
||||
{:type "layout-open"
|
||||
:col (get (nth tokens j) "col")
|
||||
:keyword (get tok "value")
|
||||
:line (get tok "line")})
|
||||
(set! suppress-next-indent true))))))
|
||||
(set! i (+ i 1))
|
||||
(hk-pre-step))))))))
|
||||
(hk-pre-step)
|
||||
result)))
|
||||
|
||||
;; ── Main pass: L algorithm ────────────────────────────────────────
|
||||
;;
|
||||
;; Stack is a list; the head is the top of stack. Each entry is
|
||||
;; either the keyword :explicit (pushed by an explicit `{`) or a dict
|
||||
;; {:col N :keyword K} pushed by a layout-open marker.
|
||||
;;
|
||||
;; Rules (following Haskell 98 §10.3):
|
||||
;;
|
||||
;; layout-open(n) vs stack:
|
||||
;; empty or explicit top → push n; emit {
|
||||
;; n > top-col → push n; emit {
|
||||
;; otherwise → emit { }; retry as indent(n)
|
||||
;;
|
||||
;; layout-indent(n) vs stack:
|
||||
;; empty or explicit top → drop
|
||||
;; n == top-col → emit ;
|
||||
;; n < top-col → emit }; pop; recurse
|
||||
;; n > top-col → drop
|
||||
;;
|
||||
;; lbrace → push :explicit; emit {
|
||||
;; rbrace → pop if :explicit; emit }
|
||||
;; `in` with implicit let on top → emit }; pop; emit in
|
||||
;; any other token → emit
|
||||
;;
|
||||
;; EOF: emit } for every remaining implicit context.
|
||||
|
||||
(define
|
||||
hk-layout-L
|
||||
(fn
|
||||
(pre-toks)
|
||||
(let
|
||||
((result (list))
|
||||
(stack (list))
|
||||
(n (len pre-toks))
|
||||
(i 0))
|
||||
(define hk-emit (fn (t) (append! result t)))
|
||||
(define
|
||||
hk-indent-at
|
||||
(fn
|
||||
(col line)
|
||||
(cond
|
||||
((or (empty? stack) (= (first stack) :explicit)) nil)
|
||||
(:else
|
||||
(let
|
||||
((top-col (get (first stack) "col")))
|
||||
(cond
|
||||
((= col top-col)
|
||||
(hk-emit
|
||||
{:type "vsemi" :value ";" :line line :col col}))
|
||||
((< col top-col)
|
||||
(do
|
||||
(hk-emit
|
||||
{:type "vrbrace" :value "}" :line line :col col})
|
||||
(set! stack (rest stack))
|
||||
(hk-indent-at col line)))
|
||||
(:else nil)))))))
|
||||
(define
|
||||
hk-open-at
|
||||
(fn
|
||||
(col keyword line)
|
||||
(cond
|
||||
((and
|
||||
(> col 0)
|
||||
(or
|
||||
(empty? stack)
|
||||
(= (first stack) :explicit)
|
||||
(> col (get (first stack) "col"))))
|
||||
(do
|
||||
(hk-emit
|
||||
{:type "vlbrace" :value "{" :line line :col col})
|
||||
(set! stack (cons {:col col :keyword keyword} stack))))
|
||||
(:else
|
||||
(do
|
||||
(hk-emit
|
||||
{:type "vlbrace" :value "{" :line line :col col})
|
||||
(hk-emit
|
||||
{:type "vrbrace" :value "}" :line line :col col})
|
||||
(hk-indent-at col line))))))
|
||||
(define
|
||||
hk-close-eof
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(not (empty? stack))
|
||||
(not (= (first stack) :explicit)))
|
||||
(do
|
||||
(hk-emit {:type "vrbrace" :value "}" :line 0 :col 0})
|
||||
(set! stack (rest stack))
|
||||
(hk-close-eof)))))
|
||||
;; Peek past further layout-indent / layout-open markers to find
|
||||
;; the next real token's value when its type is `reserved`.
|
||||
;; Returns nil if no such token.
|
||||
(define
|
||||
hk-peek-next-reserved
|
||||
(fn
|
||||
(start)
|
||||
(let ((j (+ start 1)) (found nil) (done false))
|
||||
(define
|
||||
hk-pnr-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (not done) (< j n))
|
||||
(let
|
||||
((t (nth pre-toks j)) (ty (get t "type")))
|
||||
(cond
|
||||
((or
|
||||
(= ty "layout-indent")
|
||||
(= ty "layout-open"))
|
||||
(do (set! j (+ j 1)) (hk-pnr-loop)))
|
||||
((= ty "reserved")
|
||||
(do (set! found (get t "value")) (set! done true)))
|
||||
(:else (set! done true)))))))
|
||||
(hk-pnr-loop)
|
||||
found)))
|
||||
(define
|
||||
hk-layout-step
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i n)
|
||||
(let
|
||||
((tok (nth pre-toks i)) (ty (get tok "type")))
|
||||
(cond
|
||||
((= ty "eof")
|
||||
(do
|
||||
(hk-close-eof)
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
((= ty "layout-open")
|
||||
(do
|
||||
(hk-open-at
|
||||
(get tok "col")
|
||||
(get tok "keyword")
|
||||
(get tok "line"))
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
((= ty "layout-indent")
|
||||
(cond
|
||||
((= (hk-peek-next-reserved i) "in")
|
||||
(do (set! i (+ i 1)) (hk-layout-step)))
|
||||
(:else
|
||||
(do
|
||||
(hk-indent-at (get tok "col") (get tok "line"))
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))))
|
||||
((= ty "lbrace")
|
||||
(do
|
||||
(set! stack (cons :explicit stack))
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
((= ty "rbrace")
|
||||
(do
|
||||
(when
|
||||
(and
|
||||
(not (empty? stack))
|
||||
(= (first stack) :explicit))
|
||||
(set! stack (rest stack)))
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
((and
|
||||
(= ty "reserved")
|
||||
(= (get tok "value") "in")
|
||||
(not (empty? stack))
|
||||
(not (= (first stack) :explicit))
|
||||
(= (get (first stack) "keyword") "let"))
|
||||
(do
|
||||
(hk-emit
|
||||
{:type "vrbrace"
|
||||
:value "}"
|
||||
:line (get tok "line")
|
||||
:col (get tok "col")})
|
||||
(set! stack (rest stack))
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step)))
|
||||
(:else
|
||||
(do
|
||||
(hk-emit tok)
|
||||
(set! i (+ i 1))
|
||||
(hk-layout-step))))))))
|
||||
(hk-layout-step)
|
||||
(hk-close-eof)
|
||||
result)))
|
||||
|
||||
(define hk-layout (fn (tokens) (hk-layout-L (hk-layout-pre tokens))))
|
||||
1750
lib/haskell/parser.sx
Normal file
1750
lib/haskell/parser.sx
Normal file
File diff suppressed because it is too large
Load Diff
@@ -46,6 +46,9 @@ for FILE in "${FILES[@]}"; do
|
||||
cat > "$TMPFILE" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/haskell/tokenizer.sx")
|
||||
(load "lib/haskell/layout.sx")
|
||||
(load "lib/haskell/parser.sx")
|
||||
(load "lib/haskell/testlib.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
@@ -81,6 +84,9 @@ EPOCHS
|
||||
cat > "$TMPFILE2" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/haskell/tokenizer.sx")
|
||||
(load "lib/haskell/layout.sx")
|
||||
(load "lib/haskell/parser.sx")
|
||||
(load "lib/haskell/testlib.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
|
||||
58
lib/haskell/testlib.sx
Normal file
58
lib/haskell/testlib.sx
Normal file
@@ -0,0 +1,58 @@
|
||||
;; Shared test harness for Haskell-on-SX tests.
|
||||
;; Each test file expects hk-test / hk-deep=? / counters to already be bound.
|
||||
|
||||
(define
|
||||
hk-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((= a b) true)
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ak (keys a)) (bk (keys b)))
|
||||
(if
|
||||
(not (= (len ak) (len bk)))
|
||||
false
|
||||
(every?
|
||||
(fn
|
||||
(k)
|
||||
(and (has-key? b k) (hk-deep=? (get a k) (get b k))))
|
||||
ak))))
|
||||
((and (list? a) (list? b))
|
||||
(if
|
||||
(not (= (len a) (len b)))
|
||||
false
|
||||
(let
|
||||
((i 0) (ok true))
|
||||
(define
|
||||
hk-de-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and ok (< i (len a)))
|
||||
(do
|
||||
(when
|
||||
(not (hk-deep=? (nth a i) (nth b i)))
|
||||
(set! ok false))
|
||||
(set! i (+ i 1))
|
||||
(hk-de-loop)))))
|
||||
(hk-de-loop)
|
||||
ok)))
|
||||
(:else false))))
|
||||
|
||||
(define hk-test-pass 0)
|
||||
(define hk-test-fail 0)
|
||||
(define hk-test-fails (list))
|
||||
|
||||
(define
|
||||
hk-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(hk-deep=? actual expected)
|
||||
(set! hk-test-pass (+ hk-test-pass 1))
|
||||
(do
|
||||
(set! hk-test-fail (+ hk-test-fail 1))
|
||||
(append!
|
||||
hk-test-fails
|
||||
{:actual actual :expected expected :name name})))))
|
||||
245
lib/haskell/tests/layout.sx
Normal file
245
lib/haskell/tests/layout.sx
Normal file
@@ -0,0 +1,245 @@
|
||||
;; Haskell layout-rule tests. hk-tokenizer + hk-layout produce a
|
||||
;; virtual-brace-annotated stream; these tests cover the algorithm
|
||||
;; from Haskell 98 §10.3 plus the pragmatic let/in single-line rule.
|
||||
|
||||
;; Convenience — tokenize, run layout, strip eof, keep :type/:value.
|
||||
(define
|
||||
hk-lay
|
||||
(fn
|
||||
(src)
|
||||
(map
|
||||
(fn (tok) {:value (get tok "value") :type (get tok "type")})
|
||||
(filter
|
||||
(fn (tok) (not (= (get tok "type") "eof")))
|
||||
(hk-layout (hk-tokenize src))))))
|
||||
|
||||
;; ── 1. Basics ──
|
||||
(hk-test
|
||||
"empty input produces empty module { }"
|
||||
(hk-lay "")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"single token → module open+close"
|
||||
(hk-lay "foo")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "foo" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"two top-level decls get vsemi between"
|
||||
(hk-lay "foo = 1\nbar = 2")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "foo" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "bar" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 2 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 2. Layout keywords — do / let / where / of ──
|
||||
(hk-test
|
||||
"do block with two stmts"
|
||||
(hk-lay "f = do\n x\n y")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"single-line let ... in"
|
||||
(hk-lay "let x = 1 in x")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "let" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "in" :type "reserved"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"where block with two bindings"
|
||||
(hk-lay "f = g\n where\n g = 1\n h = 2")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "g" :type "varid"}
|
||||
{:value "where" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "g" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "h" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 2 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"case … of with arms"
|
||||
(hk-lay "f x = case x of\n Just y -> y\n Nothing -> 0")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "case" :type "reserved"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "of" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "Just" :type "conid"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value "->" :type "reservedop"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "Nothing" :type "conid"}
|
||||
{:value "->" :type "reservedop"}
|
||||
{:value 0 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 3. Explicit braces disable layout ──
|
||||
(hk-test
|
||||
"explicit braces — no implicit vlbrace/vsemi/vrbrace inside"
|
||||
(hk-lay "do { x ; y }")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "lbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value ";" :type "semi"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value "}" :type "rbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 4. Dedent closes nested blocks ──
|
||||
(hk-test
|
||||
"dedent back to module level closes do block"
|
||||
(hk-lay "f = do\n x\n y\ng = 2")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "y" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "g" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 2 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
(hk-test
|
||||
"dedent closes inner let, emits vsemi at outer do level"
|
||||
(hk-lay "main = do\n let x = 1\n print x")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "main" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "let" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value ";" :type "vsemi"}
|
||||
{:value "print" :type "varid"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 5. Module header skips outer implicit open ──
|
||||
(hk-test
|
||||
"module M where — only where opens a block"
|
||||
(hk-lay "module M where\n f = 1")
|
||||
(list
|
||||
{:value "module" :type "reserved"}
|
||||
{:value "M" :type "conid"}
|
||||
{:value "where" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 6. Newlines are stripped ──
|
||||
(hk-test
|
||||
"newline tokens do not appear in output"
|
||||
(let
|
||||
((toks (hk-layout (hk-tokenize "foo\nbar"))))
|
||||
(every?
|
||||
(fn (t) (not (= (get t "type") "newline")))
|
||||
toks))
|
||||
true)
|
||||
|
||||
;; ── 7. Continuation — deeper indent does NOT emit vsemi ──
|
||||
(hk-test
|
||||
"line continuation (deeper indent) just merges"
|
||||
(hk-lay "foo = 1 +\n 2")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "foo" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "+" :type "varsym"}
|
||||
{:value 2 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
;; ── 8. Stack closing at EOF ──
|
||||
(hk-test
|
||||
"EOF inside nested do closes all implicit blocks"
|
||||
(let
|
||||
((toks (hk-lay "main = do\n do\n x")))
|
||||
(let
|
||||
((n (len toks)))
|
||||
(list
|
||||
(get (nth toks (- n 1)) "type")
|
||||
(get (nth toks (- n 2)) "type")
|
||||
(get (nth toks (- n 3)) "type"))))
|
||||
(list "vrbrace" "vrbrace" "vrbrace"))
|
||||
|
||||
;; ── 9. Qualified-newline: x at deeper col than stack top does nothing ──
|
||||
(hk-test
|
||||
"mixed where + do"
|
||||
(hk-lay "f = do\n x\n where\n x = 1")
|
||||
(list
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "f" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value "do" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "where" :type "reserved"}
|
||||
{:value "{" :type "vlbrace"}
|
||||
{:value "x" :type "varid"}
|
||||
{:value "=" :type "reservedop"}
|
||||
{:value 1 :type "integer"}
|
||||
{:value "}" :type "vrbrace"}
|
||||
{:value "}" :type "vrbrace"}))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -3,60 +3,8 @@
|
||||
;; Lightweight runner: each test checks actual vs expected with
|
||||
;; structural (deep) equality and accumulates pass/fail counters.
|
||||
;; Final value of this file is a summary dict with :pass :fail :fails.
|
||||
|
||||
(define
|
||||
hk-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((= a b) true)
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ak (keys a)) (bk (keys b)))
|
||||
(if
|
||||
(not (= (len ak) (len bk)))
|
||||
false
|
||||
(every?
|
||||
(fn
|
||||
(k)
|
||||
(and (has-key? b k) (hk-deep=? (get a k) (get b k))))
|
||||
ak))))
|
||||
((and (list? a) (list? b))
|
||||
(if
|
||||
(not (= (len a) (len b)))
|
||||
false
|
||||
(let
|
||||
((i 0) (ok true))
|
||||
(define
|
||||
hk-de-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and ok (< i (len a)))
|
||||
(do
|
||||
(when
|
||||
(not (hk-deep=? (nth a i) (nth b i)))
|
||||
(set! ok false))
|
||||
(set! i (+ i 1))
|
||||
(hk-de-loop)))))
|
||||
(hk-de-loop)
|
||||
ok)))
|
||||
(:else false))))
|
||||
|
||||
(define hk-test-pass 0)
|
||||
(define hk-test-fail 0)
|
||||
(define hk-test-fails (list))
|
||||
|
||||
(define
|
||||
hk-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(hk-deep=? actual expected)
|
||||
(set! hk-test-pass (+ hk-test-pass 1))
|
||||
(do
|
||||
(set! hk-test-fail (+ hk-test-fail 1))
|
||||
(append! hk-test-fails {:actual actual :expected expected :name name})))))
|
||||
;; The hk-test / hk-deep=? helpers live in lib/haskell/testlib.sx
|
||||
;; and are preloaded by lib/haskell/test.sh.
|
||||
|
||||
;; Convenience: tokenize and drop newline + eof tokens so tests focus
|
||||
;; on meaningful content. Returns list of {:type :value} pairs.
|
||||
|
||||
278
lib/haskell/tests/parser-case-do.sx
Normal file
278
lib/haskell/tests/parser-case-do.sx
Normal file
@@ -0,0 +1,278 @@
|
||||
;; case-of and do-notation parser tests.
|
||||
;; Covers the minimal patterns needed to make these meaningful: var,
|
||||
;; wildcard, literal, constructor (with and without args), tuple, list.
|
||||
|
||||
;; ── Patterns (in case arms) ──
|
||||
(hk-test
|
||||
"wildcard pat"
|
||||
(hk-parse "case x of _ -> 0")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list (list :alt (list :p-wild) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"var pat"
|
||||
(hk-parse "case x of y -> y")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list :alt (list :p-var "y") (list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"0-arity constructor pat"
|
||||
(hk-parse "case x of\n Nothing -> 0\n Just y -> y")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list :alt (list :p-con "Nothing" (list)) (list :int 0))
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"int literal pat"
|
||||
(hk-parse "case n of\n 0 -> 1\n _ -> n")
|
||||
(list
|
||||
:case
|
||||
(list :var "n")
|
||||
(list
|
||||
(list :alt (list :p-int 0) (list :int 1))
|
||||
(list :alt (list :p-wild) (list :var "n")))))
|
||||
|
||||
(hk-test
|
||||
"string literal pat"
|
||||
(hk-parse "case s of\n \"hi\" -> 1\n _ -> 0")
|
||||
(list
|
||||
:case
|
||||
(list :var "s")
|
||||
(list
|
||||
(list :alt (list :p-string "hi") (list :int 1))
|
||||
(list :alt (list :p-wild) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"tuple pat"
|
||||
(hk-parse "case p of (a, b) -> a")
|
||||
(list
|
||||
:case
|
||||
(list :var "p")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "a")))))
|
||||
|
||||
(hk-test
|
||||
"list pat"
|
||||
(hk-parse "case xs of\n [] -> 0\n [a] -> a")
|
||||
(list
|
||||
:case
|
||||
(list :var "xs")
|
||||
(list
|
||||
(list :alt (list :p-list (list)) (list :int 0))
|
||||
(list
|
||||
:alt
|
||||
(list :p-list (list (list :p-var "a")))
|
||||
(list :var "a")))))
|
||||
|
||||
(hk-test
|
||||
"nested constructor pat"
|
||||
(hk-parse "case x of\n Just (a, b) -> a\n _ -> 0")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
"Just"
|
||||
(list
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))))
|
||||
(list :var "a"))
|
||||
(list :alt (list :p-wild) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"constructor with multiple var args"
|
||||
(hk-parse "case t of Pair a b -> a")
|
||||
(list
|
||||
:case
|
||||
(list :var "t")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
"Pair"
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "a")))))
|
||||
|
||||
;; ── case-of shapes ──
|
||||
(hk-test
|
||||
"case with explicit braces"
|
||||
(hk-parse "case x of { Just y -> y ; Nothing -> 0 }")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list :var "y"))
|
||||
(list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
|
||||
|
||||
(hk-test
|
||||
"case scrutinee is a full expression"
|
||||
(hk-parse "case f x + 1 of\n y -> y")
|
||||
(list
|
||||
:case
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :app (list :var "f") (list :var "x"))
|
||||
(list :int 1))
|
||||
(list (list :alt (list :p-var "y") (list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"case arm body is full expression"
|
||||
(hk-parse "case x of\n Just y -> y + 1")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list :op "+" (list :var "y") (list :int 1))))))
|
||||
|
||||
;; ── do blocks ──
|
||||
(hk-test
|
||||
"do with two expressions"
|
||||
(hk-parse "do\n putStrLn \"hi\"\n return 0")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "putStrLn") (list :string "hi")))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "return") (list :int 0))))))
|
||||
|
||||
(hk-test
|
||||
"do with bind"
|
||||
(hk-parse "do\n x <- getLine\n putStrLn x")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list :do-bind (list :p-var "x") (list :var "getLine"))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "putStrLn") (list :var "x"))))))
|
||||
|
||||
(hk-test
|
||||
"do with let"
|
||||
(hk-parse "do\n let y = 5\n print y")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-let
|
||||
(list (list :bind (list :p-var "y") (list :int 5))))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "print") (list :var "y"))))))
|
||||
|
||||
(hk-test
|
||||
"do with multiple let bindings"
|
||||
(hk-parse "do\n let x = 1\n y = 2\n print (x + y)")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-let
|
||||
(list
|
||||
(list :bind (list :p-var "x") (list :int 1))
|
||||
(list :bind (list :p-var "y") (list :int 2))))
|
||||
(list
|
||||
:do-expr
|
||||
(list
|
||||
:app
|
||||
(list :var "print")
|
||||
(list :op "+" (list :var "x") (list :var "y")))))))
|
||||
|
||||
(hk-test
|
||||
"do with bind using constructor pat"
|
||||
(hk-parse "do\n Just x <- getMaybe\n return x")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-bind
|
||||
(list :p-con "Just" (list (list :p-var "x")))
|
||||
(list :var "getMaybe"))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "return") (list :var "x"))))))
|
||||
|
||||
(hk-test
|
||||
"do with explicit braces"
|
||||
(hk-parse "do { x <- a ; y <- b ; return (x + y) }")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list :do-bind (list :p-var "x") (list :var "a"))
|
||||
(list :do-bind (list :p-var "y") (list :var "b"))
|
||||
(list
|
||||
:do-expr
|
||||
(list
|
||||
:app
|
||||
(list :var "return")
|
||||
(list :op "+" (list :var "x") (list :var "y")))))))
|
||||
|
||||
;; ── Mixing case/do inside expressions ──
|
||||
(hk-test
|
||||
"case inside let"
|
||||
(hk-parse "let f = \\x -> case x of\n Just y -> y\n _ -> 0\nin f 5")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list :p-var "f")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-con "Just" (list (list :p-var "y")))
|
||||
(list :var "y"))
|
||||
(list :alt (list :p-wild) (list :int 0)))))))
|
||||
(list :app (list :var "f") (list :int 5))))
|
||||
|
||||
(hk-test
|
||||
"lambda containing do"
|
||||
(hk-parse "\\x -> do\n y <- x\n return y")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list :do-bind (list :p-var "y") (list :var "x"))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "return") (list :var "y")))))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
273
lib/haskell/tests/parser-decls.sx
Normal file
273
lib/haskell/tests/parser-decls.sx
Normal file
@@ -0,0 +1,273 @@
|
||||
;; Top-level declarations: function clauses, type signatures, data,
|
||||
;; type, newtype, fixity. Driven by hk-parse-top which produces
|
||||
;; a (:program DECLS) node.
|
||||
|
||||
(define
|
||||
hk-prog
|
||||
(fn
|
||||
(&rest decls)
|
||||
(list :program decls)))
|
||||
|
||||
;; ── Function clauses & pattern bindings ──
|
||||
(hk-test
|
||||
"simple fun-clause"
|
||||
(hk-parse-top "f x = x + 1")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-var "x"))
|
||||
(list :op "+" (list :var "x") (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"nullary decl"
|
||||
(hk-parse-top "answer = 42")
|
||||
(hk-prog
|
||||
(list :fun-clause "answer" (list) (list :int 42))))
|
||||
|
||||
(hk-test
|
||||
"multi-clause fn (separate defs for each pattern)"
|
||||
(hk-parse-top "fact 0 = 1\nfact n = n")
|
||||
(hk-prog
|
||||
(list :fun-clause "fact" (list (list :p-int 0)) (list :int 1))
|
||||
(list
|
||||
:fun-clause
|
||||
"fact"
|
||||
(list (list :p-var "n"))
|
||||
(list :var "n"))))
|
||||
|
||||
(hk-test
|
||||
"constructor pattern in fn args"
|
||||
(hk-parse-top "fromJust (Just x) = x")
|
||||
(hk-prog
|
||||
(list
|
||||
:fun-clause
|
||||
"fromJust"
|
||||
(list (list :p-con "Just" (list (list :p-var "x"))))
|
||||
(list :var "x"))))
|
||||
|
||||
(hk-test
|
||||
"pattern binding at top level"
|
||||
(hk-parse-top "(a, b) = pair")
|
||||
(hk-prog
|
||||
(list
|
||||
:pat-bind
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "pair"))))
|
||||
|
||||
;; ── Type signatures ──
|
||||
(hk-test
|
||||
"single-name sig"
|
||||
(hk-parse-top "f :: Int -> Int")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "f")
|
||||
(list :t-fun (list :t-con "Int") (list :t-con "Int")))))
|
||||
|
||||
(hk-test
|
||||
"multi-name sig"
|
||||
(hk-parse-top "f, g, h :: Int -> Bool")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "f" "g" "h")
|
||||
(list :t-fun (list :t-con "Int") (list :t-con "Bool")))))
|
||||
|
||||
(hk-test
|
||||
"sig with type application"
|
||||
(hk-parse-top "f :: Maybe a -> a")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "f")
|
||||
(list
|
||||
:t-fun
|
||||
(list :t-app (list :t-con "Maybe") (list :t-var "a"))
|
||||
(list :t-var "a")))))
|
||||
|
||||
(hk-test
|
||||
"sig with list type"
|
||||
(hk-parse-top "len :: [a] -> Int")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "len")
|
||||
(list
|
||||
:t-fun
|
||||
(list :t-list (list :t-var "a"))
|
||||
(list :t-con "Int")))))
|
||||
|
||||
(hk-test
|
||||
"sig with tuple and right-assoc ->"
|
||||
(hk-parse-top "pair :: a -> b -> (a, b)")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "pair")
|
||||
(list
|
||||
:t-fun
|
||||
(list :t-var "a")
|
||||
(list
|
||||
:t-fun
|
||||
(list :t-var "b")
|
||||
(list
|
||||
:t-tuple
|
||||
(list (list :t-var "a") (list :t-var "b"))))))))
|
||||
|
||||
(hk-test
|
||||
"sig + implementation together"
|
||||
(hk-parse-top "id :: a -> a\nid x = x")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-sig
|
||||
(list "id")
|
||||
(list :t-fun (list :t-var "a") (list :t-var "a")))
|
||||
(list
|
||||
:fun-clause
|
||||
"id"
|
||||
(list (list :p-var "x"))
|
||||
(list :var "x"))))
|
||||
|
||||
;; ── data declarations ──
|
||||
(hk-test
|
||||
"data Maybe"
|
||||
(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
|
||||
"data Either"
|
||||
(hk-parse-top "data Either a b = Left a | Right b")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Either"
|
||||
(list "a" "b")
|
||||
(list
|
||||
(list :con-def "Left" (list (list :t-var "a")))
|
||||
(list :con-def "Right" (list (list :t-var "b")))))))
|
||||
|
||||
(hk-test
|
||||
"data with no type parameters"
|
||||
(hk-parse-top "data Bool = True | False")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Bool"
|
||||
(list)
|
||||
(list
|
||||
(list :con-def "True" (list))
|
||||
(list :con-def "False" (list))))))
|
||||
|
||||
(hk-test
|
||||
"recursive data type"
|
||||
(hk-parse-top "data Tree a = Leaf | Node (Tree a) a (Tree a)")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Tree"
|
||||
(list "a")
|
||||
(list
|
||||
(list :con-def "Leaf" (list))
|
||||
(list
|
||||
:con-def
|
||||
"Node"
|
||||
(list
|
||||
(list :t-app (list :t-con "Tree") (list :t-var "a"))
|
||||
(list :t-var "a")
|
||||
(list :t-app (list :t-con "Tree") (list :t-var "a"))))))))
|
||||
|
||||
;; ── type synonyms ──
|
||||
(hk-test
|
||||
"simple type synonym"
|
||||
(hk-parse-top "type Name = String")
|
||||
(hk-prog
|
||||
(list :type-syn "Name" (list) (list :t-con "String"))))
|
||||
|
||||
(hk-test
|
||||
"parameterised type synonym"
|
||||
(hk-parse-top "type Pair a = (a, a)")
|
||||
(hk-prog
|
||||
(list
|
||||
:type-syn
|
||||
"Pair"
|
||||
(list "a")
|
||||
(list
|
||||
:t-tuple
|
||||
(list (list :t-var "a") (list :t-var "a"))))))
|
||||
|
||||
;; ── newtype ──
|
||||
(hk-test
|
||||
"newtype"
|
||||
(hk-parse-top "newtype Age = Age Int")
|
||||
(hk-prog (list :newtype "Age" (list) "Age" (list :t-con "Int"))))
|
||||
|
||||
(hk-test
|
||||
"parameterised newtype"
|
||||
(hk-parse-top "newtype Wrap a = Wrap a")
|
||||
(hk-prog
|
||||
(list :newtype "Wrap" (list "a") "Wrap" (list :t-var "a"))))
|
||||
|
||||
;; ── fixity declarations ──
|
||||
(hk-test
|
||||
"infixl with precedence"
|
||||
(hk-parse-top "infixl 5 +:, -:")
|
||||
(hk-prog (list :fixity "l" 5 (list "+:" "-:"))))
|
||||
|
||||
(hk-test
|
||||
"infixr"
|
||||
(hk-parse-top "infixr 9 .")
|
||||
(hk-prog (list :fixity "r" 9 (list "."))))
|
||||
|
||||
(hk-test
|
||||
"infix (non-assoc) default prec"
|
||||
(hk-parse-top "infix ==")
|
||||
(hk-prog (list :fixity "n" 9 (list "=="))))
|
||||
|
||||
(hk-test
|
||||
"fixity with backtick operator name"
|
||||
(hk-parse-top "infixl 7 `div`")
|
||||
(hk-prog (list :fixity "l" 7 (list "div"))))
|
||||
|
||||
;; ── Several decls combined ──
|
||||
(hk-test
|
||||
"mixed: data + sig + fn + type"
|
||||
(hk-parse-top "data Maybe a = Nothing | Just a\ntype Entry = Maybe Int\nf :: Entry -> Int\nf (Just x) = x\nf Nothing = 0")
|
||||
(hk-prog
|
||||
(list
|
||||
:data
|
||||
"Maybe"
|
||||
(list "a")
|
||||
(list
|
||||
(list :con-def "Nothing" (list))
|
||||
(list :con-def "Just" (list (list :t-var "a")))))
|
||||
(list
|
||||
:type-syn
|
||||
"Entry"
|
||||
(list)
|
||||
(list :t-app (list :t-con "Maybe") (list :t-con "Int")))
|
||||
(list
|
||||
:type-sig
|
||||
(list "f")
|
||||
(list :t-fun (list :t-con "Entry") (list :t-con "Int")))
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-con "Just" (list (list :p-var "x"))))
|
||||
(list :var "x"))
|
||||
(list
|
||||
:fun-clause
|
||||
"f"
|
||||
(list (list :p-con "Nothing" (list)))
|
||||
(list :int 0))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
258
lib/haskell/tests/parser-expr.sx
Normal file
258
lib/haskell/tests/parser-expr.sx
Normal file
@@ -0,0 +1,258 @@
|
||||
;; Haskell expression parser tests.
|
||||
;; hk-parse tokenises, runs layout, then parses. Output is an AST
|
||||
;; whose head is a keyword tag (evaluates to its string name).
|
||||
|
||||
;; ── 1. Literals ──
|
||||
(hk-test "integer" (hk-parse "42") (list :int 42))
|
||||
(hk-test "float" (hk-parse "3.14") (list :float 3.14))
|
||||
(hk-test "string" (hk-parse "\"hi\"") (list :string "hi"))
|
||||
(hk-test "char" (hk-parse "'a'") (list :char "a"))
|
||||
|
||||
;; ── 2. Variables and constructors ──
|
||||
(hk-test "varid" (hk-parse "foo") (list :var "foo"))
|
||||
(hk-test "conid" (hk-parse "Nothing") (list :con "Nothing"))
|
||||
(hk-test "qvarid" (hk-parse "Data.Map.lookup") (list :var "Data.Map.lookup"))
|
||||
(hk-test "qconid" (hk-parse "Data.Map") (list :con "Data.Map"))
|
||||
|
||||
;; ── 3. Parens / unit / tuple ──
|
||||
(hk-test "parens strip" (hk-parse "(42)") (list :int 42))
|
||||
(hk-test "unit" (hk-parse "()") (list :con "()"))
|
||||
(hk-test
|
||||
"2-tuple"
|
||||
(hk-parse "(1, 2)")
|
||||
(list :tuple (list (list :int 1) (list :int 2))))
|
||||
(hk-test
|
||||
"3-tuple"
|
||||
(hk-parse "(x, y, z)")
|
||||
(list
|
||||
:tuple
|
||||
(list (list :var "x") (list :var "y") (list :var "z"))))
|
||||
|
||||
;; ── 4. Lists ──
|
||||
(hk-test "empty list" (hk-parse "[]") (list :list (list)))
|
||||
(hk-test
|
||||
"singleton list"
|
||||
(hk-parse "[1]")
|
||||
(list :list (list (list :int 1))))
|
||||
(hk-test
|
||||
"list of ints"
|
||||
(hk-parse "[1, 2, 3]")
|
||||
(list
|
||||
:list
|
||||
(list (list :int 1) (list :int 2) (list :int 3))))
|
||||
(hk-test
|
||||
"range"
|
||||
(hk-parse "[1..10]")
|
||||
(list :range (list :int 1) (list :int 10)))
|
||||
(hk-test
|
||||
"range with step"
|
||||
(hk-parse "[1, 3..10]")
|
||||
(list
|
||||
:range-step
|
||||
(list :int 1)
|
||||
(list :int 3)
|
||||
(list :int 10)))
|
||||
|
||||
;; ── 5. Application ──
|
||||
(hk-test
|
||||
"one-arg app"
|
||||
(hk-parse "f x")
|
||||
(list :app (list :var "f") (list :var "x")))
|
||||
(hk-test
|
||||
"multi-arg app is left-assoc"
|
||||
(hk-parse "f x y z")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :app (list :var "f") (list :var "x"))
|
||||
(list :var "y"))
|
||||
(list :var "z")))
|
||||
(hk-test
|
||||
"app with con"
|
||||
(hk-parse "Just 5")
|
||||
(list :app (list :con "Just") (list :int 5)))
|
||||
|
||||
;; ── 6. Infix operators ──
|
||||
(hk-test
|
||||
"simple +"
|
||||
(hk-parse "1 + 2")
|
||||
(list :op "+" (list :int 1) (list :int 2)))
|
||||
(hk-test
|
||||
"precedence: * binds tighter than +"
|
||||
(hk-parse "1 + 2 * 3")
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :int 1)
|
||||
(list :op "*" (list :int 2) (list :int 3))))
|
||||
(hk-test
|
||||
"- is left-assoc"
|
||||
(hk-parse "10 - 3 - 2")
|
||||
(list
|
||||
:op
|
||||
"-"
|
||||
(list :op "-" (list :int 10) (list :int 3))
|
||||
(list :int 2)))
|
||||
(hk-test
|
||||
": is right-assoc"
|
||||
(hk-parse "a : b : c")
|
||||
(list
|
||||
:op
|
||||
":"
|
||||
(list :var "a")
|
||||
(list :op ":" (list :var "b") (list :var "c"))))
|
||||
(hk-test
|
||||
"app binds tighter than op"
|
||||
(hk-parse "f x + g y")
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :app (list :var "f") (list :var "x"))
|
||||
(list :app (list :var "g") (list :var "y"))))
|
||||
(hk-test
|
||||
"$ is lowest precedence, right-assoc"
|
||||
(hk-parse "f $ g x")
|
||||
(list
|
||||
:op
|
||||
"$"
|
||||
(list :var "f")
|
||||
(list :app (list :var "g") (list :var "x"))))
|
||||
|
||||
;; ── 7. Backticks (varid-as-operator) ──
|
||||
(hk-test
|
||||
"backtick operator"
|
||||
(hk-parse "x `mod` 3")
|
||||
(list :op "mod" (list :var "x") (list :int 3)))
|
||||
|
||||
;; ── 8. Unary negation ──
|
||||
(hk-test
|
||||
"unary -"
|
||||
(hk-parse "- 5")
|
||||
(list :neg (list :int 5)))
|
||||
(hk-test
|
||||
"unary - on application"
|
||||
(hk-parse "- f x")
|
||||
(list :neg (list :app (list :var "f") (list :var "x"))))
|
||||
(hk-test
|
||||
"- n + m → (- n) + m"
|
||||
(hk-parse "- 1 + 2")
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :neg (list :int 1))
|
||||
(list :int 2)))
|
||||
|
||||
;; ── 9. Lambda ──
|
||||
(hk-test
|
||||
"lambda single param"
|
||||
(hk-parse "\\x -> x")
|
||||
(list :lambda (list (list :p-var "x")) (list :var "x")))
|
||||
(hk-test
|
||||
"lambda multi-param"
|
||||
(hk-parse "\\x y -> x + y")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x") (list :p-var "y"))
|
||||
(list :op "+" (list :var "x") (list :var "y"))))
|
||||
(hk-test
|
||||
"lambda body is full expression"
|
||||
(hk-parse "\\f -> f 1 + f 2")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "f"))
|
||||
(list
|
||||
:op
|
||||
"+"
|
||||
(list :app (list :var "f") (list :int 1))
|
||||
(list :app (list :var "f") (list :int 2)))))
|
||||
|
||||
;; ── 10. if-then-else ──
|
||||
(hk-test
|
||||
"if basic"
|
||||
(hk-parse "if x then 1 else 2")
|
||||
(list :if (list :var "x") (list :int 1) (list :int 2)))
|
||||
(hk-test
|
||||
"if with infix cond"
|
||||
(hk-parse "if x == 0 then y else z")
|
||||
(list
|
||||
:if
|
||||
(list :op "==" (list :var "x") (list :int 0))
|
||||
(list :var "y")
|
||||
(list :var "z")))
|
||||
|
||||
;; ── 11. let-in ──
|
||||
(hk-test
|
||||
"let single binding"
|
||||
(hk-parse "let x = 1 in x")
|
||||
(list
|
||||
:let
|
||||
(list (list :bind (list :p-var "x") (list :int 1)))
|
||||
(list :var "x")))
|
||||
(hk-test
|
||||
"let two bindings (multi-line)"
|
||||
(hk-parse "let x = 1\n y = 2\nin x + y")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list :bind (list :p-var "x") (list :int 1))
|
||||
(list :bind (list :p-var "y") (list :int 2)))
|
||||
(list :op "+" (list :var "x") (list :var "y"))))
|
||||
(hk-test
|
||||
"let with explicit braces"
|
||||
(hk-parse "let { x = 1 ; y = 2 } in x + y")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list :bind (list :p-var "x") (list :int 1))
|
||||
(list :bind (list :p-var "y") (list :int 2)))
|
||||
(list :op "+" (list :var "x") (list :var "y"))))
|
||||
|
||||
;; ── 12. Mixed / nesting ──
|
||||
(hk-test
|
||||
"nested application"
|
||||
(hk-parse "f (g x) y")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:app
|
||||
(list :var "f")
|
||||
(list :app (list :var "g") (list :var "x")))
|
||||
(list :var "y")))
|
||||
(hk-test
|
||||
"lambda applied"
|
||||
(hk-parse "(\\x -> x + 1) 5")
|
||||
(list
|
||||
:app
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "x"))
|
||||
(list :op "+" (list :var "x") (list :int 1)))
|
||||
(list :int 5)))
|
||||
(hk-test
|
||||
"lambda + if"
|
||||
(hk-parse "\\n -> if n == 0 then 1 else n")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-var "n"))
|
||||
(list
|
||||
:if
|
||||
(list :op "==" (list :var "n") (list :int 0))
|
||||
(list :int 1)
|
||||
(list :var "n"))))
|
||||
|
||||
;; ── 13. Precedence corners ──
|
||||
(hk-test
|
||||
". is right-assoc (prec 9)"
|
||||
(hk-parse "f . g . h")
|
||||
(list
|
||||
:op
|
||||
"."
|
||||
(list :var "f")
|
||||
(list :op "." (list :var "g") (list :var "h"))))
|
||||
(hk-test
|
||||
"== is non-associative (single use)"
|
||||
(hk-parse "x == y")
|
||||
(list :op "==" (list :var "x") (list :var "y")))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
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}
|
||||
202
lib/haskell/tests/parser-module.sx
Normal file
202
lib/haskell/tests/parser-module.sx
Normal file
@@ -0,0 +1,202 @@
|
||||
;; Module header + imports. The parser switches from (:program DECLS)
|
||||
;; to (:module NAME EXPORTS IMPORTS DECLS) as soon as a module header
|
||||
;; or any `import` decl appears.
|
||||
|
||||
;; ── Module header ──
|
||||
(hk-test
|
||||
"simple module, no exports"
|
||||
(hk-parse-top "module M where\n f = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
nil
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"module with dotted name"
|
||||
(hk-parse-top "module Data.Map where\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"Data.Map"
|
||||
nil
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"module with empty export list"
|
||||
(hk-parse-top "module M () where\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
(list)
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"module with exports (var, tycon-all, tycon-with)"
|
||||
(hk-parse-top "module M (f, g, Maybe(..), List(Cons, Nil)) where\nf = 1\ng = 2")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
(list
|
||||
(list :ent-var "f")
|
||||
(list :ent-var "g")
|
||||
(list :ent-all "Maybe")
|
||||
(list :ent-with "List" (list "Cons" "Nil")))
|
||||
(list)
|
||||
(list
|
||||
(list :fun-clause "f" (list) (list :int 1))
|
||||
(list :fun-clause "g" (list) (list :int 2)))))
|
||||
|
||||
(hk-test
|
||||
"module export list including another module"
|
||||
(hk-parse-top "module M (module Foo, f) where\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
(list (list :ent-module "Foo") (list :ent-var "f"))
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"module export with operator"
|
||||
(hk-parse-top "module M ((+:), f) where\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
(list (list :ent-var "+:") (list :ent-var "f"))
|
||||
(list)
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"empty module body"
|
||||
(hk-parse-top "module M where")
|
||||
(list :module "M" nil (list) (list)))
|
||||
|
||||
;; ── Imports ──
|
||||
(hk-test
|
||||
"plain import"
|
||||
(hk-parse-top "import Foo")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list (list :import false "Foo" nil nil))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"qualified import"
|
||||
(hk-parse-top "import qualified Data.Map")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list (list :import true "Data.Map" nil nil))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"import with alias"
|
||||
(hk-parse-top "import Data.Map as M")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list (list :import false "Data.Map" "M" nil))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"import with explicit list"
|
||||
(hk-parse-top "import Foo (bar, Baz(..), Quux(X, Y))")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list
|
||||
(list
|
||||
:import
|
||||
false
|
||||
"Foo"
|
||||
nil
|
||||
(list
|
||||
:spec-items
|
||||
(list
|
||||
(list :ent-var "bar")
|
||||
(list :ent-all "Baz")
|
||||
(list :ent-with "Quux" (list "X" "Y"))))))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"import hiding"
|
||||
(hk-parse-top "import Foo hiding (x, y)")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list
|
||||
(list
|
||||
:import
|
||||
false
|
||||
"Foo"
|
||||
nil
|
||||
(list
|
||||
:spec-hiding
|
||||
(list (list :ent-var "x") (list :ent-var "y")))))
|
||||
(list)))
|
||||
|
||||
(hk-test
|
||||
"qualified + alias + hiding"
|
||||
(hk-parse-top "import qualified Data.List as L hiding (sort)")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list
|
||||
(list
|
||||
:import
|
||||
true
|
||||
"Data.List"
|
||||
"L"
|
||||
(list :spec-hiding (list (list :ent-var "sort")))))
|
||||
(list)))
|
||||
|
||||
;; ── Combinations ──
|
||||
(hk-test
|
||||
"module with multiple imports and a decl"
|
||||
(hk-parse-top "module M where\nimport Foo\nimport qualified Bar as B\nf = 1")
|
||||
(list
|
||||
:module
|
||||
"M"
|
||||
nil
|
||||
(list
|
||||
(list :import false "Foo" nil nil)
|
||||
(list :import true "Bar" "B" nil))
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"headerless file with imports"
|
||||
(hk-parse-top "import Foo\nimport Bar (baz)\nf = 1")
|
||||
(list
|
||||
:module
|
||||
nil
|
||||
nil
|
||||
(list
|
||||
(list :import false "Foo" nil nil)
|
||||
(list
|
||||
:import
|
||||
false
|
||||
"Bar"
|
||||
nil
|
||||
(list :spec-items (list (list :ent-var "baz")))))
|
||||
(list (list :fun-clause "f" (list) (list :int 1)))))
|
||||
|
||||
(hk-test
|
||||
"plain program (no header, no imports) still uses :program"
|
||||
(hk-parse-top "f = 1\ng = 2")
|
||||
(list
|
||||
:program
|
||||
(list
|
||||
(list :fun-clause "f" (list) (list :int 1))
|
||||
(list :fun-clause "g" (list) (list :int 2)))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
234
lib/haskell/tests/parser-patterns.sx
Normal file
234
lib/haskell/tests/parser-patterns.sx
Normal file
@@ -0,0 +1,234 @@
|
||||
;; Full-pattern parser tests: as-patterns, lazy ~, negative literals,
|
||||
;; infix constructor patterns (`:`, any consym), lambda pattern args,
|
||||
;; and let pattern-bindings.
|
||||
|
||||
;; ── as-patterns ──
|
||||
(hk-test
|
||||
"as pattern, wraps constructor"
|
||||
(hk-parse "case x of n@(Just y) -> n")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-as
|
||||
"n"
|
||||
(list :p-con "Just" (list (list :p-var "y"))))
|
||||
(list :var "n")))))
|
||||
|
||||
(hk-test
|
||||
"as pattern, wraps wildcard"
|
||||
(hk-parse "case x of all@_ -> all")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list :p-as "all" (list :p-wild))
|
||||
(list :var "all")))))
|
||||
|
||||
(hk-test
|
||||
"as in lambda"
|
||||
(hk-parse "\\xs@(a : rest) -> xs")
|
||||
(list
|
||||
:lambda
|
||||
(list
|
||||
(list
|
||||
:p-as
|
||||
"xs"
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "a") (list :p-var "rest")))))
|
||||
(list :var "xs")))
|
||||
|
||||
;; ── lazy patterns ──
|
||||
(hk-test
|
||||
"lazy var"
|
||||
(hk-parse "case x of ~y -> y")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list
|
||||
(list :alt (list :p-lazy (list :p-var "y")) (list :var "y")))))
|
||||
|
||||
(hk-test
|
||||
"lazy constructor"
|
||||
(hk-parse "\\(~(Just x)) -> x")
|
||||
(list
|
||||
:lambda
|
||||
(list
|
||||
(list
|
||||
:p-lazy
|
||||
(list :p-con "Just" (list (list :p-var "x")))))
|
||||
(list :var "x")))
|
||||
|
||||
;; ── negative literal patterns ──
|
||||
(hk-test
|
||||
"negative int pattern"
|
||||
(hk-parse "case n of\n -1 -> 0\n _ -> n")
|
||||
(list
|
||||
:case
|
||||
(list :var "n")
|
||||
(list
|
||||
(list :alt (list :p-int -1) (list :int 0))
|
||||
(list :alt (list :p-wild) (list :var "n")))))
|
||||
|
||||
(hk-test
|
||||
"negative float pattern"
|
||||
(hk-parse "case x of -0.5 -> 1")
|
||||
(list
|
||||
:case
|
||||
(list :var "x")
|
||||
(list (list :alt (list :p-float -0.5) (list :int 1)))))
|
||||
|
||||
;; ── infix constructor patterns (`:` and any consym) ──
|
||||
(hk-test
|
||||
"cons pattern"
|
||||
(hk-parse "case xs of x : rest -> x")
|
||||
(list
|
||||
:case
|
||||
(list :var "xs")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "x") (list :p-var "rest")))
|
||||
(list :var "x")))))
|
||||
|
||||
(hk-test
|
||||
"cons is right-associative in pats"
|
||||
(hk-parse "case xs of a : b : rest -> rest")
|
||||
(list
|
||||
:case
|
||||
(list :var "xs")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list
|
||||
(list :p-var "a")
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "b") (list :p-var "rest")))))
|
||||
(list :var "rest")))))
|
||||
|
||||
(hk-test
|
||||
"consym pattern"
|
||||
(hk-parse "case p of a :+: b -> a")
|
||||
(list
|
||||
:case
|
||||
(list :var "p")
|
||||
(list
|
||||
(list
|
||||
:alt
|
||||
(list
|
||||
:p-con
|
||||
":+:"
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "a")))))
|
||||
|
||||
;; ── lambda with pattern args ──
|
||||
(hk-test
|
||||
"lambda with constructor pattern"
|
||||
(hk-parse "\\(Just x) -> x")
|
||||
(list
|
||||
:lambda
|
||||
(list (list :p-con "Just" (list (list :p-var "x"))))
|
||||
(list :var "x")))
|
||||
|
||||
(hk-test
|
||||
"lambda with tuple pattern"
|
||||
(hk-parse "\\(a, b) -> a + b")
|
||||
(list
|
||||
:lambda
|
||||
(list
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b"))))
|
||||
(list :op "+" (list :var "a") (list :var "b"))))
|
||||
|
||||
(hk-test
|
||||
"lambda with wildcard"
|
||||
(hk-parse "\\_ -> 42")
|
||||
(list :lambda (list (list :p-wild)) (list :int 42)))
|
||||
|
||||
(hk-test
|
||||
"lambda with mixed apats"
|
||||
(hk-parse "\\x _ (Just y) -> y")
|
||||
(list
|
||||
:lambda
|
||||
(list
|
||||
(list :p-var "x")
|
||||
(list :p-wild)
|
||||
(list :p-con "Just" (list (list :p-var "y"))))
|
||||
(list :var "y")))
|
||||
|
||||
;; ── let pattern-bindings ──
|
||||
(hk-test
|
||||
"let tuple pattern-binding"
|
||||
(hk-parse "let (x, y) = pair in x + y")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "x") (list :p-var "y")))
|
||||
(list :var "pair")))
|
||||
(list :op "+" (list :var "x") (list :var "y"))))
|
||||
|
||||
(hk-test
|
||||
"let constructor pattern-binding"
|
||||
(hk-parse "let Just x = m in x")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list :p-con "Just" (list (list :p-var "x")))
|
||||
(list :var "m")))
|
||||
(list :var "x")))
|
||||
|
||||
(hk-test
|
||||
"let cons pattern-binding"
|
||||
(hk-parse "let (x : rest) = xs in x")
|
||||
(list
|
||||
:let
|
||||
(list
|
||||
(list
|
||||
:bind
|
||||
(list
|
||||
:p-con
|
||||
":"
|
||||
(list (list :p-var "x") (list :p-var "rest")))
|
||||
(list :var "xs")))
|
||||
(list :var "x")))
|
||||
|
||||
;; ── do with constructor-pattern binds ──
|
||||
(hk-test
|
||||
"do bind to tuple pattern"
|
||||
(hk-parse "do\n (a, b) <- pairs\n return a")
|
||||
(list
|
||||
:do
|
||||
(list
|
||||
(list
|
||||
:do-bind
|
||||
(list
|
||||
:p-tuple
|
||||
(list (list :p-var "a") (list :p-var "b")))
|
||||
(list :var "pairs"))
|
||||
(list
|
||||
:do-expr
|
||||
(list :app (list :var "return") (list :var "a"))))))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -55,8 +55,15 @@ Key mappings:
|
||||
|
||||
### Phase 1 — tokenizer + parser + layout rule
|
||||
- [x] Tokenizer: reserved words, qualified names, operators, numbers (int, float, Rational later), chars/strings, comments (`--` and `{-` nested)
|
||||
- [ ] Layout algorithm: turn indentation into virtual `{`, `;`, `}` tokens per Haskell 98 §10.3
|
||||
- [ ] Parser: modules, imports (stub), top-level decls, type sigs, function clauses with patterns + guards + where-clauses, expressions with operator precedence, lambdas, `let`, `if`, `case`, `do`, list comp, sections
|
||||
- [x] Layout algorithm: turn indentation into virtual `{`, `;`, `}` tokens per Haskell 98 §10.3
|
||||
- Parser (split into sub-items — implement one per iteration):
|
||||
- [x] Expressions: atoms, parens, tuples, lists, ranges, application, infix with full Haskell-98 precedence table, unary `-`, backtick operators, lambdas, `if`, `let`
|
||||
- [x] `case … of` and `do`-notation expressions (plus minimal patterns needed for arms/binds: var, wildcard, literal, 0-arity and applied constructor, tuple, list)
|
||||
- [x] Patterns — full: `as` patterns, nested, negative literal, `~` lazy, infix constructor (`:` / consym), extend lambdas/let with non-var patterns
|
||||
- [x] Top-level decls: function clauses (simple — no guards/where yet), pattern bindings, multi-name type signatures, `data` with type vars and recursive constructors, `type` synonyms, `newtype`, fixity (`infix`/`infixl`/`infixr` with optional precedence, comma-separated ops, backtick names). Types: vars / constructors / application / `->` (right-assoc) / tuples / lists. `hk-parse-top` entry.
|
||||
- [x] `where` clauses + guards (on fun-clauses, case alts, and let/do-let bindings — with the let funclause shorthand `let f x = …` now supported)
|
||||
- [x] Module header + imports — `module NAME [exports] where …`, qualified/as/hiding/explicit imports, operator exports, `module Foo` exports, dotted names, headerless-with-imports
|
||||
- [ ] List comprehensions + operator sections
|
||||
- [ ] AST design modelled on GHC's HsSyn at a surface level
|
||||
- [x] Unit tests in `lib/haskell/tests/parse.sx` (43 tokenizer tests, all green)
|
||||
|
||||
@@ -107,6 +114,160 @@ Key mappings:
|
||||
|
||||
_Newest first._
|
||||
|
||||
- **2026-04-24** — Phase 1: module header + imports. Added
|
||||
`hk-parse-module-header`, `hk-parse-import`, plus shared helpers for
|
||||
import/export entity lists (`hk-parse-ent`, `hk-parse-ent-member`,
|
||||
`hk-parse-ent-list`). New AST:
|
||||
- `(:module NAME EXPORTS IMPORTS DECLS)` — NAME `nil` means no header,
|
||||
EXPORTS `nil` means no export list (distinct from empty `()`)
|
||||
- `(:import QUALIFIED NAME AS SPEC)` — QUALIFIED bool, AS alias or nil,
|
||||
SPEC nil / `(:spec-items ENTS)` / `(:spec-hiding ENTS)`
|
||||
- Entity refs: `:ent-var`, `:ent-all` (`Tycon(..)`), `:ent-with`
|
||||
(`Tycon(m1, m2, …)`), `:ent-module` (exports only).
|
||||
`hk-parse-program` now dispatches on the leading token: `module`
|
||||
keyword → full header-plus-body parse (consuming the `where` layout
|
||||
brace around the module body); otherwise collect any leading
|
||||
`import` decls and then remaining decls with the existing logic.
|
||||
The outer shell is `(:module …)` as soon as any header or import is
|
||||
present, and stays as `(:program DECLS)` otherwise — preserving every
|
||||
previous test expectation untouched. Handles operator exports `((+:))`,
|
||||
dotted module names (`Data.Map`), and the Haskell-98 context-sensitive
|
||||
keywords `qualified`/`as`/`hiding` (all lexed as ordinary varids and
|
||||
matched only in import position). 16 new tests in
|
||||
`lib/haskell/tests/parser-module.sx` covering simple/exports/empty
|
||||
headers, dotted names, operator exports, `module Foo` exports,
|
||||
qualified/aliased/items/hiding imports, and a headerless-with-imports
|
||||
file. 189/189 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: guards + where clauses. Factored a single
|
||||
`hk-parse-rhs sep` that all body-producing sites now share: it reads
|
||||
a plain `sep expr` body or a chain of `| cond sep expr` guards, then
|
||||
— regardless of which form — looks for an optional `where` block and
|
||||
wraps accordingly. AST additions:
|
||||
- `:guarded GUARDS` where each GUARD is `:guard COND EXPR`
|
||||
- `:where BODY DECLS` where BODY is a plain expr or a `:guarded`
|
||||
Both can nest (guards inside where). `hk-parse-alt` now routes through
|
||||
`hk-parse-rhs "->"`, `hk-parse-fun-clause` and `hk-parse-bind` through
|
||||
`hk-parse-rhs "="`. `hk-parse-where-decls` reuses `hk-parse-decl` so
|
||||
where-blocks accept any decl form (signatures, fixity, nested funs).
|
||||
As a side effect, `hk-parse-bind` now also picks up the Haskell-native
|
||||
`let f x = …` funclause shorthand: a varid followed by one or more
|
||||
apats produces `(:fun-clause NAME APATS BODY)` instead of a
|
||||
`(:bind (:p-var …) …)` — keeping the simple `let x = e` shape
|
||||
unchanged for existing tests. 11 new tests in
|
||||
`lib/haskell/tests/parser-guards-where.sx` cover two- and three-way
|
||||
guards, mixed guarded + equality clauses, single- and multi-binding
|
||||
where blocks, guards plus where, case-alt guards, case-alt where,
|
||||
let with funclause shorthand, let with guards, and a where containing
|
||||
a type signature alongside a fun-clause. 173/173 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: top-level decls. Refactored `hk-parse-expr` into a
|
||||
`hk-parser tokens mode` with `:expr` / `:module` dispatch so the big lexical
|
||||
state is shared (peek/advance/pat/expr helpers all reachable); added public
|
||||
wrappers `hk-parse-expr`, `hk-parse-module`, and source-level entry
|
||||
`hk-parse-top`. New type parser (`hk-parse-type` / `hk-parse-btype` /
|
||||
`hk-parse-atype`): type variables (`:t-var`), type constructors (`:t-con`),
|
||||
type application (`:t-app`, left-assoc), right-associative function arrow
|
||||
(`:t-fun`), unit/tuples (`:t-tuple`), and lists (`:t-list`). New decl parser
|
||||
(`hk-parse-decl` / `hk-parse-program`) producing a `(:program DECLS)` shell:
|
||||
- `:type-sig NAMES TYPE` — comma-separated multi-name support
|
||||
- `:fun-clause NAME APATS BODY` — patterns for args, body via existing expr
|
||||
- `:pat-bind PAT BODY` — top-level pattern bindings like `(a, b) = pair`
|
||||
- `:data NAME TVARS CONS` with `:con-def CNAME FIELDS` for nullary and
|
||||
multi-arg constructors, including recursive references
|
||||
- `:type-syn NAME TVARS TYPE`, `:newtype NAME TVARS CNAME FIELD`
|
||||
- `:fixity ASSOC PREC OPS` — assoc one of `"l"`/`"r"`/`"n"`, default prec 9,
|
||||
comma-separated operator names, including backtick-quoted varids.
|
||||
Sig vs fun-clause disambiguated by a paren-balanced top-level scan for
|
||||
`::` before the next `;`/`}` (`hk-has-top-dcolon?`). 24 new tests in
|
||||
`lib/haskell/tests/parser-decls.sx` cover all decl forms, signatures with
|
||||
application / tuples / lists / right-assoc arrows, nullary and recursive
|
||||
data types, multi-clause functions, and a mixed program with data + type-
|
||||
synonym + signature + two function clauses. Not yet: guards, where
|
||||
clauses, module header, imports, deriving, contexts, GADTs. 162/162 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: full patterns. Added `as` patterns
|
||||
(`name@apat` → `(:p-as NAME PAT)`), lazy patterns (`~apat` →
|
||||
`(:p-lazy PAT)`), negative literal patterns (`-N` / `-F` resolving
|
||||
eagerly in the parser so downstream passes see a plain `(:p-int -1)`),
|
||||
and infix constructor patterns via a right-associative single-band
|
||||
layer on top of `hk-parse-pat-lhs` for any `consym` or reservedop `:`
|
||||
(so `x : xs` parses as `(:p-con ":" [x, xs])`, `a :+: b` likewise).
|
||||
Extended `hk-apat-start?` with `-` and `~` so the pattern-argument
|
||||
loops in lambdas and constructor applications pick these up.
|
||||
Lambdas now parse apat parameters instead of bare varids — so the
|
||||
`:lambda` AST is `(:lambda APATS BODY)` with apats as pattern nodes.
|
||||
`hk-parse-bind` became a plain `pat = expr` form, so `:bind` now has
|
||||
a pattern LHS throughout (simple `x = 1` → `(:bind (:p-var "x") …)`);
|
||||
this picks up `let (x, y) = pair in …` and `let Just x = m in x`
|
||||
automatically, and flows through `do`-notation lets. Eight existing
|
||||
tests updated to the pattern-flavoured AST. Also fixed a pragmatic
|
||||
layout issue that surfaced in multi-line `let`s: when a layout-indent
|
||||
would emit a spurious `;` just before an `in` token (because the
|
||||
let block had already been closed by dedent), `hk-peek-next-reserved`
|
||||
now lets the layout pass skip that indent and leave closing to the
|
||||
existing `in` handler. 18 new tests in
|
||||
`lib/haskell/tests/parser-patterns.sx` cover every pattern variant,
|
||||
lambda with mixed apats, let pattern-bindings (tuple / constructor /
|
||||
cons), and do-bind with a tuple pattern. 138/138 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: `case … of` and `do`-notation parsers. Added `hk-parse-case`
|
||||
/ `hk-parse-alt`, `hk-parse-do` / `hk-parse-do-stmt` / `hk-parse-do-let`, plus the
|
||||
minimal pattern language needed to make arms and binds meaningful:
|
||||
`hk-parse-apat` (var, wildcard `_`, int/float/string/char literal, 0-arity
|
||||
conid/qconid, paren+tuple, list) and `hk-parse-pat` (conid applied to
|
||||
apats greedily). AST nodes: `:case SCRUT ALTS`, `:alt PAT BODY`, `:do STMTS`
|
||||
with stmts `:do-expr E` / `:do-bind PAT E` / `:do-let BINDS`, and pattern
|
||||
tags `:p-wild` / `:p-int` / `:p-float` / `:p-string` / `:p-char` / `:p-var`
|
||||
/ `:p-con NAME ARGS` / `:p-tuple` / `:p-list`. `do`-stmts disambiguate
|
||||
`pat <- e` vs bare expression with a forward paren/bracket/brace-balanced
|
||||
scan for `<-` before the next `;`/`}` — no backtracking, no AST rewrite.
|
||||
`case` and `do` accept both implicit (`vlbrace`/`vsemi`/`vrbrace`) and
|
||||
explicit braces. Added to `hk-parse-lexp` so they participate fully in
|
||||
operator-precedence expressions. 19 new tests in
|
||||
`lib/haskell/tests/parser-case-do.sx` cover every pattern variant,
|
||||
explicit-brace `case`, expression scrutinees, do with bind/let/expr,
|
||||
multi-binding `let` in `do`, constructor patterns in binds, and
|
||||
`case`/`do` nested inside `let` and lambda. The full pattern item (as
|
||||
patterns, negative literals, `~` lazy, lambda/let pattern extension)
|
||||
remains a separate sub-item. 119/119 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: expression parser (`lib/haskell/parser.sx`, ~380 lines).
|
||||
Pratt-style precedence climbing against a Haskell-98-default op table (24
|
||||
operators across precedence 0–9, left/right/non assoc, default infixl 9 for
|
||||
anything unlisted). Supports literals (int/float/string/char), varid/conid
|
||||
(qualified variants folded into `:var` / `:con`), parens / unit / tuples,
|
||||
list literals, ranges `[a..b]` and `[a,b..c]`, left-associative application,
|
||||
unary `-`, backtick operators (`x \`mod\` 3`), lambdas, `if-then-else`, and
|
||||
`let … in` consuming both virtual and explicit braces. AST uses keyword
|
||||
tags (`:var`, `:op`, `:lambda`, `:let`, `:bind`, `:tuple`, `:range`,
|
||||
`:range-step`, `:app`, `:neg`, `:if`, `:list`, `:int`, `:float`, `:string`,
|
||||
`:char`, `:con`). The parser skips a leading `vlbrace` / `lbrace` so it can
|
||||
be called on full post-layout output, and uses a `raise`-based error channel
|
||||
with location-lite messages. 42 new tests in `lib/haskell/tests/parser-expr.sx`
|
||||
cover literals, identifiers, parens/tuple/unit, list + range, app associativity,
|
||||
operator precedence (mul over add, cons right-assoc, function-composition
|
||||
right-assoc, `$` lowest), backtick ops, unary `-`, lambda multi-param,
|
||||
`if` with infix condition, single- and multi-binding `let` (both implicit
|
||||
and explicit braces), plus a few mixed nestings. 100/100 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: layout algorithm (`lib/haskell/layout.sx`, ~260 lines)
|
||||
implementing Haskell 98 §10.3. Two-pass design: a pre-pass augments the raw
|
||||
token stream with explicit `layout-open` / `layout-indent` markers (suppressing
|
||||
`<n>` when `{n}` already applies, per note 3), then an L pass consumes the
|
||||
augmented stream against a stack of implicit/explicit layout contexts and
|
||||
emits `vlbrace` / `vsemi` / `vrbrace` tokens; newlines are dropped. Supports
|
||||
the initial module-level implicit open (skipped when the first token is
|
||||
`module` or `{`), the four layout keywords (`let`/`where`/`do`/`of`), explicit
|
||||
braces disabling layout, dedent closing nested implicit blocks while also
|
||||
emitting `vsemi` at the enclosing level, and the pragmatic single-line
|
||||
`let … in` rule (emit `}` when `in` meets an implicit let). 15 new tests
|
||||
in `lib/haskell/tests/layout.sx` cover module-start, do/let/where/case/of,
|
||||
explicit braces, multi-level dedent, line continuation, and EOF close-down.
|
||||
Shared test helpers moved to `lib/haskell/testlib.sx` so both test files
|
||||
can share one `hk-test`. `test.sh` preloads tokenizer + layout + testlib.
|
||||
58/58 green.
|
||||
|
||||
- **2026-04-24** — Phase 1: Haskell 98 tokenizer (`lib/haskell/tokenizer.sx`, 490 lines)
|
||||
covering idents (lower/upper/qvarid/qconid), 23 reserved words, 11 reserved ops,
|
||||
varsym/consym operator chains, integer/hex/octal/float literals incl. exponent
|
||||
|
||||
Reference in New Issue
Block a user