external/smarkup/src/filter.cl

   1 ;;
   2 ;; Copyright (c) 2006, Cyrus Harmon
   3 ;;
   4 ;; filter.lisp - filters are used to process markup document
   5 ;; sexps. The intent is that these filters are independent from the
   6 ;; final rendering. Think of this as a set of preprocessing stages
   7 ;; after document parsing. So now we have a markup document which gets
   8 ;; parsed, filtered and then rendered.
   9 ;;
  10 ;; Yes, perhaps the name "filter" could be better. I'm open to
  11 ;; suggestions.
  12
  13 (in-package :smarkup)
  14
  15 (defgeneric filter-gf (filter car list))
  16 (defgeneric filter (type sexp))
  17
  18 (defmethod filter-gf (filter car list)
  19   (cond ((null car) (when (cdr list) (filter filter (cdr list))))
  20         ((atom car) (cons car (filter filter (cdr list))))
  21         (t (cons (filter filter (car list))
  22                  (filter filter (cdr list))))))
  23
  24 (defmethod filter (type sexp)
  25   (filter-gf type (car sexp) sexp))
  26
  27 (defun apply-filters (sexp filters)
  28   (cond ((null filters) sexp)
  29         ((listp filters) (apply-filters (filter (car filters) sexp) (cdr filters)))
  30         (t (filter filters sexp))))
  31
  32 ;;;
  33 ;;; test filter. can reverse strings
  34 ;;;
  35 (defun reverse-strings (sexp)
  36   (cond ((null sexp) nil)
  37         ((atom sexp) (if (stringp sexp)
  38                          (reverse sexp)
  39                          sexp))
  40         (t (cons (reverse-strings (car sexp))
  41                  (reverse-strings (cdr sexp))))))
  42
  43 (defmethod filter-gf ((filter (eql :test)) (car (eql :reverse)) list)
  44   `(:span ,@(filter :test (reverse-strings (reverse (cdr list))))))
  45
  46 ;;;
  47 ;;; lisp filter. can eval lisp forms
  48 ;;;
  49 (defun collect-string (str-list)
  50   (declare (optimize (debug 2)))
  51   (apply #'concatenate 'string
  52          (mapcar
  53           #'(lambda (x)
  54               (unless (equal x 'blank-line)
  55                 (format nil "~A" x)))
  56           str-list)))
  57
  58 (defun lc-format (dest ctrl-string &rest args)
  59   (let ((*print-case* :downcase))
  60     (apply #'format dest ctrl-string args)))
  61
  62 (defun eval-lisp (tag body &key (show-commands t) (show-results t))
  63   (declare (ignore tag))
  64   (let ((lines
  65          (with-input-from-string (ifs (collect-string body))
  66            (loop for line = (read ifs nil)
  67               while line collect line))))
  68     (if (not (or show-commands show-results))
  69         (progn (mapcar #'eval lines)
  70                nil)
  71         `((:div :class "lisp")
  72           (:pre
  73            ,@(mapcan #'(lambda (x)
  74                          (cons `(:code
  75                                  ,(when show-commands
  76                                         (lc-format nil "~W~%" x)))
  77                                (let ((output (eval x)))
  78                                  (if show-results
  79                                      (list `(:results
  80                                              ,(if (stringp output)
  81                                                   (lc-format nil "~W~%" output)
  82                                                   (format nil "~S~%" output)))
  83                                            #\Newline)
  84                                      (list #\Newline)))))
  85                      lines))))))
  86
  87 (defmethod filter-gf ((filter (eql :lisp)) (car (eql :lisp)) list)
  88   (eval-lisp car (cdr list)))
  89
  90 (defmethod filter-gf ((filter (eql :lisp)) (car (eql :lisp-no-results)) list)
  91   (eval-lisp car (cdr list) :show-results nil))
  92
  93 (defmethod filter-gf ((filter (eql :lisp)) (car (eql :lisp-no-commands)) list)
  94   (eval-lisp car (cdr list) :show-commands nil))
  95
  96 (defmethod filter-gf ((filter (eql :lisp)) (car (eql :lisp-silent)) list)
  97   (eval-lisp car (cdr list) :show-results nil :show-commands nil))
  98
  99 (defmethod filter-gf ((filter (eql :lisp)) (car (eql :lisp-no-eval)) list)
 100   `((:div :class "lisp") (:pre ,@(cdr list))))
 101
 102 (defmethod filter-gf ((filter (eql :lisp)) (car (eql :lisp-value)) list)
 103   (eval (read-from-string (car (cdr list)))))
 104
 105 (defmethod filter-gf ((filter (eql :lisp)) (car (eql :setf-lisp-value)) list)
 106   (let ((sexp (read-from-string (car (cdr list)))))
 107     (setf (symbol-value (car sexp)) (cadr sexp))
 108     nil))
 109
 110 (defmethod filter-gf ((filter (eql :lisp)) (car (eql :code-block)) list)
 111   `((:div :class "lisp") (:pre ,@(cdr list))))
 112
 113 ;;;
 114 ;;; markup-metadata filter. sets various special variables with
 115 ;;; document metadata info
 116 ;;;
 117 (defmethod filter-gf ((filter (eql :smarkup-metadata)) (car (eql :copyright)) list)
 118   (setf *copyright* (cadr list))
 119   (call-next-method))
 120
 121 (defmethod filter-gf ((filter (eql :smarkup-metadata)) (car (eql :title)) list)
 122   (setf *document-title* (cadr list))
 123   (call-next-method))
 124
 125 (defmethod filter-gf ((filter (eql :smarkup-metadata)) (car (eql :titlerunning)) list)
 126   (setf *document-titlerunning* (cadr list))
 127   (call-next-method))
 128
 129 (defmethod filter-gf ((filter (eql :smarkup-metadata)) (car (eql :subtitle)) list)
 130   (setf *document-subtitle* (cadr list))
 131   (call-next-method))
 132
 133 (defmethod filter-gf ((filter (eql :smarkup-metadata)) (car (eql :author)) list)
 134   (setf *document-author* (cadr list))
 135   (call-next-method))
 136
 137 (defmethod filter-gf ((filter (eql :smarkup-metadata)) (car (eql :tocauthor)) list)
 138   (setf *document-tocauthor* (cadr list))
 139   (call-next-method))
 140
 141 (defmethod filter-gf ((filter (eql :smarkup-metadata)) (car (eql :authorrunning)) list)
 142   (setf *document-authorrunning* (cadr list))
 143   (call-next-method))
 144
 145 (defmethod filter-gf ((filter (eql :smarkup-metadata)) (car (eql :address)) list)
 146   (setf *document-address* (cadr list))
 147   (call-next-method))
 148
 149 (defmethod filter-gf ((filter (eql :smarkup-metadata)) (car (eql :institute)) list)
 150   (setf *document-institute* (cadr list))
 151   (call-next-method))
 152
 153 (defparameter *bibtex-macros* (make-hash-table :test #'equalp))
 154 (defparameter *bibtex-database* (make-hash-table :test #'equalp))
 155 (defparameter *bibtex-style* nil)
 156 (defparameter *cite-keys* nil)
 157 (defparameter *cite-order* (make-hash-table :test #'equalp))
 158 (defparameter *current-citation* 0)
 159
 160 (defmethod filter-gf ((filter (eql :smarkup-metadata)) (car (eql :bibtex-database)) list)
 161   (setf *bibtex-database* (make-hash-table :test #'equalp))
 162   (setf *cite-keys* nil)
 163   (setf *cite-order* (make-hash-table :test #'equalp))
 164   (setf *current-citation* 0)
 165   (cond ((and (stringp (cadr list))
 166               (eql (char (cadr list) 0) #\())
 167          (let ((database-spec-list
 168                 (let ((*read-eval* nil))
 169                   (read-from-string (cadr list)))))
 170            (loop for database-spec in database-spec-list
 171               do
 172                 (let ((database-uri (puri:parse-uri database-spec)))
 173                   (cond ((eql (puri:uri-scheme database-uri) :asdf)
 174                          (let ((database
 175                                 (asdf:component-pathname
 176                                  (ch-asdf::asdf-lookup database-spec))))
 177                            (let ((bibtex-runtime::*bib-database* *bibtex-database*)
 178                                  (bibtex-runtime::*bib-macros* *bibtex-macros*))
 179                              (with-open-file (f database)
 180                                (bibtex-runtime:read-bib-database f)))))
 181                         (t
 182                          (let ((database (puri:uri-path database-uri)))
 183                            (let ((bibtex-runtime::*bib-database* *bibtex-database*)
 184                                  (bibtex-runtime::*bib-macros* *bibtex-macros*))
 185                              (with-open-file (f database)
 186                                (bibtex-runtime:read-bib-database f)))))))))
 187          (call-next-method))
 188         (t (warn "Unsupported bibilography database~&"))))
 189
 190 (defmethod filter-gf ((filter (eql :smarkup-metadata))
 191                       (car (eql :bibtex-style))
 192                       list)
 193   (let ((bst (cadr list)))
 194     (setf *bibtex-style* bst)))
 195
 196 (defmethod filter-gf ((filter (eql :smarkup-metadata)) (car (eql :smarkup-metadata)) list)
 197   (filter-gf filter (cadr list) (cdr list))
 198   nil)
 199
 200 (defparameter *html-css-stylesheet-url* "style.css")
 201
 202 (defmethod filter-gf ((filter (eql :html-metadata)) (car (eql :htmlcss)) list)
 203   (setf *html-css-stylesheet-url* (cadr list))
 204   (call-next-method))
 205
 206 (defmethod filter-gf ((filter (eql :html-metadata)) (car (eql :html-metadata)) list)
 207   (filter-gf filter (cadr list) (cdr list))
 208   nil)
 209
 210
 211
 212 ;;;
 213 ;;; references
 214 ;;;
 215
 216
 217 ;;;
 218 ;;; Ok, need to get the bibtex-style and then call bibtex or its guts to get the references.
 219 ;;;
 220
 221 (defun get-bib-entry (entry)
 222   (with-output-to-string (stream)
 223     (bibtex-runtime::write-bib-entry entry stream)))
 224
 225 (defun get-bib-order (entry)
 226   (gethash entry *cite-order*))
 227
 228 (defmethod filter-gf ((filter (eql :ref)) (car (eql :bibcite)) list)
 229   (loop for  cite-key in (cdr list)
 230      do
 231        (unless (member cite-key *cite-keys* :test 'string=)
 232          (push cite-key *cite-keys*)
 233          (setf (gethash cite-key *cite-order*) (incf *current-citation*)))
 234        (let ((v (gethash cite-key *bibtex-database*)))
 235          (if v
 236              (bibtex-runtime::write-bib-entry v)
 237              (warn "~%bibliography entry ~A not found~%" cite-key))))
 238   (call-next-method))
 239
 240
 241 ;;;
 242 ;;; outline stuff
 243 ;;;
 244
 245 (defparameter *outline-elements* '(:h1 :h2 :h3 :h4 :h5 :h6))
 246
 247 (defparameter *outline-level* 6)
 248
 249 (defmethod filter-gf ((filter (eql :outline)) car list)
 250   (let ((outline-elements
 251          (subseq *outline-elements*
 252                  0 (min (length *outline-elements*)
 253                         *outline-level*))))
 254     (remove-if-not #'(lambda (x) (member (car x) outline-elements))
 255                    list)))
 256