From 6ee8a563d1b4d89004310c99cbeba5b401de9b4e Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Wed, 9 Jul 2025 15:16:06 +0200 Subject: [PATCH] init and finalizers + documentation --- main.rkt | 118 +++++++++++++++++++++---- scribblings/roos.scrbl | 196 +++++++++++++++++++++++++++++++---------- 2 files changed, 252 insertions(+), 62 deletions(-) diff --git a/main.rkt b/main.rkt index bce11d3..57040ea 100644 --- a/main.rkt +++ b/main.rkt @@ -136,7 +136,7 @@ )) )) -(define-syntax @@mk-member-info +(define-syntax @@mk-member-info* (syntax-rules () ((_ ((f) expr ...)) (list (@@mk-name f) (@@mk-lit (f)) "")) @@ -162,6 +162,24 @@ (list 'a 'a "")) )) +(define-syntax (@@mk-member-info stx) + (syntax-case stx () + ((_ (keyw)) + (let ((kw (syntax->datum #'keyw))) + (if (or (eq? kw 'init) + (eq? kw 'finalize)) + #'(list 'keyw 'keyw (format "has empty '~a'" 'keyw)) + #'(@@mk-member-info* keyw)))) + ((_ (keyw b1 ...)) + (let ((kw (syntax->datum #'keyw))) + (if (or (eq? kw 'init) + (eq? kw 'finalize)) + #'(list 'keyw 'keyw (format "has defined '~a'" 'keyw)) + #'(@@mk-member-info* (keyw b1 ...))))) + ((_ x) + #'(@@mk-member-info* x)) + )) + (define-syntax @@mk-member-infos (syntax-rules () ((_ b1 ...) @@ -334,7 +352,7 @@ ))] )) -(define-syntax @@mk-body +(define-syntax @@mk-body* (syntax-rules () ((_ this supers (doc ((f) expr ...))) (@@mk-doc-method this supers (doc ((f) expr ...)))) @@ -360,6 +378,36 @@ (@@mk-persist this supers (a b))) )) +(define-syntax (@@mk-keyw stx) + (syntax-case stx () + ((_ this keyw) + (begin + (printf "mk-keyw: ~a" (syntax->datum #'keyw)) + #'(hash-set! this 'init (lambda () #f)))) + ((_ this keyw body ...) + (begin + (printf "mk-keyw: ~a" (syntax->datum #'keyw)) + #'(hash-set! this 'init (lambda () body ...)))) + )) + +(define-syntax (@@mk-body stx) + (syntax-case stx () + ((_ this supers (keyw)) + (let ((kw (syntax->datum #'keyw))) + (if (or (eq? kw 'init) + (eq? kw 'finalize)) + #'(@@mk-keyw this keyw) + #'(@@mk-body* this supers (keyw))))) + ((_ this supers (keyw a ...)) + (let ((kw (syntax->datum #'keyw))) + (if (or (eq? kw 'init) + (eq? kw 'finalize)) + #'(@@mk-keyw this keyw a ...) + #'(@@mk-body* this supers (keyw a ...))))) + ((_ this supers any) + #'(@@mk-body* this supers any)) + )) + (define-syntax @@mk-bodies (syntax-rules () ((_ this supers (b1 ...)) @@ -410,7 +458,7 @@ (@@guard-this this) (@@guard-supers supers))))) -(define-for-syntax (@@has-persist syntax count) +(define (@@has-persist syntax count) ;(display "has-persist ")(display count)(display " ")(display syntax)(newline) (if (null? syntax) #f @@ -424,12 +472,25 @@ (@@has-persist (cdr syntax) (+ count 1)))))) -(define-syntax (@@finalize stx) - (syntax-case stx () - ((_ this body ...) - (if (@@has-persist (cddr (syntax->datum stx)) 0) - #'(register-finalizer this (lambda (obj) (@@cache-delete! obj))) - #'#t)) +(define-syntax @@finalize + (syntax-rules () + ((_ this (body ...)) + (let ((has-persist (@@has-persist '(body ...) 0))) + (if has-persist + (let ((our-finalizer (hash-ref (roos-object*-this this) 'finalize))) + (when (not our-finalizer) + (set! our-finalizer (lambda () #t))) + (hash-set! (roos-object*-this this) 'finalize 'finalizer-registered) + (register-finalizer this + (lambda (obj) + ; First call our own finalizer + (our-finalizer) + ; Next delete from storage + (@@cache-delete! obj)))) + (let ((f (hash-ref (roos-object*-this this) 'finalize))) + (unless (eq? f #f) + (register-finalizer this (lambda (obj) (f))))))) + ) )) @@ -441,6 +502,8 @@ (begin (@@check-keywords this supers ...) (define this (make-hasheq)) + + (hash-set! this 'finalize #f) (@@mk-body this (supers ...) (roos-id (@@new-id))) @@ -457,7 +520,7 @@ (let ((ff (@@find-func f (list this)))) (if ff (apply ff args) - (error "No such member")))) + (error (format "~a: ~a - no such member." (roos-object*-classname this) f))))) (set! this (roos-object* this @@ -468,7 +531,10 @@ @caller@)) (@set-caller@ @caller@) - (@@finalize this body ...) + (@@finalize this (body ...)) + + (unless (eq? (hash-ref (roos-object*-this this) 'init #f) #f) + ((hash-ref (roos-object*-this this) 'init))) this ) @@ -517,7 +583,22 @@ (@@mk-member-infos body ...) (@@mk-super-infos supers ...) (cl a ... . b))))) - + ((_ cl this supers body ...) + (error (string-append + "Wrong roos definition\n" + "Define roos classes as follows:\n\n" + "(def-roos (cl ...) this (supers ...)\n" + " (attr value)\n" + " (persist (attr value))\n" + " (\"documentation\" (attr value))\n" + " (persist \"documentation\" (attr value))\n" + "\n" + " ((method ...) body ...)\n" + " (\"documentation\" ((method ...) body ...))\n" + "\n" + " (init expr ...) ; optional initializer\n" + " (finalize expr ...) ; optional finalizer\n" + ")\n"))) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -575,7 +656,10 @@ (let ((f (@@find-func 'f obj))) (if f f - (error "No such member"))) + (error (format "~a: ~a - no such member" + (roos-object*-classname obj) + 'f + )))) (error "Not a list of roos objects (supers)")))) (error "Not a roos object"))))) @@ -600,12 +684,16 @@ (let ((f (@@find-func name (list obj)))) (if f f - (error "No such member"))) + (error (format "~a: ~a - no such member" + (roos-object*-classname obj) + name)))) (if (@@is-supers? obj) (let ((f (@@find-func name obj))) (if f f - (error "No such member"))) + (error (format "~a: ~a - no such member" + (roos-object*-classname obj) + name)))) (error "Not a roos object of roos supers")))) (define-syntax @-> diff --git a/scribblings/roos.scrbl b/scribblings/roos.scrbl index 746dd8a..0ccfb55 100644 --- a/scribblings/roos.scrbl +++ b/scribblings/roos.scrbl @@ -33,7 +33,8 @@ Each body entry may be: @item{Documented attribute: @racket[("Doc" (attr val))] — adds inline documentation to attribute.} @item{Method: @racket[((method args ...) expr ...)] — defines a public method.} @item{Documented method: @racket[("Doc" ((method args ...) expr ...))] — with documentation.} - @item{Reserved method: @racket[init] and @racket[finalize] are automatically called at creation and finalization.} + @item{Optional: you may define @racket[(init expr ...)] to run code immediately after object construction.} + @item{Optional: you may define @racket[(finalize expr ...)] to run cleanup logic when object is collected.} ] Methods and fields are always virtual. Superclass definitions are resolved based on declared order. Multiple inheritance is supported and left-to-right linearized. @@ -56,6 +57,37 @@ Methods and fields are always virtual. Superclass definitions are resolved based @item{@racket[(roos-id! obj id)] — set object's ID (used in persistence).} ] +@subsubsection{@racket[(-> obj field)]} +Call the getter for the attribute named @racket[field] in the object @racket[obj]. + +@subsubsection{@racket[(-> obj field! val)]} +Call the setter for the attribute named @racket[field], assigning it the value @racket[val]. + +@subsubsection{@racket[(-> obj method args ...)]} +Invoke the method named @racket[method] on @racket[obj] with the provided arguments. + +@subsubsection{@racket[(->> obj name)]} +Retrieve the procedure representing a method or accessor named @racket[name] from @racket[obj]. Useful for higher-order functions. + +@subsubsection{@racket[(roos-object? x)]} +Returns @racket[#t] if @racket[x] is an instance of a ROOS object, @racket[#f] otherwise. + +@subsubsection{@racket[(roos-class? x)]} +Returns @racket[#t] if @racket[x] is a valid ROOS class definition. + +@subsubsection{@racket[(roos-classname obj)]} +Returns the symbolic class name of the object @racket[obj]. + +@subsubsection{@racket[(roos-class obj)]} +Returns the class definition from which @racket[obj] was instantiated. + +@subsubsection{@racket[(roos-id obj)]} +Returns the unique persistent ID of @racket[obj]. Used for persistence resolution. + +@subsubsection{@racket[(roos-id! obj id)]} +Assigns a persistent identifier to @racket[obj]. Required when restoring from storage with known identifiers. + + @section{Persistence and Storage Backend} ROOS lets you persist selected attributes by tagging them with @racket[persist]. Persistence is handled by user-provided backends through: @@ -75,70 +107,140 @@ Each function takes a ROOS object and field name: See the full SQLite example in the next section. +@subsection{Example of persistence backend for roos} + +Below is an example SQLite backend implementation that stores fields in a table: + +@racketblock[ +(require db) +(require racket/vector) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Conversion of field values +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (value->string s-expr) + (let ((o (open-output-string))) + (write s-expr o) + (get-output-string o))) + +(define (string->value str) + (let ((o (open-input-string str))) + (read o))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Database storage backend +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define conn (sqlite3-connect #:database "roos.db" #:mode 'create)) +(query-exec conn "CREATE TABLE IF NOT EXISTS store (class TEXT, id TEXT, field TEXT, val TEXT)") + +(define stop-deleting? #f) +(define (stop-deleting-fn flag) (set! stop-deleting? flag)) + +(define (getter obj field default) + (let ((class (symbol-string (roos-classname obj))) + (id (symbol->string (roos-id obj))) + (field (symbol->string field))) + (let ((count (query-value conn + "SELECT count(*) FROM store WHERE class=? AND id=? AND field=?" + class id field))) + (if (= count 0) + default + (let ((row (query-row conn + "SELECT val FROM store WHERE class=? AND id=? AND field=?" + class id field))) + (if row + (string->value (vector-ref row 0)) + default)))))) + +(define (setter obj field val) + (let ((class (symbol->string (roos-classname obj))) + (id (symbol->string (roos-id obj))) + (fld (symbol->string field)) + (vstr (value->string val))) + (query-exec conn "DELETE FROM store WHERE class=? AND id=? AND field=?" class id fld) + (query-exec conn "INSERT INTO store (class, id, field, val) VALUES (?, ?, ?, ?)" class id fld vstr))) + +(define (deleter obj) + (unless stop-deleting? + (let ((class (symbol->string (roos-classname obj))) + (id (symbol->string (roos-id obj)))) + (query-exec conn "DELETE FROM store WHERE class=? AND id=?" class id)))) + +(roos-storage! getter setter deleter stop-deleting-fn) + +(plumber-add-flush! (current-plumber) + (lambda (x) + (printf "Collecting garbage to cleanup the storage for variables that have been cleared\n") + (collect-garbage))) +] + + @subsection{Address Book Example with Persistent Vector of Person IDs} This example builds an address book with persistent reference to persons, using ROOS' object ID mechanism. @racketblock[ +(require racket/vector) + (def-roos (person) this (supers) - (persist "Name" (name "")) - (persist "Phone" (phone ""))) + (persist (name "")) + (persist (tel ""))) -(def-roos (addressbook) this (supers) - (persist "Person IDs" (ids (vector))) - (persons (vector)) - ((init) - (let ((restored (vector-map - (lambda (id) - (let ((p (-! person))) - (roos-id! p id) - p)) - (-> this ids)))) - (set! persons restored))) +(def-roos (book) this (supers) + (persist (ids (list))) + (persist (name "")) + ("" (persons (make-vector 0))) - ((add-person p) - (let ((new-persons (vector-append persons (vector p)))) - (set! persons new-persons) - (-> this ids! (vector-map roos-id new-persons)))) + ((add p) + (set! persons (vector-extend persons (+ (vector-length persons) 1) p)) + (-> this ids! (vector->list (vector-map (lambda (o) (-> o roos-id)) persons)))) - ((insert-person-at i p) - (let* ((before (subvector persons 0 i)) - (after (subvector persons i (vector-length persons))) - (new-persons (vector-append before (vector p) after))) - (set! persons new-persons) - (-> this ids! (vector-map roos-id new-persons)))) + ((remove i) + (set! persons (vector-append (vector-take persons i) (vector-drop persons (+ i 1)))) + (-> this ids! (vector->list + (vector-map (lambda (o) (-> o roos-id)) persons)))) - ((remove-person-at i) - (let* ((before (subvector persons 0 i)) - (after (subvector persons (add1 i) (vector-length persons))) - (new-persons (vector-append before after))) - (set! persons new-persons) - (-> this ids! (vector-map roos-id new-persons)))) - - ((all-names) - (vector->list (vector-map (lambda (p) (-> p name)) persons)))) + ((for-each f) + (letrec ((g (lambda (i n) + (when (< i n) + (f (vector-ref persons i)) + (g (+ i 1) n))))) + (g 0 (vector-length persons)))) + (init (begin + (-> this roos-id! 'book) + (let ((ps (map (lambda (id) + (let ((p (roos-new person))) + (-> p roos-id! id) + p)) + (-> this ids)))) + (set! persons (list->vector ps))))) + ) + + ;; Create sample data -(define ab (-! addressbook)) -(roos-id! ab 'addressbook-id) +(define b (-! book)) -(define alice (-! person)) -(-> alice name! "Alice") -(-> alice phone! "123") -(-> ab add-person alice) +(define (adder n t) + (let ((p (-! person))) + (-> p name! n) + (-> p tel! t) + (-> b add p))) -(define bob (-! person)) -(-> bob name! "Bob") -(-> bob phone! "456") -(-> ab add-person bob) +(adder "Alice" "123") +(adder "Bob" "456") +(adder "Jos" "982") +(adder "Rebecca" "363") -(-> ab all-names) ; => '("Alice" "Bob") +(-> b (for-each (lambda (p) (displayln (-> p name))))) ;; Reopen addressbook later from persistent storage -(define ab2 (-! addressbook)) -(roos-id! ab2 'addressbook-id) -(-> ab2 all-names) ; => '("Alice" "Bob") +(define a (-! book) +(-> b (for-each (lambda (p) (displayln (-> p name))))) + ] @bold{Note:} call @racket[(roos-storage-stop-deleting! #t)] before shutdown to prevent finalizers from purging storage content.