functools
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Fri, 23 Mar 2018 14:12:31 +0000 (15:12 +0100)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Fri, 23 Mar 2018 14:12:31 +0000 (15:12 +0100)
modules/language/python/def.scm
modules/language/python/module/functools.scm [new file with mode: 0644]
modules/language/python/procedure.scm
modules/oop/pf-objects.scm

index f0bb1617cc4dde3ea245da17e5ae04a30964c30b..389e89ef792cf37b7d9a4c699ae6d6f0313a337b 100644 (file)
@@ -1,4 +1,5 @@
 (define-module (language python def)
+  #:use-module (oop pf-objects)
   #:use-module (language python for)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-11)
                            ((k ...) (map car kv))
                            ((s ...) (map ->kw (map car kv)))
                            ((v ...) (map cdr kv)))
-              #`(lambda* (#,@as . l)                     
-                   (call-with-values (lambda () (get-akw l))
-                     (lambda (ww* kw)
-                       (let*-values (((ww* k) (take-1 #,(null? ww-) ww* kw s v))
-                                     ...)
-                         (let ((ww ww*)
-                               (kw (pytonize kw)))
-                           code ...))))))))))))
+        #`(object-method
+           (lambda* (#,@as . l)                     
+             (call-with-values (lambda () (get-akw l))
+               (lambda (ww* kw)
+                 (let*-values (((ww* k) (take-1 #,(null? ww-) ww* kw s v))
+                               ...)
+                   (let ((ww ww*)
+                         (kw (pytonize kw)))
+                     code ...)))))))))))))
 
 (define-syntax-rule (def (f . args) code ...) (define f (lam args code ...)))
 
