#lang racket/base
;; For legal info, see file "info.rkt".

(require net/sendurl
         planet/planet-archives
         planet/util
         racket/cmdline
         racket/file
         racket/list
         racket/path
         racket/system
         raco/command-name
         setup/getinfo
         syntax/parse
         syntax/srcloc
         "mcfly-tools-msg.rkt"
         "mcfly-tools-plt-server.rkt"
         "mcfly-tools-scrbl-file.rkt"
         "planet-neil-progedit.rkt")

;; TODO: We copy&paste a few procedures from package "mcfly" because we don't
;; want "mcfly" to have dependencies on any other PLaneT packages, and we also
;; don't want package "mcfly-tools" to depend upon "mcfly".  Is this right?

(define (strip-dotplt pkg)
  (regexp-replace #rx"\\.plt$" pkg ""))

(define (with-dotplt pkg)
  (string-append pkg ".plt"))

(define (parse-planet-symbol/ignore-equals sym)
  (if (symbol? sym)
      (parse-planet-symbol-string/ignore-equals (symbol->string sym))
      (error 'parse-planet-symbol/ignore-equals
             "invalid PLaneT symbol: ~S"
             sym)))

(define (parse-planet-symbol-string/ignore-equals str)
  (cond ((regexp-match #rx"^([a-z-]+)/([a-z-]+):([1-9][0-9]*):=?([0-9]+)$"
                       str)
         => (lambda (m)
              (apply (lambda (whole owner name major minor)
                       (values owner
                               (regexp-replace #rx"\\.plt$" name "")
                               major
                               minor))
                     m)))
        (else (error 'parse-planet-symbol-string/ignore-equals
                     "invalid PLaneT symbol string: ~S"
                     str))))

(define (format-exact-planet-version-string owner name major minor)
  (let ((name (regexp-replace #"\\.plt$" name "")))
    (format "~A/~A:~A:=~A" owner name major minor)))

(define (format-relaxed-planet-version-string owner name major minor)
  (let ((name (regexp-replace #"\\.plt$" name "")))
    (format "~A/~A:~A:~A" owner name major minor)))

(define (normalize-path-a-lot path #:base (base (current-directory)))
  ;; (normal-case-path (cleanse-path (simplify-path (path->complete-path path base))))
  (normal-case-path (normalize-path path base)))

(define (sorted-subdir-paths-without-dot-files dir-path)
  (let loop ((paths  (directory-list dir-path))
             (result '()))
    (if (null? paths)
        (map cdr (sort result string<? #:key car))
        (let* ((relative-path (normal-case-path (car paths)))
               (name          (path->string relative-path)))
          (if (regexp-match #rx"^\\." name)
              (loop (cdr paths) result)
              (let ((full-path (build-path dir-path relative-path)))
                (if (directory-exists? full-path)
                    (loop (cdr paths) (cons (cons name full-path)
                                            result))
                    (loop (cdr paths) result))))))))

(define (get-mcfly-pathpkgspec-for-directory dir-path)
  (cond
   ((get-info/full dir-path)
    => (lambda (inforkt)
         (cond ((inforkt 'mcfly-planet (lambda () #f))
                => (lambda (planet-symbol)
                     (let-values (((owner name major minor)
                                   (parse-planet-symbol/ignore-equals planet-symbol)))
                       ;; TODO: Catch the parse error elsewhere, and add
                       ;; the directory and filename to it for
                       ;; command-line reporting.  Maybe rethrow here as
                       ;; an exn:fail:file-position-rethrow-thing that,
                       ;; when we're running as a command-line app, we can
                       ;; catch and format as a command-line error
                       ;; message?
                       (list dir-path
                             owner
                             name
                             (string->number major)
                             (string->number minor)))))
               (else #f))))
   (else #f)))

(define find-mcfly-planet-packages-in-directories
  (letrec
      ((find-in-dir
        (lambda (reverse-result visited-hash dir-path)

          (let ((dir-path (normalize-path-a-lot dir-path)))
            (if (hash-ref visited-hash dir-path #f)
                (values reverse-result visited-hash)
                (let loop ((reverse-result (cond ((get-mcfly-pathpkgspec-for-directory
                                                   dir-path)
                                                  => (lambda (location)
                                                       (cons location reverse-result)))
                                                 (else reverse-result)))
                           (visited-hash   (hash-set visited-hash dir-path #t))
                           (paths          (with-handlers
                                               ((exn:fail? (lambda (e)
                                                             ;; TODO: Always catch?
                                                             (msg-warning "~A"
                                                                          (exn-message e))
                                                             '())))
                                             (sorted-subdir-paths-without-dot-files dir-path))))
                  (if (null? paths)
                      (values reverse-result visited-hash)
                      (let-values (((reverse-result visited-hash)
                                    (find-in-dir reverse-result visited-hash (car paths))))
                        (loop reverse-result
                              visited-hash
                              (cdr paths))))))))))
    (lambda (dir-paths)
      (let loop ((dir-paths      dir-paths)
                 (reverse-result '())
                 (visited-hash   (make-immutable-hash)))
        (if (null? dir-paths)
            (reverse reverse-result)
            (let ((dir-path (normalize-path-a-lot (car dir-paths))))
              (msg-verbose "Searching directory ~S..."
                           (path->string dir-path))
              (let-values (((reverse-result visited-hash)
                            (find-in-dir reverse-result visited-hash dir-path)))
                (loop (cdr dir-paths)
                      reverse-result
                      visited-hash))))))))

(define (get-dev-link-pathpkgspecs)
  (map (lambda (item)
         (apply (lambda (path owner name unknown major minor)
                  (list path
                        owner
                        (strip-dotplt name)
                        major
                        minor))
                item))
       (get-hard-linked-packages)))

;; (get-dev-links-as-path-to-pkgspec-set-hash)
;; ==>
;; #hash((#<path:/home/user/racket/postnet>     . #hash((("neil" "postnet"     1 1) . #t)))
;;       (#<path:/home/user/racket/mcfly>       . #hash((("neil" "mcfly"       1 0) . #t)))
;;       (#<path:/home/user/racket/soundex>     . #hash((("neil" "soundex"     1 4) . #t)))
;;       (#<path:/home/user/racket/bigtime>     . #hash((("neil" "bigtime"     1 0) . #t)))
;;       (#<path:/home/user/racket/mcfly-tools> . #hash((("neil" "mcfly-tools" 1 0) . #t)))
;;       (#<path:/home/user/racket/ccnum>       . #hash((("neil" "ccnum"       1 3) . #t))))
(define (get-dev-links-as-path-to-pkgspec-set-hash)
  (let loop ((pathpkgspecs (get-dev-link-pathpkgspecs))
             (hash         (make-immutable-hash)))
    (if (null? pathpkgspecs)
        hash
        (let* ((new-pathpkgspec (car pathpkgspecs))
               (path            (car new-pathpkgspec))
               (new-pkgspec     (cdr new-pathpkgspec)))
          (loop (cdr pathpkgspecs)
                (hash-update hash
                             path
                             (lambda (pkgspec-set)

                               (if (hash-ref pkgspec-set new-pkgspec #f)
                                   (begin (msg-warning "PLaneT development links have package spec ~S multiple times for path ~S."
                                                       new-pkgspec
                                                       path)
                                          pkgspec-set)
                                   (hash-set pkgspec-set
                                             new-pkgspec
                                             #t)))
                             (make-immutable-hash '())))))))

(define (classify-provided-pathpkgspecs-with-and-without-dev-links
         path-to-dev-link-pkgspec-set-hash
         provided-pathpkgspecs)
  ;; TODO: Use normalize-path-a-lot on exiting dev link paths before comparison.
  (let loop ((provided-pathpkgspecs                   provided-pathpkgspecs)
             (path-to-dev-link-pkgspec-set-hash       path-to-dev-link-pkgspec-set-hash)
             (provided-pathpkgspecs-with-dev-links    '())
             (provided-pathpkgspecs-without-dev-links '()))
    (if (null? provided-pathpkgspecs)
        ;; TODO: Sort these lists?  Reverse them?
        (values provided-pathpkgspecs-with-dev-links
                provided-pathpkgspecs-without-dev-links
                path-to-dev-link-pkgspec-set-hash)
        (let* ((provided-pathpkgspec (car provided-pathpkgspecs))
               (provided-pkgspec     (pathpkgspec->pkgspec provided-pathpkgspec))
               (path                 (car provided-pathpkgspec)))
          (cond ((hash-ref path-to-dev-link-pkgspec-set-hash
                           path
                           #f)
                 => (lambda (dev-link-pkgspec-set-for-path)
                      (if (hash-ref dev-link-pkgspec-set-for-path
                                    provided-pkgspec
                                    #f)
                          (loop (cdr provided-pathpkgspecs)
                                (hash-update path-to-dev-link-pkgspec-set-hash
                                             path
                                             (lambda (pkgspec-set)
                                               (hash-remove pkgspec-set
                                                            provided-pkgspec)))
                                (cons provided-pathpkgspec provided-pathpkgspecs-with-dev-links)
                                provided-pathpkgspecs-without-dev-links)
                          (loop (cdr provided-pathpkgspecs)
                                path-to-dev-link-pkgspec-set-hash
                                provided-pathpkgspecs-with-dev-links
                                (cons provided-pathpkgspec
                                      provided-pathpkgspecs-without-dev-links)))))
                ;; TODO: If this "else" clause stays same as above, combine them.
                (else (loop (cdr provided-pathpkgspecs)
                            path-to-dev-link-pkgspec-set-hash
                            provided-pathpkgspecs-with-dev-links
                            (cons provided-pathpkgspec
                                  provided-pathpkgspecs-without-dev-links))))))))

(define (path+pkgspec->pathpkgspec path pkgspec)
  (cons path pkgspec))

(define (path-to-pkgspec-set-hash->pathpkgspecs hash)
  (let loop-paths ((paths  (hash-keys hash))
                   (result '()))
    (if (null? paths)
        result
        (let* ((path (car paths))
               (set  (hash-ref hash path)))
          (let loop-set ((pkgspecs (hash-keys set))
                         (result   result))
            (if (null? pkgspecs)
                (loop-paths (cdr paths)
                            result)
                (loop-set (cdr pkgspecs)
                          (cons (path+pkgspec->pathpkgspec path
                                                           (car pkgspecs))
                                result))))))))

;;-----------------------------------------------------------------------------

(define (spaces n)
  ;; TODO: Could optimize this.
  (make-string n #\space))

(define (display-two-column-table-with-headings data)
  (let ((col-0-width (let loop-sections ((data data)
                                         (width 0))
                       (if (null? data)
                           width
                           (let loop-rows ((rows  (cdar data))
                                           (width width))
                             (if (null? rows)
                                 (loop-sections (cdr data)
                                                width)
                                 (loop-rows (cdr rows)
                                            (max width (string-length (caar rows))))))))))
    (for-each (lambda (section)
                (msg-info "~A:" (car section))
                (for-each (lambda (row)
                            (apply (lambda (col-0 col-1)
                                     (display "  ")
                                     (display col-0)
                                     (display (spaces (- col-0-width
                                                         (string-length col-0))))
                                     (display "  ")
                                     (display col-1)
                                     (display "\n"))
                                   row))
                          (cdr section)))
              data)))

(define (show-sections-and-pathpkgspecs sections)
  (if (current-verbose-msg?)
      (display-two-column-table-with-headings
       (let loop-sections ((sections sections))
         (if (null? sections)
             '()
             (let* ((section      (car sections))
                    (pathpkgspecs (cddr section)))
               (if (null? pathpkgspecs)
                   (loop-sections (cdr sections))
                   (cons (cons (list-ref section 1)
                               (map (lambda (pathpkgspec)
                                      (list (apply format-relaxed-planet-version-string
                                                   (cdr pathpkgspec))
                                            (path->string (car pathpkgspec))))
                                    pathpkgspecs))
                         (loop-sections (cdr sections))))))))
      (for-each (lambda (section)
                  (let-values (((msg-proc shortwhat)
                                (case (list-ref section 0)
                                  ((keep)   (values #f #f))
                                  ((nope)   (values msg-warning "Already on PLaneT server"))
                                  ((remove) (values msg-info    "Removing development link"))
                                  ((add)    (values msg-info    "Adding development link"))
                                  (else (error 'show-sections-and-pathpkgspecs
                                               "internal error: ~S"
                                               section)))))
                    (and msg-proc
                         (for-each (lambda (pathpkgspec)
                                     (msg-proc "~A: ~A"
                                               shortwhat
                                               (quote-command-line-for-presentation
                                                (list (apply format-relaxed-planet-version-string
                                                             (cdr pathpkgspec))
                                                      (path->string (car pathpkgspec))))))
                                   (cddr section)))))
                sections)))

;;-----------------------------------------------------------------------------

(define (add-pathpkgspec-dev-link pathpkgspec)
  ;; TODO: error-checking
  (apply (lambda (path owner name major minor)
           (add-hard-link owner
                          (with-dotplt name)
                          major
                          minor
                          path))
         pathpkgspec))

(define (remove-pathpkgspec-dev-link pathpkgspec)
  ;; TODO: error-checking
  (apply (lambda (path owner name major minor)
           (remove-hard-link owner
                             (with-dotplt name)
                             major
                             minor))
         pathpkgspec))

(define (pathpkgspec->pkgspec pathpkgspec)
  (cdr pathpkgspec))

(define (pkgspec-is-on-planet-server? pathpkgspec)
  ;; TODO: We should use a cache.  Maybe maintain our own.
  (apply (lambda (owner name major minor)
           (planet-package-version-is-on-server? owner
                                                 (with-dotplt name)
                                                 major
                                                 minor))
         pathpkgspec))

(define (classify-mcfly-pathpkgspecs-needing-and-not-needing-dev-links pathpkgspecs)
  (let loop ((pathpkgspecs  pathpkgspecs)
             (needing     '())
             (not-needing '()))
    (if (null? pathpkgspecs)
        (values needing not-needing)
        (let ((pathpkgspec (car pathpkgspecs)))
          (if (pkgspec-is-on-planet-server? (pathpkgspec->pkgspec pathpkgspec))
              (loop (cdr pathpkgspecs)
                    needing
                    (cons pathpkgspec not-needing))
              (loop (cdr pathpkgspecs)
                    (cons pathpkgspec needing)
                    not-needing))))))

(define (list-subtract dev-link-patkpkgspecs-not-in-dirs pkgspecs-to-be-added)
  (let loop ((dev-link-pathpkgspecs-not-in-dirs dev-link-patkpkgspecs-not-in-dirs))
    (if (null? dev-link-pathpkgspecs-not-in-dirs)
        '()
        (let ((existing-dev-link-pathpkgspec (car dev-link-pathpkgspecs-not-in-dirs)))
          (if (member (pathpkgspec->pkgspec existing-dev-link-pathpkgspec) pkgspecs-to-be-added)
              (cons existing-dev-link-pathpkgspec
                    (loop (cdr dev-link-pathpkgspecs-not-in-dirs)))
              (loop (cdr dev-link-pathpkgspecs-not-in-dirs)))))))

(define (determine-unfound-dev-links-to-keep-and-remove unfound-dev-link-pathpkgspecs
                                                        pathpkgspecs-to-add)
  (let ((pkgspecs-to-add (map pathpkgspec->pkgspec pathpkgspecs-to-add)))
    (let loop ((unfound-dev-link-pathpkgspecs unfound-dev-link-pathpkgspecs)
               (to-keep   '())
               (to-remove '()))
      (if (null? unfound-dev-link-pathpkgspecs)
          (values to-keep to-remove)
          (let ((unfound-dev-link-pathpkgspec (car unfound-dev-link-pathpkgspecs)))
            (if (member (pathpkgspec->pkgspec unfound-dev-link-pathpkgspec) pkgspecs-to-add)
                (loop (cdr unfound-dev-link-pathpkgspecs)
                      to-keep
                      (cons unfound-dev-link-pathpkgspec
                            to-remove))
                (loop (cdr unfound-dev-link-pathpkgspecs)
                      (cons unfound-dev-link-pathpkgspec
                            to-keep)
                      to-remove)))))))

(define (update-mcfly-dev-links-for-directories start-dirs)
  (update-mcfly-dev-links-for-pathpkgspecs
   (find-mcfly-planet-packages-in-directories start-dirs)))

(define (update-mcfly-dev-links-for-pathpkgspecs mcfly-pathpkgspecs)
  ;; TODO: !!! ALSO REMOVE DEV LINKS IF WE'RE GOING TO OVERRIDE THE *PATH* (NOT
  ;; THE NAME AND VERSION, WHICH WE ALREADY REMOVE) !!! OR MAYBE IF WE KNOW WE
  ;; NEED ONE WITH A CERTAIN PATH, BUT WE DON'T KNOW WE NEED OTHERS WITH THAT
  ;; PATH !!!
  ;;
  ;; TODO: !!! OR MAYBE CHECK ALL EXISTING "UNKNOWN" PATHS FOR "mcfly-planet"
  ;; IN "info.rkt".  IF THERE IS A "mcfly-planet" AND IT DISAGREES, REMOVE THE
  ;; LINK.  OR MAYBE BEST TO JUST REMOVE THE LINK ONLY IF IT'S IN CONFLICT WITH
  ;; A LEGITIMATE LINK WE NEED (LIKE THE PATH IS THE SAME).
  ;;
  ;; TODO: !!! ERROR IF WE SEEM TO BE ADDING AND/OR KEEPING TWO LINKS WITH THE
  ;; SAME SPEC (SUCH AS HAPPENS IF WE HAVE A LEFTOVER STAGING DIRECTORY, BUT
  ;; CAN HAPPEN OTHER WAYS AS WELL).
  (msg-verbose "Updating PLaneT development links...")
  (let ((path-to-dev-link-pkgspec-set-hash (get-dev-links-as-path-to-pkgspec-set-hash)))
    (let*-values
        (((mcfly-pathpkgspecs-with-dev-links
           mcfly-pathpkgspecs-without-dev-links
           path-to-dev-link-pkgspecs-not-in-provided-hash)
          (classify-provided-pathpkgspecs-with-and-without-dev-links
           path-to-dev-link-pkgspec-set-hash mcfly-pathpkgspecs))
         ((mcfly-pathpkgspecs-with-needed-dev-link
           mcfly-pathpkgspecs-with-unneeded-dev-link)
          (classify-mcfly-pathpkgspecs-needing-and-not-needing-dev-links
           mcfly-pathpkgspecs-with-dev-links))
         ((mcfly-pathpkgspecs-without-needed-dev-link
           mcfly-pathpkgspecs-without-unneeded-dev-link)
          (classify-mcfly-pathpkgspecs-needing-and-not-needing-dev-links
           mcfly-pathpkgspecs-without-dev-links))
         ((dev-link-pathpkgspecs-not-in-dirs)
          (path-to-pkgspec-set-hash->pathpkgspecs
           path-to-dev-link-pkgspecs-not-in-provided-hash))
         ((existing-uncounf-dev-link-pathpkgs-to-keep
           existing-unfound-dev-link-pathpkgspecs-to-remove)
          (determine-unfound-dev-links-to-keep-and-remove
           dev-link-pathpkgspecs-not-in-dirs
           mcfly-pathpkgspecs-without-needed-dev-link)))
      ;; TODO: Error-check duplicate pkgspecs for links that will exist after
      ;; we are done.
      (show-sections-and-pathpkgspecs
       `((keep "Keeping development links (unknown, but not overridden)"
               ,@existing-uncounf-dev-link-pathpkgs-to-keep)
         (keep "Keeping development links (needed)"
               ,@mcfly-pathpkgspecs-with-needed-dev-link)
         (nope "Not adding development links (on PLaneT server)"
               ,@mcfly-pathpkgspecs-without-unneeded-dev-link)
         (remove "Removing development links (on PLaneT server)"
                 ,@mcfly-pathpkgspecs-with-unneeded-dev-link)
         (remove "Removing development links (to be overridden)"
                 ,@existing-unfound-dev-link-pathpkgspecs-to-remove)
         (add "Adding development links"
              ,@mcfly-pathpkgspecs-without-needed-dev-link)))

      (for-each remove-pathpkgspec-dev-link
                mcfly-pathpkgspecs-with-unneeded-dev-link)

      (for-each remove-pathpkgspec-dev-link
                existing-unfound-dev-link-pathpkgspecs-to-remove)

      (for-each add-pathpkgspec-dev-link
                mcfly-pathpkgspecs-without-needed-dev-link)

      ;; TODO: Sorting out which existing dev links weren't in the
      ;; mcfly-pathpkgspecs (and maybe going and looking at those paths, to see if
      ;; they actually have a mcfly-planet in info.rkt, and simply weren't in the
      ;; list of directories we searched, and other handling, such as possibly
      ;; removing the link).

      (void))))

;;-----------------------------------------------------------------------------

;; (define (canonicalize-path path)
;;   (path->complete-path (simplify-path (resolve-path path))))

(define (assert-no-more-syntax-after-module in #:error-name (error-name '%assert-no-more-syntax))
  (let ((stx (read-syntax #f in)))
    (if (eof-object? stx)
        (void)
        (error error-name
               "unexpected syntax after module: ~S"
               stx))))

(define bangbangbang-str (make-string 3 #\!))

(define bangbangbang-str-stx (datum->syntax #f bangbangbang-str #f))

(define todo-str (string #\T #\O #\D #\O))

(define-syntax-class setup-infotab-id-sc
  #:description "identifier setup/infotab"
  (pattern (~datum setup/infotab)))

(define-syntax-class module-begin-id-sc
  #:description "identifier #%module-begin"
  (pattern (~datum #%module-begin)))

(provide update-info-file)
(define (update-info-file path)
  (let ((path (cleanse-path path)))
    (msg-verbose "Checking ~S..." (path->string path))
    (let/ec do-not-modify-file-ec
      (progedit-file
       path
       #:read
       (lambda (in)
         (port-count-lines! in)
         (parameterize ((read-accept-lang   #t)
                        (read-accept-reader #t))
           (let*-values (((first-stx)
                          (read-syntax path in))
                         ((module-format body-stxes empty-body-position-stx-or-false)
                          (if (eof-object? first-stx)
                              (values #f
                                      '()
                                      #f)
                              (syntax-parse first-stx
                                (((~datum module) NAME:id SI:setup-infotab-id-sc (MB:module-begin-id-sc BODYn:expr ...))
                                 (assert-no-more-syntax-after-module in #:error-name 'foo)
                                 (values 'module-with-module-begin
                                         (syntax->list #'(BODYn ...))
                                         #'MB))
                                (((~datum module) NAME:id SI:setup-infotab-id-sc BODYn:expr ...)
                                 (assert-no-more-syntax-after-module in #:error-name 'foo)
                                 (values 'module
                                         (syntax->list #'(BODYn ...))
                                         #'SI))
                                (ELSE
                                 (error 'update-info-file
                                        "~S does not look like an info file: ~S"
                                        in
                                        first-stx)))))
                         ((top-position bottom-position)
                          (let ((empty-body-position (and empty-body-position-stx-or-false
                                                          (source-location-end empty-body-position-stx-or-false))))
                            (if (null? body-stxes)
                                (values empty-body-position
                                        empty-body-position)
                                (values (source-location-position (first body-stxes))
                                        (source-location-end (last body-stxes))))))
                         ((symbol-to-val-stx-hash)
                          (let loop ((body-stxes              body-stxes)
                                     (symbol-to-val-stx-hash (make-immutable-hasheqv)))
                            (if (null? body-stxes)
                                symbol-to-val-stx-hash
                                (let ((stx (car body-stxes)))
                                  (syntax-parse stx
                                    (((~datum define) NAME:id VAL:expr)
                                     ;; Note: We don't check for multiple definitions for the same name.
                                     (loop (cdr body-stxes)
                                           (hash-set symbol-to-val-stx-hash
                                                     (syntax-e #'NAME)
                                                     #'VAL)))
                                    (ELSE (loop (cdr body-stxes)
                                                symbol-to-val-stx-hash)))))))
                         ((inserts)
                          (let loop ((needs
                                      `(
                                        ,(cons 'mcfly-planet
                                               (lambda ()
                                                 ;; TODO: Infer package name from directory or any pre-existing \"name\".
                                                 (values
                                                  "Add the PLaneT owner and package name, and double-check the version:"
                                                  #''!!!/!!!:1:0)))
                                        ,(cons 'name
                                               (lambda ()
                                                 (values
                                                  "Add the name of the package (may be capitalized and have spaces):"
                                                  bangbangbang-str-stx)))
                                        ,@(if (hash-has-key? symbol-to-val-stx-hash 'mcfly-title)
                                              '()
                                              (list
                                               (cons 'mcfly-subtitle
                                                     (lambda ()
                                                       (values
                                                        "Add the subtitle string, or define \"mcfly-title\" instead:"
                                                        bangbangbang-str-stx)))))
                                        ,(cons 'blurb
                                               (lambda ()
                                                 (values #f
                                                         #'(list name
                                                                 ": "
                                                                 mcfly-subtitle))))
                                        ,(cons 'homepage
                                               (lambda ()
                                                 ;; TODO: What if they don't have a
                                                 ;; URL?  Can this be #f or an empty
                                                 ;; string?  If not, have two modes for
                                                 ;; this update procedure: an
                                                 ;; initialize mode, when we add
                                                 ;; "homepage" if missing, and a normal
                                                 ;; update mode, when we don't add
                                                 ;; "homepage" even if it's missing.
                                                 ;; Then we would change the comment to
                                                 ;; say to comment-out this form if no URL.
                                                 (values "Add the Web home page URL for this package:"
                                                         (datum->syntax
                                                          #f
                                                          (string-append
                                                           "http://"
                                                           bangbangbang-str)
                                                          #f))))
                                        ,(cons 'mcfly-author
                                               (lambda ()
                                                 (values "Add the author(s):"
                                                         bangbangbang-str-stx)))
                                        ,(cons 'repositories
                                               (lambda ()
                                                 (values #f
                                                         #''("4.x"))))
                                        ,(cons 'categories
                                               (lambda ()
                                                 (values #f
                                                         #''(misc))))
                                        ,(cons 'can-be-loaded-with
                                               (lambda ()
                                                 (values "See http://doc.racket-lang.org/search/index.html?q=can-be-loaded-with"
                                                         #''all)))
                                        ,(cons 'scribblings
                                               (lambda ()
                                                 (values #f
                                                         #''(("doc.scrbl" () (library))))))
                                        ,(cons 'primary-file
                                               (lambda ()
                                                 ;; TODO: Use <packagename>".rkt" instead
                                                 ;; of "main.rkt" if available.  Maybe
                                                 ;; look to see which file has "doc"
                                                 ;; forms.
                                                 (values "Double-check this:"
                                                         #'"main.rkt")))
                                        ,(cons 'mcfly-start
                                               (lambda ()
                                                 ;; TODO: Use <packagename>".rkt" instead
                                                 ;; of "main.rkt" if available.  Maybe
                                                 ;; look to see which file has "doc"
                                                 ;; forms.
                                                 (values "Set this to the file that has starting \"doc\" forms:"
                                                         #'"main.rkt")))
                                        ,(cons 'mcfly-files
                                               (lambda ()
                                                 ;; TODO: !!! Add any ".rkt" files
                                                 ;; currently in directory?
                                                 (values "Double-check that this includes all files for the PLaneT package:"
                                                         #''(defaults))))
                                        ,(cons 'mcfly-license
                                               (lambda ()
                                                 (values
                                                  "Add short name for license (e.g., \"LGPLv3\"). See http://www.gnu.org/licenses/"
                                                  bangbangbang-str-stx)))
                                        ,(cons 'mcfly-legal
                                               (lambda ()
                                                 (values
                                                        "Add copyright, license, disclaimers, and other legal information."
                                                        (datum->syntax
                                                         #f
                                                         (string-append "Copyright "
                                                                        bangbangbang-str)
                                                         #f))))))
                                     (reverse-inserts '()))
                            (if (null? needs)
                                (if (null? reverse-inserts)
                                    '()
                                    ;; (cons `(,bottom-position #\newline #\newline)
                                    (reverse reverse-inserts)
                                    ;; )
                                    )
                                (let* ((need     (car needs))
                                       (name-sym (car need)))
                                  (if (hash-has-key? symbol-to-val-stx-hash name-sym)
                                      (loop (cdr needs)
                                            reverse-inserts)
                                      (loop (cdr needs)
                                            (cons (let-values (((name-str) (symbol->string name-sym))
                                                               ((val-comment val-val) ((cdr need))))
                                                    `(,bottom-position
                                                      #\newline
                                                      ,@(if val-comment
                                                            `(#\newline
                                                              ";; "
                                                              ,todo-str
                                                              ": "
                                                              ,val-comment)
                                                            '())
                                                      #\newline
                                                      "(define "
                                                      ,name-str
                                                      ,(make-string (max 0 (- 18 (string-length name-str))) #\space)
                                                      #\space
                                                      ,val-val
                                                      #\)))
                                                  reverse-inserts)))))))
                         ((inserts)
                          (if module-format
                              inserts
                              (cons '(1 "#lang setup/infotab" #\newline)
                                    inserts))))
             (if (null? inserts)
                 (do-not-modify-file-ec)
                 inserts))))
       #:write
       (lambda (in out inserts)
         (msg-info "Modifying ~S..." (path->string path))
         (progedit in out #:inserts inserts))))
    (void)))

(define (%inforkt-in-dir-path-or-false dir)
  (let ((path (build-path dir "info.rkt")))
    (if (file-exists? path)
        path
        (let ((path (build-path dir "info.ss")))
          (if (file-exists? path)
              path
              #f)))))

(define (update-any-inforkt-in-dir dir)
  (cond ((%inforkt-in-dir-path-or-false dir)
         => update-info-file)))

(define (update-any-inforkt-in-dirs dirs)
  (for-each update-any-inforkt-in-dir
            dirs))

;;-----------------------------------------------------------------------------

(define (update-any-inforkt-in-dirs-and-dev-links-for-dirs dirs)
  (update-any-inforkt-in-dirs dirs)
  (update-mcfly-dev-links-for-directories dirs))

;;-----------------------------------------------------------------------------

(define (quote-command-line-for-presentation args)
  ;; TODO: This could be better.
  (let ((os (open-output-string)))
    (let loop ((args   args)
               (first? #t))
      (if (null? args)
          (get-output-string os)
          (let ((arg (car args)))
            (or first?
                (write-char #\space os))
            (if (regexp-match? #rx"^[-_.=:/a-zA-Z0-9]*$" arg)
                (display arg os)
                (write arg os))
            (loop (cdr args) #f))))))

;;-----------------------------------------------------------------------------

(define current-subcommand (make-parameter #f))

(define (current-program)
  (cond ((current-subcommand)
         => (lambda (subcommand)
              (string-append (short-program+command-name) " " subcommand)))
        (else (short-program+command-name))))

(define (set-current-program-subcommand subcommand)
  (current-program (string-append (current-program) " " subcommand)))

;;-----------------------------------------------------------------------------

(define (current-raco-executable-string)
  ;; TODO: !!! Be sensitive to which copy of Racket tools we are running under,
  ;; and try to get "raco" from the same place, for when multiple versions of
  ;; Racket are installed.
  (path->string (find-executable-path "raco")))

(define (mcfly-format-html dir-path)
  ;; TODO: Check timestamps?
  (let ((dir-path (cleanse-path dir-path)))
    (cond
     ((get-info/full dir-path)
      => (lambda (inforkt)
           (let ((start-file (inforkt 'mcfly-start
                                      (lambda () "main.rkt")))
                 (scrbl-file "doc.scrbl")
                 (html-file  "doc.html"))
             ;; TODO: What if mcfly-start has a path?
             ;;
             (create-or-update-mcfly-scribble-file start-file scrbl-file)

             ;; TODO: If we were called from raco, use the same executable
             ;; path to that.
             (let ((args (list ;; "raco"
                          (current-raco-executable-string)
                          "scribble"
                          scrbl-file)))
               ;; TODO: Change msg-info here to not format args as list.
               (msg-verbose "Executing: ~A" (quote-command-line-for-presentation args))
               (let ((exit-code (parameterize ((current-directory dir-path))
                                  (apply system*/exit-code args))))
                 (msg-verbose "Done executing: ~A" (quote-command-line-for-presentation args))
                 (if (zero? exit-code)
                     html-file
                     (error 'mcfly-format-html
                            "Scribble had exit code ~S"
                            exit-code)))))))
     (else (error 'mcfly-format-html
                  "Could not get info for directory ~S"
                  (path->string dir-path))))))

(define (mcfly-view dir-path)
  (let ((dir-path (cleanse-path dir-path)))
    (parameterize ((current-directory dir-path))
      (send-url/file (mcfly-format-html dir-path)))))

(define (pathpkgspecs->minus-p-command-line-args lst)
  (let loop ((lst lst))
    (if (null? lst)
        '()
        (apply (lambda (path owner pkg major minor)
                 `("-P"
                   ,owner
                   ,(with-dotplt pkg)
                   ,(number->string major)
                   ,(number->string minor)
                   ,@(loop (cdr lst))))
               (car lst)))))

(define (mcfly-setup start-dirs)
  (let ((specified-pathpkgspecs (find-mcfly-planet-packages-in-directories start-dirs)))
    (and (null? specified-pathpkgspecs)
         (error 'mcfly-setup
                "No McFly PLaneT packages found"))
    (update-mcfly-dev-links-for-pathpkgspecs specified-pathpkgspecs)
    ;; TODO: !!! Get list of current development links again, and make sure
    ;; that each specified-pathpkgspecs is in it.  Make list of ones that have
    ;; devlinks and use that for setup instead, and warn on the ones that don't
    ;; have development links.
    (let ((args `(,(current-raco-executable-string)
                  "setup"
                  ,@(pathpkgspecs->minus-p-command-line-args specified-pathpkgspecs))))
      (msg-verbose "Executing: ~A" (quote-command-line-for-presentation args))
      (let ((exit-code (apply system*/exit-code args)))
        (msg-verbose "Done executing: ~A" (quote-command-line-for-presentation args))
        (if (zero? exit-code)
            (void)
            (error 'mcfly-setup
                   "Setup had exit code ~S"
                   exit-code))))))

;;-----------------------------------------------------------------------------

(define (mcfly-build-planet-archive dir-path)

  (let*-values (((dir-path)      (simplify-path (path->complete-path (cleanse-path dir-path))))
                ((inforkt)       (or (get-info/full dir-path)
                                     (error 'mcfly-build-planet-archive
                                            "Could not get info for directory ~S"
                                            (path->string dir-path))))
                ((planet-symbol) (inforkt 'mcfly-planet
                                          (lambda ()
                                            (error 'mcfly-build-planet-archive
                                                   "Info for directory ~S has no mcfly-planet"
                                                   (path->string dir-path)))))
                ((planet-owner planet-name planet-major planet-minor)
                 (parse-planet-symbol/ignore-equals planet-symbol))
                ;; TODO: Check for "!!!" in "planet-name" and error?
                ((planet-relaxed-string)
                 (format-relaxed-planet-version-string planet-owner
                                                       planet-name
                                                       planet-major
                                                       planet-minor))
                ((planet-files)  (inforkt 'mcfly-files (lambda ()
                                                         '(defaults))))
                ((staging-dir)   (build-path dir-path "temporary-mcfly-planet-archive-staging"))
                ((archive-file)  (build-path dir-path
                                             (string-append (let-values ()
                                                              planet-name)
                                                            ".plt"))))
    (msg-verbose "Building PLaneT package ~S from directory ~S..."
                 planet-relaxed-string
                 (path->string dir-path))

    ;; Populate the staging directory.
    (and (directory-exists? staging-dir)
         (error 'mcfly-build-planet-archive
                "Directory ~S already exists."
                (path->string staging-dir)))
    (let loop-dir ((source-dir   dir-path)
                   (dest-dir     staging-dir)
                   (planet-files planet-files))
      (make-directory dest-dir)
      (let loop-files-in-dir ((files-spec planet-files))
        (if (null? files-spec)
            (void)
            (let ((file (car files-spec)))
              (cond ((string? file)
                     (let ((source-file (build-path source-dir file))
                           (dest-file   (build-path dest-dir   file)))

                       (if (directory-exists? source-file)
                           (loop-dir source-file dest-file '(all))
                           (copy-file source-file dest-file))
                       (loop-files-in-dir (cdr files-spec))))
                    ((pair? file)
                     (let ((subdir (car file)))
                       (or (string? subdir)
                           (error 'mcfly-build-planet-archive
                                  "Invalid directory part ~S in mcfly-files ~S"
                                  file
                                  planet-files))
                       (loop-dir (build-path source-dir subdir)
                                 (build-path dest-dir   subdir)
                                 (cdr file))
                       (loop-files-in-dir (cdr files-spec))))
                    ((eq? file 'defaults)
                     (loop-files-in-dir `("info.rkt"
                                          "main.rkt"
                                          "doc.scrbl"
                                          ,@(cdr files-spec))))
                    ((eq? file 'all)
                     (loop-files-in-dir (append
                                         (filter (lambda (file)
                                                   (not (or (regexp-match? #rx"^\\."                 file)
                                                            (regexp-match? #rx"(~|\\.[bB][aA][kK])$" file)
                                                            (regexp-match? #rx"^CVS$"                file))))
                                                 (directory-list source-dir))
                                         (cdr files-spec))))
                    (else (error 'mcfly-build-planet-archive
                                 "Invalid value ~S in mcfly-files ~S"
                                 file
                                 planet-files)))))))

    ;; Build the archive with the development links temporarily changed, and
    ;; remove the staging directory.
    (dynamic-wind
      void

      (lambda ()
        (msg-verbose "Temporarily setting PLaneT development links for staging...")
        (update-mcfly-dev-links-for-directories (list staging-dir))

        ;; Build the package from the staging directory.
        (msg-verbose "Calling make-planet-archive...")
        (parameterize ((current-directory       staging-dir)
                       (build-scribble-docs?    #t)
                       (force-package-building? #f))
          (make-planet-archive staging-dir archive-file))
        (msg-verbose "Done calling make-planet-archive...")

        ;; Sanity check that documentation was built at all (since
        ;; "make-planet-archive" seems to fail silently in Racket 5.3.0.x
        ;; nightly).
        (or (file-exists? (build-path staging-dir "planet-docs" "doc" "index.html"))
            (error 'mcfly-build-planet-archive
                   "make-planet-archive did not build documentation")))

      (lambda ()
        (and (directory-exists? staging-dir)
             (begin (msg-verbose "Removing staging directory...")
                    (delete-directory/files staging-dir)))

        (msg-verbose "Restoring PLaneT development links...")
        (update-mcfly-dev-links-for-directories (list dir-path))))

    ;; Done.
    (msg-verbose "")
    (msg-info "Created PLaneT archive for ~S: ~A"
              planet-relaxed-string
              (path->string archive-file))
    (msg-verbose "You may wish to test this file before uploading it to PLaneT.")))

;;-----------------------------------------------------------------------------

(define current-use-planet-server? (make-parameter #t))

(define (handle-mcfly-tools-command-line/no-exception-handler)
  (let-values (((subcommand subcommand-args)
                (command-line
                 #:program (current-program)
                 #:args    ((subcommand #f) . subcommand-arg)
                 (values subcommand subcommand-arg))))
    ;; TODO: This whole command-line thing could use redoing, once it's feature
    ;; complete and we know what we have to do.
    (parameterize ((current-command-line-arguments (list->vector subcommand-args)))
      (let loop-subcommand ((subcommand subcommand))
        (cond ((not subcommand)
               (loop-subcommand "view"))

              ;; Subcommands:

              ((equal? subcommand "planet-links")
               (parameterize ((current-subcommand subcommand))
                 (let* ((dirs (command-line
                               #:program (current-program)
                               #:once-each
                               (("--no-server" "--ns")
                                "Do not use the PLaneT server"
                                (current-use-planet-server? #f))
                               (("--verbose" "-v")
                                "Verbose messages"
                                (current-verbose-msg? #f))
                               #:args    directory-tree-to-search
                               directory-tree-to-search))
                        (dirs (if (null? dirs)
                                  (list (current-directory))
                                  dirs)))
                   (update-any-inforkt-in-dirs dirs)
                   (parameterize ((current-verbose-msg? #t))
                     (update-mcfly-dev-links-for-directories dirs)))))

              ((equal? subcommand "planet-archive")
               (parameterize ((current-subcommand subcommand))
                 (command-line
                  #:program (current-program)
                  #:once-each
                  (("--no-server" "--ns")
                   "Do not use the PLaneT server"
                   (current-use-planet-server? #f))
                  (("--verbose" "-v")
                   "Verbose messages"
                   (current-verbose-msg? #f)))
                 (let ((dir (current-directory)))
                   (update-any-inforkt-in-dirs (list dir))
                   (mcfly-setup (list dir))
                   (mcfly-build-planet-archive dir))))

              ((equal? subcommand "setup")
               (parameterize ((current-subcommand subcommand))
                 (let* ((dirs (command-line
                               #:program (current-program)
                               #:once-each
                               (("--no-server" "--ns")
                                "Do not use the PLaneT server"
                                (current-use-planet-server? #f))
                               (("--verbose" "-v")
                                "Verbose messages"
                                (current-verbose-msg? #f))#:args    directory-tree-to-search
                                directory-tree-to-search))
                        (dirs (if (null? dirs)
                                  (list (current-directory))
                                  dirs)))
                   (update-any-inforkt-in-dirs-and-dev-links-for-dirs dirs)
                   (mcfly-setup dirs))))

              ;; ((equal? subcommand "html")
              ;;  (parameterize ((current-subcommand subcommand))
              ;;    (command-line
              ;;     #:program (current-program)
              ;;     #:once-each
              ;;     (("--no-server" "--ns")
              ;;      "Do not use the PLaneT server"
              ;;      (current-use-planet-server? #f)))
              ;;    ;; TODO: Macroize the redundant command-line options, once we're done.
              ;;    ;;
              ;;    ;; TODO: Error if there are any extra args.
              ;;    (mcfly-format-html (current-directory))))

              ((equal? subcommand "view")
               (parameterize ((current-subcommand subcommand))
                 (command-line
                  #:program (current-program)
                  #:once-each
                  (("--no-server" "--ns")
                   "Do not use the PLaneT server"
                   (current-use-planet-server? #f))
                  (("--verbose" "-v")
                   "Verbose messages"
                   (current-verbose-msg? #f)))
                 ;; TODO: Macroize the redundant command-line options, once we're done.
                 ;;
                 ;; TODO: Error if there are any extra args.
                 (let ((dir (current-directory)))
                   (update-any-inforkt-in-dirs-and-dev-links-for-dirs (list dir))
                   (mcfly-view dir))))

              ((equal? subcommand "marty")
               (parameterize ((current-subcommand subcommand))
                 (let ((url "http://en.wikipedia.org/wiki/The_Michael_J._Fox_Foundation"))
                   (msg-info "See: ~A" url)
                   (send-url url))))

              ;; Abbreviations:
              ((equal? subcommand "h")  (loop-subcommand "html"))
              ((equal? subcommand "pl") (loop-subcommand "planet-links"))
              ((equal? subcommand "pa") (loop-subcommand "planet-archive"))
              ((equal? subcommand "s")  (loop-subcommand "setup"))
              ((equal? subcommand "v")  (loop-subcommand "view"))

              ;; Error:
              (else
               (fatal-command-line-error "Invalid subcommand ~S" subcommand)))))))

(provide handle-mcfly-tools-command-line)
(define (handle-mcfly-tools-command-line . args)
  (with-handlers ((exn:fail? (lambda (e)
                               (msg-error "exiting due to exception: ~S"
                                          (exn-message e))
                               (raise e))))
    (handle-mcfly-tools-command-line/no-exception-handler)))

;;EOF