diff options
| -rw-r--r-- | argot.asd | 4 | ||||
| -rw-r--r-- | argot.lisp | 41 | ||||
| -rw-r--r-- | docgen.lisp | 56 |
3 files changed, 84 insertions, 17 deletions
@@ -8,6 +8,6 @@ :serial t :depends-on (#:trivia #:alexandria) :components ((:file "package") - ;(:file "grammars") - ;(:file "deflanguage") + (:file "grammars") + (:file "docgen") (:file "argot"))) @@ -118,21 +118,32 @@ and it returns VAR in that case." :lhs ',lhs :pattern ',pattern ,@(expand-functional-argument :check lhs bindings check vars) - ,@(expand-functional-argument :action lhs bindings action vars))))) - `(progn - (defvar ,name nil) - (setf ,name (make-instance 'grammar - :documentation ,documentation - :start-rule ',(first (first ruledefs)))) - ,@(loop - :for ruledef :in ruledefs - :for (lhs pattern vars check action) := (handler-case (parse-rule-def ruledef) - (invalid-rule-def (e) (invoke-debugger e))) - :for bindings := (collect-let-bindings lhs vars) - :collect (rule-includer name lhs pattern check action bindings vars)) - - (defmacro ,name (&body tokens) - (argot:parse ,name tokens)))))) + ,@(expand-functional-argument :action lhs bindings action vars))))) + (let* ((parsed-rules + (loop :for ruledef :in ruledefs + :collect (handler-case (parse-rule-def ruledef) + (invalid-rule-def (e) (invoke-debugger e))))) + (rule-adder-forms + (loop :for (lhs pattern vars check action) :in parsed-rules + :for bindings := (collect-let-bindings lhs vars) + :collect (rule-includer name lhs pattern check action bindings vars))) + (docstring + (with-output-to-string (*standard-output*) + (princ documentation) + (terpri) (terpri) + (loop :for (lhs pattern . more) :in parsed-rules + :do (write-rule-doc lhs pattern) + (terpri))))) + `(progn + (defvar ,name nil) + (setf ,name (make-instance 'grammar + :documentation ,documentation + :start-rule ',(first (first ruledefs)))) + ,@rule-adder-forms + + (defmacro ,name (&body tokens) + ,docstring + (argot:parse ,name tokens))))))) diff --git a/docgen.lisp b/docgen.lisp new file mode 100644 index 0000000..cc19133 --- /dev/null +++ b/docgen.lisp @@ -0,0 +1,56 @@ +;;;; docgen.lisp -- generate a docstring from a grammar + +(in-package #:argot) + +(defun write-rule-doc (lhs pattern) + (format *standard-output* "~15s ::= " lhs) + (write-pattern-doc pattern )) + +(defun write-sequence-doc (args ) + (loop :for (a . more) :on args + :do (write-pattern-doc a ) + (when more + (princ " " )))) + +(defun write-optional-doc (arg) + (princ "[") + (write-pattern-doc arg) + (princ "]")) + +(defun write-kleene-doc (arg) + (write-pattern-doc arg) + (princ "*")) + +(defun write-one-or-more-doc (arg) + (write-pattern-doc arg) + (princ "+")) + +(defun write-alternatives-doc (args) + (loop :for (a . more) :on args + :do (write-pattern-doc a) + (when more + (princ " | ")))) + +(defun write-grammar-pattern-doc (grammar-name) + (princ "{") (princ grammar-name) (princ "}")) + +(defun write-pattern-doc (pattern ) + (if (atom pattern) + (princ pattern) + (destructuring-bind (op . args) pattern + (case op + ((:seq :seq=) (write-sequence-doc args )) + ((:? :?=) (write-optional-doc (first args))) + ((:* :*=) (write-kleene-doc (first args))) + ((:+ :+=) (write-one-or-more-doc (first args))) + ((:or :or=) (write-alternatives-doc args)) + + (:= (princ (first args))) + (:@ (write-pattern-doc (second args))) + (:{} (write-grammar-pattern-doc (first args))) + + (:item (princ "::TOKEN::")) + (:eof (princ "::EOF::")))))) + + + |