modules/oop/pf-objects.scm

   1 (define-module (oop pf-objects)
   2   #:use-module (oop goops)
   3   #:use-module (ice-9 vlist)
   4   #:use-module (ice-9 match)
   5   #:export (set ref make-pf <p> <py> <pf> <pyf>
   6                 call with copy fset fcall make-p put put!
   7                 pcall pcall! get fset-x
   8                 def-pf-class  mk-pf-class  make-pf-class
   9                 def-p-class   mk-p-class   make-p-class
  10                 def-pyf-class mk-pyf-class make-pyf-class
  11                 def-py-class  mk-py-class  make-py-class
  12                 define-python-class get-type
  13                 ))
  14 #|
  15 Python object system is basically syntactic suger otop of a hashmap and one
  16 this project is inspired by the python object system and what it measn when
  17 one in stead of hasmaps use functional hashmaps. We use vhashes, but those have a drawback in that those are not thread safe. But it is a small effort to work
  18 with assocs or tree like functional hashmaps in stead.
  19
  20 The hashmap works like an assoc e.g. we will define new values by 'consing' a
  21 new binding on the list and when the assoc take up too much space it will be
  22 reshaped and all extra bindings will be removed.
  23
  24 The datastructure is functional but the objects mutate. So one need to
  25 explicitly tell it to not update etc.
  26 |#
  27
  28 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
  29 (define-class <p>  (<applicable-struct>) h)
  30 (define-class <pf> (<p>) size n)         ; the pf object consist of a functional
  31                                          ; hashmap it's size and number of live
  32                                          ; object
  33 (define-class <py>  (<p>))
  34 (define-class <pyf> (<pf>))
  35
  36 (define (mk x)
  37   (letrec ((o (make (ref x '__goops__))))
  38     (slot-set! o 'procedure
  39                (lambda x
  40                  (apply
  41                   (ref o '__call__ (lambda x (error "no __call__ method")))
  42                   x)))
  43     (cond
  44      ((is-a? x <pf>)
  45       (let ((r (ref x '__const__)))
  46         (slot-set! o 'h    (slot-ref r 'h))
  47         (slot-set! o 'size (slot-ref r 'size))
  48         (slot-set! o 'n    (slot-ref r 'n))
  49         o))
  50
  51      ((is-a? x <p>)
  52       (let ((r (ref x '__const__))
  53             (h (make-hash-table)))
  54         (hash-set! h '__class__ x)
  55         (slot-set! o 'h    h))
  56       o))))
  57
  58 (define (make-pyclass x)
  59   (letrec ((class (make x)))
  60     (slot-set! class 'procedure
  61                (lambda x
  62                  (let ((obj (mk class)))
  63                    (aif it (ref obj '__init__)
  64                         (apply it x)
  65                         (values))
  66                    obj)))
  67     class))
  68
  69 ;; Make an empty pf object
  70 (define (make-pf)
  71   (define r (make-pyclass <pf>))
  72   (slot-set! r 'h vlist-null)
  73   (slot-set! r 'size 0)
  74   (slot-set! r 'n 0)
  75   r)
  76
  77 (define (make-p)
  78   (define r (make-pyclass <p>))
  79   (slot-set! r 'h (make-hash-table))
  80   r)
  81
  82 (define-syntax-rule (hif it (k h) x y)
  83   (let ((a (vhash-assq k h)))
  84     (if (pair? a)
  85         (let ((it (cdr a)))
  86           x)
  87         y)))
  88
  89 (define-syntax-rule (cif (it h) (k cl) x y)
  90   (let* ((h (slot-ref cl 'h))
  91          (a (vhash-assq k h)))
  92     (if (pair? a)
  93         (let ((it (cdr a)))
  94           x)
  95         y)))
  96
  97 (define fail (cons 'fail '()))
  98 (define-syntax-rule (mrefx x key l)
  99   (let ()
 100     (define (end)
 101       (if (null? l)
 102           #f
 103           (car l)))
 104
 105     (define (parents li)
 106       (let lp ((li li))
 107         (if (pair? li)
 108             (let ((p (car li)))
 109               (cif (it h) (key p)
 110                    it
 111                    (hif it ('__parents__ h)
 112                         (let ((r (parents it)))
 113                           (if (eq? r fail)
 114                               (lp (cdr li))
 115                               r))
 116                         (lp (cdr li)))))
 117             fail)))
 118
 119     (cif (it h) (key x)
 120          it
 121          (hif cl ('__class__ h)
 122               (cif (it h) (key cl)
 123                    it
 124                    (hif p ('__parents__ h)
 125                         (let ((r (parents p)))
 126                           (if (eq? r fail)
 127                               (end)
 128                               r))
 129                         (end)))
 130               (end)))))
 131
 132 (define-syntax-rule (mrefx- x key l) (mrefx-- (slot-ref x 'h) key l))
 133 (define-syntax-rule (mrefx-- hi key l)
 134   (let ()
 135     (define (end)   (if (pair? l) (car l) #f))
 136     (define (ret q) (if (eq? q fail) (end) q))
 137
 138     (define (find-in-class h)
 139       (let lp ((class-h h))
 140         (let ((r (hash-ref class-h key fail)))
 141           (if (eq? r fail)
 142               (aif parents (hash-ref class-h '__parents__ #f)
 143                    (let lpp ((parents parents))
 144                      (if (pair? parents)
 145                          (let ((parent (car parents)))
 146                            (let ((r (lp (slot-ref parent 'h))))
 147                              (if (eq? r fail)
 148                                  (lpp (cdr parents))
 149                                  r)))
 150                          fail))
 151                    fail)
 152               r))))
 153
 154     (let* ((h hi)
 155            (r (hash-ref h key fail)))
 156       (if (eq? r fail)
 157           (aif class (hash-ref h '__class__)
 158                (ret (find-in-class (slot-ref class 'h)))
 159                (end))
 160           r))))
 161
 162 (define not-implemented (cons 'not 'implemeneted))
 163
 164 (define-syntax-rule (mrefx-py- x key l)
 165   (let ((f (mrefx- x '__ref__ '())))
 166     (if (or (not f) (eq? f not-implemented))
 167         (mrefx- x key l)
 168         (apply f x key l))))
 169
 170 (define-syntax-rule (mrefx-py x key l)
 171   (let ((f (mrefx x '__ref__ '())))
 172     (if (or (not f) (eq? f not-implemented))
 173         (mrefx    x key l)
 174         (apply f x key l))))
 175
 176 (define-syntax-rule (unx mrefx- mref-)
 177   (define-syntax-rule (mref- x key l)
 178     (let ((xx x))
 179       (let ((res (mrefx- xx key l)))
 180         (if (procedure? res)
 181             (lambda z
 182               (apply res xx z))
 183             res)))))
 184
 185 (unx mrefx-    mref-)
 186 (unx mrefx     mref)
 187 (unx mrefx-py  mref-py)
 188 (unx mrefx-py- mref-py-)
 189
 190 (define-method (ref (x <pf> )  key . l) (mref     x key l))
 191 (define-method (ref (x <p>  )  key . l) (mref-    x key l))
 192 (define-method (ref (x <pyf>)  key . l) (mref-py  x key l))
 193 (define-method (ref (x <py> )  key . l) (mref-py- x key l))
 194
 195 ;; the reshape function that will create a fresh new pf object with less size
 196 ;; this is an expensive operation and will only be done when we now there is
 197 ;; a lot to gain essentially tho complexity is as in the number of set
 198 (define (reshape x)
 199   (let ((h (slot-ref x 'h))
 200         (m (make-hash-table))
 201         (n 0))
 202     (define h2 (vhash-fold (lambda (k v s)
 203                              (if (hash-ref m k #f)
 204                                  s
 205                                  (begin
 206                                    (hash-set! m k #t)
 207                                    (set! n (+ n 1))
 208                                    (vhash-consq k v s))))
 209                            vlist-null
 210                            h))
 211     (slot-set! x 'h h2)
 212     (slot-set! x 'size n)
 213     (slot-set! x 'n    n)
 214     (values)))
 215
 216 ;; on object x add a binding that key -> val
 217 (define-syntax-rule (mset x key val)
 218   (let ((h (slot-ref x 'h))
 219         (s (slot-ref x 'size))
 220         (n (slot-ref x 'n)))
 221     (slot-set! x 'size (+ 1 s))
 222     (let ((r (vhash-assq key h)))
 223       (when (not r)
 224         (slot-set! x 'n (+ n 1)))
 225       (slot-set! x 'h (vhash-consq key val h))
 226       (when (> s (* 2 n))
 227         (reshape x))
 228       (values))))
 229
 230 (define-syntax-rule (mset-py x key val)
 231   (let ((f (mref-py x '__set__ '())))
 232     (if (or (eq? f not-implemented) (not f))
 233         (mset x key val)
 234         (f key val))))
 235
 236 (define (pkh h) (hash-for-each (lambda x (pk x)) h) h)
 237
 238 (define-syntax-rule (mset- x key val)
 239   (let ()
 240     (define (s h) (begin (hash-set! h key val) #f))
 241     (define fret #t)
 242     (define (r h k) (hash-ref h k))
 243     (define-syntax-rule (ifh h fail-code)
 244       (if (r h key)
 245           (s h)
 246           fail-code))
 247
 248     (define (hm x) (slot-ref x 'h))
 249     (let ((h (hm x)))
 250       (if (ifh h
 251                (aif it (r h '__class__)
 252                     (let lp ((cl it))
 253                       (let ((h (hm cl)))
 254                         (ifh h
 255                              (aif it (r h '__parents__)
 256                                   (let lp2 ((parents it))
 257                                     (if (pair? parents)
 258                                         (if (lp (car parents))
 259                                             (lp2 (cdr parents))
 260                                             fret)
 261                                         fret))
 262                                   fret))))
 263                     fret))
 264           (s h))
 265       (values))))
 266
 267 (define-syntax-rule (mset-py- x key val)
 268   (let ((f (mref-py- x '__set__ '())))
 269     (if (or (eq? f not-implemented) (not f))
 270         (mset- x key val)
 271         (f key val))))
 272
 273 (define-method (set (x <pf>)  key val) (mset     x key val))
 274 (define-method (set (x <p>)   key val) (mset-    x key val))
 275 (define-method (set (x <pyf>) key val) (mset-py  x key val))
 276 (define-method (set (x <py>)  key val) (mset-py- x key val))
 277
 278 ;; mref will reference the value of the key in the object x, an extra default
 279 ;; parameter will tell what the fail object is else #f if fail
 280 ;; if there is no found binding in the object search the class and
 281 ;; the super classes for a binding
 282
 283 ;; call a function as a value of key in x with the object otself as a first
 284 ;; parameter, this is pythonic object semantics
 285 (define-syntax-rule (mk-call mcall mref)
 286   (define-syntax-rule (mcall x key l)
 287     (apply (mref x key '()) l)))
 288
 289 (mk-call mcall     mref)
 290 (mk-call mcall-    mref-)
 291 (mk-call mcall-py  mref-py)
 292 (mk-call mcall-py- mref-py-)
 293
 294 (define-method (call (x <pf>)  key . l) (mcall     x key l))
 295 (define-method (call (x <p>)   key . l) (mcall-    x key l))
 296 (define-method (call (x <pyf>) key . l) (mcall-py  x key l))
 297 (define-method (call (x <py>)  key . l) (mcall-py- x key l))
 298
 299
 300 ;; make a copy of a pf object
 301 (define-syntax-rule (mcopy x)
 302   (let ((r (make-pyclass <pf>)))
 303     (slot-set! r 'h (slot-ref x 'h))
 304     (slot-set! r 'size (slot-ref x 'size))
 305     (slot-set! r 'n (slot-ref x 'n))
 306     r))
 307
 308 (define-syntax-rule (mcopy- x)
 309   (let* ((r (make-p))
 310          (h (slot-ref r 'h)))
 311     (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
 312     r))
 313
 314 (define-method (copy (x <pf>)) (mcopy  x))
 315 (define-method (copy (x <p> )) (mcopy- x))
 316
 317
 318 ;; with will execute thunk and restor x to it's initial state after it has
 319 ;; finished note that this is a cheap operatoin because we use a functional
 320 ;; datastructure
 321 (define-syntax-rule (mwith x thunk)
 322   (let ((old (mcopy x)))
 323     (let ((r (thunk)))
 324       (slot-set! x 'h    (slot-ref old 'h))
 325       (slot-set! x 'size (slot-ref old 'size))
 326       (slot-set! x 'n    (slot-ref old 'n))
 327       r)))
 328
 329 (define-syntax-rule (mwith- x thunk)
 330   (let ((old (mcopy- x)))
 331     (let ((r (thunk)))
 332       (slot-set! x 'h    (slot-ref old 'h))
 333       r)))
 334
 335
 336
 337 ;; a functional set will return a new object with the added binding and keep
 338 ;; x untouched
 339 (define-method (fset (x <pf>) key val)
 340   (let ((x (mcopy x)))
 341     (mset x key val)
 342     x))
 343
 344 (define-method (fset (x <p>) key val)
 345   (let ((x (mcopy- x)))
 346     (mset x key val)
 347     x))
 348
 349 (define (fset-x obj l val)
 350   (let lp ((obj obj) (l l) (r '()))
 351     (match l
 352       (()
 353        (let lp ((v val) (r r))
 354          (if (pair? r)
 355              (lp (fset (caar r) (cdar r) v) (cdr r))
 356              v)))
 357       ((k . l)
 358        (lp (ref obj k #f) l (cons (cons obj k) r))))))
 359
 360
 361
 362
 363
 364 ;; a functional call will keep x untouched and return (values fknval newx)
 365 ;; e.g. we get both the value of the call and the new version of x with
 366 ;; perhaps new bindings added
 367 (define-method (fcall (x <pf>) key . l)
 368   (let* ((y (mcopy x))
 369          (r (mcall y key l)))
 370     (if (eq? (slot-ref x 'h) (slot-ref y 'h))
 371         (values r x)
 372         (values r y))))
 373
 374 (define-method (fcall (x <p>) key . l)
 375   (let ((x (mcopy x)))
 376     (values (mcall- x key l)
 377             x)))
 378
 379 ;; this shows how we can override addition in a pythonic way
 380 (define-syntax-rule (mk-arith + +x __add__ __radd__)
 381   (begin
 382     (define-method (+ (x <p>) y)
 383       (call x '__add__ y))
 384
 385     (define-method (+ x (y <p>))
 386       (call y '__radd__ x))
 387
 388     (define-method (+ (x <py>) y)
 389       (let ((f (mref-py- x '__add__ '())))
 390         (if f
 391             (f y)
 392             (+x y x))))
 393
 394     (define-method (+ (x <pyf>) y)
 395       (let ((f (mref-py x '__add__ '())))
 396         (if f
 397             (let ((res (f y)))
 398               (if (eq? res not-implemented)
 399                   (+x y x)
 400                   res))
 401             (+x y x))))
 402
 403     (define-method (+ (x <py>) y)
 404       (let ((f (mref-py- x '__add__ '())))
 405         (if f
 406             (let ((res (f y)))
 407               (if (eq? res not-implemented)
 408                   (+x y x)
 409                   res))
 410             (+x y x))))
 411
 412     (define-method (+ x (y <py>))
 413       (call y '__radd__ x))
 414
 415     (define-method (+ x (y <pyf>))
 416       (call y '__radd__ x))
 417
 418     (define-method (+x (x <p>) y)
 419       (call x '__radd__ y))))
 420
 421 ;; A few arithmetic operations at service
 422 (mk-arith + +x __add__ __radd__)
 423 (mk-arith - -x __sub__ __rsub__)
 424 (mk-arith * *x __mul__ __rmul__)
 425
 426 ;; lets define get put pcall etc so that we can refer to an object like
 427 ;; e.g. (put x.y.z 1) (pcall x.y 1)
 428
 429 (define-syntax-rule (cross x k f set)
 430   (call-with-values (lambda () f)
 431     (lambda (r y)
 432       (if (eq? x y)
 433           (values r x)
 434           (values r (set x k y))))))
 435
 436 (define-syntax-rule (cross! x k f _) f)
 437
 438 (define-syntax mku
 439   (syntax-rules ()
 440     ((_ cross set setx f (key) (val ...))
 441      (setx f key val ...))
 442     ((_ cross set setx f (k . l) val)
 443      (cross f k (mku cross set setx (ref f k) l val) set))))
 444
 445 (define-syntax-rule (mkk pset setx set cross)
 446   (define-syntax pset
 447     (lambda (x)
 448       (syntax-case x ()
 449         ((_ f val (... ...))
 450          (let* ((to (lambda (x)
 451                       (datum->syntax #'f  (string->symbol x))))
 452                 (l (string-split (symbol->string (syntax->datum #'f)) #\.)))
 453            (with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x))
 454                                              (cdr l)))
 455                          (h       (to (car l))))
 456              #'(mku cross setx set h (a (... ...)) (val (... ...))))))))))
 457
 458 (mkk put    fset  fset cross)
 459 (mkk put!   set   set  cross!)
 460 (mkk pcall! call  fset cross!)
 461 (mkk pcall  fcall fset cross)
 462 (mkk get    ref   fset cross!)
 463
 464 ;; it's good to have a null object so we don't need to construct it all the
 465 ;; time because it is functional we can get away with this.
 466 (define null (make-pf))
 467
 468 ;; append the bindings in x in front of y + some optimizations
 469 (define (union x y)
 470   (define hx (slot-ref x 'h))
 471   (define hy (slot-ref y 'h))
 472   (define n  (slot-ref x 'n))
 473   (define s  (slot-ref x 'size))
 474   (define m (make-hash-table))
 475
 476   (define h
 477     (vhash-fold
 478      (lambda (k v st)
 479        (if (vhash-assq k hy)
 480            (begin
 481              (set! s (+ s 1))
 482              (vhash-consq k v st))
 483            (if (hash-ref m k)
 484                s
 485                (begin
 486                  (set! n (+ n 1))
 487                  (set! s (+ s 1))
 488                  (hash-set! m k #t)
 489                  (vhash-consq k v st)))))
 490      hy
 491      hx))
 492
 493   (define out (make-pyclass <pf>))
 494   (slot-set! out 'h h)
 495   (slot-set! out 'n n)
 496   (slot-set! out 'size s)
 497   out)
 498
 499 (define (union- x y)
 500   (define hx (slot-ref x 'h))
 501   (define hy (slot-ref y 'h))
 502   (define out (make-p))
 503   (define h  (slot-ref out 'h))
 504   (hash-for-each (lambda (k v) (hash-set! h k v)) hy)
 505   (hash-for-each (lambda (k v) (hash-set! h k v)) hx)
 506   out)
 507
 508
 509 ;; make a class. A class add some meta information to allow for multiple
 510 ;; inherritance and add effectively static data to the object the functional
 511 ;; datastructure show it's effeciency now const is data that will not change
 512 ;; and bindings that are added to all objects. Dynamic is the mutating class
 513 ;; information. supers is a list of priorities
 514 (define-syntax-rule (mk-pf make-pf-class <pf>)
 515   (define-syntax make-pf-class
 516     (lambda (x)
 517       (syntax-case x ()
 518         ((_ name const dynamic (supers (... ...)))
 519          (with-syntax (((sups (... ...)) (generate-temporaries
 520                                           #'(supers (... ...)))))
 521            #'(let ((sups supers) (... ...))
 522                (define class dynamic)
 523                (define name (make-class (list sups (... ...) <pf>) '()))
 524
 525                (define __const__
 526                  (union const
 527                         (let lp ((sup (list sups (... ...))))
 528                           (if (pair? sup)
 529                               (union (ref (car sup) '__const__  null)
 530                                      (lp (cdr sup)))
 531                               null))))
 532
 533                (reshape __const__)
 534                (set  class '__const__    __const__)
 535                (set  class '__goops__    name)
 536                (set  class '__name__     'name)
 537                (set  class '__parents__  (list sups (... ...)))
 538
 539                (set  __const__ '__name__    'name)
 540                (set  __const__ '__class__   class)
 541                (set  __const__ '__parents__ (list sups (... ...)))
 542                (set  __const__ '__goops__   name)
 543                class)))))))
 544
 545 (mk-pf make-pf-class <pf>)
 546 (mk-pf make-pyf-class <pyf>)
 547
 548 (define-syntax-rule (mk-p make-p-class <p>)
 549   (define-syntax make-p-class
 550     (lambda (x)
 551       (syntax-case x ()
 552         ((_ name const dynamic (supers (... ...)))
 553          (with-syntax (((sups (... ...)) (generate-temporaries
 554                                           #'(supers (... ...)))))
 555            #'(let ((sups supers) (... ...))
 556                (define class dynamic)
 557                (define name (make-class (list (ref sups '__goops__ #f)
 558                                               (... ...) <p>) '()))
 559
 560                (set! class
 561                  (union- const
 562                          (let lp ((sup (list sups (... ...))))
 563                            (if (pair? sup)
 564                                (union- (car sup)
 565                                        (lp (cdr sup)))
 566                                (make-p)))))
 567
 568
 569                (set class '__goops__    name)
 570                (set class '__name__     'name)
 571                (set class '__parents__  (list sups (... ...)))
 572
 573                class)))))))
 574
 575 (mk-p  make-p-class  <p>)
 576 (mk-p  make-py-class <py>)
 577
 578 ;; Let's make an object essentially just move a reference
 579
 580 ;; the make class and defclass syntactic sugar
 581 (define-syntax-rule (mk-p/f make-pf mk-pf-class make-pf-class)
 582   (define-syntax-rule (mk-pf-class name (parents (... ...))
 583                                    #:const
 584                                    ((sdef mname sval) (... ...))
 585                                    #:dynamic
 586                                    ((ddef dname dval) (... ...)))
 587     (let ()
 588       (define name
 589         (make-pf-class name
 590                      (let ((s (make-pf)))
 591                        (set s 'mname sval) (... ...)
 592                        s)
 593                      (let ((d (make-pf)))
 594                        (set d 'dname dval) (... ...)
 595                        d)
 596                      (parents (... ...))))
 597       name)))
 598
 599 (mk-p/f make-pf mk-pf-class  make-pf-class)
 600 (mk-p/f make-p  mk-p-class   make-p-class)
 601 (mk-p/f make-pf mk-pyf-class make-pyf-class)
 602 (mk-p/f make-p  mk-py-class  make-py-class)
 603
 604 (define-syntax-rule (def-pf-class name . l)
 605   (define name (mk-pf-class name . l)))
 606
 607 (define-syntax-rule (def-p-class  name . l)
 608   (define name (mk-p-class name . l)))
 609
 610 (define-syntax-rule (def-pyf-class name . l)
 611   (define name (mk-pyf-class name . l)))
 612
 613 (define-syntax-rule (def-py-class  name . l)
 614   (define name (mk-py-class name . l)))
 615
 616 (define (get-class o)
 617   (cond
 618    ((is-a? o <p>)
 619     o)
 620    (else
 621     (error "not a pyclass"))))
 622
 623 (define (get-type o)
 624   (cond
 625    ((is-a? o <pyf>)
 626     'pyf)
 627    ((is-a? o <py>)
 628     'py)
 629    ((is-a? o <pf>)
 630     'pf)
 631    ((is-a? o <p>)
 632     'p)
 633    (else
 634     'none)))
 635
 636 (define (print o l)
 637   (define p1 (if (pyclass? o) "Class" "Object"))
 638   (define p2 (if (pyclass? o) "Class" "Object"))
 639   (define port (if (pair? l) (car l) #t))
 640   (format port "~a"
 641           (aif it (ref o '__repr__ #f)
 642                (format
 643                 #f "~a(~a)<~a>" p1 (get-type o) (it))
 644                (format
 645                 #f "~a(~a)<~a>" p2 (get-type o) (ref o '__name__ 'None)))))
 646
 647 (define-method (write (o <p>) . l) (print o l))
 648 (define-method (display (o <p>) . l) (print o l))
 649
 650 (define-syntax-rule (define-python-class name parents code ...)
 651   (define name
 652     (mk-py-class name parents
 653                  #:const
 654                  (code ...)
 655                  #:dynamic
 656                  ())))
 657
 658 (define (pyclass? x)
 659   (and (is-a? x <p>) (not (ref x '__class__))))