cl-markdown-20101006-darcs/ 0000755 0001750 0001750 00000000000 11453110206 013676 5 ustar xach xach cl-markdown-20101006-darcs/test-results/ 0000755 0001750 0001750 00000000000 11453110206 016354 5 ustar xach xach cl-markdown-20101006-darcs/dev/ 0000755 0001750 0001750 00000000000 11453110206 014454 5 ustar xach xach cl-markdown-20101006-darcs/dev/epilogue.lisp 0000644 0001750 0001750 00000000201 11453110206 017147 0 ustar xach xach ;;; the last file to be loaded...
(in-package #:cl-markdown)
(setf *parsing-environment* (make-instance 'parsing-environment))
cl-markdown-20101006-darcs/dev/multiple-documents.lisp 0000644 0001750 0001750 00000017347 11453110206 021213 0 ustar xach xach (in-package #:cl-markdown)
(defun markdown-many (pairs &rest args
&key format additional-extensions render-extensions
&allow-other-keys)
"Markdown-many processes several documents simultaneously as if it
was processing one large document. Its chief purpose is to make it easy to
create inter-document links. Markdown-many takes as input
* `pairs` - a list of lists where each sublist contains the markdown
file to be processed as `input` in its first element and the name of
the file to be produced as the `output`.
* `:format` - a keyword argument specifying the kind of output document
to produce
* `:additional-extensions` - a list of extensions that should be active
both while parsing and rendering.
* `:render-extensions` - a list of extensions that should be active
during rendering.
Here is an example: suppose document-1.md contains
# Document-1
See [document-2][] for details.
and document-2.md contains
# Document 2
[Document-1][] provides an overview.
Getting these links to work using only Markdown will require added explicit
reference link information that will be tied to the file _names_. Markdown-many,
on the other hand, will automatically combine the link information and
processes it automatically.
"
(let ((main-document (make-instance 'multi-document))
(docs nil))
(setf docs
(loop for datum in pairs collect
(bind (((source destination &rest doc-args) datum))
(format t "~&Parsing: ~s~%" source)
(list (apply #'markdown source
:document-class 'child-document
:parent main-document
:format :none (merge-arguments args doc-args))
destination))))
;; transfer information from docs to the parent
(loop for (doc destination) in docs do
(transfer-document-data main-document doc destination))
;; render 'em
(loop for (doc destination) in docs do
(format t "~&Rendering: ~s" destination)
(let ((*current-document* doc)
(*render-active-functions*
(mapcar #'canonize-command
(or render-extensions
(if additional-extensions
`(,@additional-extensions
,@*render-active-functions*)
*render-active-functions*)))))
(render-to-stream doc format destination)))
(setf (children main-document) (mapcar #'first docs))
(values main-document docs)))
(defun merge-arguments (args-1 args-2)
(let ((result args-1))
(map-window-over-elements
args-2 2 2
(lambda (pair)
(bind (((key value) pair)
(present (getf result key)))
(setf (getf result key)
(if present
(append (ensure-list present) (ensure-list value))
value)))))
result))
#+(or)
(merge-arguments '(:a (1) :b (2)) '(:c (3) :a (2)))
#+(or)
(defun _render-one (doc)
(let ((*current-document* doc)
(*render-active-functions*
(mapcar #'canonize-command
`(cl-markdown::docs cl-markdown::docs-index
cl-markdown::today cl-markdown::now
cl-markdown::glossary
,@*render-active-functions*))))
(render-to-stream doc :html #p"/tmp/one.html")))
#+(or)
(untrace markdown)
#+(or)
(compile 'markdown-many)
#+(or)
(cl-markdown:markdown-many
`((,(system-relative-pathname 'cl-markdown "dev/md1.md")
,(system-relative-pathname 'cl-markdown "dev/md1.html"))
(,(system-relative-pathname 'cl-markdown "dev/md2.md")
,(system-relative-pathname 'cl-markdown "dev/md2.html")))
:format :html)
(defun transfer-document-data (parent child destination)
(transfer-link-info parent child destination)
(transfer-selected-properties
parent child
(set-difference (collect-keys (properties child))
(list :footnote :style-sheet :style-sheets :title)))
(transfer-document-metadata parent child))
(defun transfer-document-metadata (parent child)
(iterate-key-value
(metadata child)
(lambda (key value)
; (print (list :p (item-at-1 (metadata parent) key)
; :c value))
(aif (item-at-1 (metadata parent) key)
(setf (item-at-1 (metadata parent) key) (merge-entries it value))
(setf (item-at-1 (metadata parent) key) value)))))
(defun transfer-selected-properties (parent child properties)
(let ((*current-document* parent))
(iterate-elements
properties
(lambda (property)
(when (item-at-1 (properties child) property)
(setf (document-property property)
(first (item-at-1 (properties child) property))))))))
(defun transfer-link-info (parent child destination)
(let ((*current-document* parent))
(iterate-key-value
(link-info child)
(lambda (id info)
(setf (item-at (link-info parent) id)
(transfer-1-link-info info parent child destination))))))
(defgeneric transfer-1-link-info (info parent child destination))
(defmethod transfer-1-link-info ((info link-info) parent child destination)
(declare (ignore parent child))
(make-instance 'link-info
:id (id info)
:url (if (relative-url-p (url info))
(format nil "~@[~a~]~@[.~a~]~a"
(pathname-name destination)
(pathname-type destination)
(url info))
(url info))
:title (title info)
:properties (properties info)))
(defun relative-url-wrt-destination (url destination)
(if (relative-url-p url)
(format nil "~@[~a~]~@[.~a~]~a"
(pathname-name destination)
(pathname-type destination)
url)
url))
(defun relative-url-p (url)
;; FIXME -- look at the spec...
(not
(or (starts-with url "http:")
(starts-with url "mailto:")
(starts-with url "file:"))))
(defmethod transfer-1-link-info ((info extended-link-info)
parent child destination)
(declare (ignore parent child destination))
(make-instance 'extended-link-info
:id (id info)
:kind (kind info)
:contents (contents info)))
;;;
;; A slightly horrid hack that is good enough for indices but
;; completely untested
(defgeneric ugly-create-from-template (thing)
)
(defmethod ugly-create-from-template ((thing standard-object))
(make-instance (class-of thing)))
(defgeneric merge-entries (a b)
(:documentation "Returns a new container C \(of the same type as `a`\)
such that C contains every *entry* in a and b. C may share structure with
`a` and `b`."))
(defmethod merge-entries :around ((a t) (b t))
; (print (list :me a b))
(call-next-method))
(defmethod merge-entries ((a null) (b t))
b)
(defmethod merge-entries ((a null) (b iteratable-container-mixin))
(error "not implemented"))
(defmethod merge-entries ((a null) (b key-value-iteratable-container-mixin))
(merge-using-key-value (ugly-create-from-template b) b))
(defmethod merge-entries ((a t) (b t))
(cond ((and (key-value-iteratable-p a)
(key-value-iteratable-p b))
#+(or)
(merge-key-value-via-iteration a b)
(error "not implemented"))
((and (iteratable-p a)
(iteratable-p b))
(merge-elements-via-iteration a b))
(t
;; FIXME - drop b?
a)))
(defmethod merge-entries ((a list) (b t))
(append a (list b)))
(defmethod merge-entries ((a list) (b list))
(merge-elements-via-iteration a b))
(defmethod merge-entries ((a iteratable-container-mixin)
(b iteratable-container-mixin))
(merge-elements-via-iteration a b))
(defmethod merge-entries
((a key-value-iteratable-container-mixin)
(b key-value-iteratable-container-mixin))
(let ((new (ugly-create-from-template a)))
(merge-using-key-value new a)
(merge-using-key-value new b)
new))
(defun merge-elements-via-iteration (a b)
(let ((new (ugly-create-from-template a)))
(iterate-elements a (lambda (elt) (insert-item new elt)))
(iterate-elements b (lambda (elt) (insert-item new elt)))
new))
(defun merge-using-key-value (a b)
(iterate-key-value b (lambda (key value)
(let ((existing (item-at a key)))
(setf (item-at a key)
(if existing
(merge-entries existing value)
value)))))
a)
cl-markdown-20101006-darcs/dev/spans.lisp 0000644 0001750 0001750 00000023415 11453110206 016476 0 ustar xach xach (in-package #:cl-markdown)
(defvar *current-span* nil)
(defstruct (markdown-scanner (:conc-name scanner-))
name regex priority function)
(setf (item-at-1 *spanner-parsing-environments* 'default)
(make-instance
'sorted-list-container
:sorter '<
:key 'scanner-priority
:initial-contents
`(,(make-markdown-scanner
:regex (create-scanner '(:sequence escaped-character))
:name 'escaped-character
:priority 1
:function 'convert-escape-temporarily)
,(make-markdown-scanner
:regex (create-scanner '(:sequence inline-image))
:name 'inline-image
:priority 2)
,(make-markdown-scanner :regex (create-scanner
'(:sequence reference-image))
:name 'reference-image
:priority 3)
,(make-markdown-scanner :regex (create-scanner
'(:sequence coded-reference-link))
:name 'code
:priority 4)
,(make-markdown-scanner :regex (create-scanner
'(:sequence inline-link))
:name 'inline-link
:priority 5)
,(make-markdown-scanner :regex (create-scanner
'(:sequence reference-link))
:name 'reference-link
:priority 6)
,(make-markdown-scanner :regex (create-scanner '(:sequence backtick))
:name 'code
:priority 7)
,(make-markdown-scanner :regex (create-scanner
'(:sequence strong-em-1))
:name 'strong-em
:priority 8)
,(make-markdown-scanner :regex (create-scanner
'(:sequence strong-em-2))
:name 'strong-em
:priority 9)
,(make-markdown-scanner :regex (create-scanner '(:sequence strong-2))
:name 'strong
:priority 10)
,(make-markdown-scanner :regex (create-scanner '(:sequence strong-1))
:name 'strong
:priority 11)
,(make-markdown-scanner :regex (create-scanner '(:sequence emphasis-2))
:name 'emphasis
:priority 12)
,(make-markdown-scanner :regex (create-scanner '(:sequence emphasis-1))
:name 'emphasis
:priority 13)
,(make-markdown-scanner :regex (create-scanner '(:sequence auto-link))
:name 'link
:priority 14)
,(make-markdown-scanner :regex (create-scanner '(:sequence auto-mail))
:name 'mail
:priority 15)
,(make-markdown-scanner :regex (create-scanner '(:sequence entity))
:name 'entity
:priority 16)
,(make-markdown-scanner :regex (create-scanner '(:sequence html))
:name 'html
:priority 7.5)
,(make-markdown-scanner
:regex (create-scanner '(:sequence line-ends-with-two-spaces))
:name 'break
:priority 1.8)
)))
(setf (item-at-1 *spanner-parsing-environments* '(code))
(make-instance
'sorted-list-container
:sorter '<
:key 'scanner-priority
:initial-contents
`(,(make-markdown-scanner
:regex (create-scanner '(:sequence html))
:name 'html
:priority 1)
,(make-markdown-scanner
:regex (create-scanner '(:sequence entity))
:name 'entity
:priority 2))))
(defun scanners-for-chunk (chunk)
(let ((it nil))
(cond ((setf it (item-at-1 *spanner-parsing-environments*
(markup-class chunk)))
(values it (markup-class chunk)))
(t
(values (item-at-1 *spanner-parsing-environments* 'default) nil)))))
(defmethod handle-spans ((document abstract-document))
(iterate-elements
(chunks document)
(lambda (chunk)
(handle-spans chunk)))
document)
(defmethod handle-spans ((chunk chunk))
(setf (slot-value chunk 'lines)
(bind ((lines (slot-value chunk 'lines))
((:values scanners kind) (scanners-for-chunk chunk))
(*current-span* kind))
(scan-lines-with-scanners lines scanners)))
chunk)
(defun scan-lines-with-scanners (lines scanners)
(when (or (consp lines)
(typep lines 'cl-containers:iteratable-container-mixin))
(iterate-elements
scanners
(lambda (scanner)
(let ((name (scanner-name scanner)))
(setf lines
(let ((result nil))
(iterate-elements
lines
(lambda (line)
(setf result
(append result (scan-one-span
line name scanner scanners)))))
result))))))
lines)
(defmethod scan-one-span ((line (eql nil)) scanner-name scanner scanners)
(declare (ignorable scanner-name scanner scanners))
(list ""))
(defmethod scan-one-span ((line cons) scanner-name scanner scanners)
;;?? what special case does this handle?
(if (process-span-in-span-p scanner-name (first line))
`((,(first line)
,@(let ((*current-span* (first line)))
(scan-one-span (second line) scanner-name scanner scanners))
,@(nthcdr 2 line)))
(list line)))
(defmethod process-span-in-span-p ((sub-span t) (current-span t))
(values t))
(defmethod process-span-in-span-p
((sub-span (eql nil)) (current-span (eql 'html)))
(values nil))
(defmethod process-span-in-span-p ((sub-span t) (current-span (eql 'html)))
(values nil))
(defmethod process-span-in-span-p ((sub-span (eql 'html)) (current-span t))
(values nil))
(defmethod process-span-in-span-p ((sub-span (eql 'html)) (current-span null))
(values t))
(defmethod process-span-in-span-p
((sub-span (eql 'link)) (current-span (eql 'code)))
(values nil))
(defmethod process-span-in-span-p
((sub-span (eql 'html)) (current-span (eql 'code)))
(values nil))
(defmethod process-span-in-span-p ((sub-span t) (current-span (eql 'code)))
(values nil))
(defmethod process-span-in-span-p
((sub-span t) (current-span (eql 'coded-reference-link)))
(values nil))
(defmethod scan-one-span ((line string) scanner-name scanner scanners)
#+debug
(print (list :sos scanner-name *current-span*
(process-span-in-span-p scanner-name *current-span*)
line))
(let ((found? nil)
(result nil)
(last-e 0)
(regex (scanner-regex scanner))
(scanner-fn (scanner-function scanner)))
(when (process-span-in-span-p scanner-name *current-span*)
(flet ((sub-scan (it)
(let ((*current-span* scanner-name))
(scan-lines-with-scanners it scanners))))
(do-scans (s e gs ge regex line)
(let ((registers (loop for s-value across gs
for e-value across ge
when (and (not (null s-value))
(/= s-value e-value)) collect
(sub-scan (subseq line s-value e-value)))))
(setf registers (process-span scanner-name registers))
(let ((converted
`(,@(when (plusp s)
`(,(sub-scan (subseq line last-e s))))
,(if scanner-fn
(funcall scanner-fn scanner-name registers)
`(,scanner-name ,@registers)))))
(setf found? t
last-e e
result (append result converted)))))
(when found?
(setf result
(let ((last (sub-scan (subseq line last-e))))
(if (plusp (size last))
(append result (list last))
result)))
(return-from scan-one-span
(values (combine-strings result) t))))))
(values (list line) nil))
(defun combine-strings (list)
(let ((result nil)
(current nil))
(flet ((maybe-add (something)
(when something
(setf result (nconc result (list something))))))
(iterate-elements
list
(lambda (elt)
(cond ((stringp elt)
(if current
(setf current (concatenate 'string current elt))
(setf current elt)))
(t
(maybe-add current)
(maybe-add elt)
(setf current nil)))))
(maybe-add current)
result)))
#+(or)
(ensure-same (combine-strings '("a" "b" 23 "c" "d")) ("ab" 23 "cd"))
#+(or)
(ensure-same (combine-strings '("a" "b" 23 2)) ("ab" 23 2))
#+(or)
(ensure-same (combine-strings '(1 2 3 )) (1 2 3))
#+(or)
(defmethod scan-one-span ((line string) scanner-name scanner scanners)
(let ((found? nil)
(result nil)
(last-e 0)
(regex (scanner-regex scanner))
(scanner-fn (scanner-function scanner))
(last-thing nil))
(when (process-span-in-span-p scanner-name *current-span*)
(flet ((sub-scan (it)
(let ((*current-span* scanner-name))
(scan-lines-with-scanners it scanners))))
(do-scans (s e gs ge regex line)
(let ((registers (loop for s-value across gs
for e-value across ge
when (and (not (null s-value))
(/= s-value e-value)) collect
(sub-scan (subseq line s-value e-value)))))
(setf registers (process-span scanner-name registers))
(let ((converted
`(,@(when (plusp s)
`(,(sub-scan (subseq line last-e s))))
,(if scanner-fn
(funcall scanner-fn scanner-name registers)
`(,scanner-name ,@registers)))))
(print (list :c converted last-thing))
(cond ((and (stringp converted)
(stringp last-thing))
(setf (first (last result))
(concatenate 'string last-thing converted)))
(t
(setf result (append result converted))))
(setf found? t
last-e e
last-thing converted))))
(when found?
(return-from scan-one-span
(values (let ((last (sub-scan (subseq line last-e))))
(if (plusp (size last))
(append result (list last))
result))
t))))))
(values (list line) nil))
(defun convert-escape-temporarily (scanner-name registers)
(declare (ignore scanner-name))
(assert (position (aref (first registers) 0) *escape-characters*))
(format nil "~c~c~a~c~c"
#\Null #\Null
(position (aref (first registers) 0) *escape-characters*)
#\Null #\Null))
(defmethod unconvert-escapes ((thing t))
thing)
(defmethod unconvert-escapes ((string string))
(cl-ppcre:regex-replace-all
'(:sequence escape-kludge) string
(lambda (_ &rest registers)
(declare (ignore _)
(dynamic-extent registers))
;(print registers)
(let ((ch (parse-integer (first registers))))
(string (aref *escape-characters* ch))))
:simple-calls t))
(defmethod unconvert-escapes ((thing list))
(collect-elements thing :transform #'unconvert-escapes))
(defmethod unconvert-escapes ((thing chunk))
(setf (slot-value thing 'lines)
(collect-elements (lines thing) :transform #'unconvert-escapes)))
(defmethod unconvert-escapes ((thing abstract-document))
(iterate-elements (chunks thing) #'unconvert-escapes))
cl-markdown-20101006-darcs/dev/docs.lisp 0000644 0001750 0001750 00000045623 11453110206 016307 0 ustar xach xach (in-package #:cl-markdown)
(defun docs-package ()
(let ((property (document-property :docs-package)))
(typecase property
(package property)
(t (let ((package
(or (find-package property)
(find-package (string-upcase property)))))
(setf (document-property :docs-package) package))))))
(defmethod check-exportedp ((symbol cons))
;; setf methods
(check-exportedp (second symbol)))
(defmethod check-exportedp ((symbol symbol))
(unless (or (eq (nth-value 1 (find-symbol (symbol-name symbol)
(symbol-package symbol)))
:external)
(eq (nth-value 1 (find-symbol (symbol-name symbol)
*package*))
:external))
(markdown-warning "Symbol ~s is not exported" symbol)))
(defun ensure-documentation-holder (thing &optional (package nil))
(etypecase thing
(symbol (if (and package (not (eq (symbol-package thing) package)))
(intern (symbol-name thing) package)
thing))
(string (if (and package (find #\space thing))
(let ((*package* package)) (read-from-string thing))
(intern thing package)))
(cons (if (and (eql (first thing) 'setf)
(= (length thing) 2)
(typep (second thing) 'symbol))
(list 'setf (ensure-documentation-holder (second thing) package))
(error "`~a` cannot be converted into something that can hold documentation" thing)))))
(defextension (docs :arguments ((name) (desired-kind))
:insertp t)
(bind ((*package* (or (docs-package) *package*))
symbol)
(labels ((find-docs (thing)
(bind (((:values kinds nil)
(let ((it nil))
(cond ((setf it (symbol-identities-with-docstring
thing desired-kind))
(values it t))
(desired-kind
nil)
(t
(values (mapcar
(lambda (x) (cons x nil))
(symbol-identities thing)) nil))))))
(setf symbol thing)
kinds)))
(bind ((kinds (or (find-docs (ensure-documentation-holder name))
(find-docs (ensure-documentation-holder
name *package*))))
(potentially-ambiguous? (> (length
(symbol-identities-with-docstring
symbol nil))
1))
(kind (or (first kinds) (cons desired-kind nil)))
(docs (and (cdr kind) (find-documentation
symbol (form-keyword (cdr kind)))))
(identity (car kind)))
(ecase phase
(:parse
;;?? could memoize this (where is it stored? in add-docs-item?)
(cond ((> (length kinds) 1)
(markdown-warning "Multiple interpretations found for ~a (~{~a~^, ~}; specify type (using ~a for now)"
name kinds identity))
((null kinds)
(markdown-warning "No docstring found for ~a (package is ~s~@[, kind is ~s~])"
name (package-name (docs-package)) kind))
(t
(check-exportedp symbol)
(add-docs-item symbol identity)
;; this is the result: t if we need to generate an anchor
(documentation-needs-anchor-p name identity))))
(:render
(when (first result)
(anchor-documentation
name identity
(and (not (documentation-needs-anchor-p name nil))
potentially-ambiguous?)))
(render-documentation (form-keyword identity) symbol docs)
nil))))))
(defmethod render-documentation (identity symbol docs)
(format *output-stream*
"" identity)
(format *output-stream*
"
")
(format *output-stream* "
")
(format *output-stream* "X")
(format *output-stream*
"~&")
(stream-string-for-html (symbol-name symbol) *output-stream*)
(format *output-stream* "")
(when (thing-may-have-arguments-p symbol)
(let ((arguments (mopu:function-arglist symbol)))
(when arguments
(format *output-stream*
"~&")
(display-arguments arguments :kind identity)
(format *output-stream* ""))))
(format *output-stream* "~&
~%")
(format *output-stream*
"~&
~a" identity)
(format *output-stream* "~&
~%")
(unless (document-property :docs-signatures-only)
(format *output-stream*
"
")
(cond
(docs
(markdown docs
:stream *output-stream*
:format *current-format*
:properties '(("html" . nil)
(:omit-final-paragraph . t)
(:omit-initial-paragraph . t))
:document-class 'included-document))
(t
(format
*output-stream*
"No documentation found")))
(format *output-stream* "~&
~%"))
(format *output-stream* "~&
" index-kind)
(format *output-stream* "~&
")
(loop for (item . real-kind) in items do
(output-documentation-link item real-kind item))
(format *output-stream* "~&
~%")
(format os "~&
Exported Symbols with no apparent use
~%")
(cond (packages
(let ((symbols (symbols-exported-with-no-definition
packages :excluded-symbols excluded)))
(format os "~&
~%")
(format os "~&
From packages:
~%")
(format os "~&~{~&~a~^ ~}"
(mapcar #'package-name packages))
(format os "~&~%")
(cond ((> (length symbols) 0)
(format os "~&
~:d Symbols
~%"
(length symbols))
(loop for s in symbols do
(format os "~&
~s ~%" s)))
(t
(format os "~&All exported symbols are accounted for~%"
(length symbols))))
(when excluded
(format os "~&
~%")
(format os "~&
Ignoring the following ~:d symbols
~%"
(length excluded))
(format os "~&~{~s ~^ ~%~}~%"
excluded)
(format os "~&~%"))))
(t
(format os "~&
There are no packages specified by the
property :documentation-packages~%")))
(format os "~&
~%")
(format os "~&
Exported Symbols not mentioned in the documentation
~%")
(cond (packages
(let ((symbols (symbols-not-documented-by-multi-document
documents
packages
*package*
:excluded-symbols excluded)))
(format os "~&
~%")
(format os "~&
From packages:
~%")
(format os "~&~{~&~a ~^ ~}"
(mapcar #'package-name packages))
(format os "~&~%")
(cond ((> (length symbols) 0)
(format os "~&
~:d Undocumented Symbols
~%"
(length symbols))
(loop for s in symbols
do (format os "~&
~s ~%" s)))
(t
(format os "~&All exported symbols are documented.~%")))
(when excluded
(format os "~&
~%")
(format os "~&
Ignoring ~d symbols
~%"
(length excluded))
(unless donot-display-excluded-symbols
(format
os "~&~{~s ~^ ~%~}~%"
excluded))
(format os "~&~%"))))
(t
(format os "~&
There are no packages specified by the
propoerty :documentation-packages~%")))
(format os "~&
~%")
(format os "~&
Exported Symbols not mentioned in the documentation
~%")
(cond (packages
(let ((symbols (symbols-not-documented-by-multi-document
documents
packages
*package*
:excluded-symbols excluded)))
(format os "~&
~%")
(format os "~&
From packages:
~%")
(format os "~&~{~&~a ~^ ~}"
(mapcar #'package-name packages))
(format os "~&~%")
(cond ((> (length symbols) 0)
(format os "~&
~:d Undocumented Symbols
~%"
(length symbols))
(loop for s in symbols
do (format os "~&
~s ~%" s)))
(t
(format os "~&All exported symbols are documented.~%")))
(when excluded
(format os "~&
~%")
(format os "~&
Ignoring ~d symbols
~%"
(length excluded))
(unless donot-display-excluded-symbols
(format
os "~&~{~s ~^ ~%~}~%"
excluded))
(format os "~&~%"))))
(t
(format os "~&
There are no packages specified by the
propoerty :documentation-packages~%")))
(format os "~&
~%")
(format os "~&
Documented symbols
~%")
(cond ((> (length symbols) 0)
(format os "~&~:d Documented Symbols
~%"
(length symbols))
(loop for s in symbols
do (format os "~&~s ~%" s)))
(t
(format os "~&All exported symbols are documented.~%")))
(format os "~&~%"))))
(defextension (markdown-warnings-report
:arguments ())
(when (eq phase :render)
(bind ((os *output-stream*)
(document (document-property :documentation-document))
(documents (merge-elements
(warnings document)
(lambda (old new)
(push new old))
(lambda (new)
(list new))
:key 'first :argument 'cdr
:filter (lambda (pair)
(typep (first pair) 'document #+(or) 'child-document))))
(warnings? nil))
(format os "~&~%")
(format os "~&
Markdown Warnings
~%")
(setf documents (sort documents #'string-lessp
:key (compose 'ensure-string 'source 'first)))
(loop for (document warnings) in documents do
(when warnings
(setf warnings? t)
(format os "~&
~%")
(format os "~&
~a
~%"
(short-source (source document)))
(format os "~&
~%")
(loop for warning in (merge-elements
warnings
(lambda (old new)
(declare (ignore new))
(incf (second old))
old)
(lambda (new) (list new 1))
:test 'equal
:return :values) do
(format os "~&- ~a
~%" warning))
(format os "~&
~%")
(format os "~&
~%")))
(unless warnings?
(format os "~%No warnings found.~%"))
(format os "~&
")
(setf *magic-space-p* nil)
(dolist (bit body)
(render-to-html bit 'encode-pre))
(format *output-stream* "")
(setf *magic-space-p* nil))
(defmethod render-span-to-html ((code (eql 'entity)) body encoding-method)
(declare (ignore encoding-method))
(setf *magic-space-p* nil
*magic-line-p* -1)
(output-html body)
(setf *magic-space-p* nil
*magic-line-p* -1))
(defmethod render-span-to-html
((code (eql 'reference-link)) body encoding-method)
(declare (ignore encoding-method))
(bind (((:values text id nil)
(if (length-1-list-p body)
(values (first body) (first body) nil)
(values (butlast body 1) (first (last body)) t)))
(link-info (find-link id)))
(cond ((not (null link-info))
;; it _was_ a valid ID
(generate-link-output link-info text))
(t
(markdown-warning "No reference found for link ~s" id)
(format *output-stream* "~a" (if (consp text) (first text) text))
(setf *magic-space-p* nil)))))
(defmethod generate-link-output ((link-info link-info) text)
(output-link (url link-info) (title link-info) text (properties link-info)))
(defmethod generate-link-output ((link-info extended-link-info) text)
;; you didn't really want it to be fast did you...?
(generate-link-output-for-kind (kind link-info) link-info text))
(defmethod render-span-to-html
((code (eql 'inline-link)) body encoding-method)
(declare (ignore encoding-method))
(bind (((text &optional (url "") title) body))
(output-link url title (list text))))
(defmethod render-span-to-html ((code (eql 'link)) body encoding-method)
(declare (ignore encoding-method))
(let ((link (first body)))
(output-link link nil link)))
(defmethod render-span-to-html
((code (eql 'reference-image)) body encoding-method)
(declare (ignore encoding-method))
(bind (((:values text id nil)
(if (length-1-list-p body)
(values (first body) (first body) nil)
(values (butlast body 1) (first (last body)) t)))
(link-info (find-link id)))
(cond ((not (null link-info))
;; it _was_ a valid ID
(output-image (url link-info) (title link-info) text
(properties link-info)))
(t
;;?? hackish
(markdown-warning "No reference found for image link ~s" id)
(format *output-stream* "~a (image)"
(if (consp text) (first text) text))
(setf *magic-space-p* nil)))))
(defmethod render-span-to-html
((code (eql 'inline-image)) body encoding-method)
(declare (ignore encoding-method))
(bind (((text &optional (url "") title) body))
(output-image url title text)))
(defun output-link (url title text &optional properties)
(cond ((not (null url))
(format *output-stream* "" *output-stream*)
(setf *magic-space-p* nil)
(encode-html (ensure-list text) nil)
(format *output-stream* "")
(setf *magic-space-p* nil))
(t
)))
(defun output-image (url title text &optional properties)
(cond ((not (null url))
(format *output-stream*
"![\"~A\"~]"](\"~A\"~@[ "\\"~A\\"~]~@[")
" *output-stream*)
(setf *magic-space-p* nil))
(t
)))
(defmethod render-span-to-html ((code (eql 'html)) body encoding-method)
;; hack!
(let ((output (first body)))
(etypecase output
(string
(output-html (list output #+(or) (encode-pre output))))
(list
(render-span-to-html (first output) (rest output) encoding-method)))))
;; Special cases R us.
(defmethod render-span-to-html ((code (eql 'break)) body encoding-method)
(encode-html body encoding-method)
(format *output-stream* "
~%"))
(defun stream-out-markup (markup reverse)
(dolist (marker (if reverse (reverse markup) markup))
(let ((cr? (member marker
*block-level-html-tags* :test 'string=)))
(when (and (not reverse) cr?)
(terpri *output-stream*))
(format *output-stream* "<~a~a>"
(if reverse "/" "") marker))))
;; FIXME - in case you're wondering, this is an ugly bit of code
(defmethod render-to-html ((document abstract-document) encoding-method)
(bind ((current-chunk nil)
(wrap-in-html (add-html-header-p document)))
(labels ((render-block (block level markup inner?)
; (print (list :rb level inner? (first block)))
(setf *magic-space-p* nil)
(let ((add-markup? (not (eq (first block) current-chunk)))
(real-markup
(if (and (not inner?) (length-1-list-p block))
(append
markup (html-inner-block-markup (first block)))
markup)))
(when add-markup?
(stream-out-markup real-markup nil))
(cond ((or (length-1-list-p block)
)
(render-to-html (first block) encoding-method))
((not add-markup?)
(render-to-html (first block) encoding-method)
(do-it (rest block) level))
(t
(setf current-chunk (and inner? (first block)))
(do-it block level)))
(when add-markup?
(stream-out-markup real-markup t))))
(do-it (chunks level)
; (print (list :di level (first chunks)))
(loop for rest = chunks then (rest rest)
for chunk = (first rest) then (first rest)
while chunk
for new-level = (level chunk)
when (= level new-level) do
(let ((index (inner-block rest))
(inner-markup (html-inner-block-markup chunk)))
(render-block (subseq rest 0 index)
level inner-markup t)
(setf rest (nthcdr (1- index) rest)))
when (< level new-level) do
(multiple-value-bind (block remaining method)
(next-block rest new-level)
(declare (ignore method))
(render-block
block new-level (html-block-markup chunk) nil)
(setf rest remaining)))))
(when wrap-in-html
(generate-html-header))
(do-it (collect-elements (chunks document)) (level document))
(when wrap-in-html
(format *output-stream* "~& ~&