From 5800a49934ab75be17f03af8c9a2243120a97339 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Wed, 2 Aug 2023 21:01:03 -0700
Subject: Add docgen

---
 argot.asd   |  4 ++--
 argot.lisp  | 41 ++++++++++++++++++++++++++---------------
 docgen.lisp | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 84 insertions(+), 17 deletions(-)
 create mode 100644 docgen.lisp

diff --git a/argot.asd b/argot.asd
index 6d6aa61..ff57f4d 100644
--- a/argot.asd
+++ b/argot.asd
@@ -8,6 +8,6 @@
   :serial t
   :depends-on (#:trivia #:alexandria)
   :components ((:file "package")
-               ;(:file "grammars")
-               ;(:file "deflanguage")
+               (:file "grammars")
+               (:file "docgen")
                (:file "argot")))
diff --git a/argot.lisp b/argot.lisp
index 2218dd5..f394e2a 100644
--- a/argot.lisp
+++ b/argot.lisp
@@ -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::"))))))
+
+
+
-- 
cgit v1.2.3