sexp.lisp

   1 ;;; -*- lisp; show-trailing-whitespace: t; indent-tabs: nil -*-
   2
   3 ;;;; Copyright (c) 2008 David Lichteblau:
   4 ;;;;
   5 ;;;; Permission is hereby granted, free of charge, to any person
   6 ;;;; obtaining a copy of this software and associated documentation
   7 ;;;; files (the "Software"), to deal in the Software without
   8 ;;;; restriction, including without limitation the rights to use, copy,
   9 ;;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  10 ;;;; of the Software, and to permit persons to whom the Software is
  11 ;;;; furnished to do so, subject to the following conditions:
  12 ;;;;
  13 ;;;; The above copyright notice and this permission notice shall be
  14 ;;;; included in all copies or substantial portions of the Software.
  15 ;;;;
  16 ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  17 ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  18 ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  19 ;;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  20 ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  21 ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  22 ;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  23 ;;;; DEALINGS IN THE SOFTWARE.
  24
  25 (in-package #:parse-docstrings)
  26
  27
  28 ;;; CLOS to Sexp
  29
  30 (defun children-to-sexp (x)
  31   (mapcar #'markup-to-sexp (child-elements x)))
  32
  33 (defgeneric markup-to-sexp (markup))
  34
  35 (defmethod markup-to-sexp ((x text))
  36   (characters x))
  37
  38 (defmethod markup-to-sexp ((x preformatted))
  39   `(:pre ,@(children-to-sexp x)))
  40
  41 (defmethod markup-to-sexp ((x code))
  42   `(:code ,@(children-to-sexp x)))
  43
  44 (defmethod markup-to-sexp ((x itemization))
  45   `(:ul ,@(children-to-sexp x)))
  46
  47 (defmethod markup-to-sexp ((x enumeration))
  48   `(:ol ,@(children-to-sexp x)))
  49
  50 (defmethod markup-to-sexp ((x paragraph))
  51   `(:p ,@(children-to-sexp x)))
  52
  53 (defmethod markup-to-sexp ((x div))
  54   `(:div ,@(children-to-sexp x)))
  55
  56 (defmethod markup-to-sexp ((x span))
  57   `(:span ,@(children-to-sexp x)))
  58
  59 (defmethod markup-to-sexp ((x bold))
  60   `(:b ,@(children-to-sexp x)))
  61
  62 (defmethod markup-to-sexp ((x italic))
  63   `(:i ,@(children-to-sexp x)))
  64
  65 (defmethod markup-to-sexp ((x underline))
  66   `(:u ,@(children-to-sexp x)))
  67
  68 (defmethod markup-to-sexp ((x definition-list))
  69   `(:dl ,@(iter (for item in (list-items x))
  70                 (collect `(:dt ,(definition-title item)))
  71                 (collect `(:dd ,@(children-to-sexp item))))))
  72
  73 (defmethod markup-to-sexp ((x hyperlink))
  74   `(:a (:href ,(href x))
  75        ,@(children-to-sexp x)))
  76
  77 (defmethod inline-cross-reference ((x hyperlink))
  78   `(:xref ,@(children-to-sexp x)))
  79
  80 (defmethod unknown-element ((x hyperlink))
  81   `(,(name x)
  82      ,(plist x)
  83      ,@(children-to-sexp x)))
  84
  85
  86 ;;; Sexp to CLOS
  87
  88 (defun sexp-to-markup (x)
  89   (typecase x
  90     (string (make-text x))
  91     (cons (sexp-to-markup-using-car (car x) x))
  92     (null nil)))
  93
  94 (defun body-to-markup (x)
  95   (mapcar #'sexp-to-markup x))
  96
  97 (defmethod sexp-to-markup-using-car ((car (eql :pre)) x)
  98   (apply #'make-preformatted (body-to-markup (cdr x))))
  99
 100 (defmethod sexp-to-markup-using-car ((car (eql :code)) x)
 101   (apply #'make-code (body-to-markup (cdr x))))
 102
 103 (defmethod sexp-to-markup-using-car ((car (eql :ul)) x)
 104   (apply #'make-itemization (body-to-markup (cdr x))))
 105
 106 (defmethod sexp-to-markup-using-car ((car (eql :ol)) x)
 107   (apply #'make-enumeration (body-to-markup (cdr x))))
 108
 109 (defmethod sexp-to-markup-using-car ((car (eql :p)) x)
 110   (apply #'make-paragraph (body-to-markup (cdr x))))
 111
 112 (defmethod sexp-to-markup-using-car ((car (eql :div)) x)
 113   (apply #'make-div (body-to-markup (cdr x))))
 114
 115 (defmethod sexp-to-markup-using-car ((car (eql :span)) x)
 116   (apply #'make-span (body-to-markup (cdr x))))
 117
 118 (defmethod sexp-to-markup-using-car ((car (eql :b)) x)
 119   (apply #'make-bold (body-to-markup (cdr x))))
 120
 121 (defmethod sexp-to-markup-using-car ((car (eql :i)) x)
 122   (apply #'make-italic (body-to-markup (cdr x))))
 123
 124 (defmethod sexp-to-markup-using-car ((car (eql :u)) x)
 125   (apply #'make-underline (body-to-markup (cdr x))))
 126
 127 (defmethod sexp-to-markup-using-car ((car (eql :dl)) x)
 128   (apply #'make-definition-list
 129          (iter (for (dt dl) in (cdr x))
 130                (check-type dt (cons (eql :dt) (cons string null)))
 131                (check-type (car dl) (eql :dl))
 132                (collect (make-definition-list-item (second dt)
 133                                                    (body-to-markup (cdr dl)))))))
 134