From 4e5352b2349eb41ddeb972696cfd2b41c6e4b20d Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Mon, 19 Mar 2018 16:18:44 +0100 Subject: modules improvements --- modules/language/python/module.scm | 185 ++++++++++++++++++++++++++++--------- 1 file changed, 140 insertions(+), 45 deletions(-) (limited to 'modules/language/python/module.scm') diff --git a/modules/language/python/module.scm b/modules/language/python/module.scm index 615d163..55120e0 100644 --- a/modules/language/python/module.scm +++ b/modules/language/python/module.scm @@ -1,11 +1,20 @@ (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) - #:export (Module)) + #:export (Module private public import)) + +(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) + +(define (private mod) + ((ref mod '__setprivate__) #t)) +(define (public mod) + ((ref mod '__setprivate__) #f)) (define e (list 'e)) @@ -22,21 +31,48 @@ (rawref self '_export)))) (define-python-class Module () + (define _modules (make-hash-table)) (define __setprivate__ (lambda (self p) - (set self '_isprivate p))) + (rawset self '_isprivate p))) + + (define _cont + (lambda (self id pre l nm) + (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))) + (_make self pre nm)))) + (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) + (pk 2 l) (match l - ((name) - (_make self (cons name pre) (cons name nm))) - ((name . (and l (name2 . _))) - (set self name2 (Module (cons name pre) l (cons name nm))) - (_make self (cons name pre) (cons name nm))))) - - ((self l) + ((name) + (set self '_path (reverse (cons name pre))) + (_cont self #f (cons name pre) #f (cons name nm))) + + ((name . (and l (name2 . _))) + (set self '_path (reverse (cons name pre))) + (_cont self name2 (cons name pre) l (cons name nm))))) + + + ((self l nm) + (_cont self #f l #f nm)) + + ((self l) + (pk 1) (if (pair? l) (if (and (> (length l) 3) (equal? (list (list-ref l 0) @@ -44,26 +80,59 @@ (list-ref l 2)) '(language python module))) (__init__ self (reverse '(language python module)) (cdddr l) '()) - (_make self l l)) + #f) (__init__ self (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))) + (__uppdate__ self (reverse '(language python module)) + (cdddr l) '())) + (__update__ self + (map string->symbol + (string-split l #\.))))))) + (define _make (lambda (self l nm) - (begin - (set self '_private #f) - (set self '__dict__ self) - (set self '__name__ (string-join (map symbol->string (reverse nm)) ".")) - (let ((_module (resolve-module (reverse l)))) - (set self '_export (module-public-interface _module)) - (set self '_module _module))))) - + (pk 'make) + (rawset self '_private #f) + (if (not (rawref self '_module)) + (begin + (pk 'a) + (set self '__dict__ self) + (set self '__name__ (string-join + (map symbol->string (reverse nm)) ".")) + (pk 'b) + (let ((_module (resolve-module (reverse l)))) + (set self '_export (module-public-interface _module)) + (set self '_module _module) + (pk 'c) + (hash-set! _modules l self)))))) + (define __getattribute__ - (lambda (self k . l) + (lambda (self k) (define (fail) - (if (pair? l) - (car l) - (raise KeyError "getattr in Module"))) + (raise KeyError "getattr in Module")) + (if (rawref self '_module) (let ((k (_k k)) (m (_m self))) @@ -79,29 +148,27 @@ (fail (lambda () (raise KeyError "getattr in Module")))) (if (rawref self k) (fail) - (if (rawref self '_module) - (let ((m (_m self))) - (catch #t - (lambda () - (if (module-defined? m k) - (module-set! m k v) - (module-define! m k v))) - (lambda x (pk 'fail x)))) - (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 (pk 'fail x))) + (fail)))))) (define __delattr__ (lambda (self k) (define (fail) (raise KeyError "getattr in Module")) - (if (rawref self '_module) - (let ((m (_m self)) - (k (_k k))) + (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 __repr__ - (lambda (self) (ref self '__name__))) + (lambda (self) (format #f "Module(~a)" (ref self '__name__)))) (define __getitem__ (lambda (self k) @@ -110,14 +177,42 @@ (define __iter__ (lambda (self) - (define m (_m self)) + (define m (_m obj)) ((make-generator () - (lambda (yield) - (define l '()) - (define (f k v) (set! l (cons (list (symbol->string k) v) l))) - (module-for-each f m) - (let lp ((l l)) - (if (pair? l) - (begin - (apply yield (car l)) - (lp (cdr l))))))))))) + (lambda (yield) + (define l '()) + (define (f k v) (set! l (cons (list (symbol->string k) v) l))) + (module-for-each f m) + (let lp ((l l)) + (if (pair? l) + (begin + (apply yield (car l)) + (lp (cdr l))))) + (hash-for-each yield (slot-ref self 'h)))))))) + + + +(define-syntax import + (lambda (x) + (pk (syntax->datum x)) + (syntax-case x () + ((_ (a ...) var) + #`(import-f #,(case (pk (syntax-local-binding #'var)) + ((lexical) + #'var) + ((global) + #'(if (pk (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) + (pk 'import-f f x) + (pk (if x + (if (m? x) + (apply (rawref x '__update__) l) + (apply f l)) + (apply (pk f) l)))) -- cgit v1.2.3