haskell: case/do + minimal patterns (+19 tests, 119/119)
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:
@@ -95,6 +95,28 @@
|
||||
(= ty "lparen")
|
||||
(= ty "lbracket"))))))
|
||||
|
||||
;; apat-start? — what can begin an atomic pattern
|
||||
(define
|
||||
hk-apat-start?
|
||||
(fn
|
||||
(tok)
|
||||
(if
|
||||
(nil? tok)
|
||||
false
|
||||
(let
|
||||
((ty (get tok "type")))
|
||||
(or
|
||||
(and (= ty "reserved") (= (get tok "value") "_"))
|
||||
(= ty "integer")
|
||||
(= ty "float")
|
||||
(= ty "string")
|
||||
(= ty "char")
|
||||
(= ty "varid")
|
||||
(= ty "conid")
|
||||
(= ty "qconid")
|
||||
(= ty "lparen")
|
||||
(= ty "lbracket"))))))
|
||||
|
||||
;; ── Main entry ───────────────────────────────────────────────────
|
||||
(define
|
||||
hk-parse-expr
|
||||
@@ -390,7 +412,336 @@
|
||||
(hk-expect! "reservedop" "=")
|
||||
(list :bind name (hk-parse-expr-inner)))))
|
||||
|
||||
;; ── lexp: lambda | if | let | fexp ──────────────────────
|
||||
;; ── Patterns ─────────────────────────────────────────────
|
||||
(define
|
||||
hk-parse-apat
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((t (hk-peek)))
|
||||
(cond
|
||||
((nil? t) (hk-err "unexpected end of input in pattern"))
|
||||
((and
|
||||
(= (get t "type") "reserved")
|
||||
(= (get t "value") "_"))
|
||||
(do (hk-advance!) (list :p-wild)))
|
||||
((= (get t "type") "integer")
|
||||
(do (hk-advance!) (list :p-int (get t "value"))))
|
||||
((= (get t "type") "float")
|
||||
(do (hk-advance!) (list :p-float (get t "value"))))
|
||||
((= (get t "type") "string")
|
||||
(do (hk-advance!) (list :p-string (get t "value"))))
|
||||
((= (get t "type") "char")
|
||||
(do (hk-advance!) (list :p-char (get t "value"))))
|
||||
((= (get t "type") "varid")
|
||||
(do (hk-advance!) (list :p-var (get t "value"))))
|
||||
((= (get t "type") "conid")
|
||||
(do
|
||||
(hk-advance!)
|
||||
(list :p-con (get t "value") (list))))
|
||||
((= (get t "type") "qconid")
|
||||
(do
|
||||
(hk-advance!)
|
||||
(list :p-con (get t "value") (list))))
|
||||
((= (get t "type") "lparen") (hk-parse-paren-pat))
|
||||
((= (get t "type") "lbracket") (hk-parse-list-pat))
|
||||
(:else (hk-err "unexpected token in pattern"))))))
|
||||
|
||||
(define
|
||||
hk-parse-paren-pat
|
||||
(fn
|
||||
()
|
||||
(hk-expect! "lparen" nil)
|
||||
(cond
|
||||
((hk-match? "rparen" nil)
|
||||
(do (hk-advance!) (list :p-con "()" (list))))
|
||||
(:else
|
||||
(let
|
||||
((first-p (hk-parse-pat))
|
||||
(items (list))
|
||||
(is-tup false))
|
||||
(append! items first-p)
|
||||
(define
|
||||
hk-ppt-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "comma" nil)
|
||||
(do
|
||||
(hk-advance!)
|
||||
(set! is-tup true)
|
||||
(append! items (hk-parse-pat))
|
||||
(hk-ppt-loop)))))
|
||||
(hk-ppt-loop)
|
||||
(hk-expect! "rparen" nil)
|
||||
(if is-tup (list :p-tuple items) first-p))))))
|
||||
|
||||
(define
|
||||
hk-parse-list-pat
|
||||
(fn
|
||||
()
|
||||
(hk-expect! "lbracket" nil)
|
||||
(cond
|
||||
((hk-match? "rbracket" nil)
|
||||
(do (hk-advance!) (list :p-list (list))))
|
||||
(:else
|
||||
(let
|
||||
((items (list)))
|
||||
(append! items (hk-parse-pat))
|
||||
(define
|
||||
hk-plt-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "comma" nil)
|
||||
(do
|
||||
(hk-advance!)
|
||||
(append! items (hk-parse-pat))
|
||||
(hk-plt-loop)))))
|
||||
(hk-plt-loop)
|
||||
(hk-expect! "rbracket" nil)
|
||||
(list :p-list items))))))
|
||||
|
||||
(define
|
||||
hk-parse-pat
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((t (hk-peek)))
|
||||
(cond
|
||||
((and
|
||||
(not (nil? t))
|
||||
(or
|
||||
(= (get t "type") "conid")
|
||||
(= (get t "type") "qconid")))
|
||||
(let
|
||||
((name (get (hk-advance!) "value")) (args (list)))
|
||||
(define
|
||||
hk-pca-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-apat-start? (hk-peek))
|
||||
(do
|
||||
(append! args (hk-parse-apat))
|
||||
(hk-pca-loop)))))
|
||||
(hk-pca-loop)
|
||||
(list :p-con name args)))
|
||||
(:else (hk-parse-apat))))))
|
||||
|
||||
;; ── case ─ of { pat -> expr ; ... } ─────────────────────
|
||||
(define
|
||||
hk-parse-alt
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((pat (hk-parse-pat)))
|
||||
(hk-expect! "reservedop" "->")
|
||||
(list :alt pat (hk-parse-expr-inner)))))
|
||||
|
||||
(define
|
||||
hk-parse-case
|
||||
(fn
|
||||
()
|
||||
(hk-expect! "reserved" "case")
|
||||
(let
|
||||
((scrut (hk-parse-expr-inner)))
|
||||
(hk-expect! "reserved" "of")
|
||||
(let
|
||||
((explicit (hk-match? "lbrace" nil)))
|
||||
(if
|
||||
explicit
|
||||
(hk-advance!)
|
||||
(hk-expect! "vlbrace" nil))
|
||||
(let
|
||||
((alts (list)))
|
||||
(when
|
||||
(not
|
||||
(if
|
||||
explicit
|
||||
(hk-match? "rbrace" nil)
|
||||
(hk-match? "vrbrace" nil)))
|
||||
(do
|
||||
(append! alts (hk-parse-alt))
|
||||
(define
|
||||
hk-case-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(or
|
||||
(hk-match? "semi" nil)
|
||||
(hk-match? "vsemi" nil))
|
||||
(do
|
||||
(hk-advance!)
|
||||
(when
|
||||
(not
|
||||
(if
|
||||
explicit
|
||||
(hk-match? "rbrace" nil)
|
||||
(hk-match? "vrbrace" nil)))
|
||||
(append! alts (hk-parse-alt)))
|
||||
(hk-case-loop)))))
|
||||
(hk-case-loop)))
|
||||
(if
|
||||
explicit
|
||||
(hk-expect! "rbrace" nil)
|
||||
(hk-expect! "vrbrace" nil))
|
||||
(list :case scrut alts))))))
|
||||
|
||||
;; ── do { stmt ; stmt ; ... } ────────────────────────────
|
||||
;; Scan ahead (respecting paren/bracket/brace depth) for a `<-`
|
||||
;; before the next `;` / `}` — distinguishes `pat <- e` from a
|
||||
;; bare expression statement.
|
||||
(define
|
||||
hk-do-stmt-is-bind?
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((j pos) (depth 0) (found false) (done false))
|
||||
(define
|
||||
hk-scan-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (not done) (< j n))
|
||||
(let
|
||||
((t (nth toks j)) (ty nil))
|
||||
(set! ty (get t "type"))
|
||||
(cond
|
||||
((and
|
||||
(= depth 0)
|
||||
(or
|
||||
(= ty "semi")
|
||||
(= ty "vsemi")
|
||||
(= ty "rbrace")
|
||||
(= ty "vrbrace")))
|
||||
(set! done true))
|
||||
((and
|
||||
(= depth 0)
|
||||
(= ty "reservedop")
|
||||
(= (get t "value") "<-"))
|
||||
(do (set! found true) (set! done true)))
|
||||
((or
|
||||
(= ty "lparen")
|
||||
(= ty "lbracket")
|
||||
(= ty "lbrace")
|
||||
(= ty "vlbrace"))
|
||||
(set! depth (+ depth 1)))
|
||||
((or
|
||||
(= ty "rparen")
|
||||
(= ty "rbracket"))
|
||||
(set! depth (- depth 1)))
|
||||
(:else nil))
|
||||
(set! j (+ j 1))
|
||||
(hk-scan-loop)))))
|
||||
(hk-scan-loop)
|
||||
found)))
|
||||
|
||||
(define
|
||||
hk-parse-do-let
|
||||
(fn
|
||||
()
|
||||
(hk-expect! "reserved" "let")
|
||||
(let ((explicit (hk-match? "lbrace" nil)))
|
||||
(if
|
||||
explicit
|
||||
(hk-advance!)
|
||||
(hk-expect! "vlbrace" nil))
|
||||
(let
|
||||
((binds (list)))
|
||||
(when
|
||||
(not
|
||||
(if
|
||||
explicit
|
||||
(hk-match? "rbrace" nil)
|
||||
(hk-match? "vrbrace" nil)))
|
||||
(do
|
||||
(append! binds (hk-parse-bind))
|
||||
(define
|
||||
hk-dlet-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(or
|
||||
(hk-match? "semi" nil)
|
||||
(hk-match? "vsemi" nil))
|
||||
(do
|
||||
(hk-advance!)
|
||||
(when
|
||||
(not
|
||||
(if
|
||||
explicit
|
||||
(hk-match? "rbrace" nil)
|
||||
(hk-match? "vrbrace" nil)))
|
||||
(append! binds (hk-parse-bind)))
|
||||
(hk-dlet-loop)))))
|
||||
(hk-dlet-loop)))
|
||||
(if
|
||||
explicit
|
||||
(hk-expect! "rbrace" nil)
|
||||
(hk-expect! "vrbrace" nil))
|
||||
(list :do-let binds)))))
|
||||
|
||||
(define
|
||||
hk-parse-do-stmt
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((hk-match? "reserved" "let") (hk-parse-do-let))
|
||||
((hk-do-stmt-is-bind?)
|
||||
(let
|
||||
((pat (hk-parse-pat)))
|
||||
(hk-expect! "reservedop" "<-")
|
||||
(list :do-bind pat (hk-parse-expr-inner))))
|
||||
(:else (list :do-expr (hk-parse-expr-inner))))))
|
||||
|
||||
(define
|
||||
hk-parse-do
|
||||
(fn
|
||||
()
|
||||
(hk-expect! "reserved" "do")
|
||||
(let
|
||||
((explicit (hk-match? "lbrace" nil)))
|
||||
(if
|
||||
explicit
|
||||
(hk-advance!)
|
||||
(hk-expect! "vlbrace" nil))
|
||||
(let
|
||||
((stmts (list)))
|
||||
(when
|
||||
(not
|
||||
(if
|
||||
explicit
|
||||
(hk-match? "rbrace" nil)
|
||||
(hk-match? "vrbrace" nil)))
|
||||
(do
|
||||
(append! stmts (hk-parse-do-stmt))
|
||||
(define
|
||||
hk-do-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(or
|
||||
(hk-match? "semi" nil)
|
||||
(hk-match? "vsemi" nil))
|
||||
(do
|
||||
(hk-advance!)
|
||||
(when
|
||||
(not
|
||||
(if
|
||||
explicit
|
||||
(hk-match? "rbrace" nil)
|
||||
(hk-match? "vrbrace" nil)))
|
||||
(append! stmts (hk-parse-do-stmt)))
|
||||
(hk-do-loop)))))
|
||||
(hk-do-loop)))
|
||||
(if
|
||||
explicit
|
||||
(hk-expect! "rbrace" nil)
|
||||
(hk-expect! "vrbrace" nil))
|
||||
(list :do stmts)))))
|
||||
|
||||
;; ── lexp: lambda | if | let | case | do | fexp ──────────
|
||||
(define
|
||||
hk-parse-lexp
|
||||
(fn
|
||||
@@ -399,6 +750,8 @@
|
||||
((hk-match? "reservedop" "\\") (hk-parse-lambda))
|
||||
((hk-match? "reserved" "if") (hk-parse-if))
|
||||
((hk-match? "reserved" "let") (hk-parse-let))
|
||||
((hk-match? "reserved" "case") (hk-parse-case))
|
||||
((hk-match? "reserved" "do") (hk-parse-do))
|
||||
(:else (hk-parse-fexp)))))
|
||||
|
||||
;; ── Prefix: unary - ─────────────────────────────────────
|
||||
|
||||
Reference in New Issue
Block a user