path: root/modules/language/python/module/functools.scm

(define-module (language python module functools)
  #:use-module (ice-9 control)
  #:use-module (ice-9 format)
  #:use-module (oop pf-objects)
  #:use-module (language python for)
  #:use-module (language python try)
  #:use-module (language python def)
  #:use-module (language python module threading)
  #:use-module (language python module weakref)
  #:use-module (language python module collections)
  #:use-module (language python module abc)
  #:use-module ((language python module python)
		#:select (iter getattr setattr repr isinstance callable
			       bool str int enumerate reversed hasattr
			       issubclass any))
  #:use-module (language python list)
  #:use-module (language python dict)
  #:use-module (language python set)
  #:use-module (language python tuple)
  #:use-module (language python property)
  #:use-module (language python exceptions)
  #:export (WRAPPER_ASSIGNMENTS WRAPPER_UPDATES
				update_wrapper wraps total_ordering
				cmp_to_key partial partialmethod lru_cache
				reduce singledispatch))

(define-syntax aif
  (syntax-rules ()
    ((_ it p x  ) (aif it p x (values)))
    ((_ it p x y) (let ((it p)) (if it x y)))))

(def (reduce f it (= initializer None))
     (let ((it    (iter it))
	   (value (if (eq? initializer None)
		      (next it)
		      initializer)))
       (for ((e : it)) ((value value))
	    (f value e)
	    #:final value)))
	   

(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 (getattr wrapped attr)))
	     (setattr wrapper attr value)))
	 (#:except #t
	  (setattr wrapper attr None))))
                
    (for ((attr : updated)) ()
	 (py-update (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)))

(define (cmp_to_key mycmp)
  (define-python-class-noname 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 __le__
      (lambda (self other)
	(<= (mycmp (ref self 'obj)  (ref other 'obj)) 0)))

    (define __ge__
      (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 tmpkw 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     (+ (list 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)))))


