modules/language/python/module.scm

   1 (define-module (language python module)
   2   #:use-module (oop pf-objects)
   3   #:use-module (oop goops)
   4   #:use-module (ice-9 match)
   5   #:use-module (system syntax)
   6   #:use-module (language python exceptions)
   7   #:use-module (language python yield)
   8   #:use-module (language python try)
   9   #:use-module (language python dir)
  10   #:export (Module private public import))
  11
  12 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
  13
  14 (define-syntax-rule (in-scheme x)
  15   (let ((lan (current-language)))
  16     (dynamic-wind
  17         (lambda () (current-language 'scheme))
  18         (lambda () x)
  19         (lambda () (current-language lan)))))
  20
  21 (define (private mod)
  22   ((ref mod '__setprivate__) #t))
  23 (define (public mod)
  24   ((ref mod '__setprivate__) #f))
  25
  26 (define e (list 'e))
  27
  28 (define _k
  29   (lambda (k)
  30     (if (string? k)
  31         (string->symbol k)
  32         k)))
  33
  34 (define _m
  35   (lambda (self)
  36     (if (rawref self '_private)
  37         (rawref self '_module)
  38         (rawref self '_export))))
  39
  40 (define-python-class Module ()
  41   (define _modules (make-hash-table))
  42   (define __setprivate__
  43     (lambda (self p)
  44       (rawset self '_isprivate p)))
  45
  46   (define _cont
  47     (lambda (self id pre l nm skip-error?)
  48       (if id
  49           (aif it (rawref self id)
  50                ((ref it '__init__) pre l nm)
  51                (begin
  52                  (rawset self id (Module pre l nm))
  53                  (_make self pre nm skip-error?)))
  54           (_make self pre nm skip-error?))))
  55
  56   (define _contupdate
  57     (lambda (self id pre l nm)
  58       (if id
  59           (aif it (rawref self id)
  60                ((ref it '__update__) pre l nm)
  61                (rawset self id (Module pre l nm)))
  62           #f)))
  63
  64   (define __init__
  65     (case-lambda
  66      ((self pre l nm)
  67       (match l
  68        ((name)
  69         (set self '_path (reverse (cons name pre)))
  70         (_cont self #f   (cons name pre) #f (cons name nm) #f))
  71
  72        ((name . (and l (name2 . _)))
  73         (set self '_path (reverse (cons name pre)))
  74         (_cont self name2 (cons name pre) l  (cons name nm) #t))))
  75
  76
  77      ((self l nm)
  78       (_cont self #f l #f nm #f))
  79
  80      ((self l)
  81       (if (pair? l)
  82           (if (and (> (length l) 3)
  83                    (equal? (list (list-ref l 0)
  84                                  (list-ref l 1)
  85                                  (list-ref l 2))
  86                            '(language python module)))
  87               (__init__ self (reverse '(language python module)) (cdddr l) '())
  88               #f)
  89           (__init__ self
  90                     (map string->symbol
  91                          (string-split l #\.)))))))
  92   (define __update__
  93     (case-lambda
  94      ((self pre l nm)
  95       (match l
  96        ((name)
  97         (_contupdate self #f   (cons name pre) #f (cons name nm)))
  98
  99        ((name . (and l (name2 . _)))
 100         (_contupdate self name2 (cons name pre) l  (cons name nm)))))
 101
 102
 103      ((self l nm)
 104       (_contupdate self #f l #f nm))
 105
 106      ((self l)
 107       (if (pair? l)
 108           (if (and (> (length l) 3)
 109                    (equal? (list (list-ref l 0)
 110                                  (list-ref l 1)
 111                                  (list-ref l 2))
 112                            '(language python module)))
 113               (__update__ self (reverse '(language python module))
 114                            (cdddr l) '()))
 115           (__update__ self
 116                       (map string->symbol
 117                            (string-split l #\.)))))))
 118
 119   (define _make
 120     (lambda (self l nm skip-error?)
 121       (rawset self '_private #f)
 122       (if (not (rawref self '_module))
 123           (begin
 124             (set self '__dict__ self)
 125             (set self '__name__ (string-join
 126                                  (map symbol->string (reverse nm)) "."))
 127             (let* ((_module (in-scheme (resolve-module (reverse l))))
 128                    (public-i (and _module (module-public-interface _module))))
 129               (if (and (not skip-error?) (not public-i))
 130                   (raise (ModuleNotFoundError
 131                           (format #f "No module named ~a"
 132                                   (ref self '__name__)))))
 133
 134               (set self '_export (module-public-interface _module))
 135               (set self '_module _module)
 136               (hash-set! _modules l self))))))
 137
 138   (define __getattribute__
 139     (lambda (self k)
 140       (define (fail)
 141         (raise (KeyError "getattr in Module")))
 142       (aif it (rawref self k)
 143            it
 144            (if (rawref self '_module)
 145                (let ((k (_k k))
 146                      (m (_m self)))
 147                  (let ((x (module-ref m k e)))
 148                    (if (eq? e x)
 149                        (fail)
 150                        x)))
 151                (fail)))))
 152
 153   (define __setattr__
 154     (lambda (self k v)
 155       (let ((k     (_k k))
 156             (fail  (lambda () (raise KeyError "getattr in Module" k))))
 157         (if (rawref self k)
 158             (fail)
 159             (aif m (rawref self '_module)
 160                  (catch #t
 161                    (lambda ()
 162                      (if (module-defined? m k)
 163                          (module-set! m k v)
 164                          (module-define! m k v)))
 165                    (lambda x (fail)))
 166                  (fail))))))
 167
 168   (define __delattr__
 169     (lambda (self k)
 170       (define (fail) (raise KeyError "getattr in Module"))
 171       (aif m (rawref self '_module)
 172           (let ((k (_k k)))
 173             (if (module-defined? m k)
 174                 (module-remove!  m k)
 175                 (raise KeyError "delattr of missing key in Module")))
 176           (fail))))
 177
 178   (define __repr__
 179     (lambda (self) (format #f "Module(~a)" (ref self '__name__))))
 180
 181   (define __getitem__
 182     (lambda (self k)
 183       (define k (if (string? k) (string->symbol k) k))
 184       (__getattribute__ self k)))
 185
 186   (define __iter__
 187     (lambda (self)
 188       (define m (_m self))
 189       ((make-generator ()
 190        (lambda (yield)
 191          (define l '())
 192          (define (f k v) (set! l (cons (list (symbol->string k) v) l)))
 193          (module-for-each f m)
 194          (let lp ((l l))
 195            (if (pair? l)
 196                (begin
 197                  (apply yield (car l))
 198                  (lp (cdr l)))))))))))
 199
 200
 201
 202 (define-syntax import
 203   (lambda (x)
 204     (syntax-case x ()
 205       ((_ (a ...) var)
 206        #`(import-f #,(case (syntax-local-binding #'var)
 207                        ((lexical)
 208                         #'var)
 209                        ((global)
 210                         #'(if (module-defined? (current-module)
 211                                                (syntax->datum #'var))
 212                               var
 213                               #f))
 214                        (else
 215                         #f)) a ...)))))
 216
 217 (define (m? x) ((@ (language python module python) isinstance) x Module))
 218 (define (import-f x f . l)
 219   (if x
 220       (if (m? x)
 221           (begin (apply (rawref x '__update__) l) x)
 222           (apply f l))
 223       (apply f l)))