More sophisticated

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 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)])
+    (if (pair? obj)
-      (-> obj @roos-object?@)))
+        (eq? (car 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@)
         #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)))
+      ;((_ self supers ((a)))
-       (hash-set! self '@supers@ (list (a))))
+      ; (hash-set! self '@supers@ (list (a))))
-      ((_ self supers ((a b ...)))
+      ;((_ self supers ((a b ...)))
-       (hash-set! self '@supers@ (list (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))
+              (roos-find (-> (car supers) @roos@) (cdr supers) f-name))
-          (apply f args))))
+          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)
+      ((_ supers @roos@ @super-starter@)
-       (define supers (lambda (f-name . args)
+       (define supers (cons 'roos-object (lambda (f-name . args)
-                        (roos-call @super-starter@ (hash-ref @roos@ '@supers@) 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))
+         (hash-set! @roos@ '@roos-id@ (new-id))
-         (define @super-starter@ (make-hash))
+         (hash-set! @roos@ '@set-roos-id@ (lambda (id)
-         (define self (lambda (f-name . args)
+                                            (hash-set! @roos@ '@roos-id@ id)))
-                        (roos-call @roos@ (hash-ref @roos@ '@supers@) f-name args)))
+         (define self (cons 'roos-object
-         (roos-supers-def supers @roos@ @super-starter@ super-invokes)
+                            (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)
+         (hash-set! @roos@ '@get-method@ (lambda (f-name)
-         (roos-def @roos@ b)
+                                           (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 @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)
+       (define a 
-         (roos1 (at ...) self (supers ...) b ...)
+         (cons 'roos-class
+               (lambda arg
+                 (@@roos-level2 (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))))))
+                         (apply (@roos-caller at ...) arg)))))))
       ((_ (a . bb) (at ... . atb) self (supers ...) b ...)
-       (define (a . arg)
+       (define a
-         (roos1 (at ... . atb) self (supers ...) b ...)
+         (cons 'roos-class
+               (lambda arg
+                 (@@roos-level2 (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))))))
+                         (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))
+   (def-roos (t1) this (supers) (a 10))
-   (let ((obj (t1)))
+   (let ((obj (-* t1)))
      (check-true (= (-> obj a) 10))
      (-> obj a! 12)
      (check-true (= (-> obj a) 12)))
@@ -194,10 +356,10 @@
   
   (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)
@@ -205,7 +367,7 @@
              (begin
                (-> supers y! (car a))
                (-> supers y)))))
-   (let ((bb (b)))
+  (let ((bb (roos-new b)))
      (check-true (= (-> bb y) 55))
      (check-true (= (-> bb g 2) 110))
      (check-true (= (-> bb v) 6))