init and finalizers + documentation

2025-07-09 15:16:06 +02:00
parent 887b2345d3
commit 6ee8a563d1
2 changed files with 252 additions and 62 deletions
--- 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 @->
--- 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.