#lang scheme/base
(require racket/string
         racket/format
         "../struct.rkt"
         "../scheme.rkt"
         "../search.rkt"
         "../basic.rkt"
         "../manual-struct.rkt"
         (only-in "../core.rkt" make-style)
         "../html-properties.rkt"
         "manual-ex.rkt"
         racket/contract/base
         (for-syntax scheme/base)
         (for-label scheme/base
                    scheme/class))

(provide definition-site
         libs->taglet
         annote-exporting-library
         with-exporting-libraries
         id-to-target-maker
         id-to-form-target-maker
         *sig-elem
         (struct-out sig)
         ;; public:
         ; XXX unknown contract
         make-binding-redirect-elements
         sigelem)
(provide/contract
 ; XXX What is return type?
 [defidentifier ((identifier?) (#:form? boolean? #:index? boolean? #:show-libs? boolean?) . ->* . any/c)])

(define (gen-absolute-tag)
  `(abs ,(make-generated-tag)))

(define-struct sig (id))

(define-syntax-rule (sigelem sig elem)
  (*sig-elem (quote-syntax sig) 'elem))

(define (*sig-elem sig elem #:defn? [defn? #f])
  (let ([s (to-element/no-color elem)])
    (make-delayed-element
     (lambda (renderer sec ri)
       (let* ([tag (find-scheme-tag sec ri sig #f)]
              [taglet (and tag (append (cadr tag) (list elem)))]
              [vtag (and tag `(sig-val ,taglet))]
              [stag (and tag `(sig-form ,taglet))]
              [sd (and stag (resolve-get/tentative sec ri stag))])
         (make-element
          symbol-color
          (list
           (cond [sd (make-link-element (if defn? syntax-def-color syntax-link-color) (list s) stag)]
                 [vtag (make-link-element (if defn? value-def-color value-link-color) (list s) vtag)]
                 [else s])))))
     (lambda () s)
     (lambda () s))))

(define hovers (make-weak-hasheq))
(define (intern-hover-style text)
  (let ([text (datum-intern-literal text)])
    (or (hash-ref hovers text #f)
        (let ([s (make-style #f (list (make-hover-property text)))])
          (hash-set! hovers text s)
          s))))

(define (annote-exporting-library e)
  (make-delayed-element
   (lambda (render p ri)
     (let ([from (resolve-get/tentative p ri '(exporting-libraries #f))])
       (if (and from (pair? from))
           (make-element
            (intern-hover-style
             (string-append
              "Provided from: "
              (string-join (map ~s from) ", ")
              (let ([from-pkgs (resolve-get/tentative p ri '(exporting-packages #f))])
                (if (and from-pkgs (pair? from-pkgs))
                    (string-append
                     " | Package: "
                     (string-join (map ~a from-pkgs) ", "))
                    ""))))
            e)
           e)))
   (lambda () e)
   (lambda () e)))

(define (get-exporting-libraries render p ri)
  (resolve-get/tentative p ri '(exporting-libraries #f)))

(define (with-exporting-libraries proc)
  (make-delayed-index-desc
   (lambda (render part ri)
     (proc (or (get-exporting-libraries render part ri) null)))))

(define (definition-site name stx-id form?)
  (let ([sig (current-signature)])
    (define (gen defn?)
      (if sig
          (*sig-elem #:defn? defn? (sig-id sig) name)
          ((if defn? annote-exporting-library values)
           (to-element #:defn? defn? (make-just-context name stx-id)))))
    (values (gen #t) (gen #f))))

(define checkers (make-hash))

(define (libs->taglet id libs source-libs)
  (let ([lib
         (or (ormap (lambda (lib)
                      (let ([checker
                             (hash-ref
                              checkers lib
                              (lambda ()
                                (let ([ns-id 
                                       (let ([ns (make-base-empty-namespace)])
                                         (parameterize ([current-namespace ns])
                                           ;; A `(namespace-require `(for-label ,lib))` can
                                           ;; fail if `lib` provides different bindings of the
                                           ;; same name at different phases. We can require phases
                                           ;; 1 and 0 separately, in which case the phase-0
                                           ;; binding shadows the phase-1 one in that case.
                                           ;; This strategy only works for documenting bindings
                                           ;; at phases 0 and 1, though.
                                           (namespace-require `(just-meta 1 (for-label ,lib)))
                                           (namespace-require `(just-meta 0 (for-label ,lib)))
                                           (namespace-syntax-introduce (datum->syntax #f 'x))))])
                                  (let ([checker
                                         (lambda (id)
                                           (free-label-identifier=?
                                            (datum->syntax ns-id (syntax-e id))
                                            id))])
                                    (hash-set! checkers lib checker)
                                    checker))))])
                        (and (checker id) lib)))
                    (or source-libs null))
             (and (pair? libs) (car libs)))])
    (and lib (module-path-index->taglet
              (module-path-index-join lib #f)))))

(define (id-to-target-maker id dep?)
  (*id-to-target-maker 'def id dep?))

(define (id-to-form-target-maker id dep?)
  (*id-to-target-maker 'form id dep?))

(define (*id-to-target-maker sym id dep?)
  (let ([sig (current-signature)])
    (lambda (content mk)
      (make-part-relative-element
       (lambda (ci)
         (let ([e (ormap (lambda (p)
                           (ormap (lambda (e)
                                    (and (exporting-libraries? e) e))
                                  (part-to-collect p)))
                         (collect-info-parents ci))])
           (unless e
             ;; Call raise-syntax-error to capture error message:
             (with-handlers ([exn:fail:syntax?
                              (lambda (exn)
                                (eprintf "~a\n" (exn-message exn)))])
               (raise-syntax-error
                'WARNING
                "no declared exporting libraries for definition" id)))
           (if e
             (let* ([lib-taglet (libs->taglet
                                 (if sig (sig-id sig) id)
                                 (exporting-libraries-libs e)
                                 (exporting-libraries-source-libs e))]
                    [tag (intern-taglet
                          (list (if sig
                                  (case sym
                                    [(def) 'sig-val]
                                    [(form) 'sig-def])
                                  sym)
                                `(,lib-taglet
                                  ,@(if sig (list (syntax-e (sig-id sig))) null)
                                  ,(syntax-e id))))])
               (if (or sig (not dep?))
                   (mk tag)
                   (make-dep (list lib-taglet (syntax-e id))
                             (mk tag))))
             content)))
       (lambda () content)
       (lambda () content)))))

(define (defidentifier id 
                       #:form? [form? #f]
                       #:index? [index? #t]
                       #:show-libs? [show-libs? #t])
  ;; This function could have more optional argument to select
  ;; whether to index the id, include a toc link, etc.
  (let ([dep? #t])
    (let ([maker (if form?
                     (id-to-form-target-maker id dep?)
                     (id-to-target-maker id dep?))])
      (define-values (elem elem-ref)
        (if show-libs?
            (definition-site (syntax-e id) id form?)
            (values (to-element id #:defn? #t)
                    (to-element id))))
      (if maker
          (maker elem
                 (lambda (tag)
                   (let ([elem
                          (if index?
                              (make-index-element
                               #f (list elem) tag
                               (list (datum-intern-literal (symbol->string (syntax-e id))))
                               (list elem)
                               (and show-libs?
                                    (with-exporting-libraries
                                     (lambda (libs)
                                       (make-exported-index-desc (syntax-e id)
                                                                 libs)))))
                              elem)])
                     (make-target-element #f (list elem) tag))))
          elem))))

(define (make-binding-redirect-elements mod-path redirects)
  (let ([taglet (module-path-index->taglet 
                 (module-path-index-join mod-path #f))])
    (make-element
     #f
     (map
      (lambda (redirect)
        (let ([id (car redirect)]
              [form? (cadr redirect)]
              [path (caddr redirect)]
              [anchor (cadddr redirect)])
          (let ([make-one
                 (lambda (kind)
                   (make-redirect-target-element
                    #f
                    null
                    (intern-taglet (list kind (list taglet id)))
                    path
                    anchor))])
            (make-element
             #f
             (list (make-one (if form? 'form 'def))
                   (make-dep (list taglet id) null)
                   (let ([str (datum-intern-literal (symbol->string id))])
                     (make-index-element #f
                                         null
                                         (intern-taglet
                                          (list (if form? 'form 'def)
                                                (list taglet id)))
                                         (list str)
                                         (list
                                          (make-element
                                           symbol-color
                                           (list
                                            (make-element
                                             (if form?
                                                 syntax-link-color
                                                 value-link-color)
                                             (list str)))))
                                         ((if form?
                                              make-form-index-desc
                                              make-procedure-index-desc)
                                          id
                                          (list mod-path)))))))))
      redirects))))


(define (make-dep t content)
  (make-collect-element
   #f
   content
   (lambda (ci)
     (collect-put! ci 
                   (intern-taglet (list 'dep t))
                   #t))))