From 7c627036b40a67550bde1d19835f67d921b22994 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Sun, 6 Jul 2025 15:59:19 +0200 Subject: [PATCH] More sophisticated --- main.rkt | 320 +++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 241 insertions(+), 79 deletions(-) diff --git a/main.rkt b/main.rkt index e866ea1..d5d0d37 100644 --- a/main.rkt +++ b/main.rkt @@ -1,32 +1,157 @@ -#lang racket/base +#lang racket - (require racket/syntax) - (provide roos -> roos-object? roos-class roos-class? roos-classname) +(require racket/syntax) +(require uuid) + +(provide def-roos + -* + -> + ->> + roos-object? + roos-obj? + roos-class + roos-class? + roos-classname + with-roos-obj + roos-id + roos-id! + roos-drop! + roos-storage! + roos-members + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Persistance helpers +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define @storage@ (make-hash)) + +(define (cache-get id symbol) + (let ((h (hash-ref @storage@ id))) + (hash-ref h symbol))) + +(define (cache-set! id symbol val) + (let ((h (hash-ref @storage@ id (make-hash)))) + (hash-set! h symbol val) + (hash-set! @storage@ id h))) + +(define (cache-del! id) + (hash-remove! @storage@ id)) + +(define (roos-storage! fn-cache-get fn-cache-set! fn-cache-del!) + (set! cache-get fn-cache-get) + (set! cache-set! fn-cache-set!) + (set! cache-del! fn-cache-del!)) + +(define (new-id) + (string->symbol (string-append "roos-" (uuid-string)))) + +(define (roos-id obj) + (->> obj @roos-id@)) + +(define (roos-id! obj id) + (-> obj @set-roos-id@ id)) + +(define (roos-drop! obj) + (let ((id (roos-id obj))) + (cache-del! id))) + + + (define (roos-class? cl) + (if (pair? cl) + (eq? (car cl) 'roos-class) + #f)) (define (roos-object? obj) - (with-handlers ([exn:fail? (lambda (exn) #f)]) - (-> obj @roos-object?@))) - - (define (roos-classname obj) - (if (roos-object? obj) - (-> obj @roos-classname@) - (if (roos-class? obj) - (obj '@roos-classname@) - #f))) - - (define (roos-class obj) - (if (roos-object? obj) - (-> obj @roos-class@) + (if (pair? obj) + (eq? (car obj) 'roos-object) #f)) + (define roos-obj? roos-object?) + + (define (roos-classname cl-obj) + (if (roos-object? cl-obj) + (-> cl-obj @roos-classname@) + (if (roos-class? cl-obj) + ((cdr cl-obj) '@roos-classname@) + (error "This is not a roos object or class")))) + + (define (roos-class cl-obj) + (if (roos-object? cl-obj) + (cons 'roos-class (-> cl-obj @roos-class@)) + (if (roos-class? cl-obj) + cl-obj + (error "This is not a roos object or class")))) + + (define (roos-members cl-obj) + (if (roos-object? cl-obj) + (-> cl-obj @roos-members@) + (if (roos-class? cl-obj) + ((cdr cl-obj) '@roos-members@) + (error "This is not a roos object or class")))) + + (define (-* . args) + (if (null? args) + (error "This is not a roos class") + (let ((cl (car args))) + (if (roos-class? cl) + (begin + ;(display cl)(display (cdr args))(newline) + (apply (cdr cl) (cdr args))) + (error "This is not a roos class"))))) + + (define roos-new -*) + + ;(define-syntax roos-new + ; (syntax-rules () + ; ((_ cl ...) + ; (-* cl ...)))) + + ;(define-syntax -* + ; (syntax-rules () + ; ((_ cl) + ; (if (roos-class? cl) + ; ((cdr cl)) + ; (error "This is not a roos class"))) + ; ((_ cl a ...) + ; (if (roos-class? cl) + ; ((cdr cl) a ...) + ; (error "This is not a roos class"))))) + + (define-syntax -> (syntax-rules () ((_ obj method) - (obj 'method)) + (if (roos-object? obj) + ((cdr obj) 'method) + (error "This is not a roos object"))) ((_ obj method arg ...) - (obj 'method arg ...)))) + (if (roos-object? obj) + (begin + ((cdr obj) 'method arg ...)) + (error "This is not a roos object"))))) - (define-syntax roos-def + (define-syntax ->> + (syntax-rules () + ((_ obj method) + (if (roos-object? obj) + (-> (cdr obj) @get-method@ 'method) + (error "This is not a roos object"))))) + + + (define-syntax with-roos-obj + (syntax-rules () + ((_ obj (m1 ...) + expr ...) + (if (roos-object? obj) + (let ((m1 (->> obj m1)) + ...) + expr + ...) + (error (format "~a: not a roos object" obj)))))) + + + (define-syntax @@roos-def (syntax-rules () ((_ h ((a) expr ...)) (begin @@ -57,16 +182,23 @@ (define a b) (hash-set! h 'a (lambda () a)) (hash-set! h (string->symbol (format "~a!" 'a)) (lambda (v) (set! a v))))) + ((_ h (p a b)) + (begin + (cache-set! (hash-ref h '@roos-id@) 'a b) + (if (not (eq? 'p 'persist)) (error (format "Keyword 'persist' expected for attribute ~a" 'a)) #t) + (hash-set! h 'a (lambda () (cache-get (hash-ref h '@roos-id@) 'a))) + (hash-set! h (string->symbol (format "~a!" 'a)) (lambda (v) (cache-set! (hash-ref h '@roos-id@) 'a v))))) )) + (define-syntax roos-supers (syntax-rules () ((_ self supers ()) (hash-set! self '@supers@ (list))) - ((_ self supers ((a))) - (hash-set! self '@supers@ (list (a)))) - ((_ self supers ((a b ...))) - (hash-set! self '@supers@ (list (a b ...)))) + ;((_ self supers ((a))) + ; (hash-set! self '@supers@ (list (a)))) + ;((_ self supers ((a b ...))) + ; (hash-set! self '@supers@ (list (a b ...)))) ((_ self supers (x y ...)) (hash-set! self '@supers@ (list x y ...))) )) @@ -76,43 +208,78 @@ ((_ name msg) (error (format "~a: ~a" name msg))))) - (define (roos-call hash supers f-name args) + (define (roos-find hash supers f-name) + ;(display hash)(display supers)(newline) (let ((f (hash-ref hash f-name '@roos-undefined@))) (if (eq? f '@roos-undefined@) (if (null? supers) (roos-err f-name "Method or Attribute not defined") - (roos-call ((car supers) '@roos@) (cdr supers) f-name args)) - (apply f args)))) + (roos-find (-> (car supers) @roos@) (cdr supers) f-name)) + f))) + + (define (roos-call hash supers f-name args) + (apply (roos-find hash supers f-name) args)) (define-syntax roos-supers-def (syntax-rules () - ((_ supers @roos@ @super-starter@ invokes) - (define supers (lambda (f-name . args) - (roos-call @super-starter@ (hash-ref @roos@ '@supers@) f-name args)))))) + ((_ supers @roos@ @super-starter@) + (define supers (cons 'roos-object (lambda (f-name . args) + (roos-call @super-starter@ (hash-ref @roos@ '@supers@) f-name args))))))) - (define-syntax roos-body + (define-syntax init-roos-body (syntax-rules () - ((_ class classname self (supers . super-invokes) b ...) + ((_ @roos@ class classname self supers) (begin - (define @roos@ (make-hash)) - (define @super-starter@ (make-hash)) - (define self (lambda (f-name . args) - (roos-call @roos@ (hash-ref @roos@ '@supers@) f-name args))) - (roos-supers-def supers @roos@ @super-starter@ super-invokes) + (hash-set! @roos@ '@roos-id@ (new-id)) + (hash-set! @roos@ '@set-roos-id@ (lambda (id) + (hash-set! @roos@ '@roos-id@ id))) + (define self (cons 'roos-object + (lambda (f-name . args) + (roos-call @roos@ (hash-ref @roos@ '@supers@) f-name args)))) + (define supers (cons 'roos-object + (lambda (f-name . args) + (roos-call (make-hash) (hash-ref @roos@ '@supers@) f-name args)))) (hash-set! @roos@ '@roos@ (lambda () @roos@)) + ;(hash-set! @roos@ '@supers@ '()) + (hash-set! @roos@ '@set-supers@ (lambda (s) (hash-set! @roos@ '@supers@ s))) (hash-set! @roos@ '@set-self@ (lambda (derived-self) (set! self derived-self) (for-each (lambda (super) - (super '@set-self@ self)) + (-> super @set-self@ self)) (hash-ref @roos@ '@supers@)))) (hash-set! @roos@ '@roos-classname@ (lambda () classname)) (hash-set! @roos@ '@roos-class@ (lambda () class)) (hash-set! @roos@ '@roos-object?@ (lambda () #t)) - (roos-supers @roos@ supers super-invokes) - (roos-def @roos@ b) + (hash-set! @roos@ '@get-method@ (lambda (f-name) + (roos-find @roos@ (hash-ref @roos@ '@supers@) f-name))))) + )) + + (define-syntax roos-body + (syntax-rules (s) + ((_ class classname self (supers) b ...) + (begin + (define @roos@ (make-hash)) + (hash-set! @roos@ '@supers@ '()) + (init-roos-body @roos@ class classname self supers) + (@@roos-def @roos@ b) ... - (self '@set-self@ self) - self)))) + (-> self @set-self@ self) + self)) + ((_ class classname self (supers super-invokes ...) b ...) + (let* ((s (list super-invokes ...)) + (obj + (begin + (let ((@roos@ (make-hash))) + (hash-set! @roos@ '@supers@ s) + (init-roos-body @roos@ class classname self supers) + (@@roos-def @roos@ b) + ... + (-> self @set-self@ self) + self)))) + ;(display "Setting supers to ")(display (list super-invokes ...))(newline) + ;(-> obj @set-supers@ (list super-invokes ...)) + obj)) + )) (define-syntax @roos-classname (syntax-rules () @@ -124,7 +291,7 @@ ((_ a . b) a))) - (define-syntax roos1 + (define-syntax @@roos-level2 (syntax-rules () ((_ (a ...) self (supers ...) b ...) (begin @@ -142,51 +309,46 @@ ((_ a . b) a))) - (define-syntax @roos-top + (define-syntax @@roos-top (syntax-rules () ((_ (a . bb) (at ...) self (supers ...) b ...) - (define (a . arg) - (roos1 (at ...) self (supers ...) b ...) - (if (null? arg) - (a) - (if (eq? (car arg) '@roos-class?) - '@is-a-roos-class - (if (eq? (car arg) '@roos-classname@) - (@roos-classname at ...) - (apply (@roos-caller at ...) arg)))))) + (define a + (cons 'roos-class + (lambda arg + (@@roos-level2 (at ...) self (supers ...) b ...) + (if (null? arg) + (a) + (if (eq? (car arg) '@roos-classname@) + (@roos-classname at ...) + (apply (@roos-caller at ...) arg))))))) ((_ (a . bb) (at ... . atb) self (supers ...) b ...) - (define (a . arg) - (roos1 (at ... . atb) self (supers ...) b ...) - (if (null? arg) - (a) - (if (eq? (car arg) '@roos-class?) - '@is-a-roos-class - (if (eq? (car arg) '@roos-classname@) - (@roos-classname at ... . atb) - (apply (@roos-caller at ... . atb) arg)))))) + (define a + (cons 'roos-class + (lambda arg + (@@roos-level2 (at ... . atb) self (supers ...) b ...) + (if (null? arg) + (a) + (if (eq? (car arg) '@roos-classname@) + (@roos-classname at ... . atb) + (apply (@roos-caller at ... . atb) arg))))))) )) - (define-syntax roos + (define-syntax def-roos (syntax-rules () ((_ (a ...) self (supers ...) b ...) - (@roos-top (a ...) (a ...) self (supers ...) b ...)) + (@@roos-top (a ...) (a ...) self (supers ...) b ...)) ((_ (a ... . b) self (supers ...) c ...) - (@roos-top (a ... . b) (a ... . b) self (supers ...) c ...)) + (@@roos-top (a ... . b) (a ... . b) self (supers ...) c ...)) )) - - (define (roos-class? cl) - (with-handlers ([exn:fail? (lambda (exn) #f)]) - (eq? (cl '@roos-class?) '@is-a-roos-class))) - (module+ test (require rackunit) (test-case "Simple ROOS declaration and usage" - (roos (t1) this (supers) (a 10)) - (let ((obj (t1))) + (def-roos (t1) this (supers) (a 10)) + (let ((obj (-* t1))) (check-true (= (-> obj a) 10)) (-> obj a! 12) (check-true (= (-> obj a) 12))) @@ -194,18 +356,18 @@ (test-case "ROOS declaration with supers" - (roos (a x) this (supers) + (def-roos (a x) this (supers) (y (+ x 4)) ((g a) (* a (-> this y)))) - (roos (b) this (supers (a 2)) + (def-roos (b) this (supers (roos-new a 2)) (y 55) ((v . a) - (if (null? a) - (-> supers y) - (begin - (-> supers y! (car a)) - (-> supers y))))) - (let ((bb (b))) + (if (null? a) + (-> supers y) + (begin + (-> supers y! (car a)) + (-> supers y))))) + (let ((bb (roos-new b))) (check-true (= (-> bb y) 55)) (check-true (= (-> bb g 2) 110)) (check-true (= (-> bb v) 6))