init and finalizers + documentation

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)
+(define-syntax @@finalize
-  (syntax-case stx ()
+  (syntax-rules ()
-    ((_ this body ...)
+    ((_ this (body ...))
-    (if (@@has-persist (cddr (syntax->datum stx)) 0)
+     (let ((has-persist (@@has-persist '(body ...) 0)))
-        #'(register-finalizer this (lambda (obj) (@@cache-delete! obj)))
+       (if has-persist
-        #'#t))
+           (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 @->

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 (name ""))
-  (persist "Phone" (phone "")))
+  (persist (tel "")))
 
-(def-roos (addressbook) this (supers)
-  (persist "Person IDs" (ids (vector)))
-  (persons (vector))
 
-  ((init)
+(def-roos (book) this (supers)
-   (let ((restored (vector-map
+  (persist (ids (list)))
-                    (lambda (id)
+  (persist (name ""))
-                      (let ((p (-! person)))
+  ("" (persons (make-vector 0)))
-                        (roos-id! p id)
-                        p))
-                    (-> this ids))))
-     (set! persons restored)))
 
-  ((add-person p)
+  ((add p)
-   (let ((new-persons (vector-append persons (vector p))))
+   (set! persons (vector-extend persons (+ (vector-length persons) 1) p))
-     (set! persons new-persons)
+   (-> this ids! (vector->list (vector-map (lambda (o) (-> o roos-id)) persons))))
-     (-> this ids! (vector-map roos-id new-persons))))
 
-  ((insert-person-at i p)
+  ((remove i)
-   (let* ((before (subvector persons 0 i))
+   (set! persons (vector-append (vector-take persons i) (vector-drop persons (+ i 1))))
-          (after (subvector persons i (vector-length persons)))
+   (-> this ids! (vector->list
-          (new-persons (vector-append before (vector p) after)))
+                    (vector-map (lambda (o) (-> o roos-id)) persons))))
-     (set! persons new-persons)
-     (-> this ids! (vector-map roos-id new-persons))))
 
-  ((remove-person-at i)
+  ((for-each f) 
-   (let* ((before (subvector persons 0 i))
+   (letrec ((g (lambda (i n)
-          (after (subvector persons (add1 i) (vector-length persons)))
+                 (when (< i n)
-          (new-persons (vector-append before after)))
+                   (f (vector-ref persons i))
-     (set! persons new-persons)
+                   (g (+ i 1) n)))))
-     (-> this ids! (vector-map roos-id new-persons))))
+     (g 0 (vector-length persons))))
-
-  ((all-names)
-   (vector->list (vector-map (lambda (p) (-> p name)) 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))
+(define b (-! book))
-(roos-id! ab 'addressbook-id)
 
-(define alice (-! person))
+(define (adder n t)
-(-> alice name! "Alice")
+  (let ((p (-! person)))
-(-> alice phone! "123")
+    (-> p name! n)
-(-> ab add-person alice)
+    (-> p tel! t)
+    (-> b add p)))
 
-(define bob (-! person))
+(adder "Alice" "123")
-(-> bob name! "Bob")
+(adder "Bob" "456")
-(-> bob phone! "456")
+(adder "Jos" "982")
-(-> ab add-person bob)
+(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))
+(define a (-! book)
-(roos-id! ab2 'addressbook-id)
+(-> b (for-each (lambda (p) (displayln (-> p name)))))
-(-> ab2 all-names) ; => '("Alice" "Bob")
+  
 ]
 
 @bold{Note:} call @racket[(roos-storage-stop-deleting! #t)] before shutdown to prevent finalizers from purging storage content.