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

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