;; Copyright (c) 2013-2022 by Greg Hendershott.
;; SPDX-License-Identifier: GPL-3.0-or-later

#lang racket/base

(require racket/contract
         racket/format
         racket/match
         racket/promise
         racket/set
         racket/string
         (only-in scribble/core
                  tag?)
         scribble/blueboxes
         scribble/manual-struct
         scribble/xref
         scribble/tag
         setup/xref
         syntax/parse/define
         "elisp.rkt")

(provide binding->path+anchor
         identifier->bluebox
         doc-index-names
         doc-index-lookup
         libs-exporting-documented)

(module+ test
  (require rackunit))

(define xref-promise (delay/thread (load-collections-xref)))

;; When running on a machine with little memory, such as a small VPS
;; or AWS instance, I have seen the oom-killer terminate the process
;; after we try to handle a back end command that does some of these
;; documentation operations. Presumably they use enough memory that
;; Racket asks the OS for more? To make that less likely, do a major
;; GC before/after. So far this seems to be a successful mitigation,
;; although it also seems like a kludge.
(define (call-avoiding-oom-killer thunk)
  (collect-garbage 'major)
  (begin0 (thunk)
    (collect-garbage 'major)))

(define-simple-macro (with-less-memory-pressure e:expr ...+)
  (call-avoiding-oom-killer (λ () e ...)))

(define/contract (binding->path+anchor stx)
  (-> identifier? (or/c #f (cons/c path-string? (or/c #f string?))))
  (with-less-memory-pressure
    (let* ([xref (force xref-promise)]
           [tag  (xref-binding->definition-tag xref stx 0)]
           [p+a  (and tag (tag->path+anchor xref tag))])
      p+a)))

(define (tag->path+anchor xref tag)
  (define-values (path anchor) (xref-tag->path+anchor xref tag))
  (and path anchor (cons path anchor)))

;;; Blueboxes

(define racket-version-6.10? (equal? (version) "6.10"))

(define bluebox-cache (delay (make-blueboxes-cache #t)))

(define/contract (identifier->bluebox stx)
  (-> identifier? (or/c #f string?))
  (match (and (not racket-version-6.10?)
              (xref-binding->definition-tag (force xref-promise) stx 0))
    [(? tag? tag)
     (match (fetch-blueboxes-strs tag #:blueboxes-cache (force bluebox-cache))
       [(list* _kind strs)
        (string-replace (string-join strs "\n")
                        "\u00A0"
                        " ")]
       [_ #f])]
    [_ #f]))

(module+ test
  ;; This test succeeds on all Racket versions before and after 6.10.
  ;; I spent an hour installing 6.10 locally and exploring the problem
  ;; but so far have no clue. As neither 6.10 nor I are getting any
  ;; younger, I am choosing to ignore this, for now.
  ;;
  ;; Probably https://github.com/racket/drracket/issues/118
  (unless racket-version-6.10?
    (check-equal? (identifier->bluebox #'list)
                  "(list v ...) -> list?\n  v : any/c"))
  (check-false (identifier->bluebox (datum->syntax #f (gensym)))))

;;; Documentation index

;; Note that `xref-index` returns a list of 30K+ `entry` structs. We
;; can't avoid that with the official API. That will bump peak memory
;; use. :( Best we can do is sandwich it in major GCs, to avoid the
;; peak going even higher. Furthermore in doc-index-names we avoid
;; making _another_ 30K+ list, by returning a thunk for elisp-write
;; to call, to do "streaming" writes.

(define ((doc-index-names))
  (with-less-memory-pressure
    (with-parens
      (define xref (force xref-promise))
      (for* ([entry (in-list (xref-index xref))]
             [desc (in-value (entry-desc entry))]
             #:when (not (constructor-index-desc? desc))
             [term (in-value (car (entry-words entry)))])
        (elisp-write term))
      (newline))))

(define (doc-index-lookup str)
  (with-less-memory-pressure
    (define xref (force xref-promise))
    (define results
      (for*/set ([entry (in-list (xref-index xref))]
                 [desc (in-value (entry-desc entry))]
                 #:when (not (constructor-index-desc? desc))
                 [term (in-value (car (entry-words entry)))]
                 #:when (equal? str term))
        (define tag (entry-tag entry))
        (define-values (path anchor) (xref-tag->path+anchor xref tag))
        (define-values (what from)
          (cond
            [(module-path-index-desc? desc)
             (values 'module null)]
            [(exported-index-desc? desc)
             (define kind
               (match desc
                 [(? language-index-desc?)  'language]
                 [(? reader-index-desc?)    'reader]
                 [(? form-index-desc?)      'syntax]
                 [(? procedure-index-desc?) 'procedure]
                 [(? thing-index-desc?)     'value]
                 [(? struct-index-desc?)    'structure]
                 [(? class-index-desc?)     'class]
                 [(? interface-index-desc?) 'interface]
                 [(? mixin-index-desc?)     'mixin]
                 [(? method-index-desc?)
                  (cond
                    [(method-tag? tag)
                     (define-values (c/i _m) (get-class/interface-and-method tag))
                     (cons 'method c/i)]
                    [else 'method])]
                 [_ ""]))
             (define libs (exported-index-desc-from-libs desc))
             (values kind libs)]
            [else
             (println (reverse (explode-path path)))
             (values 'documentation
                     (list
                      (match (reverse (explode-path path))
                        [(list* _ v _) (path->string v)]
                        [_             (~a tag)])))]))
        (list term what from path anchor)))
    (sort (set->list results)
          string<?
          #:cache-keys? #t
          #:key
          (match-lambda
            [(list* _term _what (cons from _) _path _anchor)
             (match (~a from)
               [(and (pregexp "^racket/") v)
                (string-append "0_" v)]
               [(and (pregexp "^typed/racket/") v)
                (string-append "1_" v)]
               [v v])]
            [(cons term _) term]))))

;;; This is for the requires/find command

;; Given some symbol as a string, return the modules providing it,
;; sorted by most likely to be desired.
(define (libs-exporting-documented sym-as-str)
  (with-less-memory-pressure
    (define xref (force xref-promise))
    (define results
      (for*/set ([entry (in-list (xref-index xref))]
                 [desc (in-value (entry-desc entry))]
                 #:when (exported-index-desc? desc)
                 [name (in-value (symbol->string
                                  (exported-index-desc-name desc)))]
                 #:when (equal? name sym-as-str)
                 [libs (in-value (map symbol->string
                                      (exported-index-desc-from-libs desc)))]
                 #:when (not (null? libs)))
        ;; Take just the first lib. This usually seems to be the
        ;; most-specific, e.g. (racket/base racket).
        (car libs)))
    (sort (set->list results)
          string<?
          #:cache-keys? #t
          #:key
          (lambda (lib)
            (match lib
              [(and (pregexp "^racket/") v)
               (string-append "0_" v)]
              [(and (pregexp "^typed/racket/") v)
               (string-append "1_" v)]
              [v v])))))
