diff options
Diffstat (limited to 'modules/language')
-rw-r--r-- | modules/language/python/def.scm | 18 | ||||
-rw-r--r-- | modules/language/python/module/functools.scm | 314 | ||||
-rw-r--r-- | modules/language/python/procedure.scm | 6 |
3 files changed, 330 insertions, 8 deletions
diff --git a/modules/language/python/def.scm b/modules/language/python/def.scm index f0bb161..389e89e 100644 --- a/modules/language/python/def.scm +++ b/modules/language/python/def.scm @@ -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) @@ -90,14 +91,15 @@ ((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 index 0000000..0d0311a --- /dev/null +++ b/modules/language/python/module/functools.scm @@ -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))))) + diff --git a/modules/language/python/procedure.scm b/modules/language/python/procedure.scm index 55d0b24..51b21d4 100644 --- a/modules/language/python/procedure.scm +++ b/modules/language/python/procedure.scm @@ -123,3 +123,9 @@ (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))))) |