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&