giles
cab7ca883f
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
1989 lines
68 KiB
Plaintext
1989 lines
68 KiB
Plaintext
;; Haskell 98 expression parser.
|
|
;;
|
|
;; Input: the post-layout token list from (hk-layout (hk-tokenize src)).
|
|
;; Output: an AST. Nodes are plain lists tagged by a keyword head
|
|
;; (keywords evaluate to their string name, so `(list :var "x")` is
|
|
;; indistinguishable from `(list "var" "x")` at runtime — this lets
|
|
;; tests literally write `(list :var "x")` on both sides).
|
|
;;
|
|
;; Scope (this iteration — expressions only):
|
|
;; atoms int/float/string/char/var/con, parens, tuple, list, range
|
|
;; application left-associative, f x y z
|
|
;; prefix - unary negation on an lexp
|
|
;; infix ops precedence-climbing, full Haskell 98 default table
|
|
;; lambda \x y -> body
|
|
;; if if c then t else e
|
|
;; let let { x = e ; y = e } in body (uses layout braces)
|
|
;;
|
|
;; AST shapes:
|
|
;; (:int N)
|
|
;; (:float F)
|
|
;; (:string S)
|
|
;; (:char C)
|
|
;; (:var NAME)
|
|
;; (:con NAME)
|
|
;; (:app FN ARG) — binary, chain for multi-arg
|
|
;; (:op OP LHS RHS) — binary infix
|
|
;; (:neg E)
|
|
;; (:tuple ITEMS) — ITEMS is a list of AST nodes
|
|
;; (:list ITEMS) — enumerated list
|
|
;; (:range FROM TO) — [from..to]
|
|
;; (:range-step FROM NEXT TO) — [from,next..to]
|
|
;; (:if C T E)
|
|
;; (:lambda PARAMS BODY) — PARAMS is list of varids
|
|
;; (:let BINDS BODY) — BINDS is list of (:bind NAME EXPR)
|
|
|
|
;; ── Operator precedence table (Haskell 98 defaults) ──────────────
|
|
(define
|
|
hk-op-prec-table
|
|
(let
|
|
((t (dict)))
|
|
(dict-set! t "!!" {:prec 9 :assoc "left"})
|
|
(dict-set! t "." {:prec 9 :assoc "right"})
|
|
(dict-set! t "^" {:prec 8 :assoc "right"})
|
|
(dict-set! t "^^" {:prec 8 :assoc "right"})
|
|
(dict-set! t "**" {:prec 8 :assoc "right"})
|
|
(dict-set! t "*" {:prec 7 :assoc "left"})
|
|
(dict-set! t "/" {:prec 7 :assoc "left"})
|
|
(dict-set! t "+" {:prec 6 :assoc "left"})
|
|
(dict-set! t "-" {:prec 6 :assoc "left"})
|
|
(dict-set! t ":" {:prec 5 :assoc "right"})
|
|
(dict-set! t "++" {:prec 5 :assoc "right"})
|
|
(dict-set! t "==" {:prec 4 :assoc "non"})
|
|
(dict-set! t "/=" {:prec 4 :assoc "non"})
|
|
(dict-set! t "<" {:prec 4 :assoc "non"})
|
|
(dict-set! t "<=" {:prec 4 :assoc "non"})
|
|
(dict-set! t ">" {:prec 4 :assoc "non"})
|
|
(dict-set! t ">=" {:prec 4 :assoc "non"})
|
|
(dict-set! t "&&" {:prec 3 :assoc "right"})
|
|
(dict-set! t "||" {:prec 2 :assoc "right"})
|
|
(dict-set! t ">>" {:prec 1 :assoc "left"})
|
|
(dict-set! t ">>=" {:prec 1 :assoc "left"})
|
|
(dict-set! t "=<<" {:prec 1 :assoc "right"})
|
|
(dict-set! t "$" {:prec 0 :assoc "right"})
|
|
(dict-set! t "$!" {:prec 0 :assoc "right"})
|
|
t))
|
|
|
|
(define
|
|
hk-op-info
|
|
(fn
|
|
(op)
|
|
(if
|
|
(has-key? hk-op-prec-table op)
|
|
(get hk-op-prec-table op)
|
|
{:prec 9 :assoc "left"})))
|
|
|
|
;; ── Atom-start predicate ─────────────────────────────────────────
|
|
(define
|
|
hk-atom-start?
|
|
(fn
|
|
(tok)
|
|
(if
|
|
(nil? tok)
|
|
false
|
|
(let
|
|
((ty (get tok "type")))
|
|
(or
|
|
(= ty "integer")
|
|
(= ty "float")
|
|
(= ty "string")
|
|
(= ty "char")
|
|
(= ty "varid")
|
|
(= ty "conid")
|
|
(= ty "qvarid")
|
|
(= ty "qconid")
|
|
(= 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")) (val (get tok "value")))
|
|
(or
|
|
(and (= ty "reserved") (= val "_"))
|
|
(= ty "integer")
|
|
(= ty "float")
|
|
(= ty "string")
|
|
(= ty "char")
|
|
(= ty "varid")
|
|
(= ty "conid")
|
|
(= ty "qconid")
|
|
(= ty "lparen")
|
|
(= ty "lbracket")
|
|
(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-parser
|
|
(fn
|
|
(tokens mode)
|
|
(let
|
|
((toks tokens) (pos 0) (n (len tokens)))
|
|
|
|
(define hk-peek (fn () (if (< pos n) (nth toks pos) nil)))
|
|
(define
|
|
hk-peek-at
|
|
(fn
|
|
(offset)
|
|
(if (< (+ pos offset) n) (nth toks (+ pos offset)) nil)))
|
|
(define
|
|
hk-advance!
|
|
(fn () (let ((t (hk-peek))) (set! pos (+ pos 1)) t)))
|
|
(define
|
|
hk-peek-type
|
|
(fn () (let ((t (hk-peek))) (if (nil? t) "<eof>" (get t "type")))))
|
|
(define
|
|
hk-peek-value
|
|
(fn () (let ((t (hk-peek))) (if (nil? t) nil (get t "value")))))
|
|
(define
|
|
hk-match?
|
|
(fn
|
|
(ty v)
|
|
(let
|
|
((t (hk-peek)))
|
|
(and
|
|
(not (nil? t))
|
|
(= (get t "type") ty)
|
|
(or (nil? v) (= (get t "value") v))))))
|
|
(define
|
|
hk-err
|
|
(fn
|
|
(msg)
|
|
(raise
|
|
(str
|
|
"parse error: "
|
|
msg
|
|
" (at "
|
|
(hk-peek-type)
|
|
(if (nil? (hk-peek-value)) "" (str " " (hk-peek-value)))
|
|
")"))))
|
|
(define
|
|
hk-expect!
|
|
(fn
|
|
(ty v)
|
|
(if
|
|
(hk-match? ty v)
|
|
(hk-advance!)
|
|
(hk-err
|
|
(str "expected " ty (if (nil? v) "" (str " '" v "'")))))))
|
|
|
|
;; ── Atoms ────────────────────────────────────────────────
|
|
(define
|
|
hk-parse-aexp
|
|
(fn
|
|
()
|
|
(let
|
|
((t (hk-peek)))
|
|
(cond
|
|
((nil? t) (hk-err "unexpected end of input"))
|
|
((= (get t "type") "integer")
|
|
(do (hk-advance!) (list :int (get t "value"))))
|
|
((= (get t "type") "float")
|
|
(do (hk-advance!) (list :float (get t "value"))))
|
|
((= (get t "type") "string")
|
|
(do (hk-advance!) (list :string (get t "value"))))
|
|
((= (get t "type") "char")
|
|
(do (hk-advance!) (list :char (get t "value"))))
|
|
((= (get t "type") "varid")
|
|
(do (hk-advance!) (list :var (get t "value"))))
|
|
((= (get t "type") "conid")
|
|
(do (hk-advance!) (list :con (get t "value"))))
|
|
((= (get t "type") "qvarid")
|
|
(do (hk-advance!) (list :var (get t "value"))))
|
|
((= (get t "type") "qconid")
|
|
(do (hk-advance!) (list :con (get t "value"))))
|
|
((= (get t "type") "lparen") (hk-parse-parens))
|
|
((= (get t "type") "lbracket") (hk-parse-list-lit))
|
|
(:else (hk-err "unexpected token in expression"))))))
|
|
|
|
;; Returns {:name N :len L} if the current token begins an
|
|
;; infix operator (varsym / consym / reservedop ":" / backtick),
|
|
;; else nil. `len` is the number of tokens the operator occupies.
|
|
(define
|
|
hk-section-op-info
|
|
(fn
|
|
()
|
|
(let ((t (hk-peek)))
|
|
(cond
|
|
((nil? t) nil)
|
|
((= (get t "type") "varsym")
|
|
{:name (get t "value") :len 1})
|
|
((= (get t "type") "consym")
|
|
{:name (get t "value") :len 1})
|
|
((and
|
|
(= (get t "type") "reservedop")
|
|
(= (get t "value") ":"))
|
|
{:name ":" :len 1})
|
|
((= (get t "type") "backtick")
|
|
(let ((varid-t (hk-peek-at 1)))
|
|
(cond
|
|
((and
|
|
(not (nil? varid-t))
|
|
(= (get varid-t "type") "varid"))
|
|
{:name (get varid-t "value") :len 3})
|
|
(:else nil))))
|
|
(:else nil)))))
|
|
|
|
;; ── Parens / tuple / unit / operator sections ───────────
|
|
;; Forms recognised inside parens:
|
|
;; () → unit : (:con "()")
|
|
;; (op) → operator reference : (:var OP)
|
|
;; (op e) → right section : (:sect-right OP E) (op ≠ "-")
|
|
;; (e) → plain parens : unwrapped E
|
|
;; (e1, … , en) → tuple : (:tuple ITEMS)
|
|
;; (e op) → left section : (:sect-left OP E)
|
|
;; `-` is excluded from right sections because `-e` always means
|
|
;; `negate e`; `(-)` is still a valid operator reference.
|
|
(define
|
|
hk-parse-parens
|
|
(fn
|
|
()
|
|
(hk-expect! "lparen" nil)
|
|
(cond
|
|
((hk-match? "rparen" nil)
|
|
(do (hk-advance!) (list :con "()")))
|
|
(:else
|
|
(let ((op-info (hk-section-op-info)))
|
|
(cond
|
|
;; Operator reference / right section
|
|
((and
|
|
(not (nil? op-info))
|
|
(let
|
|
((after
|
|
(hk-peek-at (get op-info "len"))))
|
|
(or
|
|
(and
|
|
(not (nil? after))
|
|
(= (get after "type") "rparen"))
|
|
(not (= (get op-info "name") "-")))))
|
|
(let
|
|
((op-name (get op-info "name"))
|
|
(op-len (get op-info "len"))
|
|
(after
|
|
(hk-peek-at (get op-info "len"))))
|
|
(hk-consume-op!)
|
|
(cond
|
|
((and
|
|
(not (nil? after))
|
|
(= (get after "type") "rparen"))
|
|
(do (hk-advance!) (list :var op-name)))
|
|
(:else
|
|
(let ((expr-e (hk-parse-expr-inner)))
|
|
(hk-expect! "rparen" nil)
|
|
(list :sect-right op-name expr-e))))))
|
|
(:else
|
|
(let
|
|
((first-e (hk-parse-expr-inner))
|
|
(items (list))
|
|
(is-tuple false))
|
|
(append! items first-e)
|
|
(define
|
|
hk-tup-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(hk-match? "comma" nil)
|
|
(do
|
|
(hk-advance!)
|
|
(set! is-tuple true)
|
|
(append! items (hk-parse-expr-inner))
|
|
(hk-tup-loop)))))
|
|
(hk-tup-loop)
|
|
(cond
|
|
((hk-match? "rparen" nil)
|
|
(do
|
|
(hk-advance!)
|
|
(if
|
|
is-tuple
|
|
(list :tuple items)
|
|
first-e)))
|
|
(:else
|
|
(let
|
|
((op-info2 (hk-section-op-info)))
|
|
(cond
|
|
((and
|
|
(not (nil? op-info2))
|
|
(not is-tuple)
|
|
(let
|
|
((after2
|
|
(hk-peek-at
|
|
(get op-info2 "len"))))
|
|
(and
|
|
(not (nil? after2))
|
|
(= (get after2 "type") "rparen"))))
|
|
(let
|
|
((op-name (get op-info2 "name")))
|
|
(hk-consume-op!)
|
|
(hk-advance!)
|
|
(list :sect-left op-name first-e)))
|
|
(:else
|
|
(hk-err
|
|
"expected ')' after expression"))))))))))))))
|
|
|
|
;; ── List comprehension qualifiers ──────────────────────
|
|
;; (:list-comp E QUALS) where each qualifier is one of:
|
|
;; (:q-gen PAT E) — `pat <- expr`
|
|
;; (:q-guard E) — bare boolean expression
|
|
;; (:q-let DECLS) — `let decls`
|
|
(define
|
|
hk-comp-qual-is-gen?
|
|
(fn
|
|
()
|
|
(let
|
|
((j pos) (depth 0) (found false) (done false))
|
|
(define
|
|
hk-qsc-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(and (not done) (< j n))
|
|
(let
|
|
((t (nth toks j)) (ty (get t "type")))
|
|
(cond
|
|
((and
|
|
(= depth 0)
|
|
(or
|
|
(= ty "comma")
|
|
(= ty "rbracket")))
|
|
(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 "rbrace")
|
|
(= ty "vrbrace"))
|
|
(set! depth (- depth 1)))
|
|
(:else nil))
|
|
(set! j (+ j 1))
|
|
(hk-qsc-loop)))))
|
|
(hk-qsc-loop)
|
|
found)))
|
|
|
|
(define
|
|
hk-parse-comp-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-cl-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-cl-loop)))))
|
|
(hk-cl-loop)))
|
|
(cond
|
|
(explicit (hk-expect! "rbrace" nil))
|
|
((hk-match? "vrbrace" nil) (hk-advance!))
|
|
;; In a single-line comprehension, `]` or `,`
|
|
;; terminates the qualifier before layout's implicit
|
|
;; vrbrace arrives — leave them for the outer parser.
|
|
((or
|
|
(hk-match? "rbracket" nil)
|
|
(hk-match? "comma" nil))
|
|
nil)
|
|
(:else
|
|
(hk-err "expected end of let block in comprehension")))
|
|
(list :q-let binds)))))
|
|
|
|
(define
|
|
hk-parse-qual
|
|
(fn
|
|
()
|
|
(cond
|
|
((hk-match? "reserved" "let") (hk-parse-comp-let))
|
|
((hk-comp-qual-is-gen?)
|
|
(let ((pat (hk-parse-pat)))
|
|
(hk-expect! "reservedop" "<-")
|
|
(list :q-gen pat (hk-parse-expr-inner))))
|
|
(:else (list :q-guard (hk-parse-expr-inner))))))
|
|
|
|
;; ── List literal / range / comprehension ───────────────
|
|
(define
|
|
hk-parse-list-lit
|
|
(fn
|
|
()
|
|
(hk-expect! "lbracket" nil)
|
|
(cond
|
|
((hk-match? "rbracket" nil)
|
|
(do (hk-advance!) (list :list (list))))
|
|
(:else
|
|
(let
|
|
((first-e (hk-parse-expr-inner)))
|
|
(cond
|
|
((hk-match? "reservedop" "..")
|
|
(do
|
|
(hk-advance!)
|
|
(let
|
|
((end-e (hk-parse-expr-inner)))
|
|
(hk-expect! "rbracket" nil)
|
|
(list :range first-e end-e))))
|
|
((hk-match? "reservedop" "|")
|
|
(do
|
|
(hk-advance!)
|
|
(let ((quals (list)))
|
|
(append! quals (hk-parse-qual))
|
|
(define
|
|
hk-lc-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(hk-match? "comma" nil)
|
|
(do
|
|
(hk-advance!)
|
|
(append! quals (hk-parse-qual))
|
|
(hk-lc-loop)))))
|
|
(hk-lc-loop)
|
|
(hk-expect! "rbracket" nil)
|
|
(list :list-comp first-e quals))))
|
|
((hk-match? "comma" nil)
|
|
(do
|
|
(hk-advance!)
|
|
(let
|
|
((second-e (hk-parse-expr-inner)))
|
|
(cond
|
|
((hk-match? "reservedop" "..")
|
|
(do
|
|
(hk-advance!)
|
|
(let
|
|
((end-e (hk-parse-expr-inner)))
|
|
(hk-expect! "rbracket" nil)
|
|
(list
|
|
:range-step
|
|
first-e
|
|
second-e
|
|
end-e))))
|
|
(:else
|
|
(let
|
|
((items (list)))
|
|
(append! items first-e)
|
|
(append! items second-e)
|
|
(define
|
|
hk-list-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(hk-match? "comma" nil)
|
|
(do
|
|
(hk-advance!)
|
|
(append!
|
|
items
|
|
(hk-parse-expr-inner))
|
|
(hk-list-loop)))))
|
|
(hk-list-loop)
|
|
(hk-expect! "rbracket" nil)
|
|
(list :list items)))))))
|
|
(:else
|
|
(do
|
|
(hk-expect! "rbracket" nil)
|
|
(list :list (list first-e))))))))))
|
|
|
|
;; ── Application: left-assoc aexp chain ───────────────────
|
|
(define
|
|
hk-parse-fexp
|
|
(fn
|
|
()
|
|
(let
|
|
((fn-e (hk-parse-aexp)))
|
|
(define
|
|
hk-app-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(hk-atom-start? (hk-peek))
|
|
(let
|
|
((arg (hk-parse-aexp)))
|
|
(set! fn-e (list :app fn-e arg))
|
|
(hk-app-loop)))))
|
|
(hk-app-loop)
|
|
fn-e)))
|
|
|
|
;; ── Lambda: \ apat1 apat2 ... apatn -> body ──────────────
|
|
(define
|
|
hk-parse-lambda
|
|
(fn
|
|
()
|
|
(hk-expect! "reservedop" "\\")
|
|
(let
|
|
((params (list)))
|
|
(when
|
|
(not (hk-apat-start? (hk-peek)))
|
|
(hk-err "lambda needs at least one pattern parameter"))
|
|
(define
|
|
hk-lam-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(hk-apat-start? (hk-peek))
|
|
(do
|
|
(append! params (hk-parse-apat))
|
|
(hk-lam-loop)))))
|
|
(hk-lam-loop)
|
|
(hk-expect! "reservedop" "->")
|
|
(list :lambda params (hk-parse-expr-inner)))))
|
|
|
|
;; ── if-then-else ────────────────────────────────────────
|
|
(define
|
|
hk-parse-if
|
|
(fn
|
|
()
|
|
(hk-expect! "reserved" "if")
|
|
(let
|
|
((c (hk-parse-expr-inner)))
|
|
(hk-expect! "reserved" "then")
|
|
(let
|
|
((th (hk-parse-expr-inner)))
|
|
(hk-expect! "reserved" "else")
|
|
(let
|
|
((el (hk-parse-expr-inner)))
|
|
(list :if c th el))))))
|
|
|
|
;; ── Let expression ──────────────────────────────────────
|
|
(define
|
|
hk-parse-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-let-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-let-loop)))))
|
|
(hk-let-loop)))
|
|
(if
|
|
explicit
|
|
(hk-expect! "rbrace" nil)
|
|
(hk-expect! "vrbrace" nil))
|
|
(hk-expect! "reserved" "in")
|
|
(list :let binds (hk-parse-expr-inner))))))
|
|
|
|
;; ── RHS: guards + optional where ─────────────────────────
|
|
;; A rhs is either a plain body after `=`/`->`, or a list of
|
|
;; guarded bodies (`| cond = e | cond = e …`), optionally
|
|
;; followed by a `where` block of local decls. Shapes:
|
|
;; plain: <expr>
|
|
;; guards: (:guarded ((:guard C1 E1) (:guard C2 E2) …))
|
|
;; where: (:where <plain|guarded> DECLS)
|
|
;; Used by fun-clauses, let/do-let bindings, and case alts.
|
|
(define
|
|
hk-parse-where-decls
|
|
(fn
|
|
()
|
|
(let ((explicit (hk-match? "lbrace" nil)))
|
|
(if
|
|
explicit
|
|
(hk-advance!)
|
|
(hk-expect! "vlbrace" nil))
|
|
(let ((decls (list)))
|
|
(when
|
|
(not
|
|
(if
|
|
explicit
|
|
(hk-match? "rbrace" nil)
|
|
(hk-match? "vrbrace" nil)))
|
|
(do
|
|
(append! decls (hk-parse-decl))
|
|
(define
|
|
hk-wd-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(or
|
|
(hk-match? "vsemi" nil)
|
|
(hk-match? "semi" nil))
|
|
(do
|
|
(hk-advance!)
|
|
(when
|
|
(not
|
|
(if
|
|
explicit
|
|
(hk-match? "rbrace" nil)
|
|
(hk-match? "vrbrace" nil)))
|
|
(append! decls (hk-parse-decl)))
|
|
(hk-wd-loop)))))
|
|
(hk-wd-loop)))
|
|
(if
|
|
explicit
|
|
(hk-expect! "rbrace" nil)
|
|
(hk-expect! "vrbrace" nil))
|
|
decls))))
|
|
|
|
(define
|
|
hk-parse-guarded
|
|
(fn
|
|
(sep)
|
|
(let ((guards (list)))
|
|
(define
|
|
hk-g-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(hk-match? "reservedop" "|")
|
|
(do
|
|
(hk-advance!)
|
|
(let
|
|
((cond-e (hk-parse-expr-inner)))
|
|
(hk-expect! "reservedop" sep)
|
|
(let
|
|
((expr-e (hk-parse-expr-inner)))
|
|
(append! guards (list :guard cond-e expr-e))
|
|
(hk-g-loop)))))))
|
|
(hk-g-loop)
|
|
(list :guarded guards))))
|
|
|
|
(define
|
|
hk-parse-rhs
|
|
(fn
|
|
(sep)
|
|
(let
|
|
((body
|
|
(cond
|
|
((hk-match? "reservedop" "|")
|
|
(hk-parse-guarded sep))
|
|
(:else
|
|
(do
|
|
(hk-expect! "reservedop" sep)
|
|
(hk-parse-expr-inner))))))
|
|
(cond
|
|
((hk-match? "reserved" "where")
|
|
(do
|
|
(hk-advance!)
|
|
(list :where body (hk-parse-where-decls))))
|
|
(:else body)))))
|
|
|
|
;; Binding LHS is a pattern (for pat-binds), a varid alone
|
|
;; (simple `x = e`), or a varid followed by apats (the
|
|
;; `let f x = …` / `let f x | g = … | g = …` funclause form).
|
|
(define
|
|
hk-parse-bind
|
|
(fn
|
|
()
|
|
(let
|
|
((t (hk-peek)))
|
|
(cond
|
|
((and
|
|
(not (nil? t))
|
|
(= (get t "type") "varid"))
|
|
(let
|
|
((name (get (hk-advance!) "value"))
|
|
(pats (list)))
|
|
(define
|
|
hk-b-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(hk-apat-start? (hk-peek))
|
|
(do
|
|
(append! pats (hk-parse-apat))
|
|
(hk-b-loop)))))
|
|
(hk-b-loop)
|
|
(if
|
|
(= (len pats) 0)
|
|
(list
|
|
:bind
|
|
(list :p-var name)
|
|
(hk-parse-rhs "="))
|
|
(list
|
|
:fun-clause
|
|
name
|
|
pats
|
|
(hk-parse-rhs "=")))))
|
|
(:else
|
|
(let
|
|
((pat (hk-parse-pat)))
|
|
(list :bind pat (hk-parse-rhs "="))))))))
|
|
|
|
;; ── Patterns ─────────────────────────────────────────────
|
|
(define
|
|
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)))
|
|
((and
|
|
(= (get t "type") "reservedop")
|
|
(= (get t "value") "~"))
|
|
(do (hk-advance!) (list :p-lazy (hk-parse-apat))))
|
|
((and
|
|
(= (get t "type") "varsym")
|
|
(= (get t "value") "-"))
|
|
(do
|
|
(hk-advance!)
|
|
(let
|
|
((n (hk-peek)))
|
|
(cond
|
|
((nil? n)
|
|
(hk-err "expected numeric literal after '-'"))
|
|
((= (get n "type") "integer")
|
|
(do
|
|
(hk-advance!)
|
|
(list :p-int (- 0 (get n "value")))))
|
|
((= (get n "type") "float")
|
|
(do
|
|
(hk-advance!)
|
|
(list :p-float (- 0 (get n "value")))))
|
|
(:else
|
|
(hk-err
|
|
"only numeric literals may follow '-' in a pattern"))))))
|
|
((= (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")
|
|
(let
|
|
((next-t (hk-peek-at 1)))
|
|
(cond
|
|
((and
|
|
(not (nil? next-t))
|
|
(= (get next-t "type") "reservedop")
|
|
(= (get next-t "value") "@"))
|
|
(do
|
|
(hk-advance!)
|
|
(hk-advance!)
|
|
(list :p-as (get t "value") (hk-parse-apat))))
|
|
(:else
|
|
(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-lhs
|
|
(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))))))
|
|
|
|
;; Infix constructor patterns: `x : xs`, `a `Cons` b`, etc.
|
|
;; Right-associative, single precedence band.
|
|
(define
|
|
hk-parse-pat
|
|
(fn
|
|
()
|
|
(let
|
|
((left (hk-parse-pat-lhs)))
|
|
(cond
|
|
((or
|
|
(= (hk-peek-type) "consym")
|
|
(and
|
|
(= (hk-peek-type) "reservedop")
|
|
(= (hk-peek-value) ":")))
|
|
(let
|
|
((op (get (hk-advance!) "value")))
|
|
(let
|
|
((right (hk-parse-pat)))
|
|
(list :p-con op (list left right)))))
|
|
(:else left)))))
|
|
|
|
;; ── case ─ of { pat -> expr ; ... } ─────────────────────
|
|
(define
|
|
hk-parse-alt
|
|
(fn
|
|
()
|
|
(let
|
|
((pat (hk-parse-pat)))
|
|
(list :alt pat (hk-parse-rhs "->")))))
|
|
|
|
(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
|
|
()
|
|
(cond
|
|
((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 - ─────────────────────────────────────
|
|
(define
|
|
hk-parse-prefix
|
|
(fn
|
|
()
|
|
(cond
|
|
((and (hk-match? "varsym" "-"))
|
|
(do (hk-advance!) (list :neg (hk-parse-lexp))))
|
|
(:else (hk-parse-lexp)))))
|
|
|
|
;; ── Infix: precedence climbing ──────────────────────────
|
|
(define
|
|
hk-is-infix-op?
|
|
(fn
|
|
(tok)
|
|
(if
|
|
(nil? tok)
|
|
false
|
|
(or
|
|
(= (get tok "type") "varsym")
|
|
(= (get tok "type") "consym")
|
|
(and
|
|
(= (get tok "type") "reservedop")
|
|
(= (get tok "value") ":"))
|
|
(= (get tok "type") "backtick")))))
|
|
|
|
(define
|
|
hk-consume-op!
|
|
(fn
|
|
()
|
|
(let
|
|
((t (hk-peek)))
|
|
(cond
|
|
((= (get t "type") "backtick")
|
|
(do
|
|
(hk-advance!)
|
|
(let
|
|
((v (hk-expect! "varid" nil)))
|
|
(hk-expect! "backtick" nil)
|
|
(get v "value"))))
|
|
(:else (do (hk-advance!) (get t "value")))))))
|
|
|
|
(define
|
|
hk-parse-infix
|
|
(fn
|
|
(min-prec)
|
|
(let
|
|
((left (hk-parse-prefix)))
|
|
(define
|
|
hk-inf-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(hk-is-infix-op? (hk-peek))
|
|
(let
|
|
((op-tok (hk-peek)))
|
|
(let
|
|
((op-len
|
|
(if
|
|
(= (get op-tok "type") "backtick")
|
|
3
|
|
1))
|
|
(op-name
|
|
(if
|
|
(= (get op-tok "type") "backtick")
|
|
(get (hk-peek-at 1) "value")
|
|
(get op-tok "value"))))
|
|
(let
|
|
((after-op (hk-peek-at op-len))
|
|
(info (hk-op-info op-name)))
|
|
(cond
|
|
;; Bail on `op )` — let the paren parser claim
|
|
;; it as a left section (e op).
|
|
((and
|
|
(not (nil? after-op))
|
|
(= (get after-op "type") "rparen"))
|
|
nil)
|
|
((>= (get info "prec") min-prec)
|
|
(do
|
|
(hk-consume-op!)
|
|
(let
|
|
((next-min
|
|
(cond
|
|
((= (get info "assoc") "left")
|
|
(+ (get info "prec") 1))
|
|
((= (get info "assoc") "right")
|
|
(get info "prec"))
|
|
(:else (+ (get info "prec") 1)))))
|
|
(let
|
|
((right (hk-parse-infix next-min)))
|
|
(set!
|
|
left
|
|
(list :op op-name left right))
|
|
(hk-inf-loop)))))
|
|
(:else nil))))))))
|
|
(hk-inf-loop)
|
|
left)))
|
|
|
|
(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)
|
|
(list :fun-clause name pats (hk-parse-rhs "="))))
|
|
(:else
|
|
(let
|
|
((pat (hk-parse-pat)))
|
|
(list :pat-bind pat (hk-parse-rhs "="))))))))
|
|
|
|
(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)))))
|
|
|
|
;; ── Module header + imports ─────────────────────────────
|
|
;; Import/export entity references:
|
|
;; (:ent-var NAME) — bare var/type name (incl. (op) form)
|
|
;; (:ent-all NAME) — Tycon(..)
|
|
;; (:ent-with NAME MEMS) — Tycon(m1, m2, …)
|
|
;; (:ent-module NAME) — module M (exports only)
|
|
;; Member names inside Tycon(…) are bare strings.
|
|
|
|
(define
|
|
hk-parse-ent-member
|
|
(fn
|
|
()
|
|
(cond
|
|
((hk-match? "varid" nil)
|
|
(get (hk-advance!) "value"))
|
|
((hk-match? "conid" nil)
|
|
(get (hk-advance!) "value"))
|
|
((hk-match? "lparen" nil)
|
|
(do
|
|
(hk-advance!)
|
|
(let
|
|
((op-name
|
|
(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!) ":"))
|
|
(:else
|
|
(hk-err "expected operator in member list")))))
|
|
(hk-expect! "rparen" nil)
|
|
op-name)))
|
|
(:else (hk-err "expected identifier in member list")))))
|
|
|
|
(define
|
|
hk-parse-ent
|
|
(fn
|
|
(allow-module?)
|
|
(cond
|
|
((hk-match? "varid" nil)
|
|
(list :ent-var (get (hk-advance!) "value")))
|
|
((hk-match? "qvarid" nil)
|
|
(list :ent-var (get (hk-advance!) "value")))
|
|
((and allow-module? (hk-match? "reserved" "module"))
|
|
(do
|
|
(hk-advance!)
|
|
(cond
|
|
((or
|
|
(hk-match? "conid" nil)
|
|
(hk-match? "qconid" nil))
|
|
(list :ent-module (get (hk-advance!) "value")))
|
|
(:else (hk-err "expected module name in export")))))
|
|
((or (hk-match? "conid" nil) (hk-match? "qconid" nil))
|
|
(let ((name (get (hk-advance!) "value")))
|
|
(cond
|
|
((hk-match? "lparen" nil)
|
|
(do
|
|
(hk-advance!)
|
|
(cond
|
|
((hk-match? "reservedop" "..")
|
|
(do
|
|
(hk-advance!)
|
|
(hk-expect! "rparen" nil)
|
|
(list :ent-all name)))
|
|
((hk-match? "rparen" nil)
|
|
(do
|
|
(hk-advance!)
|
|
(list :ent-with name (list))))
|
|
(:else
|
|
(let ((mems (list)))
|
|
(append! mems (hk-parse-ent-member))
|
|
(define
|
|
hk-mem-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(hk-match? "comma" nil)
|
|
(do
|
|
(hk-advance!)
|
|
(when
|
|
(not (hk-match? "rparen" nil))
|
|
(append!
|
|
mems
|
|
(hk-parse-ent-member)))
|
|
(hk-mem-loop)))))
|
|
(hk-mem-loop)
|
|
(hk-expect! "rparen" nil)
|
|
(list :ent-with name mems))))))
|
|
(:else (list :ent-var name)))))
|
|
((hk-match? "lparen" nil)
|
|
(do
|
|
(hk-advance!)
|
|
(let
|
|
((op-name
|
|
(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!) ":"))
|
|
(:else
|
|
(hk-err "expected operator in parens")))))
|
|
(hk-expect! "rparen" nil)
|
|
(list :ent-var op-name))))
|
|
(:else (hk-err "expected entity in import/export list")))))
|
|
|
|
(define
|
|
hk-parse-ent-list
|
|
(fn
|
|
(allow-module?)
|
|
(hk-expect! "lparen" nil)
|
|
(cond
|
|
((hk-match? "rparen" nil)
|
|
(do (hk-advance!) (list)))
|
|
(:else
|
|
(let ((items (list)))
|
|
(append! items (hk-parse-ent allow-module?))
|
|
(define
|
|
hk-el-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(hk-match? "comma" nil)
|
|
(do
|
|
(hk-advance!)
|
|
(when
|
|
(not (hk-match? "rparen" nil))
|
|
(append!
|
|
items
|
|
(hk-parse-ent allow-module?)))
|
|
(hk-el-loop)))))
|
|
(hk-el-loop)
|
|
(hk-expect! "rparen" nil)
|
|
items)))))
|
|
|
|
;; (:import QUALIFIED NAME AS SPEC)
|
|
;; QUALIFIED: bool
|
|
;; NAME : module name string (may contain dots)
|
|
;; AS : alias module name string or nil
|
|
;; SPEC : nil | (:spec-items ENTS) | (:spec-hiding ENTS)
|
|
(define
|
|
hk-parse-import
|
|
(fn
|
|
()
|
|
(hk-expect! "reserved" "import")
|
|
(let
|
|
((qualified false)
|
|
(modname nil)
|
|
(as-name nil)
|
|
(spec nil))
|
|
(when
|
|
(hk-match? "varid" "qualified")
|
|
(do (hk-advance!) (set! qualified true)))
|
|
(cond
|
|
((or
|
|
(hk-match? "conid" nil)
|
|
(hk-match? "qconid" nil))
|
|
(set! modname (get (hk-advance!) "value")))
|
|
(:else (hk-err "expected module name in import")))
|
|
(when
|
|
(hk-match? "varid" "as")
|
|
(do
|
|
(hk-advance!)
|
|
(cond
|
|
((or
|
|
(hk-match? "conid" nil)
|
|
(hk-match? "qconid" nil))
|
|
(set! as-name (get (hk-advance!) "value")))
|
|
(:else (hk-err "expected name after 'as'")))))
|
|
(cond
|
|
((hk-match? "varid" "hiding")
|
|
(do
|
|
(hk-advance!)
|
|
(set!
|
|
spec
|
|
(list :spec-hiding (hk-parse-ent-list false)))))
|
|
((hk-match? "lparen" nil)
|
|
(set!
|
|
spec
|
|
(list :spec-items (hk-parse-ent-list false)))))
|
|
(list :import qualified modname as-name spec))))
|
|
|
|
;; (:module NAME EXPORTS IMPORTS DECLS)
|
|
;; NAME : module name string or nil (no header)
|
|
;; EXPORTS : list of ent-refs, or nil (no export list)
|
|
;; IMPORTS : list of :import records
|
|
;; DECLS : list of top-level decls
|
|
(define
|
|
hk-parse-module-header
|
|
(fn
|
|
()
|
|
(hk-expect! "reserved" "module")
|
|
(let ((modname nil) (exports nil))
|
|
(cond
|
|
((or
|
|
(hk-match? "conid" nil)
|
|
(hk-match? "qconid" nil))
|
|
(set! modname (get (hk-advance!) "value")))
|
|
(:else (hk-err "expected module name")))
|
|
(when
|
|
(hk-match? "lparen" nil)
|
|
(set! exports (hk-parse-ent-list true)))
|
|
(hk-expect! "reserved" "where")
|
|
(list modname exports))))
|
|
|
|
(define
|
|
hk-collect-module-body
|
|
(fn
|
|
()
|
|
(let ((imports (list)) (decls (list)))
|
|
(define
|
|
hk-imp-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(hk-match? "reserved" "import")
|
|
(do
|
|
(append! imports (hk-parse-import))
|
|
(when
|
|
(or
|
|
(hk-match? "vsemi" nil)
|
|
(hk-match? "semi" nil))
|
|
(do (hk-advance!) (hk-imp-loop)))))))
|
|
(hk-imp-loop)
|
|
(define
|
|
hk-body-at-end?
|
|
(fn
|
|
()
|
|
(or
|
|
(nil? (hk-peek))
|
|
(= (hk-peek-type) "eof")
|
|
(hk-match? "vrbrace" nil)
|
|
(hk-match? "rbrace" nil))))
|
|
(when
|
|
(not (hk-body-at-end?))
|
|
(do
|
|
(append! decls (hk-parse-decl))
|
|
(define
|
|
hk-body-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(or
|
|
(hk-match? "vsemi" nil)
|
|
(hk-match? "semi" nil))
|
|
(do
|
|
(hk-advance!)
|
|
(when
|
|
(not (hk-body-at-end?))
|
|
(append! decls (hk-parse-decl)))
|
|
(hk-body-loop)))))
|
|
(hk-body-loop)))
|
|
(list imports decls))))
|
|
|
|
(define
|
|
hk-parse-program
|
|
(fn
|
|
()
|
|
(cond
|
|
((hk-match? "reserved" "module")
|
|
(let ((header (hk-parse-module-header)))
|
|
(let ((explicit (hk-match? "lbrace" nil)))
|
|
(if
|
|
explicit
|
|
(hk-advance!)
|
|
(hk-expect! "vlbrace" nil))
|
|
(let ((body (hk-collect-module-body)))
|
|
(if
|
|
explicit
|
|
(hk-expect! "rbrace" nil)
|
|
(hk-expect! "vrbrace" nil))
|
|
(list
|
|
:module
|
|
(nth header 0)
|
|
(nth header 1)
|
|
(nth body 0)
|
|
(nth body 1))))))
|
|
(:else
|
|
(let ((body (hk-collect-module-body)))
|
|
(if
|
|
(empty? (nth body 0))
|
|
(list :program (nth body 1))
|
|
(list
|
|
:module
|
|
nil
|
|
nil
|
|
(nth body 0)
|
|
(nth body 1))))))))
|
|
|
|
;; ── Top-level: strip leading/trailing module-level braces ─
|
|
(let
|
|
((start-brace
|
|
(or
|
|
(hk-match? "vlbrace" nil)
|
|
(hk-match? "lbrace" nil))))
|
|
(when start-brace (hk-advance!))
|
|
(let
|
|
((result
|
|
(cond
|
|
((= mode :expr) (hk-parse-expr-inner))
|
|
((= mode :module) (hk-parse-program))
|
|
(:else (hk-err "unknown parser mode")))))
|
|
(when start-brace
|
|
(when
|
|
(or
|
|
(hk-match? "vrbrace" nil)
|
|
(hk-match? "rbrace" nil))
|
|
(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)))))
|