Commit cebb7628 authored by Dave Cooper's avatar Dave Cooper

Merge branch 'release/1592a' of https://gitlab.common-lisp.net/gendl/gendl into release/1592a

parents 08b356b0 cf9db742
......@@ -335,9 +335,27 @@
(with-cl-who ()
(:p (:table (:tr (:td (ecase (the style)
(:image-figure
(htm (:img :src (if (stringp (the image-file))
(concatenate 'string "images/" (the image-file))
(namestring (the image-file)))
(htm (:img :src (let* ((image-file (if (stringp (the image-file))
(concatenate 'string "images/" (the image-file))
(namestring (the image-file))))
(png-file (when (string-equal (pathname-type image-file) "pdf")
(make-pathname :type "png" :defaults image-file))))
(when png-file
(uiop:run-program
(list (format nil "~a" *gs-path*)
"-q"
(format nil "-sDEVICE=~a" "png256")
(format nil "-sOutputFile=~a" png-file)
(format nil "-dTextAlphaBits=~a" *gs-text-alpha-bits*)
(format nil "-dGraphicsAlphaBits=~a" *gs-graphics-alpha-bits*)
"-dSAFER"
"-dBATCH"
"-dNOPAUSE"
image-file))
;;(uiop:copy-file png-file (merge-pathnames (file-namestring png-file) "~/tmp/images/"))
)
(namestring (merge-pathnames (file-namestring (or png-file image-file)) "images/")))
:style (format nil "width:~a;height:~a;" (the width) (the height))
:alt (the caption))))
(:boxed-figure (dolist (element (list-elements (the :elements)))
......
......@@ -28,6 +28,7 @@
#+nil
(defun replace-substring (string old new)
(let ((position (search old string)))
(if position
......
......@@ -325,6 +325,7 @@ loaderImg: '/static/gwl/tasty-unpix/loader.gif',loaderText: 'Narrowing Down...'}
(html (:html
(:head
(the default-header-content)
((:link :href "/static/gwl/style/top.css" :rel "stylesheet" :type "text/css"))
(:title "The " (:princ (the strings-for-display-verbose)) " Package"))
(:body
(when *developing?* (html (:p (the (write-development-links)))))
......
......@@ -317,7 +317,8 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
(setq pdf-file (merge-pathnames "example.pdf" (glisp:temporary-folder))
named-pdf-file (merge-pathnames (format nil "example-~(~a~).pdf" (the part-full-symbol))
"~/genworks/gendl/documentation/tutorial/images/"))
(uiop:copy-file pdf-file named-pdf-file))
(when (probe-file named-pdf-file) (delete-file named-pdf-file))
(uiop:copy-file pdf-file named-pdf-file))
`((:p (:textbf (:underline "Mixins:")) " "
,(format nil "~{~a~^, ~}" (mapcar #'(lambda (sym) (string sym)) (the mixins-list))))
......
......@@ -34,10 +34,12 @@ object. It contains links to default header content of a HTML
generated yadd page. This contains a link to the favicon.ico and a
link to a default CSS sheet. All these elements can be found in the
*gdl-install-dir*/static/gwl/ directories."
default-header-content (html
default-header-content (html
((:link :href "/static/gwl/images/favicon.ico"
:type "image/x-icon" :rel "icon"))))
(additional-header-content ((:link :href "/static/gwl/style/top.css" :rel "stylesheet" :type "text/css")))
("String of valid HTML. Contains standard jQuery files to include
in the header for additional search funcionality. This computed-slot
contains javascript files, found in the *gdl-install-dir* and used
......
......@@ -165,10 +165,687 @@ written consent from Genworks International.")
(when (probe-file output-images)
(uiop/filesystem:delete-directory-tree output-images :validate t))
(com.genworks.lisp:copy-directory
(merge-pathnames "documentation/tutorial/images/" (asdf:system-source-directory :gendl))
(merge-pathnames "documentation/tutorial/images/"
(if (asdf:system-source-directory :gendl)
(or (probe-file (asdf:system-source-directory :gendl))
(probe-file "~/genworks/gendl/")) (probe-file "~/genworks/gendl/")))
output-images))
(let ((html-path (make-html :output-directory output-directory
:output-file-namestring html-output-file-namestring))
(css-path (make-css :output-directory output-directory
:output-file-namestring css-output-file-namestring)))
(values html-path css-path)))
(in-package :yadd)
(define-object object-dokumentation (remark-writers-mixin base-yadd-sheet)
:input-slots
((show-supported-flag nil)
(instance-supplied nil)
(part-symbol-supplied nil)
(part-package-supplied nil)
(part-package (cond ((the :part-package-supplied) (the :part-package-supplied))
((the :instance-supplied)
(package-name (symbol-package (the
:instance-supplied
:type))))
((symbolp (the :symbol))
(package-name (symbol-package (the :symbol))))
(t (package-name *package*))))
;;
;; FLAG -- append with the symbols-for-index from each section.
;;
(symbols-for-index (cons (list self (format nil "~a" (the symbol)))
(apply #'append (mapsend (list-elements (the sections)) :symbols-for-index))))
(symbol (cond ((the :part-symbol-supplied) (the :part-symbol-supplied))
((the :instance-supplied) (the :instance-supplied :type))
(t nil)))
(instance (progn (when (or (and (the :instance-supplied)
(the :part-symbol-supplied))
(and (the :instance-supplied)
(the :part-package-supplied)))
(error "
If you specify :instance-supplied, do not specify :part-symbol-supplied or :part-package-supplied.
If you specify :part-symbol-supplied, do not specify :instance-supplied."))
(or (the :instance-supplied)
(make-canonical-part (the :part-full-symbol)))))
;;(inherit? t
(inherit? nil)
(show-all-messages? t))
:computed-slots
(
(main-sheet-body
(with-cl-who-string ()
(str (the main-section main-div))))
(documentation (with-output-to-string (*html-stream*)
(the write-documentation)))
(pretty-definition
(let ((*package* (find-package (the part-package))))
(with-cl-who-string ()
(:pre
((:div :class "gdl-object-def")
"(" ((:span :class "gdl-operator") "define-object") " "
((:span :class "gdl-defined-symbol") (str (the part-full-symbol)))
(fmt " (~{~a~^ ~})" (remove 'gdl::vanilla-mixin (the mixins-list))))
(mapc #'(lambda(section)
(str (with-output-to-string (*html-stream*)
(write-the-object section pretty-definition))))
(list-elements (the code-sections))) ")"))))
(strings-for-display (format nil "~a" (the :part-full-symbol)))
(strings-for-display-verbose (format nil "Dokumentation for ~s"
(the :part-full-symbol)))
(part-full-symbol (read-from-string
(string-append (format nil "~a" (the :part-package)) "::"
(format nil "~a" (the :symbol)))))
(part-messages (the instance
(message-list :category :all
:message-type (if (the :inherit?) :global :local)
:return-category? t
:sort-order :by-category :filter
#'(lambda (category msg)
(declare (ignore category))
(not (eql :documentation msg))))))
(category-headings (list :required-input-slots "Input Slots (required)"
:optional-input-slots "Input Slots (optional)"
:settable-optional-input-slots "Input Slots (optional, settable)"
:defaulted-input-slots "Input Slots (optional, defaulting)"
:settable-defaulted-input-slots "Input Slots (optional, defaulting, settable)"
:settable-computed-slots "Computed Slots (settable)"
:computed-slots "Computed Slots" :trickle-down-slots
"Trickle-down Slots" :query-slots "Query Slots"
:objects "Objects" :quantified-objects
"Objects (sequence)" :hidden-objects "Hidden Objects"
:quantified-hidden-objects "Hidden Objects (sequence)"
:functions "GDL Functions"))
(relevant-categories (let ((all-categories
(plist-keys (the category-headings)))
(found-categories
(plist-values (the part-messages))))
(remove-if-not
#'(lambda (category)
(member category found-categories))
all-categories)))
(part-documentation-plist (the :instance (:documentation)))
(example-code (let ((examples (getf (the part-documentation-plist) :examples)))
(when examples
(let ((start-pre (search "<pre>" examples))
(end-pre (search "</pre>" examples)))
(when (and (numberp start-pre) (numberp end-pre))
(subseq examples (+ start-pre 5) end-pre))))))
(mixins-list (the :instance (:mixins :local? t)))
;;(show-vrml? (getf (the instance %renderer-info%) :vrml?))
(show-vrml? nil)
(load-example (progn (with-open-file (out (the lisp-file) :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(princ (the example-code) out))
;;
;; FLAG -- try to muffle redefinition warnings here.
;;
(load (compile-file (the lisp-file)))) :uncached)
(image-file (glisp:temporary-file :extension "png"))
(image-url (format nil "/images/~a" (make-pathname :name (pathname-name (the image-file))
:type (pathname-type (the image-file)))))
(lisp-file (make-pathname :directory (pathname-directory (the image-file))
:name (pathname-name (the image-file))
:device (pathname-device (the image-file))
:type "lisp"))
(code-section-keywords '(:input-slots (:required-input-slots
:optional-input-slots
(:settable-optional-input-slots :settable)
(:defaulted-input-slots :defaulting)
(:settable-defaulted-input-slots :settable :defaulting))
:computed-slots (:computed-slots
(:settable-computed-slots :settable)
(:uncached-computed-slots :uncached))
:objects (:objects :quantified-objects)
:hidden-objects (:hidden-objects :quantified-hidden-objects)
:functions (:functions)
:methods (:methods))))
:objects
((sections :type 'object-dokumentation-category
:sequence (:size (length (the :relevant-categories)))
:category (nth (the-child :index) (the :relevant-categories))
:heading (getf (the category-headings) (the-child category))
:instance (the :instance)
:inherit? (the :inherit?))
(code-sections :type 'code-section
:sequence (:size (length (plist-keys (the code-section-keywords))))
:all-sections (list-elements (the sections))
:section-keys (getf (the code-section-keywords) (the-child keyword))
:keyword (nth (the-child index) (plist-keys (the code-section-keywords)))))
:hidden-objects
(
(main-section :type 'sheet-section
:inner-html (with-cl-who-string
()
(when *developing?* (htm (:p (str (the devo-links-string)))))
(when (the :return-object)
(htm (:p (str (the (back-link
:display-string "Package Documentation"))))))
(str (the :documentation))
(when (the :return-object) (htm (:p (str (the (back-link
:display-string
"Package Documentation"))))))
;;(:p (str (the pretty-definition)))
(:p (str (the :footer)))))
(vrml-sample :type (if (the show-vrml?)
(with-input-from-string (ss (the example-code))
(let ((*package* (find-package (second (read ss)))))
(intern (symbol-name (second (read ss))) *package*)))
'null-part))
(vrml-view :type (if (the show-vrml?) 'web-drawing 'null-part)
;;:view-default (getf (the instance %renderer-info%) :view-default :trimetric)
:object-roots (list (the vrml-sample)))
(vrml-sheet :type (if (the show-vrml?) 'vrml-sheet 'null-part)
:pass-down (vrml-view load-example))
)
:functions
(
(dom-body
()
(when (and (the example-code) (not (search "(generate-sample-drawing" (the example-code))))
(warn "Sample code found in ~s, but no call to generate-sample-drawing was found."
(the part-full-symbol)))
(let (pdf-file named-pdf-file (net.html.parser::*ch-format* '(:i :b :big :small :strike :s :u :em :strong :font)))
(when (and (the example-code)
(or (search "(generate-sample-drawing" (the example-code))
(search "(with-format (pdf" (the example-code))))
(format t "~&~%Loading example code and generating example image for ~s...~%"
(the part-full-symbol))
(the load-example)
(setq pdf-file (merge-pathnames "example.pdf" (glisp:temporary-folder))
named-pdf-file (merge-pathnames (format nil "example-~(~a~).pdf" (the part-full-symbol))
"~/genworks/gendl/documentation/tutorial/images/"))
(when (probe-file named-pdf-file) (delete-file named-pdf-file))
(uiop:copy-file pdf-file named-pdf-file))
`((:p (:textbf (:underline "Mixins:")) " "
,(format nil "~{~a~^, ~}" (mapcar #'(lambda (sym) (string sym)) (the mixins-list))))
(:p ((:list :style :description)
,@(mapcar #'(lambda(keyword)
`((:item :word (:underline ,(format nil "~@(~a~)" keyword)))
(:p ,@(net.html.parser:parse-html (getf (the :part-documentation-plist) keyword)))))
(remove-if-not #'(lambda(keyword)
(getf (the part-documentation-plist) keyword))
(remove :examples (safe-sort *allowed-part-documentation-keywords* #'string<))))))
,(when (the example-code)
`((:boxed-figure :caption ,(format nil "Example Code for ~s" (the part-full-symbol))
:label ,(format nil "fig:example-code-~s" (the part-full-symbol)))
(:small (:verbatim ,(the example-code)))))
,(when named-pdf-file
`((:image-figure :image-file ,named-pdf-file
:width "3in" :height "3in"
:caption ,(format nil "~s example" (the part-full-symbol))
:label ,(format nil "fig:~s" (the part-full-symbol)))))
(:p ,@(or
(remove
nil
(mapcar #'(lambda (section)
(let ((values (the-object section message-and-remarks)))
(when values
`(:p
(:textbf (:underline ,(format nil "~@(~a~):" (the-object section heading))))
((:list :style :description)
,@(mapcar #'(lambda(value)
`((:item :word ,(format nil "~@(~a~)"
(first value)
#+nil ;; reformat inheritance note
(if (sixth value)
(format nil "[~a]" (sixth value))
"")))
(:index ,(format nil "~@(~a~)~%[~(~a~)]"
(first value)
(the symbol)))
,(if (getf (fourth value) :type)
#+nil
`(:emph ,(replace-substring
(getf (fourth value) :type)
"-dot-" "."))
`(:emph ,(let ((parsed
(net.html.parser:parse-html
(replace-substring