(define-module (language python procedure)
  #:use-module (oop pf-objects)
  #:use-module (oop goops)
  #:use-module (language python dir)
  #:use-module (language python try)
  #:use-module (language python def)
  #:use-module (language python list)
  #:use-module (language python for)
  #:use-module (language python exceptions)
  #:use-module (language python dict)
  #:export (function))

(define procedure-property-      (@@ (oop pf-objects) procedure-property-))
(define procedure-properties-    (@@ (oop pf-objects) procedure-properties-))
(define set-procedure-property!- (@@ (oop pf-objects) set-procedure-property!-))
(define set-procedure-properties!- (@@ (oop pf-objects) set-procedure-properties!-))

(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))

(define-python-class function ()
  (define __init__
    (lambda x (error "function objects not implemented")))

  (define __call__
    (lam ((* l) (** kw))
	 (py-apply (* l) (** kw)))))

(define e (list 'e))
  
(define-method (ref (f <procedure>) tag . l)
  (apply ref-f f tag l))

(define-method (ref (f <generic>) tag . l)
  (apply ref-f f tag l))

(define-method (rawref (f <procedure>) tag . l)
  (apply ref-f f tag l))

(define-method (rawref (f <generic>) tag . l)
  (apply ref-f f tag l))

(define (ref-f f tag . l)    
  (set! tag (if (symbol? tag) tag (string->symbol tag)))
  
  (cond
   ((equal? tag '__class__)
    function)
   
   ((equal? tag '__name__)
    (let ((r (procedure-property- f '__name__)))
      (if (not r)
	  (symbol->string (procedure-name f))
	  r)))

   ((equal? tag '__doc__)
    (let ((r (procedure-property- f tag)))
      (if (not r)
	  ""
	  r)))

   ((equal? tag '__qualname__)
    (aif it (procedure-property- f '__qualname__)
	 it
	 (procedure-name f)))

   ((equal? tag '__dict__)
    (dict (let lp ((l (procedure-properties- f)))
	    (if (pair? l)
		(cons (list (car l) (cdr l))
		      (lp (cdr l)))
		'()))))
   
   ((equal? tag '__annotations__)
    (procedure-property- f '__annotations__))

   ((equal? tag '__closure__)
    (error "closure property is not implemented"))

   ((equal? tag  '__code__)
    (error "code tag is not implemented"))

   ((equal? tag '__defaults)
    (error "defaults tag is not implemented"))
   
   ((equal? tag '__kwdefaults__)
    (error "kwdefaults tag is not implemented"))
   
   (else
    (let ((r (procedure-property- f tag)))
      (if (not r)
	  (if (pair? l) (car l) #f)
	  r)))))

(define fixed '(__class__
		__call__
		__get__
		__annotations__
		__closure__
		__dict__
		__globals__
		__defaults__
		__kwdefaults__))

(define fixed-str (map symbol->string fixed))

(define-method (set (x <procedure>)  key val)
  (set-f x key val))

(define-method (set (x <generic>)  key val)
  (set-f x key val))

(define-method (rawset (x <procedure>)  key val)
  (set-f x key val))

(define-method (rawset (x <generic>)  key val)
  (set-f x key val))

(define-method (py-class (o <procedure>))
  (ref o '__class__))

(define-method (py-class (o <generic>))
  (ref o '__class__))

(define (set-f f tag val)
  (set! tag (if (symbol? tag) tag (string->symbol tag)))  

  (cond
   ((equal? tag '__name__)
    (set-procedure-property!- f 'name
			     (if (symbol? val)
				 val
				 (string->symbol val))))
   ((equal? tag '__dict__)
    (set-procedure-properties!- f
			       (for ((k v : val)) ((l '()))
				    (cons (cons k v) l)
				    #:final
				    (reverse l))))
   (else
    (set-procedure-property!- f tag val))))

(define-method (dir (o <procedure>))
  (let ((ret (+ (to-pylist '("__name__" "__qualname__"))
		(to-pylist fixed-str)		
		(to-pylist (map (lambda (x)
				  (let ((x (car x)))
				    (if (symbol? x)
					(symbol->string x)
					x)))
				(procedure-properties- o))))))
    (pylist-sort! ret)
    ret))

(define-method (dir (o <generic>))
  (let ((ret (+ (to-pylist '("__name__" "__qualname__"))
		(to-pylist fixed-str)		
		(to-pylist (map (lambda (x)
				  (let ((x (car x)))
				    (if (symbol? x)
					(symbol->string x)
					x)))
				(procedure-properties- o))))))
    (pylist-sort! ret)
    ret))