Add Typed Jerboa parser skeleton
ober
0a6f7a59c4b9c31f877d1edf70c6a1b93b5d05aa
--- a/Makefile +++ b/Makefile @@ -27,7 +27,7 @@ CHEZ_EXT_LDPATH = $(CHEZ_EXT_DIR)/chez-ssl:$(CHEZ_EXT_DIR)/chez-zlib:$(CHEZ_EXT_ PURE_AUDIT_ROOT ?= $(HOME)/mine PURE_AUDIT_ARGS ?= --summary --discover $(PURE_AUDIT_ROOT) -.PHONY: help chez chez-cross build binary binary-cross native-cross pure-audit test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-contract test-ergo test-pure-audit test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-security-profile test-native test-gaps native clean-native audit-native clean security security-production security-profile fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-fuzz fuzz-websocket-fuzz fuzz-dns-fuzz fuzz-pregexp-fuzz fuzz-csv-fuzz fuzz-base64-fuzz fuzz-hex-fuzz fuzz-uri-fuzz fuzz-format-fuzz fuzz-router-fuzz fuzz-sandbox-fuzz test-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict docker-build docker-push +.PHONY: help chez chez-cross build binary binary-cross native-cross pure-audit test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-contract test-ergo test-typed-parser test-pure-audit test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-security-profile test-native test-gaps native clean-native audit-native clean security security-production security-profile fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-fuzz fuzz-websocket-fuzz fuzz-dns-fuzz fuzz-pregexp-fuzz fuzz-csv-fuzz fuzz-base64-fuzz fuzz-hex-fuzz fuzz-uri-fuzz fuzz-format-fuzz fuzz-router-fuzz fuzz-sandbox-fuzz test-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict docker-build docker-push help: @echo "Usage: make <target>" @@ -66,6 +66,7 @@ help: @echo " test-gaps Gap coverage tests" @echo " test-contract Runtime contract tests" @echo " test-ergo Ergonomic contract marker tests" + @echo " test-typed-parser Typed Jerboa parser tests" @echo " test-pure-audit Pure Jerboa migration scanner tests" @echo "" @echo "Test (features):" @@ -292,7 +293,7 @@ binary-cross: chez build chez-cross CC="$(CROSS_CC)" \ support/build-binary.sh $(BINARY_ENTRY) $(BINARY_OUTPUT)-$(CHEZ_TARGET_MACHINE) -test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-regex-all test-contract test-ergo test-pure-audit +test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-regex-all test-contract test-ergo test-typed-parser test-pure-audit pure-audit: @$(SCHEME) --libdirs $(LIBDIRS) --script support/pure-audit.ss $(PURE_AUDIT_ARGS) @@ -343,6 +344,9 @@ test-ergo: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-ergo.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-jerboa-prelude-ergo.ss +test-typed-parser: + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-parser.ss + test-pure-audit: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-pure-audit.ss --- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -133,6 +133,16 @@ a new top-level form: The compiler can later accept `.tss` as a convenience. +Current landing: + +- `(jerboa typed parser)` parses and validates `(typed-library ...)` datums + into a first AST layer. +- The parser currently recognizes explicit `export` forms, `type` declarations, + immutable and `mut` record fields, variants including nullary cases, and + `def` forms with typed parameters and `:` or `->` return markers. +- This is a front-end milestone only. It does not yet typecheck expressions, + resolve imports, lower to typed core IR, or emit Rust/LLVM. + ## Surface Syntax A typed module should look familiar to Jerboa users: @@ -706,10 +716,11 @@ Minimum excluded features: ### Milestone 1: Parser and AST -- Read typed module forms. -- Preserve source spans. -- Parse type expressions. -- Parse records, variants, and function definitions. +- Read typed module forms. Initial datum parser landed as + `(jerboa typed parser)`. +- Preserve source spans. Not yet landed; the first parser validates datums only. +- Parse type expressions. Initial symbolic and compound type parsing landed. +- Parse records, variants, and function definitions. Initial AST records landed. - Reject unsupported forms clearly. ### Milestone 2: Type Checker new file mode 100644 --- /dev/null +++ b/lib/jerboa/typed/parser.ss @@ -0,0 +1,236 @@ +#!chezscheme +;;; (jerboa typed parser) -- Typed Jerboa surface form parser +;;; +;;; Parses `(typed-library ...)` datums into a small AST used by the future +;;; type checker and backends. This is validation only: it does not expand +;;; macros, check expression types, or generate native code. + +(library (jerboa typed parser) + (export + typed-library-form? + parse-typed-library + parse-typed-declaration + parse-typed-type + + typed-module? make-typed-module + typed-module-name typed-module-exports typed-module-declarations + + typed-type-decl? make-typed-type-decl + typed-type-decl-name + + typed-field? make-typed-field + typed-field-name typed-field-type typed-field-mutable? + + typed-record? make-typed-record + typed-record-name typed-record-fields + + typed-variant? make-typed-variant + typed-variant-name typed-variant-cases + + typed-variant-case? make-typed-variant-case + typed-variant-case-name typed-variant-case-fields + + typed-param? make-typed-param + typed-param-name typed-param-type + + typed-def? make-typed-def + typed-def-name typed-def-params typed-def-return-type typed-def-body) + + (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted typed compiler front-end module + (only (jerboa core) def defstruct)) + + (defstruct typed-module (name exports declarations)) + (defstruct typed-type-decl (name)) + (defstruct typed-field (name type mutable?)) + (defstruct typed-record (name fields)) + (defstruct typed-variant (name cases)) + (defstruct typed-variant-case (name fields)) + (defstruct typed-param (name type)) + (defstruct typed-def (name params return-type body)) + + (def (proper-list? x) + (cond + [(null? x) #t] + [(pair? x) (proper-list? (cdr x))] + [else #f])) + + (def (expect-proper-list who form) + (unless (proper-list? form) + (error who "expected a proper list" form)) + form) + + (def (expect-symbol who value context) + (unless (symbol? value) + (error who "expected symbol" value context)) + value) + + (def (expect-length who form n) + (expect-proper-list who form) + (unless (= (length form) n) + (error who "wrong form arity" form)) + form) + + (def (symbol-list? xs) + (and (proper-list? xs) + (for-all symbol? xs))) + + (def (parse-module-name name) + (unless (and (pair? name) (symbol-list? name)) + (error 'parse-typed-library + "module name must be a non-empty list of symbols" + name)) + name) + + (def (parse-export-form form) + (expect-proper-list 'parse-typed-library form) + (unless (and (pair? form) (eq? (car form) 'export)) + (error 'parse-typed-library + "typed-library requires an explicit export form" + form)) + (let ([exports (cdr form)]) + (unless (symbol-list? exports) + (error 'parse-typed-library + "exports must be symbols" + exports)) + exports)) + + (def (typed-library-form? form) + (and (pair? form) + (eq? (car form) 'typed-library))) + + (def (parse-typed-library form) + (expect-proper-list 'parse-typed-library form) + (unless (typed-library-form? form) + (error 'parse-typed-library "expected typed-library form" form)) + (unless (>= (length form) 3) + (error 'parse-typed-library + "expected (typed-library name (export ...) declarations ...)" + form)) + (let ([name (parse-module-name (cadr form))] + [exports (parse-export-form (caddr form))] + [declarations (map parse-typed-declaration (cdddr form))]) + (make-typed-module name exports declarations))) + + (def (parse-typed-type type) + (cond + [(symbol? type) type] + [(and (pair? type) (proper-list? type) (symbol? (car type))) + (cons (car type) (map parse-typed-type (cdr type)))] + [else + (error 'parse-typed-type + "expected a type symbol or compound type expression" + type)])) + + (def (parse-field form) + (expect-proper-list 'parse-typed-field form) + (case (length form) + [(3) + (unless (eq? (cadr form) ':) + (error 'parse-typed-field + "expected (name : Type)" + form)) + (make-typed-field + (expect-symbol 'parse-typed-field (car form) form) + (parse-typed-type (caddr form)) + #f)] + [(4) + (unless (and (eq? (car form) 'mut) + (eq? (caddr form) ':)) + (error 'parse-typed-field + "expected (mut name : Type)" + form)) + (make-typed-field + (expect-symbol 'parse-typed-field (cadr form) form) + (parse-typed-type (cadddr form)) + #t)] + [else + (error 'parse-typed-field + "expected (name : Type) or (mut name : Type)" + form)])) + + (def (parse-param form) + (expect-length 'parse-typed-param form 3) + (unless (eq? (cadr form) ':) + (error 'parse-typed-param + "expected (name : Type)" + form)) + (make-typed-param + (expect-symbol 'parse-typed-param (car form) form) + (parse-typed-type (caddr form)))) + + (def (parse-record form) + (expect-length 'parse-typed-record form 3) + (let ([name (expect-symbol 'parse-typed-record (cadr form) form)] + [fields-form (caddr form)]) + (expect-proper-list 'parse-typed-record fields-form) + (make-typed-record name (map parse-field fields-form)))) + + (def (parse-variant-case form) + (expect-proper-list 'parse-typed-variant-case form) + (unless (and (pair? form) (symbol? (car form))) + (error 'parse-typed-variant-case + "expected (Case field ...)" + form)) + (make-typed-variant-case + (car form) + (map parse-field (cdr form)))) + + (def (parse-variant form) + (expect-proper-list 'parse-typed-variant form) + (unless (>= (length form) 3) + (error 'parse-typed-variant + "expected (variant Name case ...)" + form)) + (make-typed-variant + (expect-symbol 'parse-typed-variant (cadr form) form) + (map parse-variant-case (cddr form)))) + + (def (parse-def-head head) + (expect-proper-list 'parse-typed-def head) + (unless (and (pair? head) (symbol? (car head))) + (error 'parse-typed-def + "expected function head (name (arg : Type) ...)" + head)) + (values (car head) (map parse-param (cdr head)))) + + (def (parse-def form) + (expect-proper-list 'parse-typed-def form) + (unless (>= (length form) 5) + (error 'parse-typed-def + "expected (def (name (arg : Type) ...) : Return body ...)" + form)) + (let ([head (cadr form)] + [return-marker (caddr form)] + [return-type (cadddr form)] + [body (cddddr form)]) + (unless (memq return-marker '(: ->)) + (error 'parse-typed-def + "expected : or -> before return type" + form)) + (let-values ([(name params) (parse-def-head head)]) + (make-typed-def + name + params + (parse-typed-type return-type) + body)))) + + (def (parse-type-decl form) + (expect-length 'parse-typed-type-decl form 2) + (make-typed-type-decl + (expect-symbol 'parse-typed-type-decl (cadr form) form))) + + (def (parse-typed-declaration form) + (expect-proper-list 'parse-typed-declaration form) + (unless (pair? form) + (error 'parse-typed-declaration "empty declaration" form)) + (case (car form) + [(type) (parse-type-decl form)] + [(record) (parse-record form)] + [(variant) (parse-variant form)] + [(def) (parse-def form)] + [else + (error 'parse-typed-declaration + "unsupported typed declaration" + form)])) + +) ;; end library --- a/support/build.ss +++ b/support/build.ss @@ -17,6 +17,7 @@ (jerboa ffi) (jerboa modules) (jerboa build) + (jerboa typed parser) ;; Regex / rx / peg tier — compiled independently so errors are isolated (std srfi srfi-115) (std regex) new file mode 100644 --- /dev/null +++ b/tests/test-typed-parser.ss @@ -0,0 +1,154 @@ +#!chezscheme +;;; Tests for (jerboa typed parser) + +(import (chezscheme) + (jerboa typed parser)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: exception ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) + (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(define-syntax test-error + (syntax-rules () + [(_ name expr) + (test name + (guard (exn [#t #t]) + expr + #f) + #t)])) + +(define sample + '(typed-library (sample typed split-tree) + (export make-leaf split? split-size apply-op) + + (type Split) + + (record Pane + ((id : Nat) + (mut focused? : Bool))) + + (variant EditOp + (Insert (at : Nat) (text : String)) + (Delete (start : Nat) (end : Nat)) + (Noop)) + + (def (make-leaf (name : String)) : Split + name) + + (def (split-size (s : Split)) -> Nat + 0))) + +(define parsed (parse-typed-library sample)) +(define declarations (typed-module-declarations parsed)) +(define type-decl (list-ref declarations 0)) +(define record-decl (list-ref declarations 1)) +(define variant-decl (list-ref declarations 2)) +(define make-leaf-def (list-ref declarations 3)) +(define split-size-def (list-ref declarations 4)) + +(printf "--- Typed Jerboa parser tests ---~%") + +(test "typed-library-form? true" + (typed-library-form? sample) + #t) + +(test "typed-library-form? false" + (typed-library-form? '(library (x))) + #f) + +(test "module name" + (typed-module-name parsed) + '(sample typed split-tree)) + +(test "module exports" + (typed-module-exports parsed) + '(make-leaf split? split-size apply-op)) + +(test "declaration count" + (length declarations) + 5) + +(test "type declaration" + (and (typed-type-decl? type-decl) + (typed-type-decl-name type-decl)) + 'Split) + +(test "record declaration" + (and (typed-record? record-decl) + (typed-record-name record-decl)) + 'Pane) + +(test "record field count" + (length (typed-record-fields record-decl)) + 2) + +(test "record mutable field" + (typed-field-mutable? (cadr (typed-record-fields record-decl))) + #t) + +(test "record field type" + (typed-field-type (car (typed-record-fields record-decl))) + 'Nat) + +(test "variant declaration" + (and (typed-variant? variant-decl) + (typed-variant-name variant-decl)) + 'EditOp) + +(test "variant case count" + (length (typed-variant-cases variant-decl)) + 3) + +(test "variant nullary case" + (typed-variant-case-name (caddr (typed-variant-cases variant-decl))) + 'Noop) + +(test "def declaration" + (and (typed-def? make-leaf-def) + (typed-def-name make-leaf-def)) + 'make-leaf) + +(test "def param name" + (typed-param-name (car (typed-def-params make-leaf-def))) + 'name) + +(test "def return type colon" + (typed-def-return-type make-leaf-def) + 'Split) + +(test "def return type arrow" + (typed-def-return-type split-size-def) + 'Nat) + +(test "compound type expression" + (parse-typed-type '(Result String (Option Nat))) + '(Result String (Option Nat))) + +(test-error "rejects missing export" + (parse-typed-library + '(typed-library (bad module) + (def (f (x : Nat)) : Nat x)))) + +(test-error "rejects bad field marker" + (parse-typed-declaration + '(record Bad ((x :: Nat))))) + +(test-error "rejects unsupported declaration" + (parse-typed-declaration + '(import (jerboa prelude)))) + +(printf "~%Typed parser: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) + (exit 1))