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 (getf (cadr (find-if #1'(funcall (getf $1 :checker) line) (reverse *line-parsers*) :key #'cadr)) :parser)))
  34    (when (not parser) (error "Weird!  Couldn't find a match for ~A" line))
  35    (multiple-value-bind (parsed-line squash-prev suspension) (funcall (funcall parser line) prev)
  36     (cond
  37      (squash-prev (parse-lines (cdr lines) parsed-line))
  38      (suspension
  39       (let*
  40        ((regex-to-find (car suspension))
  41         (function-to-call (cadr suspension))
  42         (pos
  43          (position-if
  44           (lambda (line) (cl-ppcre:scan regex-to-find line))
  45           (cdr lines))))
  46        (append
  47         (list
  48          prev
  49          (funcall function-to-call (subseq (cdr lines) 0 (or pos (length lines)))))
  50         (parse-lines (nthcdr (1+ pos) (cdr lines))))))
  51      (t (cons prev (parse-lines (cdr lines) parsed-line))))))))
  52
  53 (defun parse-texts (line)
  54  (cond
  55   ((textp line) (parse-inline (cadr line)))
  56   ((listp line) (mapcar #'parse-texts line))
  57   (t line)))
  58
  59 (defun parse-inline (str)
  60  (let
  61   ((parser (getf (cadr (find-if #1'(funcall (getf $1 :checker) str) (reverse *inline-parsers*) :key #'cadr)) :parser)))
  62   (if parser (funcall parser str) str)))
  63
  64 (defmacro defline-parser (regex handler)
  65  (let
  66   ((regex (format nil "^~A$" regex)))
  67   `(progn
  68     (when (not (utils:strassoc ,regex *line-parsers*)) (push (list ,regex nil) *line-parsers*))
  69     (setf (utils:strassoc ,regex *line-parsers*)
  70      (list
  71       :checker (lambda (str) (cl-ppcre:scan ,regex str))
  72       :parser (lambda (str)
  73                (apply
  74                 (function ,handler)
  75                 (mapcar
  76                  #'as-text
  77                  (coerce (second (multiple-value-list (cl-ppcre:scan-to-strings ,regex str))) 'list)))))))))
  78
  79 (defmacro definline-parser (regex handler)
  80  (let
  81   ((regex (format nil "^~A$" regex)))
  82   `(progn
  83     (when (not (utils:strassoc ,regex *inline-parsers*)) (push (list ,regex nil) *inline-parsers*))
  84     (setf (utils:strassoc ,regex *inline-parsers*)
  85      (list
  86       :checker (lambda (str) (cl-ppcre:scan ,regex str))
  87       :parser (lambda (str)
  88                (apply (function ,handler)
  89                 (mapcar
  90                  #'parse-inline
  91                  (coerce (second (multiple-value-list (cl-ppcre:scan-to-strings ,regex str))) 'list)))))))))
  92
  93 ; each parser function needs to return a function that takes the previous line and returns
  94 ;
  95 ; the values:
  96 ;   the new element
  97 ;   whether the previous line should be consumed (optional)
  98 ;   an optional list with two items, which suspends parsing until regex is found
  99 ;     - the regex to end the suspension
 100 ;     - the function to call with the list of lines
 101
 102 (defun prev-h2 ()
 103  (lambda (prev)
 104   (if (textp prev) (values (h2 prev) t) (hr))))
 105
 106 (defun prev-h1 ()
 107  (lambda (prev)
 108   (if (textp prev) (values (h1 prev) t) (hr))))
 109
 110 (defun inline-h1 (text) (lambda (prev) (h1 text)))
 111 (defun inline-h2 (text) (lambda (prev) (h2 text)))
 112 (defun inline-h3 (text) (lambda (prev) (h3 text)))
 113 (defun inline-h4 (text) (lambda (prev) (h4 text)))
 114 (defun inline-h5 (text) (lambda (prev) (h5 text)))
 115
 116 (defun list-item (text)
 117  (lambda (prev)
 118   (let
 119    ((li (li text)))
 120    (if (and prev (listp prev) (eql 'ul (car prev)))
 121     (values (append prev (list li)) t)
 122     (ul li)))))
 123
 124 (defun emptiness ()
 125  (lambda (prev)
 126   (cond
 127    ((textp prev) (values (p prev) t)))))
 128
 129 (defun default (text)
 130  (lambda (prev) (declare (ignore prev)) text))
 131
 132 (defun codefence (codetype)
 133  (lambda (prev)
 134   (declare (ignore prev))
 135   (values
 136    nil
 137    nil
 138    (list
 139     "^```$"
 140     (lambda (lines)
 141      (pre
 142       (code
 143        (format nil "~{~A~%~}" lines))))))))
 144
 145 (defline-parser "-+" prev-h2)
 146 (defline-parser "=+" prev-h1)
 147
 148 ; These need to be in reverse order so they match correctly
 149 (defline-parser "##### *(.*)" inline-h5)
 150 (defline-parser "#### *(.*)" inline-h4)
 151 (defline-parser "### *(.*)" inline-h3)
 152 (defline-parser "## *(.*)" inline-h2)
 153 (defline-parser "# *(.*)" inline-h1)
 154 (defline-parser "```(.*)" codefence)
 155 (defline-parser " *\\* *(.*)" list-item)
 156 (defline-parser " *" emptiness)
 157 (defline-parser "(.*)" default)
 158
 159 (defun strength (before during after)
 160  (list before (span :style-font-weight "bold" during) after))
 161
 162 (defun emphasis (before during after)
 163  (list before (span :style-font-style "italic" during) after))
 164
 165 (defun md-link (before text md-link after)
 166  (list before (a :href md-link (parse-texts text)) after))
 167
 168 (definline-parser "(.*)\\[([^\\]]*)\\]\\(([^)]*)\\)(.*)" md-link)
 169 (definline-parser "(.*)\\*\\*(.*)\\*\\*(.*)" strength)
 170 (definline-parser "(.*)\\*(.*)\\*(.*)" emphasis)