haskell: module header + imports (+16 tests, 189/189)
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:
@@ -1421,13 +1421,238 @@
|
||||
((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-program
|
||||
hk-parse-ent-member
|
||||
(fn
|
||||
()
|
||||
(let ((decls (list)))
|
||||
(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-prog-at-end?
|
||||
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
|
||||
@@ -1436,11 +1661,11 @@
|
||||
(hk-match? "vrbrace" nil)
|
||||
(hk-match? "rbrace" nil))))
|
||||
(when
|
||||
(not (hk-prog-at-end?))
|
||||
(not (hk-body-at-end?))
|
||||
(do
|
||||
(append! decls (hk-parse-decl))
|
||||
(define
|
||||
hk-prog-loop
|
||||
hk-body-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
@@ -1450,11 +1675,46 @@
|
||||
(do
|
||||
(hk-advance!)
|
||||
(when
|
||||
(not (hk-prog-at-end?))
|
||||
(not (hk-body-at-end?))
|
||||
(append! decls (hk-parse-decl)))
|
||||
(hk-prog-loop)))))
|
||||
(hk-prog-loop)))
|
||||
(list :program decls))))
|
||||
(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
|
||||
|
||||
Reference in New Issue
Block a user