5c83b6f8de3fcc8580945e26a2f086333ec67bb3
[software/python-on-guile.git] / modules / language / python / def.scm
1 (define-module (language python def)
2 #:use-module (oop pf-objects)
3 #:use-module (language python for)
4 #:use-module (ice-9 match)
5 #:use-module (srfi srfi-11)
6 #:export (def lam py-apply))
7
8 (define e (list 'error))
9 (define-syntax-rule (aif it p x y) (let ((it p)) (if (not (eq? it e)) x y)))
10 (define (fold lam s l)
11 (if (pair? l)
12 (lam (car l) (fold lam s (cdr l)))
13 s))
14
15 (define-syntax-rule (take-1 pww ww* kw s v)
16 (if (not pww)
17 (values ww*
18 (aif it (hash-ref kw s e)
19 (begin
20 (hash-remove! kw s)
21 it)
22 v))
23 (if (pair? ww*)
24 (begin
25 (hash-remove! kw s)
26 (values (cdr ww*) (car ww*)))
27 (values ww*
28 (aif it (hash-ref kw s e)
29 (begin
30 (hash-remove! kw s)
31 it)
32 v)))))
33
34
35 (define (get-akw l)
36 (let lp ((l l) (args '()) (kw (make-hash-table)))
37 (match l
38 (((? keyword? k) v . l)
39 (hash-set! kw k v)
40 (lp l args kw))
41 ((x . l)
42 (lp l (cons x args) kw))
43 (()
44 (values (reverse args) kw)))))
45
46 (define hset! hash-set!)
47
48 (define (pytonize kw)
49 (hash-fold
50 (lambda (k v h)
51 (hset! h (symbol->string (keyword->symbol k)) v)
52 h)
53 (make-hash-table)
54 kw))
55
56 (define-syntax lam
57 (lambda (x)
58 (define-syntax-rule (mk get-as (k v s) x y z w)
59 (define get-as
60 (lambda (a s)
61 (syntax-case a (= * **)
62 ((= k v) x)
63 ((** k) y)
64 ((* k) z)
65 (k w)))))
66
67 (mk get-as (k v s)
68 s s s (cons #'k s))
69 (mk get-kw (k v s)
70 s (cons #'k s) s s )
71 (mk get-ww (k v s)
72 s s (cons #'k s) s )
73 (mk get-kv (k v s)
74 (cons (cons #'k #'v) s) s s s )
75
76 (define (->kw x) (symbol->keyword (syntax->datum x)))
77
78 (syntax-case x ()
79 ((_ (arg ...) code ...)
80 (let* ((as (fold get-as '() #'(arg ...)))
81 (kw (fold get-kw '() #'(arg ...)))
82 (ww- (fold get-ww '() #'(arg ...)))
83 (kv (fold get-kv '() #'(arg ...))))
84 (if (and-map null? (list kw ww- kv))
85 #`(object-method (lambda #,as code ...))
86 (with-syntax ((kw (if (null? kw)
87 (datum->syntax x (gensym "kw"))
88 (car kw)))
89 (ww (if (null? ww-)
90 (datum->syntax x (gensym "ww"))
91 (car ww-)))
92 ((k ...) (map car kv))
93 ((s ...) (map ->kw (map car kv)))
94 ((v ...) (map cdr kv)))
95 #`(object-method
96 (lambda* (#,@as . l)
97 (call-with-values (lambda () (get-akw l))
98 (lambda (ww* kw)
99 (let*-values (((ww* k) (take-1 #,(null? ww-) ww* kw s v))
100 ...)
101 (let ((ww ww*)
102 (kw (pytonize kw)))
103 code ...)))))))))))))
104
105 (define-syntax-rule (def (f . args) code ...) (define f (lam args code ...)))
106
107
108 (define (no x)
109 (and-map
110 (lambda (x)
111 (syntax-case x (* ** =)
112 ((* _) #f)
113 ((** _) #f)
114 ((= a b) #f)
115 (_ #t)))
116 x))
117
118 (define (mk-k x)
119 (if (keyword? x)
120 x
121 (symbol->keyword
122 (if (string? x)
123 (string->symbol x)
124 x))))
125
126 (define-syntax m*
127 (syntax-rules (* ** =)
128 ((_ (= a b))
129 (list (symbol->keyword 'a) b))
130 ((_ (* a)) a)
131 ((_ (** kw))
132 (for ((k v : kw)) ((l '()))
133 (cons* v (mk-k k) l)
134 #:final (reverse l)))
135 ((_ a) (list a))))
136
137 (define-syntax py-apply
138 (lambda (x)
139 (syntax-case x ()
140 ((_ f a ...)
141 (if (no #'(a ...))
142 #'(f a ...)
143 #'(apply f (let lp ((l (list (m* a) ...)))
144 (if (pair? l)
145 (append (car l) (lp (cdr l)))
146 '()))))))))
147