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 documentation*))
  39   `(:documentation ,@(children-to-sexp x)))
  40
  41 (defmethod markup-to-sexp ((x preformatted))
  42   `(:pre ,@(children-to-sexp x)))
  43
  44 (defmethod markup-to-sexp ((x code-block))
  45   `(:code-block ,@(children-to-sexp x)))
  46
  47 (defmethod markup-to-sexp ((x itemization))
  48   `(:ul ,@(children-to-sexp x)))
  49
  50 (defmethod markup-to-sexp ((x enumeration))
  51   `(:ol ,@(children-to-sexp x)))
  52
  53 (defmethod markup-to-sexp ((x paragraph))
  54   `(:p ,@(children-to-sexp x)))
  55
  56 (defmethod markup-to-sexp ((x div))
  57   `(:div ,@(children-to-sexp x)))
  58
  59 (defmethod markup-to-sexp ((x span))
  60   `(:span ,@(children-to-sexp x)))
  61
  62 (defmethod markup-to-sexp ((x bold))
  63   `(:b ,@(children-to-sexp x)))
  64
  65 (defmethod markup-to-sexp ((x italic))
  66   `(:i ,@(children-to-sexp x)))
  67
  68 (defmethod markup-to-sexp ((x fixed-width))
  69   `(:tt ,@(children-to-sexp x)))
  70
  71 (defmethod markup-to-sexp ((x inline-code))
  72   `(:inline-code ,@(children-to-sexp x)))
  73
  74 (defmethod markup-to-sexp ((x underline))
  75   `(:u ,@(children-to-sexp x)))
  76
  77 (defmethod markup-to-sexp ((x definition-list))
  78   `(:dl ,@(iter (for item in (list-items x))
  79                 (collect `(:dt ,(definition-title item)))
  80                 (collect `(:dd ,@(children-to-sexp item))))))
  81
  82 (defmethod markup-to-sexp ((x hyperlink))
  83   `(:a (:href ,(href x))
  84        ,@(children-to-sexp x)))
  85
  86 (defmethod markup-to-sexp ((x inline-cross-reference))
  87   `(:xref (:target ,(cross-reference-target x)
  88                    :doc-type ,(cross-reference-doc-type x)
  89                    :annotation-category ,(annotation-category x))
  90           ,@(children-to-sexp x)))
  91
  92 (defmethod unknown-element ((x hyperlink))
  93   `(,(name x)
  94      ,(plist x)
  95      ,@(children-to-sexp x)))
  96
  97
  98 ;;; Sexp to CLOS
  99
 100 (defun sexp-to-markup (x)
 101   (typecase x
 102     (string (make-text x))
 103     (cons (sexp-to-markup-using-car (car x) x))
 104     (null nil)))
 105
 106 (defun body-to-markup (x)
 107   (mapcar #'sexp-to-markup x))
 108
 109 (defmethod sexp-to-markup-using-car ((car (eql :pre)) x)
 110   (apply #'make-preformatted (body-to-markup (cdr x))))
 111
 112 (defmethod sexp-to-markup-using-car ((car (eql :code-block)) x)
 113   (apply #'make-code-block (body-to-markup (cdr x))))
 114
 115 (defmethod sexp-to-markup-using-car ((car (eql :inline-code)) x)
 116   (apply #'make-inline-code (body-to-markup (cdr x))))
 117
 118 (defmethod sexp-to-markup-using-car ((car (eql :ul)) x)
 119   (apply #'make-itemization (body-to-markup (cdr x))))
 120
 121 (defmethod sexp-to-markup-using-car ((car (eql :ol)) x)
 122   (apply #'make-enumeration (body-to-markup (cdr x))))
 123
 124 (defmethod sexp-to-markup-using-car ((car (eql :p)) x)
 125   (apply #'make-paragraph (body-to-markup (cdr x))))
 126
 127 (defmethod sexp-to-markup-using-car ((car (eql :div)) x)
 128   (apply #'make-div (body-to-markup (cdr x))))
 129
 130 (defmethod sexp-to-markup-using-car ((car (eql :span)) x)
 131   (apply #'make-span (body-to-markup (cdr x))))
 132
 133 (defmethod sexp-to-markup-using-car ((car (eql :b)) x)
 134   (apply #'make-bold (body-to-markup (cdr x))))
 135
 136 (defmethod sexp-to-markup-using-car ((car (eql :i)) x)
 137   (apply #'make-italic (body-to-markup (cdr x))))
 138
 139 (defmethod sexp-to-markup-using-car ((car (eql :u)) x)
 140   (apply #'make-underline (body-to-markup (cdr x))))
 141
 142 (defmethod sexp-to-markup-using-car ((car (eql :dl)) x)
 143   (apply #'make-definition-list
 144          (iter (for (dt dl) in (cdr x))
 145                (check-type dt (cons (eql :dt) (cons string null)))
 146                (check-type (car dl) (eql :dl))
 147                (collect (make-definition-list-item (second dt)
 148                                                    (body-to-markup (cdr dl)))))))
 149
 150 (defmethod sexp-to-markup-using-car ((car (eql :xref)) x)
 151   (destructuring-bind ((&key target doc-type annotation-category) &body body)
 152       (cdr x)
 153     (apply #'make-inline-cross-reference
 154            target
 155            doc-type
 156            annotation-category
 157            (body-to-markup body))))