i am the cl-bnf god now

(defun stringify (thing)
  (coerce thing 'string))

(defmacro shuffle-parts (input-parts (tag &rest output-parts))
  (let ((input-parts
         (loop for part in input-parts collect (list part
                                                     (gensym (string part))
                                                     (eql part '_)))))
    `(lambda (parts)
       (destructuring-bind ,(mapcar #'second input-parts) parts
         (declare (ignore ,@(mapcar #'second (remove-if-not #'third input-parts))))
         (list ',tag ,@(loop for part in output-parts
                          collect (second (assoc part input-parts))))))))

(set-dispatch-macro-character #\# #\~
                              (lambda (s c n)
                                (destructuring-bind (input output) (read s)
                                  (macroexpand-1 `(shuffle-parts ,input ,output)))))

(define-grammar pdl-parser
    whitespace := (:many (:char #\Space))

    pdl-number := (:many (:one #'digit-char-p))
               :call (lambda (match) (parse-integer (stringify match)))

    pdl-at          := (:char #\@)
    pdl-left-paren  := (:char #\()
    pdl-right-paren := (:char #\))
    pdl-mutate      := (:string ":=")

    pdl-binop-colon := (:char #\:)
    pdl-monop-stop  := (:char #\.)
    pdl-binop-sym   := (:and #'pdl-word #'pdl-binop-colon)
                    :call (lambda (match) (first match))
    pdl-monop-sym   := (:and #'pdl-word #'pdl-monop-stop)
                    :call (lambda (match) (first match))

    pdl-word        := (:many (:one #'alpha-char-p))
                    :call (lambda (match) (stringify match))

    pdl-binop       := (:and #'pdl-term #'whitespace #'pdl-binop-sym
                             #'whitespace #'pdl-expression)
                    :call #~((a _ s _ c) (:binop s a c))

    pdl-monop       := (:and #'pdl-term #'whitespace #'pdl-monop-sym)
                    :call #~((s _ t) (:monop t s))

    pdl-mutation    := (:and #'pdl-word #'whitespace #'pdl-mutate
                             #'whitespace #'pdl-expression)
                    :call #~((a _ _ _ b) (:mutate a b))

    pdl-getter-fn   := (:and #'pdl-at #'pdl-word)
                    :call (lambda (match) `(:getter ,(second match)))

    pdl-paren-wrap  := (:and #'pdl-left-paren #'pdl-expression #'pdl-right-paren)
                    :call (lambda (match) (second match))

    pdl-term        := (:or #'pdl-getter-fn #'pdl-number #'pdl-word #'pdl-paren-wrap)

    pdl-expression  := (:or #'pdl-mutation #'pdl-monop #'pdl-binop #'pdl-term)
    )