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

(define-module (language python module)
  #:use-module (oop pf-objects)
  #:use-module (oop goops)
  #:use-module (ice-9 match)
  #:use-module (system syntax)
  #:use-module (language python exceptions)
  #:use-module (language python yield)
  #:use-module (language python try)
  #:use-module (language python dir)
  #:use-module (language python list)
  #:use-module (language python dict)
  #:export (Module private public import __import__ modules))

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

(define-syntax-rule (in-scheme x)
  (let ((lan (current-language)))
    (dynamic-wind
	(lambda () (current-language 'scheme))
	(lambda () x)
	(lambda () (current-language lan)))))

(define (private mod)
  ((ref mod '__setprivate__) #t))
(define (public mod)
  ((ref mod '__setprivate__) #f))

(define e (list 'e))

(define _k
  (lambda (k)
    (if (string? k)
	(string->symbol k)
	k)))

(define _m
  (lambda (self)
    (if (rawref self '_private)
	(rawref self '_module)
	(rawref self '_export))))

(define (globals self)  
  (aif it (rawref self '_export)
       it
       (rawref self '_module)))

(define-python-class Module ()
  (define _modules (make-hash-table))
  (define __setprivate__
    (lambda (self p)
      (rawset self '_private p)))

  (define _cont
    (lambda (self id pre l nm skip-error?)
      (if id
	  (aif it (rawref self id)
	       ((ref it '__init__) pre l nm)
	       (begin
		 (rawset self id (Module pre l nm))
		 (_make self pre nm skip-error?)))
          (aif it (and (module-defined? (current-module) (car nm))
                       (module-ref (current-module) (car nm)))
               (if (module? it)
                   (begin
                     ((rawref it '__init__) pre l nm)
                     it)
                   (_make self pre nm skip-error?))
               (_make self pre nm skip-error?)))))

  (define _contupdate
    (lambda (self id pre l nm)
      (if id
	  (aif it (rawref self id)
	       ((ref it '__update__) pre l nm)
	       (rawset self id (Module pre l nm)))
	  #f)))

    (define __init__
      (case-lambda
        ((self pre l nm)
         (match l
           ((name)
            (rawset self '_path (reverse (cons name pre)))	      
            (_cont self #f   (cons name pre) #f (cons name nm) #f))
       
           ((name . (and l (name2 . _)))
            (rawset self '_path (reverse (cons name pre)))
            (_cont self name2 (cons name pre) l  (cons name nm) #t))))
       
        
        ((self l nm)
         (_cont self #f l #f nm #f))

        ((self l)
         (if (pair? l)
             (if (and (> (length l) 3)
                      (equal? (list (list-ref l 0)
                                    (list-ref l 1)
                                    (list-ref l 2))
                              '(language python module)))
                 (__init__ self (reverse '(language python module)) (cdddr l)
                           '())
                 (__init__ self '() (reverse l) '()))
             (__init__ self
                       (append
                        '(language python module)
                        (map string->symbol
                             (string-split l #\.))))))))

  (define __update__
    (case-lambda
     ((self pre l nm)
      (match l
       ((name)
	(_contupdate self #f   (cons name pre) #f (cons name nm)))
       
       ((name . (and l (name2 . _)))
	(_contupdate self name2 (cons name pre) l  (cons name nm)))))
       

     ((self l nm)
      (_contupdate self #f l #f nm))

     ((self l)
      (if (pair? l)
	  (if (and (> (length l) 3)
		   (equal? (list (list-ref l 0)
				 (list-ref l 1)
				 (list-ref l 2))
			   '(language python module)))
	      (__update__ self (reverse '(language python module))
			   (cdddr l) '()))	      
	  (__update__ self
		      (map string->symbol
			   (string-split l #\.)))))))
  
  (define _make
    (lambda (self l nm skip-error?)
      (rawset self '_private #t)
      (if (not (rawref self '_module))
	  (begin
	    (rawset self '__name__ (string-join
                                    (map symbol->string (reverse nm)) "."))
	    (let* ((_module (in-scheme (resolve-module (reverse l))))
                   (public-i (and _module (module-public-interface _module))))
              (if (and (not skip-error?) (not public-i))
                  (raise (ModuleNotFoundError
                          (format #f "No module named ~a"
                                  (rawref self '__name__)))))
              
	      (rawset self '_export   (module-public-interface _module))
	      (rawset self '_module   _module)
	      (hash-set! _modules l self))))))
      
  (define __getattribute__
    (lambda (self k)
      (define (fail)
	(raise (AttributeError "getattr in Module")))
      (let ((k (_k k)))
        (cond
         ((memq k '(__iter__ __repr__ __dir__))
          (lambda () ((rawref self k) self)))
         (else
          (let ((x (aif it (rawref self '_export)
                        (module-ref it k e)
                        e)))
            (if (eq? e x)
                (let ((x (aif it (_m self)
                              (module-ref it k e)
                              e)))
                  (if (eq? e x)
                      (let ((x (rawref self k e)))
                        (if (eq? e x)
                            (fail)
                            x))
                      x))
                x)))))))
  
  (define __setattr__
    (lambda (self k v)
      (let ((k     (_k k))
	    (fail  (lambda () (raise KeyError "setattr in Module" k))))
	(if (rawref self k)
	    (fail)
	    (aif m (rawref self '_module)
		 (catch #t
                   (lambda ()
                     (if (module-defined? m k)
                         (module-set! m k v)
                         (module-define! m k v)))			
                   (lambda x (fail)))
		 (fail))))))

  (define __global_setitem__
    (lambda (self k v)
      (let ((k     (_k k))
	    (fail  (lambda () (raise KeyError "setattr in Module" k))))
        (aif m (rawref self '_module)
             (catch #t
               (lambda ()
                 (if (module-defined? m k)
                     (module-set! m k v)
                     (begin
                       (module-define! m k v)
                       (module-export! m (list k)))))
               (lambda x (fail)))
             (fail)))))

  (define __global_getitem__
    (lambda (self k)
      (let ((k     (_k k))
	    (fail  (lambda () (raise KeyError "global setattr in Module" k))))
        (aif m (rawref self '_export)
             (catch #t
               (lambda ()
                 (if (module-defined? m k)
                     (module-ref m k)
                     (fail)))
               (lambda x (fail)))
             (fail)))))

  (define __global_get__
    (lambda (self k . es)
      (let ((k     (_k k))
	    (fail  (lambda () (raise KeyError "global setattr in Module" k))))
        (aif m (rawref self '_export)
             (catch #t
               (lambda ()
                 (if (module-defined? m k)
                     (module-ref m k)
                     (if (pair? es) (car es) #f)))
               (lambda x (fail)))
             (fail)))))
  
  (define __delattr__
    (lambda (self k)
      (define (fail) (raise KeyError "delattr in Module"))
      (aif m (rawref self '_module)
	  (let ((k (_k k)))
	    (if (module-defined? m k)
		(module-remove!  m k)
		(raise KeyError "delattr of missing key in Module")))
	  (fail))))

  (define __dir__
    (lambda (self)
      (let* ((h (slot-ref self 'h))
	     (l '())
             (m (_m self))
	     (add (lambda (k . u)
                    (if (not (in "-" (symbol->string k)))
                        (set! l (cons (symbol->string k) l))))))
	(hash-for-each add h)
        (if m (module-for-each add m))
	(aif it (rawref self '_export) (module-for-each add it))
        (hash-for-each add (slot-ref self 'h))
	(py-list l))))


  (define __iter__
    (lambda (self)
      (let* ((h (slot-ref self 'h))
	     (l '())
             (m (_m self))
	     (add (lambda (k v)
                    (let ((k (symbol->string k)))
                      (if (and (not (in "-" k)) (variable-bound? v))
                          (set! l (cons (list k (variable-ref v))
                                        l)))))))
        (module-for-each add m)
	(module-for-each add (rawref self '_export))
	l)))

  (define __global_iter__
    (lambda (self)
      (let* ((m (globals self))
             (l '())
	     (add (lambda (k v)
                    (let ((k (symbol->string k)))
                      (if (and (not (in "-" k)) (variable-bound? v))
                          (set! l (cons (list k (variable-ref v))
                                        l)))))))
        (module-for-each add m)
	l)))

	
  
  (define __repr__
    (lambda (self) (format #f "Module(~a)" (rawref self '__name__))))

  (define __getitem__
    (lambda (self k)
      (define k (if (string? k) (string->symbol k) k))
      (__getattribute__ self k)))) 


(define-syntax import
  (lambda (x)
    (syntax-case x ()
      ((_ (a ...) var)
       #`(import-f #,(case (syntax-local-binding #'var)
		       ((lexical)
			#'var)
		       ((global)
			#'(if (module-defined? (current-module)
					       (syntax->datum #'var))
			      var
			      #f))
		       (else
			#f)) a ...)))))

(define (m? x) ((@ (language python module _python) isinstance) x Module))
(define (import-f x f . l)
  (if x
      (if (m? x)
	  (begin (apply (rawref x '__update__) x l) x)
	  (apply f l))
      (apply f l)))

(define-python-class ms (dict)
  (define __getitem__
    (lambda (self k)
      (if (string? k)
          (aif it (py-get (slot-ref self 't) k #f)
               it
               (let* ((l   (map string->symbol (string-split k #\.)))
                      (pth (cons* 'language 'python 'module l)))
                 (Module (reverse pth) (reverse l))))
          (pylist-ref (slot-ref self 't) k))))

  (define get
    (lambda* (self k #:optional (e #f))
      (if (string? k)
          (aif it (py-get (slot-ref self 't) k #f)
               it
               (let* ((l   (map string->symbol (string-split k #\.)))
                      (pth (cons* 'language 'python 'module l)))
                 (Module (reverse pth) (reverse l))))
          (py-get (slot-ref self 't) k e)))))
      
          

(define modules (ms))
(define (__import__ x)
  (let ((x (py-get modules x #f)))
    (if x
        (values)
        (let ((e (Module x)))
          (pylist-set! modules x e)
          e))))

(set! (@@ (oop pf-objects) Module) Module)