haskell: top-level decls (fn-clause, type-sig, data, type, newtype, fixity) + type parser (+24 tests, 162/162)
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:
@@ -119,11 +119,28 @@
|
||||
(and (= ty "varsym") (= val "-"))
|
||||
(and (= ty "reservedop") (= val "~")))))))
|
||||
|
||||
;; ── Atype-start predicate (types) ───────────────────────────────
|
||||
(define
|
||||
hk-atype-start?
|
||||
(fn
|
||||
(tok)
|
||||
(if
|
||||
(nil? tok)
|
||||
false
|
||||
(let
|
||||
((ty (get tok "type")))
|
||||
(or
|
||||
(= ty "conid")
|
||||
(= ty "qconid")
|
||||
(= ty "varid")
|
||||
(= ty "lparen")
|
||||
(= ty "lbracket"))))))
|
||||
|
||||
;; ── Main entry ───────────────────────────────────────────────────
|
||||
(define
|
||||
hk-parse-expr
|
||||
hk-parser
|
||||
(fn
|
||||
(tokens)
|
||||
(tokens mode)
|
||||
(let
|
||||
((toks tokens) (pos 0) (n (len tokens)))
|
||||
|
||||
@@ -901,6 +918,423 @@
|
||||
|
||||
(define hk-parse-expr-inner (fn () (hk-parse-infix 0)))
|
||||
|
||||
;; ── Types ────────────────────────────────────────────────
|
||||
;; AST: (:t-var N) | (:t-con N) | (:t-app F A)
|
||||
;; (:t-fun A B) | (:t-tuple ITEMS) | (:t-list T)
|
||||
(define
|
||||
hk-parse-paren-type
|
||||
(fn
|
||||
()
|
||||
(hk-expect! "lparen" nil)
|
||||
(cond
|
||||
((hk-match? "rparen" nil)
|
||||
(do (hk-advance!) (list :t-con "()")))
|
||||
(:else
|
||||
(let
|
||||
((first-t (hk-parse-type))
|
||||
(items (list))
|
||||
(is-tup false))
|
||||
(append! items first-t)
|
||||
(define
|
||||
hk-pt-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "comma" nil)
|
||||
(do
|
||||
(hk-advance!)
|
||||
(set! is-tup true)
|
||||
(append! items (hk-parse-type))
|
||||
(hk-pt-loop)))))
|
||||
(hk-pt-loop)
|
||||
(hk-expect! "rparen" nil)
|
||||
(if is-tup (list :t-tuple items) first-t))))))
|
||||
|
||||
(define
|
||||
hk-parse-list-type
|
||||
(fn
|
||||
()
|
||||
(hk-expect! "lbracket" nil)
|
||||
(cond
|
||||
((hk-match? "rbracket" nil)
|
||||
(do (hk-advance!) (list :t-con "[]")))
|
||||
(:else
|
||||
(let
|
||||
((inner (hk-parse-type)))
|
||||
(hk-expect! "rbracket" nil)
|
||||
(list :t-list inner))))))
|
||||
|
||||
(define
|
||||
hk-parse-atype
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((t (hk-peek)))
|
||||
(cond
|
||||
((nil? t) (hk-err "unexpected end of input in type"))
|
||||
((= (get t "type") "conid")
|
||||
(do (hk-advance!) (list :t-con (get t "value"))))
|
||||
((= (get t "type") "qconid")
|
||||
(do (hk-advance!) (list :t-con (get t "value"))))
|
||||
((= (get t "type") "varid")
|
||||
(do (hk-advance!) (list :t-var (get t "value"))))
|
||||
((= (get t "type") "lparen") (hk-parse-paren-type))
|
||||
((= (get t "type") "lbracket") (hk-parse-list-type))
|
||||
(:else (hk-err "unexpected token in type"))))))
|
||||
|
||||
(define
|
||||
hk-parse-btype
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((head (hk-parse-atype)))
|
||||
(define
|
||||
hk-bt-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-atype-start? (hk-peek))
|
||||
(do
|
||||
(set! head (list :t-app head (hk-parse-atype)))
|
||||
(hk-bt-loop)))))
|
||||
(hk-bt-loop)
|
||||
head)))
|
||||
|
||||
(define
|
||||
hk-parse-type
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((left (hk-parse-btype)))
|
||||
(cond
|
||||
((hk-match? "reservedop" "->")
|
||||
(do (hk-advance!) (list :t-fun left (hk-parse-type))))
|
||||
(:else left)))))
|
||||
|
||||
;; ── Top-level declarations ──────────────────────────────
|
||||
;; AST:
|
||||
;; (:fun-clause NAME APATS BODY)
|
||||
;; (:pat-bind PAT BODY)
|
||||
;; (:type-sig NAMES TYPE)
|
||||
;; (:data NAME TVARS CONS) — CONS is list of :con-def
|
||||
;; (:con-def CNAME FIELDS) — FIELDS is list of types
|
||||
;; (:type-syn NAME TVARS TYPE)
|
||||
;; (:newtype NAME TVARS CNAME FIELD)
|
||||
;; (:fixity ASSOC PREC OPS) — ASSOC ∈ "l" | "r" | "n"
|
||||
;; (:program DECLS)
|
||||
|
||||
;; Scan ahead for a top-level `::` (respecting paren/bracket
|
||||
;; depth) before the next statement terminator. Used to tell a
|
||||
;; type signature apart from a function clause.
|
||||
(define
|
||||
hk-has-top-dcolon?
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((j pos) (depth 0) (found false) (done false))
|
||||
(define
|
||||
hk-dcol-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (not done) (< j n))
|
||||
(let
|
||||
((t (nth toks j)) (ty (get t "type")))
|
||||
(cond
|
||||
((and
|
||||
(= depth 0)
|
||||
(or
|
||||
(= ty "vsemi")
|
||||
(= ty "semi")
|
||||
(= 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-dcol-loop)))))
|
||||
(hk-dcol-loop)
|
||||
found)))
|
||||
|
||||
(define
|
||||
hk-parse-type-sig
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((names (list)))
|
||||
(when
|
||||
(not (hk-match? "varid" nil))
|
||||
(hk-err "type signature must start with a variable"))
|
||||
(append! names (get (hk-advance!) "value"))
|
||||
(define
|
||||
hk-sig-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "comma" nil)
|
||||
(do
|
||||
(hk-advance!)
|
||||
(when
|
||||
(not (hk-match? "varid" nil))
|
||||
(hk-err "expected name after ','"))
|
||||
(append! names (get (hk-advance!) "value"))
|
||||
(hk-sig-loop)))))
|
||||
(hk-sig-loop)
|
||||
(hk-expect! "reservedop" "::")
|
||||
(list :type-sig names (hk-parse-type)))))
|
||||
|
||||
(define
|
||||
hk-parse-fun-clause
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((t (hk-peek)))
|
||||
(cond
|
||||
((and
|
||||
(not (nil? t))
|
||||
(= (get t "type") "varid"))
|
||||
(let
|
||||
((name (get (hk-advance!) "value"))
|
||||
(pats (list)))
|
||||
(define
|
||||
hk-fc-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-apat-start? (hk-peek))
|
||||
(do
|
||||
(append! pats (hk-parse-apat))
|
||||
(hk-fc-loop)))))
|
||||
(hk-fc-loop)
|
||||
(hk-expect! "reservedop" "=")
|
||||
(list :fun-clause name pats (hk-parse-expr-inner))))
|
||||
(:else
|
||||
(let
|
||||
((pat (hk-parse-pat)))
|
||||
(hk-expect! "reservedop" "=")
|
||||
(list :pat-bind pat (hk-parse-expr-inner))))))))
|
||||
|
||||
(define
|
||||
hk-parse-con-def
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(not (hk-match? "conid" nil))
|
||||
(hk-err "expected constructor name"))
|
||||
(let
|
||||
((name (get (hk-advance!) "value")) (fields (list)))
|
||||
(define
|
||||
hk-cd-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-atype-start? (hk-peek))
|
||||
(do
|
||||
(append! fields (hk-parse-atype))
|
||||
(hk-cd-loop)))))
|
||||
(hk-cd-loop)
|
||||
(list :con-def name fields))))
|
||||
|
||||
(define
|
||||
hk-parse-tvars
|
||||
(fn
|
||||
()
|
||||
(let ((vs (list)))
|
||||
(define
|
||||
hk-tv-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "varid" nil)
|
||||
(do
|
||||
(append! vs (get (hk-advance!) "value"))
|
||||
(hk-tv-loop)))))
|
||||
(hk-tv-loop)
|
||||
vs)))
|
||||
|
||||
(define
|
||||
hk-parse-data
|
||||
(fn
|
||||
()
|
||||
(hk-expect! "reserved" "data")
|
||||
(when
|
||||
(not (hk-match? "conid" nil))
|
||||
(hk-err "data declaration needs a type name"))
|
||||
(let
|
||||
((name (get (hk-advance!) "value"))
|
||||
(tvars (hk-parse-tvars))
|
||||
(cons-list (list)))
|
||||
(when
|
||||
(hk-match? "reservedop" "=")
|
||||
(do
|
||||
(hk-advance!)
|
||||
(append! cons-list (hk-parse-con-def))
|
||||
(define
|
||||
hk-dc-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "reservedop" "|")
|
||||
(do
|
||||
(hk-advance!)
|
||||
(append! cons-list (hk-parse-con-def))
|
||||
(hk-dc-loop)))))
|
||||
(hk-dc-loop)))
|
||||
(list :data name tvars cons-list))))
|
||||
|
||||
(define
|
||||
hk-parse-type-syn
|
||||
(fn
|
||||
()
|
||||
(hk-expect! "reserved" "type")
|
||||
(when
|
||||
(not (hk-match? "conid" nil))
|
||||
(hk-err "type synonym needs a name"))
|
||||
(let
|
||||
((name (get (hk-advance!) "value"))
|
||||
(tvars (hk-parse-tvars)))
|
||||
(hk-expect! "reservedop" "=")
|
||||
(list :type-syn name tvars (hk-parse-type)))))
|
||||
|
||||
(define
|
||||
hk-parse-newtype
|
||||
(fn
|
||||
()
|
||||
(hk-expect! "reserved" "newtype")
|
||||
(when
|
||||
(not (hk-match? "conid" nil))
|
||||
(hk-err "newtype needs a type name"))
|
||||
(let
|
||||
((name (get (hk-advance!) "value"))
|
||||
(tvars (hk-parse-tvars)))
|
||||
(hk-expect! "reservedop" "=")
|
||||
(when
|
||||
(not (hk-match? "conid" nil))
|
||||
(hk-err "newtype needs a constructor name"))
|
||||
(let
|
||||
((cname (get (hk-advance!) "value")))
|
||||
(when
|
||||
(not (hk-atype-start? (hk-peek)))
|
||||
(hk-err "newtype constructor needs one field"))
|
||||
(list :newtype name tvars cname (hk-parse-atype))))))
|
||||
|
||||
(define
|
||||
hk-parse-op
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((hk-match? "varsym" nil)
|
||||
(get (hk-advance!) "value"))
|
||||
((hk-match? "consym" nil)
|
||||
(get (hk-advance!) "value"))
|
||||
((and
|
||||
(hk-match? "reservedop" nil)
|
||||
(= (hk-peek-value) ":"))
|
||||
(do (hk-advance!) ":"))
|
||||
((hk-match? "backtick" nil)
|
||||
(do
|
||||
(hk-advance!)
|
||||
(let
|
||||
((v (hk-expect! "varid" nil)))
|
||||
(hk-expect! "backtick" nil)
|
||||
(get v "value"))))
|
||||
(:else (hk-err "expected operator name in fixity decl")))))
|
||||
|
||||
(define
|
||||
hk-parse-fixity
|
||||
(fn
|
||||
()
|
||||
(let ((assoc "n"))
|
||||
(cond
|
||||
((hk-match? "reserved" "infixl") (set! assoc "l"))
|
||||
((hk-match? "reserved" "infixr") (set! assoc "r"))
|
||||
((hk-match? "reserved" "infix") (set! assoc "n"))
|
||||
(:else (hk-err "expected fixity keyword")))
|
||||
(hk-advance!)
|
||||
(let ((prec 9))
|
||||
(when
|
||||
(hk-match? "integer" nil)
|
||||
(set! prec (get (hk-advance!) "value")))
|
||||
(let ((ops (list)))
|
||||
(append! ops (hk-parse-op))
|
||||
(define
|
||||
hk-fx-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "comma" nil)
|
||||
(do
|
||||
(hk-advance!)
|
||||
(append! ops (hk-parse-op))
|
||||
(hk-fx-loop)))))
|
||||
(hk-fx-loop)
|
||||
(list :fixity assoc prec ops))))))
|
||||
|
||||
(define
|
||||
hk-parse-decl
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((hk-match? "reserved" "data") (hk-parse-data))
|
||||
((hk-match? "reserved" "type") (hk-parse-type-syn))
|
||||
((hk-match? "reserved" "newtype") (hk-parse-newtype))
|
||||
((or
|
||||
(hk-match? "reserved" "infix")
|
||||
(hk-match? "reserved" "infixl")
|
||||
(hk-match? "reserved" "infixr"))
|
||||
(hk-parse-fixity))
|
||||
((hk-has-top-dcolon?) (hk-parse-type-sig))
|
||||
(:else (hk-parse-fun-clause)))))
|
||||
|
||||
(define
|
||||
hk-parse-program
|
||||
(fn
|
||||
()
|
||||
(let ((decls (list)))
|
||||
(define
|
||||
hk-prog-at-end?
|
||||
(fn
|
||||
()
|
||||
(or
|
||||
(nil? (hk-peek))
|
||||
(= (hk-peek-type) "eof")
|
||||
(hk-match? "vrbrace" nil)
|
||||
(hk-match? "rbrace" nil))))
|
||||
(when
|
||||
(not (hk-prog-at-end?))
|
||||
(do
|
||||
(append! decls (hk-parse-decl))
|
||||
(define
|
||||
hk-prog-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(or
|
||||
(hk-match? "vsemi" nil)
|
||||
(hk-match? "semi" nil))
|
||||
(do
|
||||
(hk-advance!)
|
||||
(when
|
||||
(not (hk-prog-at-end?))
|
||||
(append! decls (hk-parse-decl)))
|
||||
(hk-prog-loop)))))
|
||||
(hk-prog-loop)))
|
||||
(list :program decls))))
|
||||
|
||||
;; ── Top-level: strip leading/trailing module-level braces ─
|
||||
(let
|
||||
((start-brace
|
||||
@@ -909,7 +1343,11 @@
|
||||
(hk-match? "lbrace" nil))))
|
||||
(when start-brace (hk-advance!))
|
||||
(let
|
||||
((result (hk-parse-expr-inner)))
|
||||
((result
|
||||
(cond
|
||||
((= mode :expr) (hk-parse-expr-inner))
|
||||
((= mode :module) (hk-parse-program))
|
||||
(:else (hk-err "unknown parser mode")))))
|
||||
(when start-brace
|
||||
(when
|
||||
(or
|
||||
@@ -918,7 +1356,14 @@
|
||||
(hk-advance!)))
|
||||
result)))))
|
||||
|
||||
(define hk-parse-expr (fn (tokens) (hk-parser tokens :expr)))
|
||||
(define hk-parse-module (fn (tokens) (hk-parser tokens :module)))
|
||||
|
||||
;; ── Convenience: tokenize + layout + parse ───────────────────────
|
||||
(define
|
||||
hk-parse
|
||||
(fn (src) (hk-parse-expr (hk-layout (hk-tokenize src)))))
|
||||
|
||||
(define
|
||||
hk-parse-top
|
||||
(fn (src) (hk-parse-module (hk-layout (hk-tokenize src)))))
|
||||
|
||||
Reference in New Issue
Block a user