Add ergonomic typing layer: (std ergo) with using, :, and typed def
ober
0a5f71d4cbb7d1c66e18ddc33ab693363f2d1ffd
--- a/lib/jerboa/core.sls +++ b/lib/jerboa/core.sls @@ -107,7 +107,8 @@ (std os path) (std misc thread) (only (std misc string) string-split string-empty?) - (only (std misc list) filter-map)) + (only (std misc list) filter-map) + (only (std typed) check-type! check-return-type!)) ;;;; ---- Compile-time helpers ---- @@ -250,9 +251,84 @@ ;;;; ---- DEF ---- + ;; Check if a datum looks like a typed param: (name : type) + (meta define (typed-param? p) + (and (pair? p) + (pair? (cdr p)) + (pair? (cddr p)) + (null? (cdddr p)) + (symbol? (car p)) + (eq? (cadr p) ':) + (symbol? (caddr p)))) + + ;; Check if any param in the list is typed + (meta define (has-typed-params? params) + (cond + [(null? params) #f] + [(not (pair? params)) #f] + [(typed-param? (car params)) #t] + [else (has-typed-params? (cdr params))])) + + ;; Extract just the arg names from a mixed typed/untyped param list + (meta define (extract-arg-names params) + (map (lambda (p) + (if (typed-param? p) (car p) p)) + params)) + + ;; Extract typed params as list of (name type) pairs + (meta define (extract-typed-params params) + (let loop ([rest params] [acc '()]) + (cond + [(null? rest) (reverse acc)] + [(typed-param? (car rest)) + (loop (cdr rest) + (cons (list (caar rest) (caddar rest)) acc))] + [else (loop (cdr rest) acc)]))) + (define-syntax def (lambda (stx) (syntax-case stx () + ;; Typed def with return type: (def (name (x : fixnum) y) : ret-type body ...) + [(_ (name . params) colon ret-type body ...) + (and (identifier? #'name) + (eq? (syntax->datum #'colon) ':) + (let ([pl (syntax->datum #'params)]) + (and (list? pl) (has-typed-params? pl)))) + (let* ([params-list (syntax->datum #'params)] + [arg-names (extract-arg-names params-list)] + [typed (extract-typed-params params-list)] + ;; Build individual check-type! calls + [checks (map (lambda (ta) + (let ([aname (car ta)] [atype (cadr ta)]) + `(check-type! ',#'name ',aname ,aname ',atype))) + typed)]) + (with-syntax ([(arg ...) (datum->syntax #'name arg-names)] + [(chk ...) (datum->syntax #'name checks)]) + #'(define (name arg ...) + chk ... + (let ([result (begin body ...)]) + (check-return-type! 'name result 'ret-type) + result))))] + + ;; Typed def without return type: (def (name (x : fixnum) y) body ...) + [(_ (name . params) body ...) + (and (identifier? #'name) + (let ([pl (syntax->datum #'params)]) + (and (list? pl) (has-typed-params? pl)))) + (let* ([params-list (syntax->datum #'params)] + [arg-names (extract-arg-names params-list)] + [typed (extract-typed-params params-list)] + [checks (map (lambda (ta) + (let ([aname (car ta)] [atype (cadr ta)]) + `(check-type! ',#'name ',aname ,aname ',atype))) + typed)]) + (with-syntax ([(arg ...) (datum->syntax #'name arg-names)] + [(chk ...) (datum->syntax #'name checks)]) + #'(define (name arg ...) + chk ... + body ...)))] + + ;; Original: plain function def [(_ (name . params) body ...) (identifier? #'name) (let ([params-list (syntax->datum #'params)]) --- a/lib/jerboa/prelude.sls +++ b/lib/jerboa/prelude.sls @@ -116,7 +116,10 @@ ;; ---- FFI ---- c-lambda define-c-lambda - begin-ffi c-declare) + begin-ffi c-declare + + ;; ---- std/ergo ---- + using : as maybe list-of?) (import (except (chezscheme) @@ -157,6 +160,7 @@ (std misc string) (std misc list) (std misc alist) - (std misc ports)) + (std misc ports) + (std ergo)) ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/ergo.sls @@ -0,0 +1,141 @@ +#!chezscheme +;;; (std ergo) — Ergonomic typing layer +;;; +;;; Gerbil-inspired type annotations with minimal friction. +;;; +;;; Type cast: +;;; (: expr type) — checked cast (raises in debug mode if wrong type) +;;; +;;; Typed scopes with dot-access: +;;; (using (var expr : type) var.field ...) — checked type + dot-access +;;; (using (var expr as type) var.field ...) — unchecked, dot-access only +;;; (using ((v1 e1 : t1) (v2 e2 as t2)) ...) — multiple bindings +;;; +;;; Contract predicates: +;;; (maybe pred) — returns predicate: #f or satisfies pred +;;; (list-of? pred) — returns predicate: list where all elements satisfy pred + +(library (std ergo) + (export using : maybe list-of?) + (import (chezscheme) + (std typed)) + + ;; ========== Type Cast ========== + + ;; (: expr type) — checked cast, raises on failure in debug mode + (define-syntax : + (lambda (stx) + (syntax-case stx () + [(kw expr type-name) + (identifier? #'type-name) + #'(let ([v expr]) + (check-type! ': 'expr v 'type-name) + v)]))) + + ;; ========== Contract Predicates ========== + + (define (maybe pred) + (lambda (v) (or (not v) (pred v)))) + + (define (list-of? pred) + (lambda (v) (and (list? v) (for-all pred v)))) + + ;; ========== using Macro ========== + + (define-syntax using + (lambda (stx) + + ;; Find index of first #\. in a string, or #f + (define (dot-index str) + (let loop ([i 0]) + (cond + [(= i (string-length str)) #f] + [(char=? (string-ref str i) #\.) i] + [else (loop (+ i 1))]))) + + ;; Split "var.field" -> (values "var" "field"), or (values #f #f) + (define (split-dot str) + (let ([idx (dot-index str)]) + (if idx + (values (substring str 0 idx) + (substring str (+ idx 1) (string-length str))) + (values #f #f)))) + + ;; Check if a symbol contains a dot matching a var in var-map + (define (dotted-var? d var-map) + (and (symbol? d) + (let-values ([(prefix suffix) (split-dot (symbol->string d))]) + (and prefix suffix (assoc prefix var-map))))) + + ;; Walk syntax tree, replacing var.field with (type-field var). + ;; var-map: alist of (var-name-string . type-name-string) + ;; ctx: syntax object for lexical context + (define (transform s var-map ctx) + (let ([d (syntax->datum s)]) + (cond + [(dotted-var? d var-map) + (let-values ([(prefix suffix) (split-dot (symbol->string d))]) + (let* ([type-str (cdr (assoc prefix var-map))] + [accessor (string->symbol + (string-append type-str "-" suffix))] + [var (string->symbol prefix)]) + (datum->syntax ctx (list accessor var))))] + [(not (pair? d)) s] + [(eq? (car d) 'quote) s] + [else + (let ([lst (syntax->list s)]) + (if lst + (datum->syntax ctx + (map (lambda (x) + (syntax->datum (transform x var-map ctx))) + lst)) + s))]))) + + (define (make-var-entry var-stx type-stx) + (cons (symbol->string (syntax->datum var-stx)) + (symbol->string (syntax->datum type-stx)))) + + (define (transform-body body-stx var-map ctx) + (map (lambda (b) + (datum->syntax ctx (syntax->datum (transform b var-map ctx)))) + (syntax->list body-stx))) + + ;; Detect binding operator: : or as + (define (binding-op? stx) + (let ([d (syntax->datum stx)]) + (or (eq? d ':) (eq? d 'as)))) + + (define (checked-op? stx) + (eq? (syntax->datum stx) ':)) + + (syntax-case stx () + ;; Single binding: (using (var expr :/as type) body ...) + [(_ (var expr op type) body ...) + (and (identifier? #'var) + (identifier? #'type) + (binding-op? #'op)) + (let ([var-map (list (make-var-entry #'var #'type))]) + (with-syntax ([(tbody ...) (transform-body #'(body ...) var-map #'var)]) + (if (checked-op? #'op) + #'(let ([var expr]) + (check-type! 'using 'var var 'type) + tbody ...) + #'(let ([var expr]) + tbody ...))))] + + ;; Multiple bindings: expand into nested using + [(_ (first-binding rest-binding ...) body ...) + (let () + (syntax-case #'first-binding () + [(var expr op type) + (and (identifier? #'var) + (identifier? #'type) + (binding-op? #'op)) + #'(using (var expr op type) + (using (rest-binding ...) body ...))]))] + + ;; Base case: empty binding list + [(_ () body ...) + #'(begin body ...)]))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-ergo.ss @@ -0,0 +1,200 @@ +#!chezscheme +;;; Tests for (std ergo) — Ergonomic typing layer + +(import (chezscheme) (std typed) (std ergo) (jerboa core)) + +(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 ~a, expected ~a~%" name got expected)))))])) + +(define-syntax test-error + (syntax-rules () + [(_ name expr) + (test name + (guard (exn [#t #t]) + expr + #f) + #t)])) + +(printf "--- (std ergo) tests ---~%") + +;;; ========== : (checked cast) ========== + +(printf "~%-- : (checked cast) --~%") + +(parameterize ([*typed-mode* 'debug]) + (test ": fixnum pass" (: 42 fixnum) 42) + (test ": string pass" (: "hello" string) "hello") + (test-error ": fixnum fail" (: "oops" fixnum)) + (test-error ": string fail" (: 42 string))) + +(parameterize ([*typed-mode* 'release]) + (test ": release mode no check" (: "oops" fixnum) "oops")) + +;;; ========== maybe / list-of? ========== + +(printf "~%-- contract predicates --~%") + +(test "maybe: #f passes" ((maybe string?) #f) #t) +(test "maybe: string passes" ((maybe string?) "hi") #t) +(test "maybe: fixnum fails" ((maybe string?) 42) #f) + +(test "list-of?: empty" ((list-of? fixnum?) '()) #t) +(test "list-of?: valid" ((list-of? fixnum?) '(1 2 3)) #t) +(test "list-of?: invalid" ((list-of? fixnum?) '(1 "x" 3)) #f) +(test "list-of?: not list" ((list-of? fixnum?) 42) #f) + +;;; ========== using with : ========== + +(printf "~%-- using (checked) --~%") + +(defstruct point (x y)) + +(parameterize ([*typed-mode* 'debug]) + ;; Basic dot-access + (test "using : dot-access x" + (using (p (make-point 10 20) : point) + p.x) + 10) + + (test "using : dot-access y" + (using (p (make-point 10 20) : point) + p.y) + 20) + + ;; Dot-access in expressions + (test "using : dot in expr" + (using (p (make-point 3 4) : point) + (+ p.x p.y)) + 7) + + ;; Dot-access in nested forms + (test "using : dot in if" + (using (p (make-point 5 0) : point) + (if (> p.x 0) p.y -1)) + 0) + + ;; Type check in debug mode + (test-error "using : type check fails" + (using (p "not a point" : point) + p.x))) + +;;; ========== using with as (unchecked) ========== + +(printf "~%-- using (unchecked) --~%") + +;; Unchecked: no type check, but dot-access works +(test "using as: dot-access" + (using (p (make-point 7 8) as point) + (+ p.x p.y)) + 15) + +;; No type check even in debug mode +(parameterize ([*typed-mode* 'debug]) + (test "using as: no type check" + (using (p "not-a-point" as point) + 42) + 42)) + +;;; ========== using multiple bindings ========== + +(printf "~%-- using (multiple bindings) --~%") + +(defstruct rect (w h)) + +(test "using: two bindings" + (using ((p (make-point 1 2) : point) + (r (make-rect 10 20) : rect)) + (+ p.x r.w)) + 11) + +(test "using: mixed checked/unchecked" + (using ((p (make-point 3 4) : point) + (r (make-rect 5 6) as rect)) + (* p.y r.h)) + 24) + +;;; ========== using: quoted symbols not transformed ========== + +(printf "~%-- using: quotes preserved --~%") + +(test "using: quote not transformed" + (using (p (make-point 1 2) : point) + 'p.x) + 'p.x) + +;;; ========== def with typed params ========== + +(printf "~%-- def with typed params --~%") + +;; Basic typed def +(def (add-fx (x : fixnum) (y : fixnum)) + (fx+ x y)) + +(parameterize ([*typed-mode* 'debug]) + (test "def typed: basic" (add-fx 3 4) 7) + (test-error "def typed: arg type error" + (add-fx "bad" 4))) + +;; Typed def with return type +(def (greet (name : string)) : string + (string-append "hello " name)) + +(parameterize ([*typed-mode* 'debug]) + (test "def typed: return type" (greet "world") "hello world")) + +;; Return type error +(def (bad-ret (x : fixnum)) : string + x) + +(parameterize ([*typed-mode* 'debug]) + (test-error "def typed: return type error" + (bad-ret 42))) + +;; Mixed typed and untyped params +(def (mixed (x : fixnum) y) + (list x y)) + +(parameterize ([*typed-mode* 'debug]) + (test "def typed: mixed" (mixed 1 "two") '(1 "two")) + (test-error "def typed: mixed type error" + (mixed "bad" "two"))) + +;;; ========== def backward compat ========== + +(printf "~%-- def backward compat --~%") + +;; Plain def still works +(def (plain-add x y) (+ x y)) +(test "def plain" (plain-add 3 4) 7) + +;; Optional args still work +(def (with-default x (y 10)) (+ x y)) +(test "def optional: both" (with-default 1 2) 3) +(test "def optional: default" (with-default 5) 15) + +;; Variable def +(def my-val 42) +(test "def value" my-val 42) + +;; Void def +(def my-void) +(test "def void" my-void (void)) + +;;; ========== Summary ========== + +(printf "~%~a tests, ~a passed, ~a failed~%" (+ pass fail) pass fail) +(when (> fail 0) (exit 1))