modules improvements
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Mon, 19 Mar 2018 15:18:44 +0000 (16:18 +0100)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Mon, 19 Mar 2018 15:18:44 +0000 (16:18 +0100)
modules/language/python/compile.scm
modules/language/python/module.scm
modules/oop/pf-objects.scm

index d0e1ca57d383eb1f18cfa5be9a6b50168e62513f..3d9fc951a948cab68dc23681afe294a28ed04340 100644 (file)
                      l)
                     (l l)))))))))))
 
+ (#:verb
+  ((_ x) x))
  (#:scm
   ((_ (#:string _ s)) (with-input-from-string s read)))
  
  (#:import
-  ((_ (#:from (() nm) . #f))
-   `(use-modules (language python module ,(exp vs nm))))
+  ((_ (#:from (() . nm) . #f))
+   `(use-modules (language python module ,@(map (lambda (nm) (exp vs nm))
+                                               nm))))
   
-  ((_ (#:name ((ids ...) . as) ...))
+  ((_ (#:name ((ids ...) . as)) ...)
+   (pk x)
    `(begin
-      ,@(map (lambda (ids as)
-               (let* ((syms (map (g vs exp) ids))
-                      (id   (if as (exp vs as) (car (reverse syms)))))
-                 (add-prefix id)
-                 `(use-modules ((language python module ,@syms)
-                                #:prefix
-                                ,(string->symbol
-                                  (string-append (symbol->string id) "."))))))
-             ids as))))
-                             
-                                   
-  
+      ,@(map
+        (lambda (ids as)            
+          (let ((path (map (g vs exp) ids)))
+            (if as
+                (exp
+                 vs
+                 `(#:expr-stmt
+                   ((#:test (#:power #f ,as ())))
+                   (#:assign 
+                    ((#:verb
+                      ((@ (language python module) Module)
+                       ',(reverse (append '(language python module) path))
+                       ',(reverse path)))))))
+                      
+                (exp
+                 vs
+                 `(#:expr-stmt
+                   ((#:test (#:power #f ,(car ids) ())))
+                   (#:assign
+                    ((#:verb
+                      (((@ (language python module) import)
+                        ((@ (language python module) Module)
+                         ',(append '(language python module) path))
+                        ,(exp vs (car ids))))))))))))
+        ids as))))
+              
  (#:for
   ((_ e in code . #f)
    (=> next)
        (cons 'values (map (g vs exp) l))
        (exp vs (car l)))))
   
-
  (#:expr-stmt
   ((_ (l ...) (#:assign))
    (let ((l (map (g vs exp) l)))
index 615d163a5aae7f8aaf0dbffbc19da1b77c0eea46..55120e01890517f50c857be412b79b98ae80fa37 100644 (file)
@@ -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))
 
        (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)
                                 (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)))
            (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)
   
   (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))))
index 5b7806332c89e6ffb258e14e4bb3dd58eec158fb..0f583268231d45b0fa8fed4462de89b1edaa3b07 100644 (file)
@@ -2,6 +2,7 @@
   #:use-module (oop goops)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
   #:use-module (logic guile-log persistance)
   #:replace (equal?)  
   #:export (set ref make-p <p> <py> <pf> <pyf> <property>
@@ -13,7 +14,7 @@
                 py-super-mac py-super py-equal? 
                 *class* *self* pyobject? pytype?
                 type object pylist-set! pylist-ref tr
-               resolve-method rawref
+               resolve-method rawref rawset
                 ))
 
 #|
@@ -426,6 +427,9 @@ explicitly tell it to not update etc.
 (define-method (set (x <pyf>) key val) (mklam (mset-py  x key) val))
 (define-method (set (x <py>)  key val) (mklam (mset-py  x key) val))
 
+(define-method (rawset (x <pf>)  key val) (mklam (mset     x key) val))
+(define-method (rawset (x <p>)   key val) (mklam (mset     x key) val))
+
 ;; mref will reference the value of the key in the object x, an extra default
 ;; parameter will tell what the fail object is else #f if fail
 ;; if there is no found binding in the object search the class and
@@ -924,6 +928,10 @@ explicitly tell it to not update etc.
     ((_ class self)
      (py-super class self))))
 
+(define (pp x)
+  (pretty-print (syntax->datum x))
+  x)
+
 (define-syntax letruc
   (lambda (x)
     (syntax-case x ()