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

(define-module (language python module _python)
  #:use-module (oop goops)
  #:use-module (ice-9 match)
  #:use-module (ice-9 readline)
  #:use-module ((oop pf-objects) #:select
                (<p> <property> class-method static-method ref (set . pf-set)
                     py-super-mac type object pylist-ref define-python-class
		     object-method py-dict))
  #:use-module (language python exceptions       )
  #:use-module ((language python module string   ) #:select ())
  #:use-module ((language python module io       ) #:select (open))
  #:use-module (language python def              ) 
  #:use-module (language python for              )
  #:use-module (language python try              )
  #:use-module (language python yield            )
  #:use-module (language python module           )
  #:use-module (language python list             )
  #:use-module (language python dict             )
  #:use-module (language python set              )
  #:use-module (language python string           )
  #:use-module (language python bytes            )
  #:use-module (language python set              )
  #:use-module (language python number           )
  #:use-module (language python dir              )
  #:use-module (language python hash             )
  #:use-module (language python property         )
  #:use-module (language python range            )
  #:use-module (language python tuple            )
  #:use-module (language python eval             )
  #:use-module (language python bool             )

  #:replace (list abs min max hash round format map filter)
  
  #:re-export (StopIteration GeneratorExit RuntimeError
                             Exception ValueError TypeError
                             IndexError KeyError AttributeError
                             send sendException next
                             GeneratorExit sendClose RuntimeError
                             SyntaxError bool compile
                             len dir next dict None property range
                             tuple bytes bytearray eval locals globals
                             exec type object open __import__ frozenset
			     Warning BytesWarning DeprecationWarning
                             py-list
                             )
  
  #:export (print repr complex float int str
                  set all any bin callable reversed
                  chr classmethod staticmethod objectmethod
                  divmod enumerate 
                  getattr hasattr setattr hex isinstance issubclass
                  iter sum id input oct ord pow super
                  sorted zip vars slice))

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