(define _CacheInfo (namedtuple "CacheInfo"
			       '("hits" "misses" "maxsize" "currsize")))

(define-python-class _HashedSeq (py-list)
  (define __init__
    (lam (self tup (= hash hash))
      ((ref py-list '__init__) self tup)
      (set self 'hashvalue (hash tup))))

  (define __hash__
    (lambda (self)
      (ref self 'hashvalue))))

(def (_make_key args kwds typed
		(= kwd_mark  (list (object)))
		(= fasttypes (py-set (list int str frozenset type(None))))
		(= tuple     tuple)
		(= type      type)
		(= len       len))

     (let ((key (py-list args)))
       (if (> (len kwds) 0)
	   (begin
	     (set! key (+ key kwd_mark))
	     (for ((item : (py-items kwds))) ()
		  (set! key (+ key item)))))
       
       (if typed
	   (begin
	     (set! key
		   (+ key
		      (for ((a : args)) ((l '()))
			   (cons (type a) l)
			   #:final (reverse l))))
	     (if (bool kwds)
		 (set! key
		       (+ key
			  (for ((v : (py-values kwds))) ((l '()))
			       (cons (type v) l)
			       #:final (reverse l))))))
       
	   (if (and (= (len key) 1)
		    (in (type (pylist-ref key 0)) fasttypes))
	       (pylist-ref key 0)
	       (_HashedSeq key)))))

(def (lru_cache (= maxsize 128) (= typed #f))
    "Least-recently-used cache decorator.

    If *maxsize* is set to None, the LRU features are disabled and the cache
    can grow without bound.

    If *typed* is True, arguments of different types will be cached separately.
    For example, f(3.0) and f(3) will be treated as distinct calls with
    distinct results.

    Arguments to the cached function must be hashable.

    View the cache statistics named tuple (hits, misses, maxsize, currsize)
    with f.cache_info().  Clear the cache and statistics with f.cache_clear().
    Access the underlying function with f.__wrapped__.

    See:  http://en.wikipedia.org/wiki/Cache_algorithms#Least_Recently_Used

    "

    (if (not (or (number? maxsize) (eq? maxsize None)))
        (raise TypeError "Expected maxsize to be an integer or None"))

    (lambda (user_function)
      (let ((wrapper (_lru_cache_wrapper
		      user_function maxsize typed _CacheInfo)))
	(update_wrapper wrapper user_function))))

(define <dict> `(,<py-hashtable> . _))

(define (_lru_cache_wrapper user_function maxsize typed _CacheInfo)
  (define sentinel (object))
  (define make_key _make_key)
  (define-values (PREV NEXT KEY RESULT)
    (values 0 1 2 3))
  (define cache (dict))
  (define-values (hits misses) (values 0 0))
  (define full #f)
  (define cache_get (resolve-method-g py-get <dict>))
  (define cache_len (resolve-method-g len    <dict>))
  (define lock      (RLock))
  (define root      (list 0 0 0 0))
  (list-set! root 0 root)
  (list-set! root 1 root)
  (list-set! root 2 None)
  (list-set! root 3 None)

  (let ((wrapper
	 (cond
	     ((eq? maxsize None)
	      (lam ((* args) (** kwds))
		   (let* ((key     (make_key args kwds typed))
			  (result  (cache_get key sentinel)))
		     (if (not (eq? result sentinel))
			 (begin
			   (set! hits (+ hits 1))
			   result)
			 (let ((result (py-apply user_function
						 (* args) (** kwds))))
			   (pylist-set! cache key result)
			   (set! misses (+ misses 1))
			   result)))))

	  ((= maxsize 0)
	   (lam ((* args) (** kwds))
		(let ((result (py-apply user_function (* args) (** kwds))))
		  (set! misses (+ misses 1))
		  result)))


	  (else
	   (lam ((* args) (** kwds))
	     (let/ec return
		(let* ((key     (make_key args kwds typed)))
		  (with (lock)
			(let ((link (cache_get key)))
			  (when (not (eq? link None))
			    (let ((link_prev (list-ref link 0))
				  (link_next (list-ref link 1))
				  (_key      (list-ref link 2))
				  (result    (list-ref link 3)))
			      (list-set! link_prev NEXT link_next)
			      (list-set! link_next PREV link_prev)
			      (let ((last (list-ref root PREV)))
				(list-set! last NEXT link)
				(list-set! root PREV link)
				(list-set! link PREV last)
				(list-set! link NEXT root)
				(set! hits (+ hits 1))
				(return result))))))

		  (let ((result (py-apply user_function (* args) (** kwds))))
		    (with (lock)
			  (cond
			   ((in key cache) (values))
			   (full
			    (let ((oldroot root))
			      (list-set! oldroot KEY key)
			      (list-set! oldroot RESULT result)
			      (set! root (list-ref oldroot NEXT))
			      (let ((oldkey    (list-ref root KEY))
				    (oldresult (list-ref root RESULT)))
				(list-set! root KEY    None)
				(list-set! root RESULT None)
				(pylist-delete! cache oldkey)
				(pylist-set! cache key oldroot))))
			   (else
			    (let* ((last (list-ref root PREV))
				   (link (list last root key result)))
			      (list-set!   last  NEXT link)
			      (list-set!   root  PREV link)
			      (pylist-set! cache key  link)
			      (set! full (>= (cache_len) maxsize)))))
			  (set! misses (+ misses 1)))
		    result))))))))

    (define (cache_info)
      (with lock
	    (_CacheInfo hits misses maxsize (cache_len))))

    (define (cache_clear)
      (with lock
            (py-clear cache)
            (set! root (list #f #f None None))
	    (list-set! root 0 root)
	    (list-set! root 1 root)
            (set! hits   0)
	    (set! misses 0)
            (set! full   #f)))

    (set wrapper 'cache_info  cache_info)
    (set wrapper 'cache_clear cache_clear)
    wrapper))


;; single dispatch
(define (_c3_merge sequences)
  (let lp ((result '()))
    (set! sequences (for ((s : sequences)) ((l '()))
			 (if (bool s)
			     (cons s l)
			     l)
			 #:final (reverse l)))
    (if (bool sequences)
	(let ((cand
	       (let lp2 ((s1 sequences))
		 (if (pair? s1)
		     (let ((cand (pylist-ref (car s1) 0)))
		       (let lp3 ((s2 sequences))
			 (if (pair? s2)
			     (if (in cand (pylist-slice (car s2) 1 None None))
				 (lp2 (cdr s1))
				 (lp3 (cdr s2)))
			     cand)))
		     (raise RuntimeError "Inconsistant hierarky")))))
	  
	  (let lp ((s sequences))
	    (if (pair? s)
		(begin
		  (if (equal? (pylist-ref (car s) +) cand)
		      (pylist-delete! (car s) 0))
		  (lp (cdr s)))))
		    
	  (lp (cons cand result)))

	(py-list (reverse result)))))

(def (_c3_mro cls (= abcs None))
    (define bases (ref cls '__bases__ '()))
    (define boundary
      (for ((i base : (enumerate (reversed bases)))) ()
	 (if (hasattr base '__abstractmethods__)
	     (break (- (len bases) i)))
	 #:final 0))

    (define abcs             (if (bool abcs) (py-list abcs) (py-list)))
    (define explicit_bases   (py-list (pylist-slice bases None boundary None)))
    (define abstract_bases   (py-list))
    (define other_bases      (py-list (pylist-slice bases boundary None None)))
    
    (for ((base : abcs)) ()
	 (if (and (issubclass cls base)
		  (not (any (map (lambda (b) (issubclass b base)) bases))))
	     (pylist-append! abstract_bases base)))

    (for ((base : abstract_bases)) ()
	 (pylist-remove! abcs base))
    
    (let* ((f (lambda (bases)
		(for ((base : bases)) ((l '()))
		     (cons (_c3_mro base #:abcs abcs) l)
		     #:final (reverse l))))

	   (explicit_c3_mros (f explicit_bases))	  
	   (abstract_c3_mros (f abstract_bases))	  
	   (other_c3_mros    (f other_bases)))

      (_c3_merge
       (+ (py-list (py-list cls))
	  explicit_c3_mros
	  abstract_c3_mros
	  other_c3_mros
	  (py-list explicit_bases)
	  (py-list abstract_bases)
	  (py-list other_bases)))))

(define (_compose_mro cls types)
    "Calculates the method resolution order for a given class *cls*.

    Includes relevant abstract base classes (with their respective bases) from
    the *types* iterable. Uses a modified C3 linearization algorithm.

    "
    (define bases (py-set (ref cls '__mro__)))

    ;; Remove entries which are already present in the __mro__ or unrelated.
    (define (is_related typ)
      (and (not (in typ bases))
	   (ref typ  '__mro__)
	   (issubclass cls typ)))
    
    (define types (for ((n : types)) ((l '()))
		       (if (is_related n)
			   (cons n l)
			   l)
		       #:final (reverse l)))
    
    ;; Remove entries which are strict bases of other entries (they will end up
    ;; in the MRO anyway.
    (define (is_strict_base typ)
      (for ((other : types)) ()
	   (if (and (not (equal? typ other))
		    (in typ (ref other '__mro__ '())))
	       (break #t))
	   #:final #f))
    
    (define types2 (for ((n : types)) ((l '()))
			(if (is_strict_base n)
			   (cons n l)
			   l)
		       #:final (reverse l)))
    
    ; Subclasses of the ABCs in *types* which are also implemented by
    ; *cls* can be used to stabilize ABC ordering.
    (define type_set (py-set types))
    (define mro      (py-list))
    
    (for ((typ : types)) ()
	 (let ((found (py-list)))
	   (for ((sub : ((ref typ '__subclasses__ (lambda () '()))))) ()
		(if (and (not (in sub bases))
			 (issubclass cls sub))
		    (pylist-append! found
				    (for ((s : (ref sub '__mro__ '())))
					 ((l '()))
					 (if (in s type_set)
					     (cons s l)
					     l)
					 #:final (py-list (reverse l))))))
	   (if (not (bool found))
	       (begin
		 (pylist-append! mro typ)
		 (pylist-sort! found #:key len #:reverse #t)
		 (for ((sub : found)) ()
		      (for ((subcls : sub)) ()
			   (if (not (in subcls mro))
			       (pylist-append! mro subcls))))))))

    (_c3_mro cls #:abcs mro))

(define (_find_impl cls registry)
    "Returns the best matching implementation from *registry* for type *cls*.

    Where there is no registered implementation for a specific type, its method
    resolution order is used to find a more generic implementation.

    Note: if *registry* does not contain an implementation for the base
    *object* type, this function may return None.

    "
    (define mro   (_compose_mro cls (py-keys registry)))
    (define match None)
    (define clsmro (ref cls '__mro__ '()))
    (for ((t : mro)) ()
	 (if (not (eq? match None))
	     (begin
	       ;; If *match* is an implicit ABC but there is another unrelated,
	       ;; equally matching implicit ABC, refuse the temptation to guess.
	       (if (and (in t registry)
			(not (in t    clsmro))
			(not (in match clsmro))
			(not (issubclass match t)))
		   (raise RuntimeError
			  (format #f "Ambiguous dispatch: ~a or ~a"
				  match t)))
	       (break)))
	 (if (in t registry)
	     (set! match t)))
    
    (py-get registry match))

(define (singledispatch func)
    "Single-dispatch generic function decorator.

    Transforms a function into a generic function, which can have different
    behaviours depending upon the type of its first argument. The decorated
    function acts as the default implementation, and additional
    implementations can be registered using the register() attribute of the
    generic function.

    "
    (define registry         (py-set))
    (define dispatch_cache   (weak-key-dict))
    (define cache_token      None)

    (define (dispatch cls)
        "generic_func.dispatch(cls) -> <function implementation>

        Runs the dispatch algorithm to return the best available implementation
        for the given *cls* registered on *generic_func*.

        "
	
        (if (not (eq? cache_token None))
            (let ((current_token (get_cache_token)))
	      (if (not (equal? cache_token current_token))
		  (begin
		    (py-clear dispatch_cache)
		    (set! cache_token current_token)))))

	(let ((impl (try
		     (lambda () (pylist-ref dispatch_cache cls))
		     (#:except KeyError =>
			       (lambda x
				 (_find_impl cls registry))))))
	  (pylist-set! dispatch_cache cls impl)
	  impl))
    
    (def (register cls (= func None))
        "generic_func.register(cls, func) -> func

        Registers a new implementation for the given *cls* on a *generic_func*.

        "
        (if (eq? func None)
            (lambda (f) (register cls f))
	    (begin
	      (pylist-set! registry cls func)
	      (if (and (eq? cache_token None)
		       (ref cls '__abstractmethods__))
		  (set! cache_token (get_cache_token)))
	      (py-clear dispatch_cache)
	      func)))

    (def (wrapper (* args) (** kw))
	 (py-apply (dispatch (ref (pylist-ref args 0) '__class__))
		   (* args) (** kw)))

    (pylist-set! registry object func)
    (set wrapper 'register register)
    (set wrapper 'dispatch dispatch)
    (set wrapper 'registry  registry)
    (set wrapper '_clear_cache (ref dispatch_cache 'clear))
    (update_wrapper wrapper func)

    wrapper)