diff --git a/modules/language/python/module/functools.scm b/modules/language/python/module/functools.scm
new file mode 100644 (file)
index 0000000..0d0311a
--- /dev/null
@@ -0,0 +1,314 @@
+
+
+
+(define WRAPPER_ASSIGNMENTS '("__module__" "__name__" "__qualname__" "__doc__"
+                             "__annotations__"))
+
+(define WRAPPER_UPDATES     '("__dict__"))
+
+(def (update_wrapper wrapper
+                    wrapped
+                    (= assigned WRAPPER_ASSIGNMENTS)
+                    (= updated  WRAPPER_UPDATES))
+    "Update a wrapper function to look like the wrapped function
+
+       wrapper is the function to be updated
+       wrapped is the original function
+       assigned is a tuple naming the attributes assigned directly
+       from the wrapped function to the wrapper function (defaults to
+       functools.WRAPPER_ASSIGNMENTS)
+       updated is a tuple naming the attributes of the wrapper that
+       are updated with the corresponding attribute from the wrapped
+       function (defaults to functools.WRAPPER_UPDATES)
+    "
+    (for ((attr : assigned)) ()
+        (try
+        (lambda ()
+          (let ((value (getatt wrapped attr)))
+            (setattr wrapper attr value)))
+        (#:except AttributeError => values)))
+                
+    (for ((attr : updated)) ()
+        (py-uppdate (getattr wrapper attr) (getattr wrapped attr (dict))))
+    
+    (set wrapper '__wrapped__ wrapped)
+
+    wrapper)
+
+
+(def (wraps wrapped
+           (= assigned WRAPPER_ASSIGNMENTS)
+           (= updated  WRAPPER_UPDATES))
+    "Decorator factory to apply update_wrapper() to a wrapper function
+
+      Returns a decorator that invokes update_wrapper() with the decorated
+      function as the wrapper argument and the arguments to wraps() as the
+      remaining arguments. Default arguments are as for update_wrapper().
+      This is a convenience function to simplify applying partial() to
+      update_wrapper().
+    "
+    (partial update_wrapper #:wrapped wrapped #:assigned assigned
+            #:updated updated))
+
+;;; TOTAL ORDER ADDITIONS
+(define-syntax-rule (and-not-noteq _gt_from_lt <)
+  (def (_gt_from_lt self other (= NotImplemented NotImplemented))
+       (let ((op_result  (< self other)))
+        (if (eq? op_result NotImplemented)
+            op_result
+            (and (not op_result) (not (equal? self other)))))))
+
+(and-not-noteq _gt_from_lt <)
+
+(define-syntax-rule (or-eq _le_from_lt <)
+  (def (_le_from_lt self other (= NotImplemented NotImplemented))
+       (let ((op_result (< self other)))
+        (or op_result (equal? self other)))))
+
+(or-eq _le_from_lt <)
+
+(define-syntax-rule (not- _ge_from_lt <)
+  (def (_ge_from_lt self other (= NotImplemented NotImplemented))
+       (let ((op_result (< self other)))
+        (if (eq? op_result NotImplemented)
+            op_result
+            (not op_result)))))
+
+(not- _ge_from_lt <)
+
+(define-syntax-rule (or-not-eq _ge_from_le <=)
+  (def (_ge_from_le self other (= NotImplemented NotImplemented))
+       (let ((op_result (<= self other)))
+        (if (eq? op_result NotImplemented)
+            op_result
+            (or (not op_result) (equal? self other))))))
+(or-not-eq _ge_from_le <=)
+
+(define-syntax-rule (and-noteq _lt_from_le <=)
+  (def (_lt_from_le self other (= NotImplemented NotImplemented))
+       (let ((op_result (<= self other)))
+        (if (eq? op_result NotImplemented)
+            op_result
+            (and op_result (not (equal? self other)))))))
+
+(and-noteq _lt_from_le <=)
+
+(not- _gt_from_le <=)
+
+(and-not-noteq _lt_from_gt >)
+
+(define-syntax-rule (or-eq _ge_from_gt >)
+  (def (_ge_from_gt self other (= NotImplemented NotImplemented))
+       (let ((op_result (> self other)))
+        (or op_result (equal? self other)))))
+
+(or-eq _ge_from_gt >)
+(not- _le_from_gt >)
+
+(or-not-eq _le_from_ge >=)
+(and-noteq _gt_from_ge >=)
+(not-      _lt_from_ge >=)
+
+(define _convert
+  (let ((h (make-hash-table)))
+    (for-each
+     (lambda (x)
+       (hash-set! h (car x) (cdr x)))
+     `(
+       (__lt__ (__gt__ ,_gt_from_lt)
+               (__le__ ,_le_from_lt)
+               (__ge__ ,_ge_from_lt))
+       (__le__ (__ge__ ,_ge_from_le)
+               (__lt__ ,_lt_from_le)
+               (__gt__ ,_gt_from_le))
+       (__gt__ (__lt__ ,_lt_from_gt)
+               (__ge__ ,_ge_from_gt)
+               (__le__ ,_le_from_gt))
+       (__ge__ (__le__ ,_le_from_ge)
+               (__gt__ ,_gt_from_ge)
+               (__lt__ ,_lt_from_ge))))
+    h))
+
+(define (total_ordering cls)
+  (call-with-values
+      (lambda ()
+       (for ((k v : _convert)) ((mk #f) (mv #f) (l '()))
+            (if (ref cls k)
+                (if mk
+                    (if (> k mk)
+                        (values k v   (cons k l))
+                        (values mk mv (cons k l)))
+                    (values k v (list k)))
+                (values mk mv l))
+            #:final (values mk mv l)))
+    (lambda (op v roots)
+      (if (not op)
+         (raise ValueError
+                "must define at least one ordering operation: < > <= >="))
+      (for ((opname opfunc : v)) ()
+          (if (not (in opname roots))
+              (let ((f (lambda (self other) (opfunc self other))))
+                (set f   '__name__ opname)
+                (set cls opname    f))))
+
+      cls)))
+
+
+def cmp_to_key(mycmp):
+    """Convert a cmp= function into a key= function"""
+    class K(object):
+        __slots__ = ['obj']
+        def __init__(self, obj):
+            self.obj = obj
+        def __lt__(self, other):
+            return mycmp(self.obj, other.obj) < 0
+        def __gt__(self, other):
+            return mycmp(self.obj, other.obj) > 0
+        def __eq__(self, other):
+            return mycmp(self.obj, other.obj) == 0
+        def __le__(self, other):
+            return mycmp(self.obj, other.obj) <= 0
+        def __ge__(self, other):
+            return mycmp(self.obj, other.obj) >= 0
+        __hash__ = None
+    return K
+(define (cmp_to_key mycmp)
+  (define-python-class-unamed K
+    (define __init__
+      (lambda (self, obj)
+       (set self 'obj obj)))
+    
+    (define __lt__
+      (lambda (self, other)
+       (< (mycmp (ref self 'obj)  (ref other obj)) 0)))
+
+    (define __gt__
+      (lambda (self, other)
+       (> (mycmp (ref self 'obj)  (ref other obj)) 0)))
+
+    (define __eq__
+      (lambda (self, other)
+       (= (mycmp (ref self 'obj)  (ref other obj)) 0)))
+
+    (define __lt__
+      (lambda (self, other)
+       (<= (mycmp (ref self 'obj)  (ref other obj)) 0)))
+
+    (define __gt__
+      (lambda (self, other)
+       (>= (mycmp (ref self 'obj)  (ref other obj)) 0))))
+
+  K)
+
+(define-python-class partial ()
+  (define __init__
+    (lam (self func (* args) (** keywords))
+        (if (not (callable func))
+            (raise TypeError "the first argument must be callable"))
+        
+        (aif it (ref func 'func)
+            (begin
+              (set! args (+ (ref func 'args) args))
+              (let ((tmpkw (py-copy (ref func 'keywords))))
+                (py-update mpkw keywords)
+                (set! keywords tmpkw)
+                (set func it))))
+        
+        (set self 'func     func    )
+        (set self 'args     args    )
+        (set self 'keywords keywords)
+        self))
+
+  (define __call__
+    (lam (self (* args) (** keywords))
+        (let ((newkeywords (py-copy (ref self 'keywords))))
+         (py-update newkeywords 'keywords)
+         (py-apply (ref self 'func) (* (ref self 'args) (* args)
+                                       (** newkeywords))))))
+
+
+  (define __repr__
+    (lambda (self)
+      (let* ((args (ref self 'args '()))
+            (s1   (if (null? args)
+                      "*"
+                      (format #f "~a~{, ~a~}, *" (car args) (cdr args))))
+            (kws  (ref self 'keywords (make-hash-table)))
+            (kw2  (for ((k v : kws)) ((l '()))
+                       (cons (format #f "~a=~a" k (repr v)) l)
+                       #:final (reverse l)))
+            (s2   (if (null? kw2)
+                      ""
+                      (format #f ", ~a~{, ~a~}" (car kw2) (cdr kw2)))))
+       (format #f "partial[~a](~a~a)" (repr (ref self 'func)) s1 s2)))))
+
+
+(define-python-class partialmethod ()
+  (define __init__
+    (lam (self func (* args) (** keywords))
+        (if (and (not (callable func)) (not (ref func '__get__)))
+            (raise TypeError (+ (repr func)
+                               "is not callable or a descriptor")))
+
+        (if (isinstance func partialmethod)
+            (begin
+             (set self 'func (ref func 'func))
+             (set self 'args (+ (ref func 'args) args))
+             (let ((kws (py-copy (ref func 'keywords))))
+               (py-update kws keywords)
+               (set self 'keywords kws)))
+           (begin
+             (set self 'func     func    )
+             (set self 'args     args    )
+             (set self 'keywords keywords)))))
+  
+  (define __repr__
+    (lambda (self)
+      (let* ((args (ref self 'args '()))
+            (s1   (if (null? args)
+                      "*"
+                      (format #f "~a~{, ~a~}, *" (car args) (cdr args))))
+            (kws  (ref self 'keywords (make-hash-table)))
+            (kw2  (for ((k v : kws)) ((l '()))
+                       (cons (format #f "~a=~a" k (repr v)) l)
+                       #:final (reverse l)))
+            (s2   (if (null? kw2)
+                      ""
+                      (format #f ", ~a~{, ~a~}" (car kw2) (cdr kw2)))))
+       (format #f "partialMethod[~a](~a~a)" (repr (ref self 'func)) s1 s2))))
+
+  (define _make_unbound_method
+    (lambda (self)
+      (def (_method self (* args) (** keywords))
+       (let ((call_keywords (py-copy (ref self 'keywords)))
+             (call_args     (+ (cls_or_self) (ref self 'args) args)))
+         (py-update call_keywords keywords)
+         (py-apply (ref self 'func) (* call_args) (** call_keywords))))
+
+      (set _method '__isabstractmethod__ (ref self '__isabstractmethod__))
+      (set _method '_partialmethod       self)
+      _method))
+
+  (define __get__
+    (lambda (self obj cls)
+      (let* ((func   (ref self 'func))
+            (get    (ref func '__get__))
+            (result #f))
+        (if get
+            (let ((new_func  (get obj cls)))
+             (if (not (eq? new_func func))
+                 (begin
+                   (set! result (py-apply partial new_func
+                                          (*  (ref self 'args    ))
+                                          (** (ref self 'keywords))))
+                   (aif it (ref new_func '__self__)
+                        (set! result '__self__ it))))))
+       (if (not result)
+            ((ref (ref self '_make_unbound_method) '__get__) obj cls)
+           result))))
+  
+  (define __isabstractmethod__
+    (property
+     (lambda (self)
+       (ref (ref self 'func) '__isabstractmethod__ #f)))))
+
index 55d0b24069640e62b7dab8b2f3cc739cf79d6842..51b21d4e938b8f8c8c1f0b1faec39cdc574ad026 100644 (file)
                                (procedure-properties o))))))
     (pylist-sort! ret)
     ret))
+
+(define (mk-getter-object f)
+  (lambda (obj cls)
+    (if (eq? obj cls)
+       (lambda x (apply f x))
+       (lambda x (apply f obj x)))))
index 5de0168ef52d3e9b03b5a9747ed3895675e9d4db..655f49c54551705363313cc53c9ea4b901eab70e 100644 (file)
@@ -11,7 +11,8 @@
                 call with copy fset fcall put put!
                 pcall pcall! get fset-x pyclass?                
                 def-p-class   mk-p-class   make-p-class
-                define-python-class get-type py-class
+                define-python-class define-python-class-noname
+               get-type py-class
                 object-method class-method static-method
                 py-super-mac py-super py-equal? 
                 *class* *self* pyobject? pytype?
@@ -67,6 +68,48 @@ explicitly tell it to not update etc.
 (name-object <pyf>)
 (name-object <property>)
 
+(define-method (ref (o <procedure>) key . l)
+  (aif it (procedure-property o key)
+       it
+       (if (pair? l)
+          (car l)
+          #f)))
+
+(define-method (rawref (o <procedure>) key . l)
+  (aif it (procedure-property o key)
+       it
+       (if (pair? l)
+          (car l)
+          #f)))
+
+(define-method (set (o <procedure>) key val)
+  (set-procedure-property! o key val))
+
+(define-method (rawset (o <procedure>) key val)
+  (set-procedure-property! o key val))
+
+(define (mk-getter-object f)
+  (lambda (obj cls)
+    (if (eq? obj cls)
+       (lambda x (apply f x))
+       (lambda x (apply f obj x)))))
+
+(define (mk-getter-class f)                                   
+  (lambda (obj cls)
+    (if (eq? obj cls)
+       (lambda x (apply f x))
+       (lambda x (apply f cls x)))))
+
+(define (class-method f)
+  (set f '__get__ (mk-getter-class f)))
+
+(define (object-method f)
+  (set f '__get__ (mk-getter-object f)))
+
+(define (static-method f)
+  (set f '__get__ #f))
+
+
 (define (resolve-method-g g pattern)
   (define (mmatch p pp)
     (if (eq? pp '_)
@@ -208,6 +251,13 @@ explicitly tell it to not update etc.
           x)
         y)))
 
+(define-inlinable (gox obj it)
+  (let ((class (fluid-ref *location*)))
+    (aif it (rawref it '__get__)
+        (it obj class)
+        it)))
+
+(define *location* (make-fluid #f))
 (define-syntax-rule (mrefx x key l)
   (let ()
     (define (end)
@@ -220,15 +270,15 @@ explicitly tell it to not update etc.
         (if (pair? li)
             (let ((p (car li)))
               (cif (it h) (key p)
-                   it
+                   (begin (fluid-set! *location* p) it)
                   (lp (cdr li))))
             fail)))
   
     (cif (it h) (key x)
-         it
+         (begin (fluid-set! *location* x) it)
          (hif cl ('__class__ h)
               (cif (it h) (key cl)
-                   it
+                   (begin (fluid-set! *location* cl) it)
                    (hif p ('__mro__ h)
                         (let ((r (parents p)))
                           (if (eq? r fail)
@@ -237,8 +287,6 @@ explicitly tell it to not update etc.
                         (end)))
               (end)))))
 
-(define *refkind* (make-fluid 'object))
-
 (define-method (find-in-class (klass <p>) key fail)
   (hash-ref (slot-ref klass 'h) key fail))
 
@@ -250,12 +298,12 @@ explicitly tell it to not update etc.
 
 (define-syntax-rule (find-in-class-and-parents klass key fail)
   (kif r (find-in-class klass key fail)
-       r
+       (begin (fluid-set! *location* klass) r)
        (aif parents (find-in-class klass '__mro__ #f)
            (let lp ((parents parents))
              (if (pair? parents)
                  (kif r (find-in-class (car parents) key fail)
-                      r
+                      (begin (fluid-set! *location* (car parents)) r)
                       (lp (cdr parents)))
                  fail))
            fail)))
@@ -263,11 +311,10 @@ explicitly tell it to not update etc.
 (define-syntax-rule (mrefx klass key l)
   (let ()
     (define (end) (if (pair? l) (car l) #f))
-    (fluid-set! *refkind* 'object)
+    (fluid-set! *location* klass)
     (kif it (find-in-class klass key fail)
         it
         (begin
-          (fluid-set! *refkind* 'class)
           (aif klass (find-in-class klass '__class__ #f)
                (kif it (find-in-class-and-parents klass key fail)
                     it
@@ -291,40 +338,32 @@ explicitly tell it to not update etc.
            (f (if g
                   (if (eq? g #t)
                       (aif it (mrefx xx '__getattribute__ '())
-                           (begin
-                             (mset xx '__fget__ it it)
-                             it)
+                           (let ((f (gox xx it)))
+                             (rawset xx '__fget__ it)
+                             f)                            
                            (begin
                              (if (mc?)
-                                 (mset xx '__fget__ it it))
+                                 (rawset xx '__fget__ #f))
                              #f))
                       g)
                   #f)))
        (if (or (not f) (eq? f not-implemented))
-          (mrefx xx key l)
+          (gox xx (mrefx xx key l))
           (catch #t
                  (lambda ()
-                   (make-variable
-                    ((f xx (fluid-ref *refkind*)) key)))
+                   (f key))
                  (lambda x
-                   (mrefx xx key l))))))))
+                   (gox xx (mrefx xx key l)))))))))
 
 
 (define-syntax-rule (mref x key l)
   (let ((xx x))
-    (let ((res (mrefx xx key l)))
-      (if (and (not (struct? res)) (procedure? res))
-         (res xx (fluid-ref *refkind*))
-         res))))
+    (mrefx xx key l)))
 
 (define-syntax-rule (mref-py x key l)
   (let ((xx x))
     (let ((res (mrefx-py xx key l)))
-      (if (variable? res)
-         (variable-ref res)
-         (if (and (not (struct? res)) (procedure? res))
-             (res xx (fluid-ref *refkind*))
-             res)))))
+      res)))
 
 (define-method (ref x key . l) (if (pair? l) (car l) #f))
 (define-method (ref (x <pf> )  key . l) (mref     x key l))
@@ -332,6 +371,7 @@ explicitly tell it to not update etc.
 (define-method (ref (x <pyf>)  key . l) (mref-py  x key l))
 (define-method (ref (x <py> )  key . l) (mref-py  x key l))
 
+(define-method (rawref x key . l) (if (pair? l) (car l) #f))
 (define-method (rawref (x <pf> )  key . l) (mref     x key l))
 (define-method (rawref (x <p>  )  key . l) (mref     x key l))
 
@@ -367,7 +407,7 @@ explicitly tell it to not update etc.
     (values)))
 
 ;; on object x add a binding that key -> val
-(define-method (mset (x <pf>) key rval val)
+(define-method (mset (x <pf>) key val)
   (let ((h (slot-ref x 'h))
         (s (slot-ref x 'size))
         (n (slot-ref x 'n)))
@@ -382,7 +422,7 @@ explicitly tell it to not update etc.
 
 (define (pkh h) (hash-for-each (lambda x (pk x)) h) h)
 
-(define-method (mset (x <p>) key rval val)
+(define-method (mset (x <p>) key val)
   (begin
     (hash-set! (slot-ref x 'h) key val)
     (values)))
@@ -390,7 +430,7 @@ explicitly tell it to not update etc.
 (define *make-class* (make-fluid #f))
 (define (mc?) (not (fluid-ref *make-class*)))
 
-(define-syntax-rule (mset-py x key rval val)
+(define-syntax-rule (mset-py x key val)
   (let* ((xx x)
         (v  (mref xx key (list fail))))
     (if (or (eq? v fail)
@@ -399,34 +439,25 @@ explicitly tell it to not update etc.
        (let* ((g (mrefx xx '__fset__ '(#t)))
               (f (if g
                      (if (eq? g #t)
-                         (aif it (mrefx xx '__setattr__ '())
+                         (aif it (rawref xx '__setattr__)
                               (begin
-                                (mset xx '__fset__ it it)
+                                (rawset xx '__fset__ it)
                                 it)
                               (begin
                                 (if (mc?)
-                                    (mset xx '__fset__ it it))
+                                    (rawset xx '__fset__ it))
                                 #f))
                          g)
                      #f)))
          (if (or (eq? f not-implemented) (not f))
-             (mset xx key val val)              
+             (mset xx key val)              
              (catch #t
-               (lambda () ((f xx (fluid-ref *refkind*)) key rval))
-               (lambda x (mset xx key val val)))))
+               (lambda () (f key val))
+               (lambda q  (mset xx key val)))))
        ((slot-ref v 'set) xx val))))
 
 (define-syntax-rule (mklam (mset a ...) val)
-  (if (and (procedure? val)
-           (not (pyclass? val))
-           (not (pytype?  val))
-           (if (is-a? val <p>)
-               (ref val '__call__)
-               #t))
-      (if (procedure-property val 'py-special)
-          (mset a ... val val)
-          (mset a ... val (object-method val)))
-      (mset a ... val val)))
+  (mset a ... val))
 
 (define-method (set (x <pf>)  key val) (mklam (mset     x key) val))
 (define-method (set (x <p>)   key val) (mklam (mset     x key) val))
@@ -781,6 +812,21 @@ explicitly tell it to not update etc.
            (name-object name)
            name))))))
 
+(define-syntax mk-p-class-noname
+  (lambda (x)
+    (syntax-case x ()
+      ((_ name parents (ddef dname dval) ...)
+       #'(let ()
+          (define name 
+            (letruc ((dname dval) ...)
+                    (make-p-class 'name
+                                  parents
+                                  (lambda (dict)
+                                    (pylist-set! dict 'dname dname)
+                                    ...
+                                    (values)))))
+          name)))))
+
 (define-syntax-rule (def-p-class name . l)
   (define name (mk-p-class name . l)))
 
@@ -835,6 +881,10 @@ explicitly tell it to not update etc.
 (define-syntax-rule (define-python-class name (parents ...) code ...)
   (define name (mk-p-class name (arglist->pkw (list parents ...)) code ...)))
 
+(define-syntax-rule (define-pythonc-lass-noname name (parents ...) code ...)
+  (define name (mk-p-class-noname name (arglist->pkw (list parents ...))
+                                 code ...)))
+
 
 (define-syntax make-python-class
   (lambda (x)
@@ -862,32 +912,6 @@ explicitly tell it to not update etc.
   (set-procedure-property! f 'py-special tag)
   f)
 
-(define (object-method f)
-  (letrec ((self
-            (mark-fkn 'object
-                      (lambda (x kind)
-                       (if (eq? kind 'object)
-                           f
-                           (lambda z (apply f x z)))))))
-    self))
-
-(define (class-method f)
-  (letrec ((self
-            (mark-fkn 'class
-              (lambda (x kind)
-               (if (eq? kind 'object)
-                   (let ((klass (ref x '__class__)))
-                     (lambda z (apply f klass z)))
-                   (lambda z (apply f x z)))))))
-    self))
-
-(define (static-method f)
-  (letrec ((self
-            (mark-fkn 'static
-                      (lambda (x kind) f))))
-    self))
-
-        
 (define-syntax-parameter
   *class* (lambda (x) (error "*class* not parameterized")))
 (define-syntax-parameter