Changeset 33913 in project


Ignore:
Timestamp:
04/01/17 19:25:41 (6 months ago)
Author:
zbigniew
Message:

chicken-doc-html: parse sigs more fully, and light up variables and arguments found in {{plaintext}}

Location:
release/4/chicken-doc-html/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/chicken-doc-html/trunk/chicken-doc-html.scm

    r29554 r33913  
    1212           pre-post-order* universal-conversion-rules*))   ;; temp, for toc
    1313(use matchable)
    14 (use (only data-structures conc ->string string-intersperse string-translate alist-ref string-split))
    15 (use (only ports with-output-to-string))
     14(use (only data-structures conc ->string string-intersperse string-translate alist-ref string-split intersperse))
     15(use (only ports with-output-to-string with-input-from-string))
    1616(use regex) (import irregex)
    1717(use (only extras sprintf))
    1818(use (only srfi-13 string-downcase string-index))
    19 (use (only srfi-1 remove))
     19(use (only srfi-1 remove append-map))
    2020
    2121(define (sxml-walk doc ss)
     
    8282;; WARNING: Currently being used to both generate new ids for headers and
    8383;; to figure out the id for an internal-link target.  However the former may
    84 ;; distinuish duplicate IDs while the latter should ignore duplicates.
     84;; distinguish duplicate IDs while the latter should ignore duplicates.
    8585;; FIXME: Duplicate IDs will be generated for duplicate section or
    8686;; definition names.  A unique suffix is needed.
     
    192192                             ; (warning "dropped" (cons t b))
    193193                             '()))
    194          (quote-text `(*text* . ,(lambda (t b s) (quote-html b)))))
     194         (quote-text `(*text* . ,(lambda (t b s) (quote-html b))))
     195         (sig-args '())) ;; FIXME temp TESTING
    195196     (letrec ((block (lambda (tag)        ;; could be moved out of letrec, but eh
    196197                       (let ((open (conc "<" tag ">"))
     
    212213                    (b . ,(inline "b"))
    213214                    (i . ,(inline "i"))
    214                     (tt . ,(inline "tt"))
     215                    ;; Conversion of <tt> to <var> is done here, via a fluid-let
     216                    (tt . ,(lambda (t b s)
     217                             (cond ((not (pair? b)) "")
     218                                   ((memq (string->symbol (car b))
     219                                          sig-args)
     220                                    (sxml->html `(var (@ (class "arg")) ,b)))
     221                                   ((def->href (car b)) =>
     222                                    (lambda (href)
     223                                      ;; def->href generates a direct node
     224                                      ;; link, where we might prefer a # link.
     225                                      ;; Also, A embedded in VAR is odd, but
     226                                      ;; it's easier to style.
     227                                      (sxml->html `(var (@ (class "id"))
     228                                                        (a (@ (href ,href)) ,b)))))
     229                                   (else
     230                                    ((inline "tt") t b s)))))
    215231                    (sup . ,(inline "sup"))
    216232                    (sub . ,(inline "sub"))
     
    307323          (def
    308324           . ,(lambda (t b def-ss)
    309                 `("<dl class=\"defsig\">"
    310                   ,(match b
    311                           ((('sig . sigs) . body)
    312                            `(,(map
    313                                (lambda (s)
    314                                  (match s
    315                                         ((type sig . alist)
    316                                          (let* ((defid (cond ((assq 'id alist) => cadr)
    317                                                              (else (signature->identifier sig type))))
    318                                                 (defid (and defid (->string defid))))
    319                                            `("<dt class=\"defsig\""
    320                                              ,(if defid
    321                                                   `(" id=\""
    322                                                     ,(quote-identifier
    323                                                       (definition->identifier defid))
    324                                                     #\")
    325                                                   '())
    326                                              #\>
    327                                              ;; Link to underlying node.
    328                                              ,(let ((def-href (and defid
    329                                                                    (def->href defid))))
    330                                                 `(,(if def-href
    331                                                        `("<a href=\"" ,def-href "\">")
    332                                                        '())
    333                                                   "<span class=\"sig\"><tt>"
    334                                                   ,(quote-html sig) "</tt></span>"
    335                                                   ,(if def-href "</a>" '())))
    336                                              " "
    337                                              "<span class=\"type\">"
    338                                              ,(quote-html (->string type))
    339                                              "</span>"
    340                                              "</dt>\n")))
    341                                         (else (error "malformed defsig sig" s))))
    342                                sigs)
    343                              "<dd class=\"defsig\">"
    344                              ,(walk body def-ss)
    345                              "</dd>\n"))
    346                           (else
    347                            (error "malformed defsig" b)))
    348                   "</dl>\n")))
     325                ;; FIXME: Setter signatures not handled
     326                ;; FIXME handle car=quote
     327                ;; FIXME: Handle (?) result shown as -> or => after read object
     328                ;; --HANDLED--
     329                ;; Optionals after #!optional are handled. They must look like foo or (foo bar).
     330                ;; Keywords after #!key are handled. They must look like foo or (foo bar).
     331                ;; Rest args after #!rest are handled.
     332                ;; Rest args as in (foo . bar) are handled and converted to (foo #!rest bar).
     333                ;; Optionals like [foo [bar [baz]] in last position are handled and converted to #!optionals foo bar baz.
     334                ;; If a default value for optionals is desired, use #!optionals (foo val).
     335                ;; --NOT HANDLED--
     336                ;; Optionals like [foo bar baz] (srfi-13) and [foo] [bar] [baz] (sundials) are not allowed and
     337                ;;    the signature is rendered unchanged.
     338                ;; Keyword optionals like [foo: foo-procedure] (spiffy start-server) or [#:foo 1.0] (srfi-27)
     339                ;;   or [#:foo FOO] (setup-helper) or [#:foo FOO #t] or [foo: FOO] (smsmatrix)
     340                ;;   or [name [source #f [tag 'locale]]] (locale make-locale-components) are not handled.
     341                ;; Arguments can be lowercased, but this is done via CSS.
     342               
     343                (define (parse-signature sig type)
     344                  ;; Testing read/write invariance as strings is problematic because
     345                  ;; - 'foo is written as (quote foo)
     346                  ;; - #!optional is written as |#!optional|
     347                  ;; but we need to render each arg as an HTML string anyway, so it might work
     348                  (and (memq type '(procedure parameter constant record setter string))
     349                       (let ((L (handle-exceptions exn #f
     350                                  (with-input-from-string sig read))))
     351                         L)))
     352                (define (parse-argument arg dsssl)
     353                  (cond ((keyword? arg) #f)
     354                        ((symbol? arg)
     355                         (case arg
     356                           ((#!optional #!key #!rest) `(var (@ (class "dsssl")) ,arg))
     357                           ;; Perhaps anything starting with # should be marked as
     358                           ;; a keyword or such
     359                           (else `(var (@ (class arg)) ,arg))))
     360                        ((or (string? arg) (number? arg))
     361                         `(var (@ (class value)) ,arg))
     362                        ((pair? arg)
     363                         (cond ((not (pair? (cdr arg))) #f) ;; never permit (foo . bar)
     364                               ((null? (cdr arg)) #f)       ;; Optionals like [foo] were rewritten to #!optionals foo
     365                               ((null? (cddr arg))
     366                                ;; optional value as (foo 3) -- in an #!optional or #!key clause
     367                                (if (eq? (car arg) 'quote)
     368                                    (let ((val (cadr arg)))
     369                                      (if (or (symbol? val) (string? val) (number? val))
     370                                          ;; Render simple values as <var class=value>. We could even do a def->href test
     371                                          ;; and render as <var class=id>, but that's unlikely to ever be useful.
     372                                          `(var (@ (class value)) #\' ,val)
     373                                          `(tt ,(conc #\' val))))
     374                                    (and (memq dsssl '(#!optional #!key))
     375                                         (and-let* ((key (parse-argument (car arg) '()))
     376                                                    (val (parse-argument (cadr arg) '())))
     377                                           ;; This will erroneously render val as class arg when val is a plain
     378                                           ;; symbol, when it should be class value or, fancily, class id.
     379                                           ;; Could do this by changing the dsssl arg to 'mode' and parsing IDs here
     380                                           ;; instead of upstream in compute-sig-shtml.
     381                                           `(#\( ,key " " ,val #\))))))
     382                               (else #f)))
     383                        (else
     384                         `(tt ,(->string arg)))))
     385                (define (parse-optional-arg arg dsssl)
     386                  ;; Parse (foo), (foo (bar)), (foo (bar (baz))), ... and return a list of optional args,
     387                  ;; or #f if parsing failed. Note: Unlike parse-argument, does not return shtml.
     388                  (define (loop acc arg)
     389                    (if (and (pair? arg)
     390                           (not (keyword? (car arg)))
     391                           (symbol? (car arg)))
     392                        (cond ((null? (cdr arg))
     393                             (reverse (cons (car arg) acc)))
     394                            ((and (null? (cddr arg)))
     395                             (loop (cons (car arg) acc) (cadr arg)))
     396                            (else #f))
     397                      #f))
     398                  (and (not dsssl)
     399                       (loop '() arg)))
     400                (define (extract-var-args-from-shtml shtml)
     401                  ;; The SHTML is not a proper sexpr markup of the signature. We walk it because
     402                  ;; it may not be flat.
     403                  (append-map (lambda (b) (match b
     404                                            (('var ('@ ('class 'arg)) x)
     405                                             (list x))
     406                                            ((_ . _)   ; recurse into pair
     407                                             (extract-var-args-from-shtml b))
     408                                            (else '())))
     409                              shtml))
     410                (define (compute-sig-shtml sig type)
     411                  `(span (@ (class sig)) .
     412                         ,(cond ((parse-signature sig type)
     413                                 => (lambda (siglist)
     414                                      (cond ((not (pair? siglist))
     415                                             `((var (@ (class id))
     416                                                    ,siglist))) ; might need to check type
     417                                            ((match siglist
     418                                                    ;; Handle setters. Kinda gross!
     419                                                    (('set! (id arg) val)
     420                                                     `((var (@ (class dsssl)) set!)   ; meh
     421                                                       " ("
     422                                                       (var (@ (class id)) ,id)
     423                                                       " "
     424                                                       ,(parse-argument arg '()) ") "
     425                                                       ,(parse-argument val '())))
     426                                                    (else #f)))
     427                                            ((call/cc (lambda (k) ; rewrite in iterative style pls
     428                                                        (let ((shtml
     429                                                               `((var (@ (class "id"))
     430                                                                      ,(car siglist)) ; might need to verify is symbol
     431                                                                 . ,(let loop ((siglist (cdr siglist))
     432                                                                               (dsssl #f))
     433                                                                      (cond ((null? siglist) '())
     434                                                                            ((pair? siglist)
     435                                                                             (let ((dsssl (if (memq (car siglist) '(#!optional #!key #!rest))
     436                                                                                              (car siglist) dsssl))) ; hmm
     437                                                                               (let ((opt-args
     438                                                                                      (and (null? (cdr siglist))
     439                                                                                           (parse-optional-arg (car siglist) dsssl))))
     440                                                                                 (if opt-args
     441                                                                                     (loop (cons '#!optional opt-args) dsssl)
     442                                                                                     (cons (or (parse-argument (car siglist) dsssl)
     443                                                                                               (k #f))
     444                                                                                           (loop (cdr siglist) dsssl))))))
     445                                                                            (else
     446                                                                             ;; Convert improper list (foo bar . baz) to (foo bar #!rest baz)
     447                                                                             (loop `(#!rest ,siglist) dsssl)))))))
     448                                                          (intersperse shtml " ")))))
     449                                            (else
     450                                             `((tt ,sig))))))
     451                                (else `((tt ,sig))))))
     452
     453                (sxml->html
     454                 `(dl
     455                   (@ (class "defsig"))
     456                   ,(match b
     457                           ((('sig . sigs) . body)
     458                            (let ((args '()))
     459                              `(,(map
     460                                  (lambda (s)
     461                                    (match s
     462                                           ((type sig . alist)
     463                                            (let* ((defid (cond ((assq 'id alist) => cadr)
     464                                                                (else (signature->identifier sig type))))
     465                                                   (defid (and defid (->string defid))))
     466                                              `(dt (@ (class "defsig")
     467                                                      ,(if defid
     468                                                           `(id (lit ,(quote-identifier
     469                                                                       (definition->identifier defid))))
     470                                                           '()))
     471                                                   ,(let ((def-href (and defid
     472                                                                         (def->href defid))))
     473                                                      (let ((sig-span (compute-sig-shtml sig type)))
     474                                                        (set! args (append (extract-var-args-from-shtml sig-span)
     475                                                                           args)) ;; horrible!
     476                                                        (if def-href
     477                                                            ;; Link to underlying node, when present.
     478                                                            `(a (@ href ,def-href) ,sig-span)
     479                                                            sig-span)))
     480                                                   (span (@ (class type))
     481                                                         ,(->string type)))))
     482                                           (else (error "malformed defsig sig" s))))
     483                                  sigs)
     484                                (dd (@ (class "defsig"))
     485                                    (lit ,(fluid-let ((sig-args (append args sig-args))) ;; FIXME
     486                                            (walk body def-ss)))))))
     487                           (else
     488                            (error "malformed defsig" b)))))))
    349489          (pre . ,(block "pre"))        ; may need to quote contents
    350490          (ul . ,(lambda (t b ul-ss)
  • release/4/chicken-doc-html/trunk/chicken-doc-html.setup

    r29554 r33913  
    11;;; -*- scheme -*-
    22
    3 (define version "0.2.7")
     3(define version "0.3.0")
    44
    55(compile -s -O2 -d1 -SJ chicken-doc-html.scm)
Note: See TracChangeset for help on using the changeset viewer.