modules/language/python/def.scm

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