code.consxy.com Git - honey/blob - src/main/parse.lisp

   1 ; Copyright 2022 Frank Duncan (frank@consxy.com) under AGPL3.  See distributed LICENSE.txt.
   2 (in-package #:honey)
   3
   4 (defparameter *line-parsers* nil)
   5 (defparameter *inline-parsers* nil)
   6
   7 (defun parse (str)
   8  "PARSE STR => HTML
   9
  10 ARGUMENTS AND VALUES:
  11
  12   STR: a string, representing the markdown
  13   HTML: a weave style html form
  14
  15 DESCRIPTION:
  16
  17   Parses the actual markdown, returing the html.  This is the main
  18   function for the honey package."
  19  (let
  20   ((lines (cl-ppcre:split "\\n" str)))
  21   (mapcar
  22    #'parse-texts
  23    (parse-lines (append lines (list ""))))))
  24
  25 (defun textp (x) (and (listp x) (eql 'text (car x))))
  26 (defun as-text (x) (list 'text x))
  27
  28 (defun parse-lines (lines &optional prev)
  29  (if
  30   (not lines)
  31   (list prev)
  32   (let*
  33    ((line (car lines))
  34     (parser
  35      (getf
  36       (cadr (find-if (lambda (parser) (funcall (getf parser :checker) line)) (reverse *line-parsers*) :key #'cadr))
  37       :parser)))
  38    (when (not parser) (error "Weird!  Couldn't find a match for ~A" line))
  39    (multiple-value-bind (parsed-line squash-prev suspension) (funcall (funcall parser line) prev)
  40     (cond
  41      (squash-prev (parse-lines (cdr lines) parsed-line))
  42      (suspension
  43       (let*
  44        ((regex-to-find (car suspension))
  45         (function-to-call (cadr suspension))
  46         (pos
  47          (position-if
  48           (lambda (line) (cl-ppcre:scan regex-to-find line))
  49           (cdr lines))))
  50        (append
  51         (list
  52          prev
  53          (funcall function-to-call (subseq (cdr lines) 0 (or pos (1- (length lines))))))
  54         (parse-lines (nthcdr (if pos (1+ pos) (length lines)) (cdr lines))))))
  55      (t (cons prev (parse-lines (cdr lines) parsed-line))))))))
  56
  57 (defun parse-texts (line)
  58  (cond
  59   ((textp line) (parse-inline (cadr line)))
  60   ((listp line) (mapcar #'parse-texts line))
  61   (t line)))
  62
  63 (defun parse-inline (str)
  64  (let
  65   ((parser
  66     (getf
  67      (cadr (find-if (lambda (parser) (funcall (getf parser :checker) str)) (reverse *inline-parsers*) :key #'cadr))
  68      :parser)))
  69   (if parser (funcall parser str) str)))
  70
  71 (defmacro defline-parser (regex handler)
  72  (let
  73   ((regex (format nil "^~A$" regex)))
  74   `(progn
  75     (when (not (find ,regex *line-parsers* :key #'car :test #'string=)) (push (list ,regex nil) *line-parsers*))
  76     (let
  77      ((parser (find ,regex *line-parsers* :key #'car :test #'string=)))
  78      (setf
  79       (cadr parser)
  80       (list
  81        :checker (lambda (str) (cl-ppcre:scan ,regex str))
  82        :parser (lambda (str)
  83                 (apply
  84                  (function ,handler)
  85                  (mapcar
  86                   #'as-text
  87                   (coerce (second (multiple-value-list (cl-ppcre:scan-to-strings ,regex str))) 'list))))))))))
  88
  89 (defmacro definline-parser (regex handler)
  90  (let
  91   ((regex (format nil "^~A$" regex)))
  92   `(progn
  93     (when (not (find ,regex *inline-parsers* :key #'car :test #'string=)) (push (list ,regex nil) *inline-parsers*))
  94     (let
  95      ((parser (find ,regex *inline-parsers* :key #'car :test #'string=)))
  96      (setf
  97       (cadr parser)
  98       (list
  99        :checker (lambda (str) (cl-ppcre:scan ,regex str))
 100        :parser (lambda (str)
 101                 (apply (function ,handler)
 102                  (mapcar
 103                   #'parse-inline
 104                   (coerce (second (multiple-value-list (cl-ppcre:scan-to-strings ,regex str))) 'list))))))))))
 105
 106 ; each parser function needs to return a function that takes the previous line and returns
 107 ;
 108 ; the values:
 109 ;   the new element
 110 ;   whether the previous line should be consumed (optional)
 111 ;   an optional list with two items, which suspends parsing until regex is found
 112 ;     - the regex to end the suspension
 113 ;     - the function to call with the list of lines
 114
 115 (defun prev-h2 ()
 116  (lambda (prev)
 117   (if (textp prev) (values (h2 prev) t) (hr))))
 118
 119 (defun prev-h1 ()
 120  (lambda (prev)
 121   (if (textp prev) (values (h1 prev) t) (hr))))
 122
 123 (defun inline-h1 (text) (lambda (prev) (h1 text)))
 124 (defun inline-h2 (text) (lambda (prev) (h2 text)))
 125 (defun inline-h3 (text) (lambda (prev) (h3 text)))
 126 (defun inline-h4 (text) (lambda (prev) (h4 text)))
 127 (defun inline-h5 (text) (lambda (prev) (h5 text)))
 128
 129 (defun list-item (text)
 130  (lambda (prev)
 131   (let
 132    ((li (li text)))
 133    (if (and prev (listp prev) (eql 'ul (car prev)))
 134     (values (append prev (list li)) t)
 135     (ul li)))))
 136
 137 (defun emptiness ()
 138  (lambda (prev)
 139   (cond
 140    ((textp prev) (values (p prev) t)))))
 141
 142 (defun default (text)
 143  (lambda (prev)
 144   (if
 145    (textp prev)
 146    (values (as-text (format nil "~A ~A" (cadr prev) (cadr text))) t)
 147    text)))
 148
 149 (defun codefence (codetype)
 150  (lambda (prev)
 151   (declare (ignore prev))
 152   (values
 153    nil
 154    nil
 155    (list
 156     "^```$"
 157     (lambda (lines)
 158      (pre
 159       (code
 160        (format nil "~{~A~%~}" lines))))))))
 161
 162 (defline-parser "-+" prev-h2)
 163 (defline-parser "=+" prev-h1)
 164
 165 ; These need to be in reverse order so they match correctly
 166 (defline-parser "##### *(.*)" inline-h5)
 167 (defline-parser "#### *(.*)" inline-h4)
 168 (defline-parser "### *(.*)" inline-h3)
 169 (defline-parser "## *(.*)" inline-h2)
 170 (defline-parser "# *(.*)" inline-h1)
 171
 172 ; Ignore codefence
 173 (defline-parser "(```.*```.*)" default)
 174
 175 (defline-parser "```(.*)" codefence)
 176
 177 ; If we start with a space after the asterisk, we really do want a list
 178 (defline-parser " *\\* (.*)" list-item)
 179 ; Ignore list-tiem
 180 (defline-parser "(\\*\\*.*\\*\\*.*)" default)
 181 (defline-parser "(\\*.*\\*.*)" default)
 182 (defline-parser " *\\* *(.*)" list-item)
 183 (defline-parser " *" emptiness)
 184 (defline-parser "(.*)" default)
 185
 186 (defun strength (before during after)
 187  (list before (span :style-font-weight "bold" during) after))
 188
 189 (defun emphasis (before during after)
 190  (list before (span :style-font-style "italic" during) after))
 191
 192 (defun md-link (before text md-link after)
 193  (list before (a :href md-link (parse-texts text)) after))
 194
 195 (defun inline-code (before during after)
 196  (list before (code during) after))
 197
 198 (definline-parser "(.*)\\[([^\\]]*)\\]\\(([^)]*)\\)(.*)" md-link)
 199 (definline-parser "(.*)\\*\\*(.*)\\*\\*(.*)" strength)
 200 (definline-parser "(.*)\\*(.*)\\*(.*)" emphasis)
 201 (definline-parser "(.*)_(.*)_(.*)" emphasis)
 202 (definline-parser "(.*)```(.*)```(.*)" inline-code)