(define (vars x)
  (for ((k v : x)) ((l '()))
       (cons (cons k v) l)
       #:final
       (dict l)))

(define (repr x) ((@ (guile) format) #f "~a" x))
(define abs     py-abs)
(define str     pystring)
(define complex py-complex)
(define float   py-float)
(define int     py-int)
(define round   py-round)
(define set     py-set)
(define all     py-all)
(define any     py-any)
(define bin     py-bin)
(define divmod  py-divmod)
(define format  py-format)
(define hash    py-hash)
(define hex     py-hex)

(define-method (callable  x                     ) #f)
(define-method (callable (x <procedure>        )) #t)
(define-method (callable (x <procedure-class>  )) #t)
(define-method (callable (x <applicable>       )) #t)
(define-method (callable (x <primitive-generic>)) #t)
(define-method (callable (x <p>))
  (ref x '__call__))

(define chr integer->char)

(define objectmethod object-method)
(define classmethod  class-method)
(define staticmethod static-method)

(def (enumerate l (= start 0))
  ((make-generator ()
    (lambda (yield)
       (for ((x : l)) ((i start))
            (yield i x)
           (+ i 1))))))

(define (filter f l)
  ((make-generator ()
     (lambda (yield)
       (for ((x : l)) ()
            (if (f x)
                (yield x)))))))

(define miss ((@ (guile) list) 'miss))

(define* (getattr a b #:optional (k miss))
  (let ((r (ref a (if (string? b) (string->symbol b) b) k)))
    (if (eq? r miss)
        (raise AttributeError "object/class ~a is missing attribute ~a" a b)
        r)))

(define (setattr a k v)
  (pf-set a (if (string? k) (string->symbol k) k) v))

(define (hasattr a b)
  (let ((r (ref a (if (string? b) (string->symbol b) b) miss)))
    (not (eq? r miss))))

(define-method (issubclass x y) #f)
(define-method (issubclass (sub <p>) (cls <p>))
  (aif it (ref cls '__subclasscheck__)
       (it sub)
       (if (eq? sub cls)
	   #t
	   (if (memq cls (ref sub '__mro__))
               #t
               #f))))

(define-method (isinstance x y)
  (cond
   ((null? y)
    #f)
   ((pair? y)
    (or (isinstance x (car y))
	(isinstance x (cdr y))))
   (else
    (catch #t
	   (lambda () (is-a? x y))
	   (lambda x  #f)))))

(define-method (isinstance (i <integer>) (y <p>))
  (cond
   ((ref y '__instancecheck__) =>
    (lambda (it)
      (it i)))
   (else
    (next-method))))

(define-method (isinstance (i <integer>) y)
  (if (issubclass y int)
      #t
      (if (pair? y)
	  (or (isinstance i (car y))
	      (isinstance i (cdr y)))
	  (is-a? i y))))

(define-method (isinstance (i <real>) (y <p>))
  (cond
   ((ref y '__instancecheck__) =>
    (lambda (it)
      (it i)))
   (else
    (next-method))))

(define-method (isinstance (i <real>) y)
  (if (issubclass y float)
      #t
      (if (pair? y)
	  (or (isinstance i (car y))
	      (isinstance i (cdr y)))
	  (is-a? i y))))

(define-method (isinstance (i <pair>) (y <p>))
  (cond
   ((ref y '__instancecheck__) =>
    (lambda (it)
      (it i)))
   (else
    (next-method))))

(define-method (isinstance (i <pair>) y)
  (if (issubclass y tuple)
      #t
      (if (pair? y)
	  (or (isinstance i (car y))
	      (isinstance i (cdr y)))
	  (is-a? i y))))

(define-method (isinstance (i <string>) (y <p>))
  (cond
   ((ref y '__instancecheck__) =>
    (lambda (it)
      (it i)))
   (else
    (next-method))))

(define-method (isinstance (i <string>) y)
  (if (issubclass y str)
      #t
      (if (pair? y)    
	  (or (isinstance i (car   y))
	      (isinstance i (cdr y)))
	  (is-a? i y))))

(define-method (isinstance (i <bytevector>) (y <p>))
  (cond
   ((ref y '__instancecheck__) =>
    (lambda (it)
      (it i)))
   (else
    (next-method))))

(define-method (isinstance (i <bytevector>) y)
  (if (issubclass y bytes)
      #t
      (if (pair? y)
	  (or (isinstance i (car y))
	      (isinstance i (cdr y)))
	  (is-a? i y))))


(define-method (isinstance o (cl <p>))
  (cond
   ((eq? cl py-list)
    (is-a? o <py-list>))
   (else #f)))
  
(define-method (isinstance (o <p>) (cl <p>))
  (cond
   ((ref cl '__instancecheck__) =>
    (lambda (it)
      (it o)))
   ((pair? cl)
    (or
     (isinstance o (car cl))
     (isinstance o (cdr cl))))
   (else
    (is-a? o (ref cl '__goops__)))))
	       
	       

(define iter
  (case-lambda
    ((o) (aif it (wrap-in o)
              it
              (aif get (ref o '__getitem__)
                   (make-generator iter
                                   (lambda (yield)
                                     (for () ((i 0))
                                          (yield (get i))
                                          (+ i 1))))
                   (raise TypeError "not iterable" o))))
    ((f sent)
     (make-generator iter
                     (lambda (yield)
                       (for () ()
                            (let ((r (f)))
                              (if (equal? r sent)
                                  (break)
                                  (yield r)))))))))
                               
                                      

(define-syntax map
  (lambda (x)
    (syntax-case x ()
      ((map f a ...)
       (with-syntax (((x ...) (generate-temporaries #'(a ...))))
	 #'(for ((x : a) ...) ((l '()))
	    (cons (f x ...) l)
	    #:final (py-list (reverse l))))))))
                    
(define* (sum i #:optional (start 0))
  (for ((x : i)) ((s start))
       (+ s x)
       #:final
       s))


(define (id x) (object-address x))

(define (input str)
  ((@ (guile) format) #t str)
  (readline))

(define (idx x) x)


(define-syntax min
  (lambda (x)
    (syntax-case x ()
      ((_ x y)
       #'(if (and (number? x) (number? y))
             (if (<= x y) x y)
             (py-min- x y)))

      ((_ l ...)
       #'(if (and (number? l) ...)
             ((@ (guile) min) l ...)
             (py-min- l ...)))
      (_ #'py-min-))))

(def (py-min- (* l) (= key idx) (= default miss))
     (let lp ((l l))
       (match l
         ((it)
          (for ((x : it)) ((s miss) (b miss))
               (if (eq? s miss)
                   (values (key x) x)
                   (let ((k (key x)))
                     (if (< k s)
                         (values k x)
                         (values s b))))
               #:final
               (if (eq? b miss)
		   (if (eq? default miss)
		       (raise ValueError
			      "min does not work for zero length list")
		       default)
                   b)))
         (_ (lp ((@ (guile) list) l))))))

(define-syntax max
  (lambda (x)
    (syntax-case x ()
      ((_ x y)
       #'(if (and (number? x) (number? y))
             (if (>= x y) x y)
             (py-max- x y)))
      ((_ l ...)
       #'(if (and (number? l) ...)
             ((@ (guile) max) l ...)
             (py-max- l ...)))
      (_ #'py-max-))))

(def (py-max- (* l) (= key idx) (= default miss))
     (let lp ((l l))
       (match l
         ((it)
          (for ((x : it)) ((s miss) (b miss))
               (if (eq? s miss)
                   (values (key x) x)
                   (let ((k (key x)))
                     (if (> k s)
                         (values k x)
                         (values s b))))
               #:final
               (if (eq? b miss)
		   (if (eq? default miss)
		       (raise ValueError
			      "min does not work for zero length list")
		       default)
                   b)))
         (_ (lp ((@ (guile) list) l))))))

(define (oct x) (+ "0o" (number->string (py-index x) 8)))
(define (ord x) (char->integer (string-ref (pylist-ref x 0) 0)))

(define pow
  (case-lambda
    ((x y)
     (expt x y))
    ((x y z)
     (if (and (number? y) (integer? y) (number? x) (integer? x) (number? z) (integer? z))
	 (modulo-expt x y z)
	 (modulo (expt x y) z)))))

(define-syntax-rule (super . l) (py-super-mac . l))       

(define list pylist)
(define reversed py-reversed)
(define (key-id x) x)
(define* (sorted it #:key (key key-id) (reverse #f))
  (define l (to-pylist '()))
  (for ((x : it)) () (pylist-append! l x))
  (pylist-sort! l #:key key #:reverse reverse)
  l)

(define (zip . l)
  (let ((l ((@ (guile) map) wrap-in l)))
    ((make-generator ()
      (lambda (yield)
        (let lp ()
          (let lp2 ((l l) (r '()))
            (if (pair? l)
                (call-with-values (lambda () (next (car l)))
                  (lambda z
                    (lp2 (cdr l) (append (reverse z) r))))
                (begin
                  (yield (reverse r))
                  (lp))))))))))
  
(define print
  (lam ((= file #f) (* l))
       (if file
	   (if (port? file)
	       #t
	       (set! file (ref file '_port)))
	   (set! file (current-output-port)))
       (with-output-to-port file
	 (lambda ()
	   (apply
	    (case-lambda
	     (()  ((@ (guile) display) "\n"))
	     ((x) ((@ (guile) display) x    ) (print))
	     (l   ((@ (guile) display) l    ) (print)))
	    l)))))


(define-syntax-rule (mk cl cls ? tp)
  (begin
    (set! (@@ (oop pf-objects) cl) cls)
    (set! (@@ (oop pf-objects) ? ) (lambda (x) (isinstance x tp)))))

(mk int-cls    int   int?   int)
(mk tuple-cls  tuple tuple? tuple)
(mk string-cls str   str?   str)
(mk bytes-cls  bytes bytes? bytes)
(mk list-cls   list  list?  list)
(mk float-cls  float float? float)

(define-python-class slice ()
  (define __init__
    (lam (self x (= y None) (= z None))
         (pf-set self 'x x)
         (pf-set self 'y y)
         (pf-set self 'z z))))


(set! (@@ (language python module) m?)
  (lambda (x) (isinstance x (@@ (language python module) Module))))