From a70b94a7f4f32b02d95c5515ebcb677e25e1ddb6 Mon Sep 17 00:00:00 2001 From: David Lichteblau Date: Thu, 25 Dec 2008 13:12:00 +0100 Subject: [PATCH] Revamped markup class hierarchy ... many more classes, vaguely inspired by HTML, atdoc, texinfo, etc. ... markup all the way down: paragraph has markup children now, not strings ... new sexp functions to translate from clos to lists and back also in this commit: ... use iterate, not loop ... always use c2mop, SBCL doesn't get special treatment here --- annotation-plist.lisp | 9 --- classes.lisp | 128 +++++++++++++++++++++++++++++--------- package.lisp | 77 ++++++++++++++++------- parse-docstrings.asd | 3 +- parse-docstrings.lisp | 16 ++--- sexp.lisp | 134 ++++++++++++++++++++++++++++++++++++++++ syntax-plugins/syntax-sbcl.lisp | 38 +++++++----- 7 files changed, 321 insertions(+), 84 deletions(-) create mode 100644 sexp.lisp diff --git a/annotation-plist.lisp b/annotation-plist.lisp index 831d980..a2be3b9 100644 --- a/annotation-plist.lisp +++ b/annotation-plist.lisp @@ -1,14 +1,5 @@ ;;; -*- lisp; show-trailing-whitespace: t; indent-tabs: nil -*- -;;;; Part of this software was originally written as docstrings.lisp in -;;;; SBCL, but is now part of the parse-docstrings project. The file -;;;; docstrings.lisp was written by Rudi Schlatte , -;;;; mangled by Nikodemus Siivola, turned into a stand-alone project by -;;;; Luis Oliveira. SBCL is in the public domain and is provided with -;;;; absolutely no warranty. - -;;;; parse-docstrings is: -;;;; ;;;; Copyright (c) 2008 David Lichteblau: ;;;; ;;;; Permission is hereby granted, free of charge, to any person diff --git a/classes.lisp b/classes.lisp index 11009ba..02e6935 100644 --- a/classes.lisp +++ b/classes.lisp @@ -54,34 +54,106 @@ ;;;; Markup classes -(defclass document-block () ()) - -(defclass lisp-block (document-block) - ((string :initarg :string :reader get-string))) - -(defclass itemization (document-block) - ((items :initarg :items :reader get-items))) - -(defclass section (document-block) - ((blocks :initarg :blocks :reader get-blocks))) - -(defmethod print-object ((section section) stream) - (print-unreadable-object (section stream :type t) - (prin1 (get-blocks section) stream))) - -(defclass paragraph (document-block) - ((string :initarg :string :reader get-string))) - -(defmethod print-object ((paragraph paragraph) stream) - (print-unreadable-object (paragraph stream :type t) - (prin1 (get-string paragraph) stream))) - -(defclass tabulation (document-block) - ((items :initarg :items :reader get-items))) - -(defclass tabulation-item (document-block) - ((title :initarg :title :reader get-title) - (body :initarg :body :reader get-body))) +(defclass markup-element () ()) +(defclass block-content (markup-element) ()) +(defclass inline-content (markup-element) ()) + +(defclass parent-mixin () + ((child-elements :initarg :child-elements + :accessor child-elements))) + +(defmethod print-object ((object parent-mixin) stream) + (print-unreadable-object (object stream :type t) + (prin1 (child-elements object) stream))) + +(defclass text (inline-content) + ((characters :initarg :characters + :accessor characters))) + +(defclass preformatted (parent-mixin block-content) ()) +(defclass code (preformatted) ()) +(defclass itemization (parent-mixin block-content) ()) +(defclass enumeration (parent-mixin block-content) ()) + +(defclass paragraph (parent-mixin block-content) ()) +(defclass div (parent-mixin block-content) ()) +(defclass span (parent-mixin inline-content) ()) + +(defclass bold (parent-mixin inline-content) ()) +(defclass italic (parent-mixin inline-content) ()) +(defclass underline (parent-mixin inline-content) ()) + +;; this isn't a parent, because its children aren't markup +(defclass definition-list (block-content) + ((items :initarg :items + :accessor definition-list-items))) + +;; this isn't markup by itself, because it can only appear in a +;; definition-list, but its children are markup again +(defclass definition-list-item (parent-mixin) + ((title :initarg :title + :accessor definition-title))) + +(defclass hyperlink (parent-mixin inline-content) + ((href :initarg :href + :accessor href))) + +(defclass inline-cross-reference (parent-mixin inline-content) + ()) + +(defclass unknown-element (parent-mixin inline-content) + ((name :initarg :name + :accessor name) + (plist :initarg :plist + :accessor plist))) + +(defun make-text (characters) + (check-type characters string) + (make-instance 'text :characters characters)) + +(macrolet ((%simple-parent (constructor class) + `(defun ,constructor (&rest children) + (dolist (child children) + (check-type child markup-element)) + (make-instance ',class :child-elements children)))) + (%simple-parent make-preformatted preformatted) + (%simple-parent make-code code) + (%simple-parent make-itemization itemization) + (%simple-parent make-enumeration enumeration) + (%simple-parent make-paragraph paragraph) + (%simple-parent make-div div) + (%simple-parent make-span span) + (%simple-parent make-bold bold) + (%simple-parent make-italic italic) + (%simple-parent make-underline underline)) + +(defun make-definition-list (&rest items) + (dolist (item items) + (check-type item definition-list-item)) + (make-instance 'definition-list :items items)) + +(defun make-definition-list-item (title &rest children) + (check-type title string) + (dolist (child children) + (check-type child markup-element)) + (make-instance 'definition-list-item :title title :child-elements children)) + +(defun make-hyperlink (href &rest children) + (check-type href string) + (dolist (child children) + (check-type child markup-element)) + (make-instance 'hyperlink :href href :child-elements children)) + +(defun make-unknown-element (name plist &rest children) + (check-type name string) + (dolist (child children) + (check-type child markup-element)) + (iter (for (name value) on plist by #'cddr) + (check-type name (or symbol string)) + (check-type value string)) + (make-instance 'unknown-element :name name + :plist plist + :child-elements children)) ;;;; Annotation Classes diff --git a/package.lisp b/package.lisp index 545c211..40eab33 100644 --- a/package.lisp +++ b/package.lisp @@ -32,36 +32,69 @@ ;;;; DEALINGS IN THE SOFTWARE. (defpackage #:parse-docstrings - (:use #:cl #-sbcl #:c2mop #+sbcl #:sb-mop) + (:use #:cl #:c2mop :iterate) (:export #:documentation* #:collect-documentation - #:collect-symbol-documentation + #:documentation< + #:setf-name-p + #:lambda-list) - #:get-name - #:get-kind - #:get-content - #:get-items - #:get-blocks - #:get-string - #:get-title - #:get-package-name - #:get-body - #:get-children - - #:document-block + (:export #:markup-element + #:block-content + #:inline-content + #:parent-mixin + #:text + #:preformatted + #:code #:itemization - #:section + #:enumeration #:paragraph - #:tabulation - #:tabulation-item - #:lisp-content - #:lisp-block + #:div + #:span + #:bold + #:italic + #:underline + #:definition-list + #:definition-list-item + #:hyperlink + #:inline-cross-reference + #:unknown-element - #:documentation< - #:setf-name-p + #:make-text + #:make-preformatted + #:make-code + #:make-itemization + #:make-enumeration + #:make-paragraph + #:make-div + #:make-span + #:make-bold + #:make-italic + #:make-underline + #:make-definition-list + #:make-definition-list-item + #:make-hyperlink + #:make-unknown-element) + + (:export #:documentation-annotations + #:cross-reference-annotation + #:parameter-annotation + + #:argument-annotations + #:return-value-annotations + #:condition-annotations + #:slot-accessor-annotations + #:constructor-annotations + #:see-also-annotations + #:cross-reference-target + #:cross-reference-doc-type + + #:make-parameter-annotation + #:make-cross-reference-annotation) - #:lambda-list)) + (:export #:markup-to-sexp + #:sexp-to-markup)) (defpackage #:parse-docstrings.sbcl (:use :cl) diff --git a/parse-docstrings.asd b/parse-docstrings.asd index 9e4aff9..3744eda 100644 --- a/parse-docstrings.asd +++ b/parse-docstrings.asd @@ -1,13 +1,14 @@ ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- (asdf:defsystem parse-docstrings - :depends-on (#-sbcl closer-mop) + :depends-on (:closer-mop :iterate) :serial t :components ((:file "package") (:file "annotate-documentation") (:file "classes") (:file "annotation-plist") (:file "parse-docstrings") + (:file "sexp") (:file "syntax-plugins/syntax-sbcl"))) ;; vim: ft=lisp et diff --git a/parse-docstrings.lisp b/parse-docstrings.lisp index 4367f72..44e7131 100644 --- a/parse-docstrings.lisp +++ b/parse-docstrings.lisp @@ -294,16 +294,16 @@ there is no corresponding docstring." (defun collect-gf-documentation (gf) "Collects method documentation for the generic function GF" - (loop for method in (generic-function-methods gf) - for doc = (documentation* method t) - when doc - collect doc)) + (iter (for method in (generic-function-methods gf)) + (for doc = (documentation* method t)) + (when doc + (collect doc)))) (defun collect-name-documentation (name) - (loop for type in *documentation-types* - for doc = (documentation* name type) - when doc - collect doc)) + (iter (for type in *documentation-types*) + (for doc = (documentation* name type)) + (when doc + (collect doc)))) (defun collect-symbol-documentation (symbol) "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of diff --git a/sexp.lisp b/sexp.lisp new file mode 100644 index 0000000..4e03fd2 --- /dev/null +++ b/sexp.lisp @@ -0,0 +1,134 @@ +;;; -*- lisp; show-trailing-whitespace: t; indent-tabs: nil -*- + +;;;; Copyright (c) 2008 David Lichteblau: +;;;; +;;;; Permission is hereby granted, free of charge, to any person +;;;; obtaining a copy of this software and associated documentation +;;;; files (the "Software"), to deal in the Software without +;;;; restriction, including without limitation the rights to use, copy, +;;;; modify, merge, publish, distribute, sublicense, and/or sell copies +;;;; of the Software, and to permit persons to whom the Software is +;;;; furnished to do so, subject to the following conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;;; DEALINGS IN THE SOFTWARE. + +(in-package #:parse-docstrings) + + +;;; CLOS to Sexp + +(defun children-to-sexp (x) + (mapcar #'markup-to-sexp (child-elements x))) + +(defgeneric markup-to-sexp (markup)) + +(defmethod markup-to-sexp ((x text)) + (characters x)) + +(defmethod markup-to-sexp ((x preformatted)) + `(:pre ,@(children-to-sexp x))) + +(defmethod markup-to-sexp ((x code)) + `(:code ,@(children-to-sexp x))) + +(defmethod markup-to-sexp ((x itemization)) + `(:ul ,@(children-to-sexp x))) + +(defmethod markup-to-sexp ((x enumeration)) + `(:ol ,@(children-to-sexp x))) + +(defmethod markup-to-sexp ((x paragraph)) + `(:p ,@(children-to-sexp x))) + +(defmethod markup-to-sexp ((x div)) + `(:div ,@(children-to-sexp x))) + +(defmethod markup-to-sexp ((x span)) + `(:span ,@(children-to-sexp x))) + +(defmethod markup-to-sexp ((x bold)) + `(:b ,@(children-to-sexp x))) + +(defmethod markup-to-sexp ((x italic)) + `(:i ,@(children-to-sexp x))) + +(defmethod markup-to-sexp ((x underline)) + `(:u ,@(children-to-sexp x))) + +(defmethod markup-to-sexp ((x definition-list)) + `(:dl ,@(iter (for item in (definition-list-items x)) + (collect `(:dt ,(definition-title item))) + (collect `(:dd ,@(children-to-sexp item)))))) + +(defmethod markup-to-sexp ((x hyperlink)) + `(:a (:href ,(href x)) + ,@(children-to-sexp x))) + +(defmethod inline-cross-reference ((x hyperlink)) + `(:xref ,@(children-to-sexp x))) + +(defmethod unknown-element ((x hyperlink)) + `(,(name x) + ,(plist x) + ,@(children-to-sexp x))) + + +;;; Sexp to CLOS + +(defun sexp-to-markup (x) + (typecase x + (string (make-text x)) + (cons (sexp-to-markup-using-car (car x) x)) + (null nil))) + +(defun body-to-markup (x) + (mapcar #'sexp-to-markup x)) + +(defmethod sexp-to-markup-using-car ((car (eql :pre)) x) + (apply #'make-preformatted (body-to-markup (cdr x)))) + +(defmethod sexp-to-markup-using-car ((car (eql :code)) x) + (apply #'make-code (body-to-markup (cdr x)))) + +(defmethod sexp-to-markup-using-car ((car (eql :ul)) x) + (apply #'make-itemization (body-to-markup (cdr x)))) + +(defmethod sexp-to-markup-using-car ((car (eql :ol)) x) + (apply #'make-enumeration (body-to-markup (cdr x)))) + +(defmethod sexp-to-markup-using-car ((car (eql :p)) x) + (apply #'make-paragraph (body-to-markup (cdr x)))) + +(defmethod sexp-to-markup-using-car ((car (eql :div)) x) + (apply #'make-div (body-to-markup (cdr x)))) + +(defmethod sexp-to-markup-using-car ((car (eql :span)) x) + (apply #'make-span (body-to-markup (cdr x)))) + +(defmethod sexp-to-markup-using-car ((car (eql :b)) x) + (apply #'make-bold (body-to-markup (cdr x)))) + +(defmethod sexp-to-markup-using-car ((car (eql :i)) x) + (apply #'make-italic (body-to-markup (cdr x)))) + +(defmethod sexp-to-markup-using-car ((car (eql :u)) x) + (apply #'make-underline (body-to-markup (cdr x)))) + +(defmethod sexp-to-markup-using-car ((car (eql :dl)) x) + (apply #'make-definition-list + (iter (for (dt dl) in (cdr x)) + (check-type dt (cons (eql :dt) (cons string null))) + (check-type (car dl) (eql :dl)) + (collect (make-definition-list-item (second dt) + (body-to-markup (cdr dl))))))) + diff --git a/syntax-plugins/syntax-sbcl.lisp b/syntax-plugins/syntax-sbcl.lisp index be2e7d8..66e587f 100644 --- a/syntax-plugins/syntax-sbcl.lisp +++ b/syntax-plugins/syntax-sbcl.lisp @@ -160,6 +160,8 @@ an item in an itemization." line :start offset)) offset))) +;;; is this bitrot? Can we remove it? +#+(or) (defun collect-maybe-itemized-section (lines starting-line) ;; Return index of next line to be processed outside (let ((this-offset (maybe-itemize-offset (svref lines starting-line))) @@ -262,8 +264,9 @@ followed another tabulation label or a tabulation body." (current nil)) (labels ((end-paragraph () (when current - (push (make-instance 'parse-docstrings:paragraph - :string (flatten-to-string (reverse current))) + (push (parse-docstrings:make-paragraph + (parse-docstrings:make-text + (flatten-to-string (reverse current))) ) parsed) (setf current nil))) (add-line (line) @@ -295,12 +298,13 @@ followed another tabulation label or a tabulation body." for line = (and (< index (length lines)) (svref lines index)) while (indentation line) collect line))) - (values (length lisp) (make-instance 'parse-docstrings:lisp-block - :string (flatten-to-string lisp))))) + (values (length lisp) (parse-docstrings:make-code + (parse-docstrings:make-text + (flatten-to-string lisp)))))) (defun section (paragraphs) (if (cdr paragraphs) - (make-instance 'parse-docstrings:section :blocks paragraphs) + (apply #'parse-docstrings:make-paragraph paragraphs) (car paragraphs))) (defun parse-maybe-itemization (lines starting-line) @@ -312,8 +316,9 @@ followed another tabulation label or a tabulation body." (lines-consumed 0)) (labels ((end-paragraph () (when current - (push (make-instance 'parse-docstrings:paragraph - :string (flatten-to-string (reverse current))) + (push (parse-docstrings:make-paragraph + (parse-docstrings:make-text + (flatten-to-string (reverse current)))) paragraphs) (setf current nil))) (end-item () @@ -357,8 +362,9 @@ followed another tabulation label or a tabulation body." (end-item)) ;; a single-item itemization isn't. (if (> (length items) 1) - (values lines-consumed (make-instance 'parse-docstrings:itemization - :items (nreverse items))) + (values lines-consumed + (apply #'parse-docstrings:make-itemization + (nreverse items))) (values nil nil)))) @@ -372,16 +378,17 @@ followed another tabulation label or a tabulation body." (lines-consumed 0)) (labels ((end-paragraph () (when current - (push (make-instance 'parse-docstrings:paragraph - :string (flatten-to-string (reverse current))) + (push (parse-docstrings:make-paragraph + (parse-docstrings:make-text + (flatten-to-string (reverse current)))) paragraphs) (setf current nil))) (end-item () (end-paragraph) (when paragraphs - (push (make-instance 'parse-docstrings:tabulation-item - :title title - :body (section (reverse paragraphs))) + (push (parse-docstrings:make-definition-list-item + title + (section (reverse paragraphs))) items) (setf paragraphs nil title nil))) @@ -415,5 +422,4 @@ followed another tabulation label or a tabulation body." (loop-finish)))) (end-item)) (values lines-consumed - (make-instance 'parse-docstrings:tabulation - :items (reverse items))))) + (apply #'parse-docstrings:make-definition-list (reverse items))))) -- 2.11.4.GIT