;; ;; Copyright 2002-2011 Genworks International ;; ;; This source file is part of the General-purpose Declarative ;; Language project (GDL). ;; ;; This source file contains free software: you can redistribute it ;; and/or modify it under the terms of the GNU Affero General Public ;; License as published by the Free Software Foundation, either ;; version 3 of the License, or (at your option) any later version. ;; ;; This source file is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Affero General Public License for more details. ;; ;; You should have received a copy of the GNU Affero General Public ;; License along with this source file. If not, see ;; . ;; (in-package :yadd) (define-object base-yadd-sheet (base-ajax-sheet) :documentation (:author "Dave Cooper (Genworks)" :description "Base mixin for a yadd sheet") :computed-slots (;; FLAG JB-090817 added default header content with links to style-sheet and icons ("Contains default header contents for yadd html files. This computed-slot is available in all children of this 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 ((:link :href "/static/gwl/images/favicon.ico" :type "image/x-icon" :rel "icon")))) ("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 throughout the yadd pages for the generation of automatic search forms (like the master-index). The javascript loaded is jquery." additional-header-js (with-cl-who-string () ;; ;; FLAG -- base jquery should come with base-ajax-sheet. ;; #+nil ((:script :type "text/javascript" :src "/static/3rdpty/jquery/js/jquery-1.3.2.min.js")) ((:script :type "text/javascript" :src "/static/3rdpty/jquery/js/jquery.quicksearch.js")))) (footer (let* ((version "1581") (patch 9)) (with-cl-who-string () ((:p :class "copyrightFooter") "Copyright © " (multiple-value-bind (seconds minutes hours date month year) (get-decoded-time) (declare (ignore seconds minutes hours date month)) (str year)) " " ((:a :href "http://www.genworks.com") "Genworks") (:sup "®") " " ((:a :href "http://www.genworks.com") "International") ". All rights reserved. " (:i (:small "Genworks Build: " (str version) (when patch (htm "p")) (str (format nil "~3,,,'0@a" patch))))) ((:p :class "copyrightFooter") (:i "User Code Packages copyright © their respective authors")))))) :functions ((dom-body () "") (compute-url () (the descriptive-url)) (write-footer () (let ((*stream* (or *html-stream* *stream*))) (let* ((version "1581") (patch 9)) (with-cl-who() ((:p :class "copyrightFooter") "Copyright © " (multiple-value-bind (seconds minutes hours date month year) (get-decoded-time) (declare (ignore seconds minutes hours date month)) (str year)) " " ((:a :href "http://www.genworks.com") "Genworks") (:sup "®") " " ((:a :href "http://www.genworks.com") "International") ". All rights reserved. " (:i (:small "Genworks Build: " (str version) (when patch (htm "p")) (str (format nil "~3,,,'0@a" patch))))))))))) (define-object remark-writers-mixin () :computed-slots ((dok-type (ecase (the :type) (object-dokumentation "Object") (function-dokumentation (if (the :macro?) "Macro" "Function")) (variable-dokumentation "Parameter or Constant"))) (macro? nil)) :functions ((supported? (type-string) (search "(supported)" type-string)) (write-type (type-string &key (show-supported-flag? t)) (let* ((supported? (the (:supported? type-string))) (type-string (replace-substring type-string "(supported)" "")) (type-page (gethash (ignore-errors (intern (string-upcase type-string) (the package))) (the index-ht)))) (if type-page (html ((:a :href (the-object type-page :url)) (:princ (string-downcase type-string)))) (html (:princ (string-downcase type-string)))) (when show-supported-flag? (html " " (if supported? (html ((:font :color :green) (:b "[Supported Message]"))) (html ((:font :color :red) (:b "[Internal, Unsupported Message]")))))))) (write-remark-body (plist &key show-package) (html (:p (:princ (getf plist :intro))) (:dl (when show-package (html (:dt (:i "Package:")) (:dd (:tt (:small (:princ (string-downcase (package-name show-package))))) (let ((nicknames (mapcar #'string-downcase (package-nicknames show-package)))) (when nicknames (html " (a.k.a. " (:tt (:small (:princ (format nil "~{~a~^, ~}" nicknames)))) ")")))))) (mapcar #'(lambda (key value) (html (:dt (:i (:princ (string-downcase (case key (:&optional "Optional Arguments") (:&key "Keyword Arguments") (:&rest "Rest Arguments") (:&body "Body Arguments") (otherwise key)))) ":")) (:dd (case key ((:arguments :&rest :&body) (the (:write-arguments value))) ((:&optional :&key) (the (:write-optional-arguments value))) (otherwise (html (:princ value))))))) (plist-keys (rest (rest (rest (rest plist))))) (plist-values (rest (rest (rest (rest plist))))))))) (write-optional-arguments (plist) (html (:dl (mapcar #'(lambda (key value) (let* ((arg (if (listp key) (first key) key)) (default (when (listp key) (second key))) (value-strings (split value #\.)) (type (first value-strings)) (description-strings (rest value-strings)) (description-string (format nil "~{~a~^.~}" description-strings))) (html (:small (:dt (:b (:princ (string-downcase arg))) " " (:i (:princ type)) ", Default Value: " (:tt (:prin1 default))) (:dd (:princ description-string)))))) (plist-keys plist) (plist-values plist))))) (write-arguments (plist) (html (:dl (mapcar #'(lambda (key value) (let* ((value-strings (split value #\.)) (type (first value-strings)) (description-strings (rest value-strings)) (description-string (format nil "~{~a~^.~}" description-strings))) (html (:small (:dt (:b (:princ (string-downcase key))) " " (:i (:princ type))) (:dd (:princ description-string)))))) (plist-keys plist) (plist-values plist))))))) (define-object doc-links-mixin (base-html-sheet) :input-slots (package return-object heading external-only?) :computed-slots ((package-object (find-package (format nil "~a" (the :package)))) (doks (list-elements (if (the :external-only?) (the :dokumentation-external) (the :dokumentation))))) :objects ((dokumentation :type (the :part-type) :sequence (:size (length (the :symbols))) :symbol (nth (the-child :index) (the :symbols)) :pass-down (:return-object :package)) (dokumentation-all :type (the :part-type) :sequence (:size (length (the :symbols-all))) :symbol (nth (the-child :index) (the :symbols-all)) :pass-down (:return-object :package)) (dokumentation-external :type (the :part-type) :sequence (:size (length (the :symbols-external))) :symbol (nth (the-child :index) (the :symbols-external)) :pass-down (:return-object))) :functions ((dom-subsections nil (let ((documentations (safe-sort (the :doks) #'string-lessp :key #'(lambda (obj) (format nil "~a" (the-object obj :symbol)))))) (when documentations `((:subsection :title ,(the :heading)) ((:list :style :itemize) ,@(mapcar #'(lambda(documentation) (remove nil `(:item (:index ,(format nil "~a" (the-object documentation symbol))) ,(format nil "~a~a" (the-object documentation symbol) (if (the-object documentation :macro?) " [Macro]" "")) ,(the-object documentation dom-body)))) documentations)))))) (write-documentation-links nil (let ((documentations (safe-sort (the :doks) #'string-lessp :key #'(lambda (obj) (format nil "~a" (the-object obj :symbol)))))) (when documentations (html (:p (:h3 (:princ (the :heading))) (:ul (dolist (documentation documentations) (html (:li (the-object documentation (:write-self-link :display-string (string-downcase (format nil "~a" (the-object documentation :symbol))))) (when (the-object documentation :macro?) (html " [Macro]"))))))))))))) (define-object doc-string-parser-mixin nil :input-slots (remark-string package) :computed-slots ((string-lines (let (in-pre?) (mapcar #'(lambda (string) (when (search "
" string) (setq in-pre? t))
                               (when (search "
" string) (setq in-pre? nil)) (if in-pre? string (string-trim (list #\Space #\Tab) string))) (remove :newline (split (the :remark-string) (list #\Newline #\Return)))))) (remark-type (when (and (find #\. (first (the :string-lines))) (not (all-caps? (first (split (first (the :string-lines))))))) (first (split (first (the :string-lines)) #\.)))) (string-lines-rest (if (the :remark-type) (cons (format nil "~{~a~^.~}~a" (rest (split (first (the :string-lines)) (list #\.))) (let ((line (string-trim (list #\Space #\Tab) (first (the :string-lines))))) (if (eql (aref line (1- (length line))) #\.) "." ""))) (rest (the :string-lines))) (the :string-lines))) (section-start-positions (let ((count -1) result in-pre?) (dolist (line (the :string-lines-rest) (nreverse result)) (incf count) (when (and (not in-pre?) (not (zerop (length line))) (or (eql (aref (string-trim (list #\Space #\Tab) line) 0) #\:) (all-caps? (first (split line))))) (push count result)) (when (search "
" line) (setq in-pre? t))
                                (when (search "
" line) (setq in-pre? nil))))) (section-plist (append (list :type (the :remark-type) :intro (apply #'string-append (mapcar #'(lambda (string) (string-append string (format nil "~%"))) (subseq (the :string-lines-rest) 0 (first (the :section-start-positions)))))) (mapcan #'(lambda (start end) (let ((key (make-keyword (read-from-string (first (split (first (subseq (the :string-lines-rest) start (1+ start)))))))) (value (apply #'string-append (cons (apply #'string-append (append (mapcar #'(lambda (string) (string-append string " ")) (rest (split (first (subseq (the :string-lines-rest) start (1+ start)))))) (list (format nil "~%")))) (mapcar #'(lambda (string) (string-append string (format nil "~%"))) (subseq (the :string-lines-rest) (1+ start) end)))))) (list key (case key ((:arguments :&optional :&key :&rest) (read-from-string value)) (otherwise value))))) (the :section-start-positions) (append (rest (the :section-start-positions)) (list nil))))))) (defparameter *keyword-length-threshhold* 3) (defun all-caps? (string) (and (> (length string) *keyword-length-threshhold*) (every #'(lambda(char) (find char "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) string)))