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) (funcall (funcall parser line) prev)
  36     (if squash-prev
  37      (parse-lines (cdr lines) parsed-line)
  38      (cons prev (parse-lines (cdr lines) parsed-line)))))))
  39
  40 (defun parse-texts (line)
  41  (cond
  42   ((textp line) (parse-inline (cadr line)))
  43   ((listp line) (mapcar #'parse-texts line))
  44   (t line)))
  45
  46 (defun parse-inline (str)
  47  (let
  48   ((parser (getf (cadr (find-if #1'(funcall (getf $1 :checker) str) (reverse *inline-parsers*) :key #'cadr)) :parser)))
  49   (if parser (funcall parser str) str)))
  50
  51 (defmacro defline-parser (regex handler)
  52  (let
  53   ((regex (format nil "^~A$" regex)))
  54   `(progn
  55     (when (not (utils:strassoc ,regex *line-parsers*)) (push (list ,regex nil) *line-parsers*))
  56     (setf (utils:strassoc ,regex *line-parsers*)
  57      (list
  58       :checker (lambda (str) (cl-ppcre:scan ,regex str))
  59       :parser (lambda (str)
  60                (apply
  61                 (function ,handler)
  62                 (mapcar
  63                  #'as-text
  64                  (coerce (second (multiple-value-list (cl-ppcre:scan-to-strings ,regex str))) 'list)))))))))
  65
  66 (defmacro definline-parser (regex handler)
  67  (let
  68   ((regex (format nil "^~A$" regex)))
  69   `(progn
  70     (when (not (utils:strassoc ,regex *inline-parsers*)) (push (list ,regex nil) *inline-parsers*))
  71     (setf (utils:strassoc ,regex *inline-parsers*)
  72      (list
  73       :checker (lambda (str) (cl-ppcre:scan ,regex str))
  74       :parser (lambda (str)
  75                (apply (function ,handler)
  76                 (mapcar
  77                  #'parse-inline
  78                  (coerce (second (multiple-value-list (cl-ppcre:scan-to-strings ,regex str))) 'list)))))))))
  79
  80 ; each parser function needs to return a function that takes the previous line and returns either
  81 ;
  82 ; a single element being the new element, and optionally a second values option about whether
  83 ; the previous line should be consumed
  84
  85 (defun prev-h2 ()
  86  (lambda (prev)
  87   (if (textp prev) (values (h2 prev) t) (hr))))
  88
  89 (defun prev-h1 ()
  90  (lambda (prev)
  91   (if (textp prev) (values (h1 prev) t) (hr))))
  92
  93 (defun list-item (text)
  94  (lambda (prev)
  95   (let
  96    ((li (li text)))
  97    (if (and prev (listp prev) (eql 'ul (car prev)))
  98     (values (append prev (list li)) t)
  99     (ul li)))))
 100
 101 (defun emptiness ()
 102  (lambda (prev)
 103   (cond
 104    ((textp prev) (values (p prev) t)))))
 105
 106 (defun default (text)
 107  (lambda (prev) (declare (ignore prev)) text))
 108
 109 (defline-parser "-+" prev-h2)
 110 (defline-parser "=+" prev-h1)
 111 (defline-parser " *\\* *(.*)" list-item)
 112 (defline-parser " *" emptiness)
 113 (defline-parser "(.*)" default)
 114
 115 (defun strength (before during after)
 116  (list before (span :style-font-weight "bold" during) after))
 117
 118 (defun emphasis (before during after)
 119  (list before (span :style-font-style "italic" during) after))
 120
 121 (defun md-link (before text md-link after)
 122  (list before (a :href md-link (parse-texts text)) after))
 123
 124 (definline-parser "(.*)\\[([^\\]]*)\\]\\(([^)]*)\\)(.*)" md-link)
 125 (definline-parser "(.*)\\*\\*(.*)\\*\\*(.*)" strength)
 126 (definline-parser "(.*)\\*(.*)\\*(.*)" emphasis)