86e799dd99940939d9e8bf91707796300a53a418 — Timur Ismagilov 5 years ago b84cd77
Refactor `prepare`
1 files changed, 42 insertions(+), 68 deletions(-)

M prepare.scm
M prepare.scm => prepare.scm +42 -68
@@ 10,82 10,56 @@
         (srfi 69)
         (clojurian syntax)

 ;; `elt` is either a list or an atom.
 ;; if `elt` is a list, eval it according to (car `elt`) signature.
 ;; else return `elt`.
 (define (aeval elt)
   (if (list? elt)
       (let* ((λ-name (string->symbol (car elt)))
              (signature-parser (make-signature-parser λ-name)))
         (cons (symbol-append '/agidel/ λ-name) (signature-parser (cdr elt))))

 (define (aquote elt)
   (eval (list 'quote elt)))
 ;; Hash-table of signatures.
 (define signatures (make-hash-table))

 ;; Return function that will transform (either quote or aeval) args of a
 ;; function.
 (define (make-signature-parser λ-name)
   (define signature (hash-table-ref signatures λ-name))
 (define (aquote expr)
   (quote expr))

   ;; q → quote
   ;; e → aeval
   (define (q/e->λ q/e)
     (case q/e
       ((q) aquote)
       ((e) aeval)))
 (define (q/e->λ q/e)
    ((eq? q/e 'q) aquote)
    ((eq? q/e 'e) aeval)))

   ;; Signature parser for macros with signatures that are proper lists:
   ;; (a a a a).
   (define normal-signature
     (lambda args
       (let* ((signature-λ (map q/e->λ signature))
              (expected-length (length signature))
              (args-length (length args)))
         (if (eq? args-length expected-length)
             (map eval (zip signature-λ args))
               (format (current-error-port)
                       "Error when expanding `~A`: got ~A args instead of ~A."
                       λ-name args-length expected-length)
               (exit 1))))))
 (define (make-parser name-of-λ)
   (define signature (hash-table-ref signatures name-of-λ))

   ;; Signature parser for macros with signatures that are dotted lists:
   ;; (a a a . a).
   (define normal+rest-signature
     (lambda args
       (let* ((normal-part-length (length+ args))
               (map q/e->λ (take signature normal-part-length)))
              (normal-part (take args normal-part-length))
               (q/e->λ (drop signature normal-part-length)))
              (rest-part (drop args normal-part-length)))
         (append (map eval (zip normal-part-signature normal-part))
                 (map rest-part-q/e rest-part)))))
   (define (rest-parser . args)
     (define λ (q/e->λ signature))
     (map λ args))
   (define (normal-parser . args)
     (define λs (map q/e->λ signature))
     (map (lambda (λ+arg)
            ((car λ+arg) (cdr λ+arg)))
          (zip λs args)))

   ;; Signature parser for macros with signatures that are symbols: a.
   (define rest-signature
     (lambda args
       (map (q/e->λ signature) args)))
   (define (normal+rest-parser . args)
     (define normal-length (length+ signature))
     (define normal-λs (map q/e->λ (take signature normal-length)))
     (define rest-λ (q/e->λ (drop signature normal-length)))

   (define signature-parser
      ((symbol? signature) rest-signature)
      ((proper-list? signature) normal-signature)
      ((dotted-list? signature) normal+rest-signature)))
     (append (map (lambda (λ+arg) ((car λ+arg) (cdr λ+arg)))
                  (zip normal-λs args))
             (map rest-λ (drop args normal-length))))

    ((symbol? signature)      rest-parser)
    ((proper-list? signature) normal-parser)
    ((dotted-list? signature) normal+rest-parser)))

 (define (aeval expr)
    ((list? expr)
     (let* ((name-of-λ   (string->symbol (car expr)))
            (name-of-λ*  (symbol-append '/agidel/ name-of-λ))
            (args        (cdr expr))
            (parser      (make-parser name-of-λ))
            (parsed-args (parser args)))
       (cons name-of-λ* parsed-args)))
    (else expr)))

 (define (main source-string plugin-list)
   (set! signatures (plugin/signatures plugin-list))
   (-> source-string
       (as-> x (map aeval x))
       (as-> x (map (lambda (e) (format "~S" e)) x))
       (as-> x (string-join x "\n" 'suffix)))))
 (define (main source-string plugins)
   (set! signatures (plugin/signatures plugins))
   (map aeval
        (core/parse-string source-string))))