#|-------------------- 0.4.1 |# "./chicken-doc-text.scm" 14607
(module chicken-doc-text (write-sxml-as-text)

(import scheme chicken)
(use fmt)
(use sxml-transforms)
(use matchable)
(use data-structures srfi-13 ports)
(require-library srfi-1)
(import (only srfi-1 filter-map reduce make-list))

(define walk pre-post-order)

;; sxml-transforms does not allow us to pass state around so we
;; use parameters and preorder traversal; it also does not let
;; us obtain the current stylesheet bindings, so we must approximate
;; them with a letrec
(define (make-text-stylesheet doc #!key (wrap 78) (warnings #f))
  (define (flatten-frags frags)
    (with-output-to-string (lambda () (SRV:send-reply frags))))
  (define (indent-and-wrap-with-bullet indent wrap prefix items)
    ;; we could have caller combine indent and prefix into prefix
    (define (split-first-line s)
      (cond ((string-index s #\newline)
             => (lambda (i) (cons (substring s 0 i)
                             (substring s (+ i 1)))))
            (else (cons s #f))))
    (let* ((prefix (string-append (make-string indent #\space) prefix)))
      (if (not wrap)
          `(,prefix ,items #\newline)
          (match
           ;; split required to extract indented lists in items ("rest") -- rethink this?
           (split-first-line (flatten-frags items))
           ((line1 . rest)
            `(,(fmt #f (with-width
                        wrap
                        (columnar (string-length prefix) (dsp prefix)
                                  (wrap-lines line1))))
              ,rest))))))
  (define (extract-dl-items dl)  ; returns ( (term . defs) ...)
    (let loop ((dl dl)
               (L '())
               (dt #f)    ; the unknown term
               (dd '()))
      (if (null? dl)
          (if dt
              (let ((L (cons (cons dt (reverse dd)) L))) ; remaining dt
                (reverse L))
              '())
          (match (car dl)
                 (('dt . term)
                  (if dt
                      (loop (cdr dl) (cons (cons dt (reverse dd)) L) term '())
                      (loop (cdr dl) L term '())))    ; skip until first dt
                 (('dd . def)
                  (loop (cdr dl) L dt (cons def dd)))))))
  (define (extract-table-items table cell-ss)
    ;; returns ( (td td ...) (td td ...) )
    ;; with TD flattened into strings and wrapped
    (let ((cell-ss `((@ *preorder* . ,drop-tag)
                     . ,cell-ss)))
      (filter-map (match-lambda (('tr . tds)
                            (filter-map
                             (match-lambda (('td . body)
                                       (flatten-frags (pre-post-order body cell-ss)))
                                      ;; we don't pass the "th" identity back, so we can't
                                      ;; do further processing, such as centering
                                      (('th . body)
                                       (string-upcase
                                        (flatten-frags (pre-post-order body cell-ss))))
                                      (else #f))
                             tds))
                           (else #f))   ; usu. whitespace and (@ ...)
                  table)))
  ;; special formatter for table top/bottom
  (define (fill char) (lambda (st) ((cat (make-string (fmt-width st) char)) st)))
  ;(define (fill char) (lambda (st) ((pad-char char (pad/both (fmt-width st))) st)))
  (define (drop-tag . x) '())
  (define (text-warning . args)
    (when warnings (apply warning args)))
  (define (drop-tag-noisily tag . body)
    (text-warning "dropped" (cons tag body))
    '())
                           
  (let* ((wrap (and wrap (not (zero? wrap)) (max wrap 0)))
         (list-indent (make-parameter 2))
         (hr-glyph (if wrap (make-string wrap #\-) "--------")))
    (letrec
        ((default-elts
          `((*text* . ,(lambda (tag text) text))
            (*default* . ,drop-tag-noisily)))
         (inline-elts
          `((b . ,(lambda (tag . body) `("_" ,body "_")))
            (i . ,(lambda (tag . body) `("/" ,body "/")))
            (tt . ,(lambda (tag . body) `("`" ,body "`")))
            (sub . ,(lambda (tag . body) body))
            (sup . ,(lambda (tag . body) body))
            (big . ,(lambda (tag . body) body))
            (small . ,(lambda (tag . body) body))

            (link . ,(lambda (tag href #!optional (desc #f))
                       (if desc
                           `(,desc #\space #\( ,href #\))
                           href)))
            (int-link . ,(lambda (tag href #!optional (desc #f))
                           (or desc
                               href ;; `(#\[ ,href #\])
                               )))))
         (block-elts
          `((section . ,(lambda (tag level name . body)
                          `(#\newline
                            ,(case level
                               ((2) "==")
                               ((3) "===")
                               ((4) "====")
                               ((5) "=====")
                               ((6) "======")
                               (else "======"))
                            " " ,name #\newline ,body)))
            ,@(let ((parse-LIs
                     (lambda (items prefix)
                       (let ((index 0))
                         `(#\newline
                           ,(pre-post-order
                             items
                             `((li *preorder* .
                                   ,(lambda (tag . items)
                                      (set! index (+ index 1)) ; grr
                                      (let ((p (prefix index))
                                            (i (list-indent)))
                                        (indent-and-wrap-with-bullet
                                         i wrap p
                                         (parameterize ((list-indent (+ i (string-length p))))
                                           ;; NB the transformer won't correctly handle
                                           ;; block elements other than nested lists
                                           (pre-post-order items ss)))))))))))))
                `((ul *preorder* .
                      ,(lambda (tag . items)
                         (parse-LIs items (lambda (i) "* "))))
                  (ol *preorder* .
                      ,(lambda (tag . items)
                         (parse-LIs items (lambda (i) (string-append
                                                 (number->string i) ". ")))))))

            (dl *preorder* .
                ,(lambda (tag . items)
                   `(#\newline
                     ,(map (match-lambda
                            ((term . defs)
                             (let* ((term (flatten-frags (pre-post-order term inline-ss)))
                                    (bullet (string-append "- " term ": ")))
                               ;; Indent the term's description to align with the term.
                               ;; If this indent exceeds 25% of the output width, just
                               ;; align to the "- " bullet as in a normal list.
                               (let* ((indent-limit (inexact->exact (truncate (* .25 wrap))))
                                      (desc-indent-limit (max 0 (- indent-limit (list-indent)))))
                                 (if (> (string-length bullet) desc-indent-limit)
                                     (indent-and-wrap-with-bullet
                                      (list-indent) wrap "- "
                                      (cons (string-append term ": ")
                                            (pre-post-order defs inline-ss)))
                                     (indent-and-wrap-with-bullet
                                      (list-indent) wrap bullet
                                      ;; FIXME: multiple defs should be displayed separately
                                      (pre-post-order defs inline-ss)))))))
                           (extract-dl-items items)))))
            
            (p . ,(lambda (tag . body)
                    (let ((str (flatten-frags body)))  ; FIXME remove if no wrap
                      `(#\newline
                        ,(if wrap
                             (fmt #f (with-width wrap (wrap-lines str)))
                             (list str #\newline)))))) ; need extra NL if no wrap-lines
            (pre . ,(lambda (tag . body)
                      `(#\newline "    "  ; dumb
                        ,(string-intersperse (string-split (flatten-frags body) "\n" #t)
                                             "\n    ")
                        #\newline ; hmm
                        )
                      ))
            (highlight . ,(lambda (tag lang . body)
                            ;; use PRE output for now; ignore LANG
                            `(#\newline "    " ; dumb
                              ,(string-intersperse (string-split (flatten-frags body) "\n" #t)
                                                   "\n    ")
                              #\newline ; hmm
                              )
                            ))

            (def ((sig *preorder*
                       . ,(lambda (tag . sigs)
                            (list (map (lambda (s)
                                         (match s
                                                ((type sig . alist)
                                                 ;; don't bother filtering by valid types
                                                 `(#\newline "-- " ,type ": "
                                                   ,(walk sig inline-ss)))))
                                       sigs)
                                  #\newline))))
                 . ,(lambda (tag . body) body))

            
            (hr .
                ,(lambda (tag)
                   `(#\newline ,hr-glyph #\newline)))

            ;; (fmt #f (columnar "| " (wrap-lines col1) " | " (wrap-lines col2)
            ;;                   " | " (wrap-lines col3) " |"))
            
            (table *preorder* .
                   ,(lambda (tag . elts)
                      ;; Using columnar essentially requires that wrapping is enabled,
                      ;; so if not, set it to 76 just for tables. *FIXME*
                      (let* ((wrap (if (or (not wrap) (zero? wrap)) 76 wrap))
                             (rows (extract-table-items elts inline-ss))
                             (ncol (reduce max 0 (map length rows)))
                             (sep (fmt #f (with-width
                                           wrap
                                           (apply columnar
                                                  `(" +-"
                                                    ,@(intersperse
                                                       (make-list ncol (fill #\-))
                                                       "-+-")
                                                    "-+"))))))
                        (list
                         #\newline
                         ;;sep
                         (map (lambda (row)
                                ;; first pad row to uniform number of columns
                                (let* ((len (length row))
                                       (row (if (> ncol len)
                                                (append row (make-list (- ncol len) ""))
                                                row)))
                                  (list
                                   sep
                                   (fmt #f (with-width
                                            wrap
                                            (apply columnar
                                                   `(" | "
                                                     ,@(intersperse
                                                        (map wrap-lines row) " | ")
                                                     " |")))))))
                              rows)
                         sep))))

            (blockquote
             . ,(lambda (tag . body)
                  (let ((str (flatten-frags body)))
                    `(#\newline
                      ,(if wrap
                           (fmt #f (with-width wrap (columnar "  > " (wrap-lines str))))
                           (list "  > " str #\newline))))))

            ;; (examples (example (expr ...) (result ...)) ...) => (pre ...)
            ;; Some extraneous NLs are deleted, not all; newline output is crappy
            ;; (init ...) clause ignored
            (examples *preorder*
                      . ,(lambda (tag . body)
                           (pre-post-order
                            body
                            `((example *preorder*
                                       . ,(lambda (tag . body)
                                            (pre-post-order
                                             `(pre .
                                                   ,(pre-post-order
                                                     body
                                                     `((init *preorder*
                                                             . ,(lambda (tag . body)
                                                                  `(,body #\newline)))
                                                       (expr *preorder*
                                                             . ,(lambda (tag . body)
                                                                  body))
                                                       (result *preorder*
                                                               . ,(lambda (tag . body)
                                                                    `("\n; Result: " ,body)))
                                                       (*default* . ,drop-tag))))
                                             ss)))
                              (*default* . ,drop-tag)))))
            
            (tags *preorder* . ,drop-tag)
            (toc *preorder* . ,drop-tag)))

         (ss `(,@block-elts
               ,@inline-elts
               ,@default-elts))
         (inline-ss `(,@inline-elts
                      ,@default-elts)))

      ss)))

(define (write-sxml-as-text doc wrap-col #!key (warnings #f))
  (SRV:send-reply
   (pre-post-order doc
                   (make-text-stylesheet doc
                                         wrap: wrap-col
                                         warnings: warnings))))

)

#|-------------------- 0.4.1 |# "./chicken-doc-cmd.scm" 5848
(require-library chicken-doc)
(import chicken-doc)
(require-library posix)
(import (only posix with-output-to-pipe setenv))
(use regex) (import irregex)

;;; Usage

(define (usage)
  (with-output-to-port (current-error-port)
    (lambda ()
      (print "usage: " (program-name) " -s|-c|-i path")
      (print "       " (program-name) " -f id")
      (print "       " (program-name) " -m re")
      (print "       " (program-name) " id | path")
      (print "   -s path        Show signature")
      (print "   -c path        Show table of contents (child IDs)")
      (print "   -i path        Show documentation")
      (print "   -f id          Show all matching paths for ID")
      (print " where ID is a single identifier and PATH is zero or")
      (print " more IDs comprising a path from the documentation root,")
      (print " separated by spaces or the # character.")
      (print)
      (print "   -m re          Show all matching paths for RE")
      (print " where RE is a POSIX regular expression.  Similar to -f.")
      (print)
      (print "When no option is given, guess the user's intent.  With")
      (print "a single ID, find the ID (as with -f) and show its")
      (print "documentation (as with -i) or show all matching paths")
      (print "if multiple matches exist.  If more than one ID is")
      (print "provided, show documentation on the path (as with -i).")
      (print)
      (print "Examples:")
      (print "  -f open/rdonly           # Show matches for open/rdonly")
      (print "  -s posix open/rdonly     # Show signature of open/rdonly in Unit posix")
      (print "  -s 9p open/rdonly        # Show signature of open/rdonly in 9p egg")
      (print "  -i 9p#open/rdonly        # Show documentation for same")
      (print "  -c posix                 # Show TOC for Unit posix")
      (print "  -c                       # Show toplevel TOC")
      (print "  -m call-                 # Show identifiers containing call-")
      (print "  -m -file$                # Show identifiers ending in -file")
      (print "  use                      # Show doc for \"use\" in chicken core")
      (print "  posix                    # Show doc for Unit posix")
      (print "  open/rdonly              # Show matches for open/rdonly")
      (print "  posix open/rdonly        # Show doc for open/rdonly in Unit posix")
      (exit 1))))

;;; Pager

(define *default-pager*
  (case (software-type)
    ((windows) "more /s")
    ((unix) "less")
    (else "")))
(define (with-output-to-pager thunk)
  (cond ((get-environment-variable "EMACS")
         (thunk))  ; Don't page in emacs subprocess.
        ((not (terminal-port? (current-output-port)))
         (thunk))  ; Don't page if stdout is not a TTY.
        (else
         (unless (get-environment-variable "LESS")
           (setenv "LESS" "FRXis"))  ; Default 'less' options
         (let ((pager (or (get-environment-variable "CHICKEN_DOC_PAGER")
                          (get-environment-variable "PAGER")
                          *default-pager*
                          "")))
           (if (or (string=? pager "")
                   (string=? pager "cat"))
               (thunk)
               ;; with-output-to-pipe does not close pipe on exception, borking tty
               (let ((pipe (open-output-pipe pager))
                     (rv #f))
                 (handle-exceptions exn (begin (close-output-pipe pipe)
                                               (signal exn))
                   ;; Can't reliably detect if pipe open fails.
                   (set! rv (with-output-to-port pipe thunk)))
                 (close-output-pipe pipe)
                 rv))))))

;;; Wrapping

(define (determine-wrap-column)
  (define (safe-terminal-size p)
    (handle-exceptions e (values 0 0)
      (terminal-size p)))
  (cond ((get-environment-variable "CHICKEN_DOC_WRAP")
         => string->number)
        (else
         (let-values (((rows cols) (safe-terminal-size
                                    (current-input-port))))
           (if (= cols 0)
               76       ; (* 80 0.95)
               (inexact->exact (truncate (* cols 0.95))))))))

;;; Helpers

;; Special lookup for command-line.  Treat args as a standard path list
;; -but- if only one argument is provided, try to decompose it as a
;; qualified path string.
(define (lookup args)
  (define (normalize-path p)
    (cond ((null? p) p)
          ((null? (cdr p))
           (decompose-qualified-path (car p)))
          (else p)))
  (lookup-node (normalize-path args)))

;;; Main

(when (null? (command-line-arguments))
  (usage))

(verify-repository)

(wrap-column (determine-wrap-column))
(chicken-doc-warnings
 (get-environment-variable "CHICKEN_DOC_WARNINGS"))

(with-output-to-pager
 (lambda ()
   (let ((o (car (command-line-arguments))))
     (cond ((string=? o "-s")
            (describe-signatures (list (lookup (cdr (command-line-arguments))))))
           ((string=? o "-f")
            ;; Is this useful?  Identifier search ("find") on signatures, showing path.
            ;; I wonder if we need the signature, or just the path.
            (search-only (cadr (command-line-arguments))))
           ((string=? o "-m")
            ;; Not doing search-and-describe because when there are zero
            ;; matches, that will throw an error
            (search-only (irregex (cadr (command-line-arguments)))))
           ((string=? o "-c")
            (describe-contents (lookup (cdr (command-line-arguments)))))
           ((string=? o "-i")
            ;; FIXME: decompose-pathspec required here but won't work yet.
            (describe (lookup (cdr (command-line-arguments)))))
           (else
            (let ((ids (command-line-arguments)))
              (if (null? (cdr ids))
                  (doc-dwim (car ids))
                  (doc-dwim ids))))))))

#|-------------------- 0.4.1 |# "./chicken-doc.meta" 352
((egg "chicken-doc.egg")
 (synopsis "Explore Chicken documentation locally")
 (author "Jim Ursetto")
 (category doc-tools)
 (license "BSD")
 (doc-from-wiki)
 (needs matchable
        (fmt 0.703) sxml-transforms ; chicken-doc-text
        )
 (files "chicken-doc-text.scm" "chicken-doc.meta" "chicken-doc.scm" "chicken-doc-cmd.scm" "chicken-doc.setup"))

#|-------------------- 0.4.1 |# "./chicken-doc.scm" 30315
;;; chicken-doc

(include "chicken-doc-text.scm") ; local module

(module chicken-doc
;; Used by chicken-doc command
(verify-repository
 open-repository close-repository locate-repository current-repository
 describe-signatures
 search-only
 describe-contents
 describe
 doc-dwim
;; Used additionally by chicken-doc-admin.  Somewhat internal, but exported.
 repository-information repository-root repository-base open-repository*
 repository-magic +repository-version+
 repository-id-cache set-repository-id-cache!
 path->keys keys->pathname field-filename keys+field->pathname key->id
 make-id-cache id-cache-filename id-cache-table validate-id-cache!
 make-repository-placeholder
 repository-modification-time
;; Node API
 lookup-node
 match-nodes
 match-node-paths/re
 match-ids/prefix
 match-paths/prefix
 node-signature
 node-type
 node-sxml
 node-path
 node-id
 node-timestamp
 node-children
 node-child
 node-child-ids
 node-definition-ids    ;experimental
 node-definition-id?    ;experimental
;; Other API
 decompose-qualified-path
;; Parameters
 wrap-column
 chicken-doc-warnings
 )

(import scheme chicken)
(use matchable regex srfi-13 posix data-structures srfi-69 extras files utils srfi-1)
(import irregex)
(import (only csi toplevel-command))
(import chicken-doc-text)

;;; Config

(define wrap-column
  (make-parameter 76))   ; 0 or #f for no wrapping
(define chicken-doc-warnings
  (make-parameter #f))

;;; Lowlevel

(define +rx:%escape+ (irregex "[%/,.*<>?!: ]"))
(define +rx:%unescape+ (irregex "%([0-9a-fA-F][0-9a-fA-F])"))

(define (id->key id)
  (define (escape str)
    (irregex-replace/all +rx:%escape+ str
                         (lambda (m) (sprintf "%~x"
                                         (char->integer
                                          (string-ref (irregex-match-substring m 0) 0))))))
  (let ((str (escape (->string id))))
    (cond ((or (string=? str ".")
               (string=? str ".."))
           (warning "Identifier must not be . or .." str)     ;; ?
           #f)
          (else
           str))))
(define (key->id key)
  (string->symbol
   (irregex-replace/all +rx:%unescape+ key
                        (lambda (m) (string
                                (integer->char
                                 (string->number (irregex-match-substring m 1)
                                                 16)))))))

(define (path->keys path)
  (map id->key path))
(define (keys->pathname keys)
  (make-pathname (cons (repository-root (current-repository)) keys) #f))
(define (field-filename name)
  (string-append "," (->string name)))
(define (pathname+field->pathname pathname field)
  (make-pathname pathname (field-filename field)))
(define (keys+field->pathname keys field)  ;; should this take a path instead of keys?
  (pathname+field->pathname (keys->pathname keys) field))

;; Turn pathspec (a path list or path string) into a path or id.
;; Path lists pass through.  Qualified path strings (contains #) become
;; path lists.  Unqualified path strings become ids (symbols).  An empty
;; path string becomes () -- i.e. toplevel.
(define (decompose-pathspec pathspec)
  (if (pair? pathspec)
      pathspec
      (let ((p (decompose-qualified-path pathspec)))
        (cond ((null? p) p)
              ((null? (cdr p)) (string->symbol (car p)))
              (else p)))))

;; Split path STR at #.  However, keep any #+ prefix in the first segment.
;; In other words, sys#foo#bar -> ("sys" "foo" "bar")
;; but ##sys#foo#bar -> ("##sys" "foo" "bar")
;; and #u8 -> ("#u8").  Allows # read syntax and internal namespaces.
(define (decompose-qualified-path path)
  (let ((str (if (symbol? path) (symbol->string path) path)))
    (cond ((string=? str "") '())  ;; string-skip returns #f for ""
          ((string-skip str #\#)
           => (lambda (i)
                (if (= i 0)
                    (string-split str "#")
                    (let ((S (string-split (substring str i) "#")))
                      (cons (string-append (substring str 0 i)
                                           (car S))
                            (cdr S))))))
          (else str)   ;; all #s
          )))

;;; Access

(define-record-type chicken-doc-node
  (%make-node path id md pathname definfo)
  node?
  (path node-path)            ; includes ID
  (id node-id)
  (md node-md)
  (pathname node-pathname)    ; internal; cached node pathname
  (definfo %node-definfo)    ; internal; node definitions record
  )

(define (node-definfo n)
  (force (%node-definfo n)))

(define-record-type chicken-doc-node-definfo
  (make-node-definfo index start pathname)
  node-definfo?
  (index node-definfo-index)
  (start node-definfo-start)
  (pathname node-definfo-pathname))

(define (make-empty-node-definfo)
  (make-node-definfo #f 0 #f))
(define (node-definfo-keys D)
  (let ((I (node-definfo-index D)))
    (if I
        (hash-table-keys (node-definfo-index D))
        '())))
(define (node-definfo-offset D id)
  (car (hash-table-ref/default (node-definfo-index D) id '(#f))))
(define (node-definfo-sxml D id)
  (cond ((node-definfo-offset D id)
         => (lambda (o)
              (let ((pos (+ o (node-definfo-start D))))
                (call-with-input-file*
                 (node-definfo-pathname D)
                 (lambda (p)
                   (set-file-position! p pos seek/set)
                   (read p))))))
        (else #f)))

(define (make-node path id pathname)
  (%make-node path id
              (delay (read-path-metadata pathname))
              pathname
              (delay (read-definfo pathname))))

;; Return string list of child keys (directories) directly under PATH, or #f
;; if the PATH is invalid.  FIXME: might return '() if PATH indicates a
;; definition node (or if that is otherwise indicated).

(define (node-child-keys node)
  (let ((dir (node-pathname node)))
    (if (directory? dir)
        (filter (lambda (x) (not (eqv? (string-ref x 0) #\,)))  ;; Contains hardcoded ,
                (sort (directory dir) string<?))
        '())))

(define (node-children node)   ;; FIXME: inefficient for definition children.
  (map (lambda (id) (node-child node id))
       (node-child-ids node)))

;; Returns child node of NODE with id ID, or #f if not found.
(define (node-child node id)
  (let ((path (node-path node))
        (pathname (node-pathname node)))
    (let ((child-path (append path (list id)))
          (idstr (->string id)))
      (if (node-definition-id? node idstr)
          (make-definition-node node child-path idstr)
          (let ((child-pathname (make-pathname pathname (id->key id))))  ;; otherwise regular node
            (and (directory? child-pathname)
                 (make-node child-path id child-pathname)))))))

;; Shortcut if you only need identifiers for node children.
;; Might be faster than node-children.
(define (node-child-ids node)
  (append (map key->id (node-child-keys node))
          (node-definition-ids node)))

;; (define (node-definition-ids node)
;;   (let next-def ((defs (node-definitions node))
;;                  (ids '()))
;;     (if (null? defs)
;;         ids
;;         (let next-sig ((sigs (cdadr (car defs))) (sigids '()))
;;           (if (null? sigs)
;;               (next-def (cdr defs)
;;                         (append sigids ids))
;;               (let* ((x (car sigs)) (type (car x)) (sig (cadr x)) (alist (cddr x)))
;;                 (next-sig
;;                  (cdr sigs)
;;                  (cons
;;                   (cond ((assq 'id alist) => cadr) ;; Check for pre-parsed ID.
;;                         (else
;;                          (error 'node-definition-ids "preparsed ID unavailable")))
;;                   sigids))))))))

(define (node-definition-ids node)
  (sort (node-definfo-keys (node-definfo node))
        string<?))
(define (node-definition-id? node id)
  (and-let* ((D (node-definfo node))       ;; check if this node is in the definition index
             (I (node-definfo-index D)))
    (hash-table-exists? I (->string id))))

(define (make-definition-node parent path id)
  (define (find-sig def id)
    (let ((sigs (cdadr def)))
      (find (lambda (s) (cond ((assq 'id (cddr s))
                          => (lambda (idc) (equal? id (->string (cadr idc)))))
                         (else #f)))
            sigs)))
  (define (get-definition-sxml parent id)
    (node-definfo-sxml (node-definfo parent) id))
  (define (definition-sxml->metadata sxml parent id)
    (let ((s (find-sig sxml id)))
      (if s
          (let ((type (car s)) (signature (cadr s)))
            `((type ,type)
              (signature ,signature)
              (timestamp ,(node-timestamp parent))
              (sxml ,sxml)))
          (error 'definition-sxml->metadata "no match for id in signature" id))))
  (%make-node path id
              (definition-sxml->metadata (get-definition-sxml parent id) parent id)
              (pathname+field->pathname (node-pathname parent) 'defs) ;; tmp -- non-dir indicates def node
              (make-empty-node-definfo)))

;; Obtain metadata alist at node at PATHNAME.  Valid node without metadata record
;; returns '().  Invalid node throws error.
(define (read-path-metadata pathname)
  (let ((metafile (pathname+field->pathname pathname 'meta)))
    (cond ((file-exists? metafile)
           (call-with-input-file* metafile read-file)) ;; ensure binary read
          ((directory? pathname)
           ;; write-keys may create intermediate container directories
           ;; without metadata, so handle this specially.
           '())
          (else
           (error "No such metadata pathname" metafile) ;; internal error
           ))))

(define (call-with-input-file* file proc)
  (let ((p (open-input-file file #:binary)))
    (handle-exceptions exn (begin (close-input-port p)
                                  (signal exn))
      (let ((rc (proc p)))
        (close-input-port p)
        rc))))
(define (read-definfo pathname)
  (let ((deffile (pathname+field->pathname pathname 'defs)))
    (cond ((file-exists? deffile)
           (call-with-input-file* deffile
             (lambda (p)
               (let ((index (read p)))
                 (unless (and (pair? index)
                              (eq? (car index) 'index))
                   (error "Invalid file format in definition index"))
                 (make-node-definfo (alist->hash-table (cdr index) string=?)
                                    (+ (file-position p) 1) deffile)))))
          (else
           (make-empty-node-definfo)))))

(define (node-metadata-field node field)
  (cond ((assq field (node-metadata node))
         => cadr)
        (else #f)))

(define (node-metadata node)
  (force (node-md node)))         ;  load metadata as needed

(define (node-definitions node)
  (force (node-metadata-field node 'defs)))

;; Return node record at PATH or throw error if the record does
;; not exist.  It would be acceptable to return #f on failure,
;; like node-child does; the only reason we don't is to
;; signal to the caller which part of the path lookup failed,
;; which is perhaps not that useful.
(define (lookup-node path)
  (define (make-root-node)
    (make-node '() "" (keys->pathname '())))
  (let loop ((node (make-root-node))
             (P path))
    (if (null? P)
        node
        (loop (or (node-child node (car P))
                  (error 'lookup-node "node path not found"
                         `(,@(node-path node) ,(car P))))
              (cdr P)))))

;; Return string representing signature of PATH.  If no signature, return "".
(define (node-signature node)
  (or (node-metadata-field node 'signature)
      ""))

;; Return symbol representing type of PATH, or 'unknown.
(define (node-type node)
  (let ((key (node-metadata-field node 'type)))
    (if key
        (if (string? key)
            (string->symbol key)
            key)
        'unknown)))

;; Return SXML document for node.  If small enough, it may be packed
;; into the metadata; otherwise read it from the filesystem.
(define (node-sxml node)
  (or (node-metadata-field node 'sxml)  ;; FIXME? Returns #f on (sxml #f)
      (let* ((file (pathname+field->pathname (node-pathname node)
                                             'sxml)))
        (and (file-exists? file)
             (with-input-from-file file read)))))

#|
(define (node-modification-time node)
  ;; hypothetical function returning the last update time of a node.
  ;; The most accurate result is probably obtained by returning the
  ;; mtime of the ,meta file.  Clients may also want to know when
  ;; children have been updated (or at least when the child IDs change).
  ;; It may be sufficient to check the parent directory mtime or
  ;; the max of that and ,meta since rename, add and delete of child
  ;; directories will change parent mtime.  Parent mtime is usually
  ;; not affected when ,meta or ,sxml file is overwritten, though.
  )
  
|#

;; Return timestamp of a node in seconds since UNIX epoch,
;; or #f if no timestamp was available. (Should we return 0 in that case?)
(define (node-timestamp node)
  (node-metadata-field node 'timestamp))

;;; Describe

;; Utility procedure (dropped in Chicken >= 4.3.2)
(define (for-each-line proc #!optional (port (current-input-port)))
  (do ((line (read-line port) (read-line port)))
      ((eof-object? line))
    (proc line)))

;; Display file to stdout
(define (cat file)
  (with-input-from-file file
    (lambda ()
      (for-each-line (lambda (x) (display x) (newline))))))

;; Display the "text" field of NODE to current-output-port.  Even if
;; NODE is a valid node, that doesn't mean it has text contents.
(define (describe node)
  (cond ((node-sxml node)
         => (lambda (doc)
              (write-sxml-as-text doc (wrap-column)
                                  warnings: (chicken-doc-warnings))))
        (else
         (error "No such identifier"
                (sprintf "~a" (node-path node))))))

;; Display the signature of all child keys of PATH, to stdout.
(define (maximum-string-length strs)
  (reduce max 0 (map string-length strs)))
(define (padding len s)
  (make-string (max 0 (- len (string-length s)))
               #\space))
(define (describe-contents node)
  (let ((kids (node-children node)))
    (let* ((strids (map ->string (map node-id kids)))
           (len (maximum-string-length strids)))
      (for-each (lambda (n s) (print s (padding len s)
                                "  "
                                (node-signature n)))
                kids strids))))

(define (describe-signatures nodes)
  (let* ((strpaths (map ->string (map node-path nodes)))
         (len (maximum-string-length strpaths)))
    (for-each (lambda (n s) (print s (padding len s)
                              "  "
                              (node-signature n)))
              nodes strpaths)))

(define (describe-matches nodes)
  (print "Found " (length nodes) " matches:")
  (describe-signatures nodes))

;;; ID search cache

;; Cache is unique to repository but is shared between
;; threads holding the same repository object.
(define-record-type id-cache
  (%make-id-cache table mtime filename
                  ids ; id string vector
                  paths ; path string vector
                  )
  id-cache?
  (table id-cache-table)
  (mtime id-cache-mtime)
  (filename id-cache-filename)
  (ids %id-cache-ids)
  (paths %id-cache-paths))

;; Delayed construction of id string list and paths is legal
;; because cache updates are disallowed.  Note that any
;; change to the id cache on disk will result in revalidation
;; and full recomputation of the delayed constructors.
(define (make-id-cache table mtime filename)
  (%make-id-cache table mtime filename
                  (delay (list->vector
                          (sort (map ->string (hash-table-keys table))
                                ;; ->string not symbol->string to workaround WRITE bug for integer symbols
                                string<?)))
                  (delay (list->vector
                          (sort
                           (flatten
                            (hash-table-fold
                             table
                             (lambda (k v s)
                               (cons
                                (map (lambda (x)
                                       (string-intersperse
                                        (map ->string (append x (list k))) " "))
                                     v)
                                s))
                             '()))
                           string<?)))))

(define (make-invalid-id-cache repo-base)
  (make-id-cache #f 0
                 (make-pathname repo-base "id.idx")))

(define (current-id-cache)  ; access current id cache hash table; legacy
  (repository-id-cache (current-repository)))
(define (id-cache-ref c id)
  (hash-table-ref/default (id-cache-table c) id '()))
(define (id-cache-keys c)
  (hash-table-keys (id-cache-table c)))

;; Validate and update the shared id cache in repository R.
(define (validate-id-cache! r)
  (define (read-id-cache! r c)
    (define (read-id-cache c)
      (let ((fn (id-cache-filename c)))
        (call-with-input-file fn
          (lambda (in)
            (make-id-cache
             (alist->hash-table (read in) eq?)
             (file-modification-time (port->fileno in))
             fn)))))
    (set-repository-id-cache! r (read-id-cache c)))

  ;; We don't currently lock id-cache validations with a mutex.
  ;; All that (should) happen is that when the cache is (rarely)
  ;; updated, if two threads validate at the same time both will
  ;; read the entire cache in.
  (let* ((c (repository-id-cache r)))
    (when (< (id-cache-mtime c)
             (file-modification-time (id-cache-filename c)))
      (read-id-cache! r c))))

;; Not currently needed.  Also not tested and not thread-safe
;; (define (invalidate-id-cache!)
;;   (set-repository-id-cache! (current-repository) (make-invalid-id-cache)))

;; Return a list of sorted IDs as strings, suitable for regex node matching.
;; Construction is lazy because it is not that cheap.
(define (id-cache-ids c)
  (force (%id-cache-ids c)))
;; This one's pretty expensive (time and space wise).
(define (id-cache-paths c)
  (force (%id-cache-paths c)))

;;; ID search

;; Returns list of nodes matching identifier ID.
;; ID may be a symbol or string.
(define (match-nodes/id id)
  (define (lookup id)
    (id-cache-ref (current-id-cache) id))
  (validate-id-cache! (current-repository))
  (let ((id (if (string? id) (string->symbol id) id)))
    (map (lambda (x)
           (lookup-node (append x (list id))))
         (lookup id))))

(define (vector-filter-map f v)
  ;; filter-map vector V to list.  this is here because
  ;; we converted the id-cache-ids to a vector.
  (let ((len (vector-length v)))
    (let lp ((i 0) (L '()))
      (if (fx>= i len)
          (reverse L)
          (lp (fx+ i 1)
              (cond ((f i (vector-ref v i))
                     => (lambda (x) (cons x L)))
                    (else
                     L)))))))
(define (vector-copy v #!optional (start 0) (end (vector-length v)) (fill (void)))
  ;; SRFI-43 vector-copy.  Why is vector-lib's implementation so verbose?
  (let ((len (vector-length v)))
    (when (> start end) (error 'vector-copy "start > end" start end))
    (when (< start 0)   (error 'vector-copy "start < 0" start))
    (when (> start len) (error 'copy-vec "start > len" start len))
    (let ((c (make-vector (- end start))))
      (let ((end (min end len)))
        (let loop ((vi start)
                   (ci 0))
          (cond ((< vi end)
                 (vector-set! c ci (vector-ref v vi))
                 (loop (+ vi 1) (+ ci 1)))
                (else c)))))))


;; Returns list of nodes whose identifiers
;; match regex RE.
(define (match-nodes/re re)
  (let ((rx (irregex re)))
    (validate-id-cache! (current-repository))
    (append-map (lambda (id)
                  (match-nodes id))
                (vector-filter-map (lambda (i k)   ; was filter-map
                                     (and (string-search rx k) k))
                                   (id-cache-ids (current-id-cache))))))

;; Match against full node paths with RE.
(define (match-node-paths/re re)
  (let ((rx (irregex re)))
    (validate-id-cache! (current-repository))
    (map (lambda (path)
           (lookup-node (string-split path))) ; stupid resplit
         (vector-filter-map (lambda (i k)
                              (and (string-search rx k) k))
                            (id-cache-paths (current-id-cache))))))

;; Search for "nearest" VAL in vector V at start or end of a range.
;; START? is a boolean indicating whether this is the start or end of
;; the range.  INCLUSIVE? is a boolean indicating whether VAL itself
;; should be included in the results.  CMP is a procedure of two
;; arguments x y which returns < 0 if x < y, 0 if x = y, or > 0 if x >
;; y.  Returns a vector index of the nearest value; in "start" mode
;; this is inclusive, in "end" mode it is exclusive.
(define (binary-search-nearest v val cmp start? inclusive?)
  (let ((len (vector-length v)))
    (let lp ((L 0)
             (R len))
      (let ((M (fx/ (fx+ R L) 2)))
        (let ((item (vector-ref v M)))
          ;;(printf "item: ~a L: ~a M: ~a R: ~a\n" item L M R)
          (let ((dir (cmp val item)))
            (cond ((fx= dir 0)
                   (if inclusive?
                       (if start? M (fx+ M 1))
                       (if start? (fx+ M 1) M)))
                  ((fx< dir 0)
                   (if (fx> M L)
                       (lp L M)
                       M))           ; not sure this can happen
                  (else
                   (if (fx< M (- R 1))
                       (lp M R)
                       (fx+ M 1))))))))))

;; Return a vector (??) of identifier name strings or full path
;; strings which match the prefix STR.
(define match-ids/prefix)     ; probably not the best name
(define match-paths/prefix)

(let ()
  (define (strcmp x y)
    (cond ((string<? x y) -1)
          ((string=? x y) 0)
          (else 1)))
  ;; finds strings in v in range [str1,str2) and returns indices [start . end)
  (define (binary-search-range v str1 str2)
    (cons (binary-search-nearest v str1 strcmp #t #t)
          (binary-search-nearest v str2 strcmp #f #f)))
  (define (next-string str)
    ;; ASSUMING BYTE SEMANTICS!
    ;; Note that src char #\xff will fail and wrap around.
    (let ((len (string-length str))
          (new (string-copy str)))
      (string-set! new (- len 1)
                   (integer->char (+ 1 (char->integer
                                        (string-ref str (- len 1))))))
      new))
  (define (match-vector v str limit)
    (if (= 0 (string-length str))
        '#()
        (match (binary-search-range v str (next-string str))
               ((start . end)
                (if limit
                    (vector-copy v start (min (+ start limit) end))
                    (vector-copy v start end))))))

  (set! match-ids/prefix
        (lambda (str #!optional (limit #f))
          (validate-id-cache! (current-repository))
          (match-vector (id-cache-ids (current-id-cache))
                        str limit)))
  (set! match-paths/prefix
        (lambda (str #!optional (limit #f))
          (validate-id-cache! (current-repository))          
          (match-vector (id-cache-paths (current-id-cache))
                        str limit))))

;; ,t (validate-id-cache!)
;;    0.123 seconds elapsed
;;    0.024 seconds in (major) GC
;;    47942 mutations
;;        3 minor GCs
;;        5 major GCs
;; after id cache loaded, disk cache warm
;; ,t (match-nodes (irregex "posix"))
;;    0.065 seconds elapsed                (0.06 - 0.10 sec)
;;        0 seconds in (major) GC
;;    68054 mutations
;;      832 minor GCs
;;        0 major GCs
;; after id-cache-ids cache
;; ,t (match-nodes (irregex "posix"))
;;    0.036 seconds elapsed
;;        0 seconds in (major) GC
;;     9642 mutations
;;       83 minor GCs
;;        0 major GCs
;; ,t (match-nodes (irregex "."))
;;    1.978 seconds elapsed           ; actually about 10-15 seconds on disk
;;    0.057 seconds in (major) GC
;;   147205 mutations
;;      404 minor GCs
;;        4 major GCs
;; time chicken-doc -m . >/dev/null    ; presuming totally warm disk cache
;; real    0m0.960s
;; ,t (match-nodes (irregex "."))
;;    0.321 seconds                    ; if metadata read is delayed, but dir checked
;;    0.133 seconds                    ; if metadata read delayed and dir not checked
;;    0.250 seconds                    ; if metadata read delayed and dir not checked, but path->pathname still computed



;; Return list of nodes whose identifiers match
;; symbol, string or re.
(define (match-nodes idre)
  (if (or (irregex? idre) (regexp? idre))
      (match-nodes/re idre)
      (match-nodes/id idre)))

(define (search-and-describe id)
  (let ((nodes (match-nodes id)))
    (cond ((null? nodes)
           (error "No such identifier" id))
          ((null? (cdr nodes))
           (print "path: " (node-path (car nodes)))
           (describe (car nodes)))
          (else
           (describe-matches nodes)))))
(define (search-only id)
  (let ((nodes (match-nodes id)))
    (describe-signatures nodes)))
(define (search-and-describe-contents id)
  (let ((nodes (match-nodes id)))
    (cond ((null? nodes)
           (void))
          ((null? (cdr nodes))
           (print "path: " (car nodes))
           (describe-contents (car nodes)))
          (else
           (describe-matches nodes)))))

(define (doc-dwim pathspec)
  (let ((p (decompose-pathspec pathspec)))
    (if (or (pair? p) (null? p))
        (describe (lookup-node p))
        (search-and-describe p))))

;;; Repository

(define +repository-version+ 3)

;; The repository object is a new concept (formerly all fields
;; were global parameters) so our API does not expect a
;; repository object to be passed in.  Therefore, we make
;; current-repository a global parameter.

(define-record-type chicken-doc-repository
  (make-repository base root magic info id-cache)
  repository?
  (base repository-base)
  (root repository-root)
  (magic repository-magic)
  (info repository-information)
  (id-cache repository-id-cache set-repository-id-cache!))

;; Current repository for node lookup API.
(define current-repository (make-parameter #f))

;; Return standard location of repository.  Does not
;; guarantee it exists.
(define (locate-repository)
  (or (get-environment-variable "CHICKEN_DOC_REPOSITORY")
      (make-pathname (chicken-home) "chicken-doc")))

;; Open the repository found in the standard location
;; and set the current repository for the thread.
(define (verify-repository)  ; legacy name; should be changed
  (current-repository
   (open-repository
    (locate-repository))))

;; Internal; make a fake repository object containing
;; all the fields a valid object would have.
(define (make-repository-placeholder base)
  (make-repository base
                   (make-pathname base "root")
                   (make-pathname base ".chicken-doc-repo")
                   `((version . ,+repository-version+))
                   (make-invalid-id-cache base)))

;; Open repository and return new repository object or
;; throw error if nonexistent or unknown format.  May accept
;; some old repository formats, so this repo MUST only be
;; passed to procedures which explicitly handle old formats.
;; Currently, that is only destroy-repository!.
(define (open-repository* base)
  (let ((rp (make-repository-placeholder base)))
    (let ((magic (repository-magic rp)))
      (if (file-exists? magic)
          (let ((info (with-input-from-file magic read)))
            (let ((r (make-repository (repository-base rp)
                                      (repository-root rp)
                                      magic
                                      info
                                      (repository-id-cache rp))))
              (set-finalizer! r close-repository)
              r))
          (error "No chicken-doc repository found at" base)))))
;; Open repository like open-repository*, but only permit the
;; current repository format.  Unless otherwise stated, procedures can only
;; handle the current format, and rely on the check happening at open time.
(define (open-repository base)
  (let ((r (open-repository* base)))
    (let ((version (or (alist-ref 'version (repository-information r)) 0)))
      (cond ((= version +repository-version+)
             r)
            (else (error (sprintf "Invalid repository version number ~a, expected ~a\n"
                                          version +repository-version+)))))))
(define (close-repository r)
  (void))

;; Last modification time of entire repository.  We just use the mtime
;; of the id cache, as update operations do not modify any global timestamp.
;; This means stale data may be returned until the cache is refreshed.
(define (repository-modification-time r)
  (validate-id-cache! r)  ;; may be wasteful, but we need the current mtime
  (id-cache-mtime (repository-id-cache r)))

;;; REPL

(define repl-doc-dwim doc-dwim)
(define repl-toc-dwim            ;; FIXME: ignore # paths for now
  (lambda (pathspec)
    (let ((p (decompose-pathspec pathspec)))
      (cond ((or (null? p)
                 (pair? p))
             (describe-contents (lookup-node p)))
            (else
             (search-and-describe-contents p))))))
(define repl-wtf
  (lambda (re)
    (search-only (irregex re))))

(when (feature? 'csi)
  ;; Warning -- will execute if called from a script.
  ;; We really only want this to execute at the REPL.
  (verify-repository)
  
  (toplevel-command 'wtf (lambda () (repl-wtf (string-trim-both
                                          (read-line))))
                    ",wtf RE           Regex search with chicken-doc (\"where to find\")")
  (toplevel-command 'toc (lambda () (repl-toc-dwim (read)))
                    ;; TOC should look up if this is a relative path
                    ",toc PATHSPEC     List contents of path with chicken-doc")
  (toplevel-command 'doc (lambda () (repl-doc-dwim (read)))
                    ",doc PATHSPEC     Describe identifier or path with chicken-doc"))

)  ;; end module


#|-------------------- 0.4.1 |# "./chicken-doc.setup" 516
(define version "0.4.1")

(compile -s -O2 -d1 -S chicken-doc.scm -j chicken-doc -j chicken-doc-text)
(compile -s -O2 -d0 chicken-doc.import.scm)
(compile -s -O2 -d0 chicken-doc-text.import.scm)    ; annoying
(compile -o chicken-doc -O2 -d1 -S chicken-doc-cmd.scm)

(install-extension
  'chicken-doc
  '("chicken-doc.so" "chicken-doc.import.so" "chicken-doc-text.import.so")
  `((version ,version)
    (documentation "chicken-doc.html")))

(install-program
 'chicken-doc-cmd
 '("chicken-doc")
 `((version ,version)))