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