From 16e1c2e03364b20f402be75788b68410efb5b95d Mon Sep 17 00:00:00 2001
From: Frank Duncan <frank@consxy.com>
Date: Thu, 6 Jan 2022 11:21:05 -0600
Subject: [PATCH] Initial commit

---
 .candle               |   8 +++
 honey.asd             |  10 ++++
 src/main/package.lisp |   5 ++
 src/main/parse.lisp   | 126 ++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 149 insertions(+)
 create mode 100644 .candle
 create mode 100644 honey.asd
 create mode 100644 src/main/package.lisp
 create mode 100644 src/main/parse.lisp

diff --git a/.candle b/.candle
new file mode 100644
index 0000000..3e36ab2
--- /dev/null
+++ b/.candle
@@ -0,0 +1,8 @@
+(:packages :honey :wolf :sheep)
+(:name :honey
+ :tasks
+ ((:name :wolf :directions
+   (wolf:pretty-print-check-directory "src"))
+  (:name :sheep :directions
+   (sheep:pretty-print-validate-packages :honey))))
+; vim:ft=lisp
diff --git a/honey.asd b/honey.asd
new file mode 100644
index 0000000..94eacaf
--- /dev/null
+++ b/honey.asd
@@ -0,0 +1,10 @@
+(asdf:defsystem honey
+ :name "Markdown processor that exports to Weave html forms"
+ :version "0.0"
+ :maintainer "Frank Duncan (frank@consxy.com)"
+ :author "Frank Duncan (frank@consxy.com)"
+ :serial t
+ :pathname "src/main"
+ :components ((:file "package")
+              (:file "parse"))
+ :depends-on (:webthiteth :herbie-utility))
diff --git a/src/main/package.lisp b/src/main/package.lisp
new file mode 100644
index 0000000..d1c5091
--- /dev/null
+++ b/src/main/package.lisp
@@ -0,0 +1,5 @@
+(defpackage #:honey (:use :common-lisp :webthiteth-html) (:export #:parse)
+ (:documentation "Main honey package.
+
+Honey is a simple markdown parse that translates to weave style html,
+which can then be inserted into pages."))
diff --git a/src/main/parse.lisp b/src/main/parse.lisp
new file mode 100644
index 0000000..b64cb22
--- /dev/null
+++ b/src/main/parse.lisp
@@ -0,0 +1,126 @@
+(in-package #:honey)
+
+(defparameter *line-parsers* nil)
+(defparameter *inline-parsers* nil)
+
+(defun parse (str)
+ "PARSE STR => HTML
+
+ARGUMENTS AND VALUES:
+
+  STR: a string, representing the markdown
+  HTML: a weave style html form
+
+DESCRIPTION:
+
+  Parses the actual markdown, returing the html.  This is the main
+  function for the honey package."
+ (let
+  ((lines (cl-ppcre:split "\\n" str)))
+  (mapcar
+   #'parse-texts
+   (parse-lines (append lines (list ""))))))
+
+(defun textp (x) (and (listp x) (eql 'text (car x))))
+(defun as-text (x) (list 'text x))
+
+(defun parse-lines (lines &optional prev)
+ (if
+  (not lines)
+  (list prev)
+  (let*
+   ((line (car lines))
+    (parser (getf (cadr (find-if #1'(funcall (getf $1 :checker) line) (reverse *line-parsers*) :key #'cadr)) :parser)))
+   (when (not parser) (error "Weird!  Couldn't find a match for ~A" line))
+   (multiple-value-bind (parsed-line squash-prev) (funcall (funcall parser line) prev)
+    (if squash-prev
+     (parse-lines (cdr lines) parsed-line)
+     (cons prev (parse-lines (cdr lines) parsed-line)))))))
+
+(defun parse-texts (line)
+ (cond
+  ((textp line) (parse-inline (cadr line)))
+  ((listp line) (mapcar #'parse-texts line))
+  (t line)))
+
+(defun parse-inline (str)
+ (let
+  ((parser (getf (cadr (find-if #1'(funcall (getf $1 :checker) str) (reverse *inline-parsers*) :key #'cadr)) :parser)))
+  (if parser (funcall parser str) str)))
+
+(defmacro defline-parser (regex handler)
+ (let
+  ((regex (format nil "^~A$" regex)))
+  `(progn
+    (when (not (utils:strassoc ,regex *line-parsers*)) (push (list ,regex nil) *line-parsers*))
+    (setf (utils:strassoc ,regex *line-parsers*)
+     (list
+      :checker (lambda (str) (cl-ppcre:scan ,regex str))
+      :parser (lambda (str)
+               (apply
+                (function ,handler)
+                (mapcar
+                 #'as-text
+                 (coerce (second (multiple-value-list (cl-ppcre:scan-to-strings ,regex str))) 'list)))))))))
+
+(defmacro definline-parser (regex handler)
+ (let
+  ((regex (format nil "^~A$" regex)))
+  `(progn
+    (when (not (utils:strassoc ,regex *inline-parsers*)) (push (list ,regex nil) *inline-parsers*))
+    (setf (utils:strassoc ,regex *inline-parsers*)
+     (list
+      :checker (lambda (str) (cl-ppcre:scan ,regex str))
+      :parser (lambda (str)
+               (apply (function ,handler)
+                (mapcar
+                 #'parse-inline
+                 (coerce (second (multiple-value-list (cl-ppcre:scan-to-strings ,regex str))) 'list)))))))))
+
+; each parser function needs to return a function that takes the previous line and returns either
+;
+; a single element being the new element, and optionally a second values option about whether
+; the previous line should be consumed
+
+(defun prev-h2 ()
+ (lambda (prev)
+  (if (textp prev) (values (h2 prev) t) (hr))))
+
+(defun prev-h1 ()
+ (lambda (prev)
+  (if (textp prev) (values (h1 prev) t) (hr))))
+
+(defun list-item (text)
+ (lambda (prev)
+  (let
+   ((li (li text)))
+   (if (and prev (listp prev) (eql 'ul (car prev)))
+    (values (append prev (list li)) t)
+    (ul li)))))
+
+(defun emptiness ()
+ (lambda (prev)
+  (cond
+   ((textp prev) (values (p prev) t)))))
+
+(defun default (text)
+ (lambda (prev) (declare (ignore prev)) text))
+
+(defline-parser "-+" prev-h2)
+(defline-parser "=+" prev-h1)
+(defline-parser " *\\* *(.*)" list-item)
+(defline-parser " *" emptiness)
+(defline-parser "(.*)" default)
+
+(defun strength (before during after)
+ (list before (span :style-font-weight "bold" during) after))
+
+(defun emphasis (before during after)
+ (list before (span :style-font-style "italic" during) after))
+
+(defun md-link (before text md-link after)
+ (list before (a :href md-link (parse-texts text)) after))
+
+(definline-parser "(.*)\\[([^\\]]*)\\]\\(([^)]*)\\)(.*)" md-link)
+(definline-parser "(.*)\\*\\*(.*)\\*\\*(.*)" strength)
+(definline-parser "(.*)\\*(.*)\\*(.*)" emphasis)
-- 
2.25.1