;; Shared dependency-checking infrastructure, used by "check-dists.ss"
;; and by bundle script

#lang scheme/base

(require scheme/cmdline scheme/runtime-path scheme/match scheme/promise 
         scheme/list ; for use in specs too
         (for-syntax scheme/base) ; for runtime-path
         (except-in scheme/mpair mappend)
         (only-in (lib "process.ss") system)
         "specs.ss")

(define cd current-directory)

(provide current-verbose-port)
(define current-verbose-port (make-parameter current-output-port))

;;; ===========================================================================
;;; Utilities etc

(define concat string-append)

(define (sort* l)
  (sort l string<?))

(define (dir-list . args)
  (sort* (map path->string (apply directory-list args))))

(define (dprintf fmt . args)
  (let ([p ((current-verbose-port))])
    (apply fprintf p fmt args)
    (flush-output p)))

;;; ===========================================================================
;;; Object properties

(define *properties* (make-weak-hasheq))

(provide get-props
         prop-get
         prop-set!)

(define (get-props obj)
  (hash-ref *properties* obj (lambda ()
                               (let ([props (mlist 'props)])
                                 (hash-set! *properties* obj props)
                                 props))))

(define (prop-get obj prop [default #f])
  (let ([props (get-props obj)])
    (cond [(massq prop (mcdr props)) => mcdr]
          [(procedure? default) (default)]
          [(promise? default) (force default)]
          [else default])))

(define (prop-set! obj prop val)
  (let ([props (get-props obj)])
    (cond [(massq prop (mcdr props)) => (lambda (p) (set-mcdr! p val))]
          [else (set-mcdr! props (mcons (mcons prop val) (mcdr props)))])))

;;; ===========================================================================
;;; Tree utilities

;; A directory tree structure is either a string (for a file), or a pair of a
;; string (for a directory) and its entries.  Directory entries are always
;; sorted.  The strings are all paths beginning where the tree was scanned
;; from, and end with a "/" iff it is a directory.  Sometimes #f is used as an
;; exception "empty tree" value.

(provide get-tree)
;; path -> tree
;; Returns the tree with path (a string with no "/"s) at its root.
(define (get-tree path fake-path)
  (define base (regexp-replace #rx"/$" (path->string (cd)) ""))
  (let loop ([name path] [fake-name fake-path] [path ""] [fake-path ""])
    (cond [(or (file-exists? name) (link-exists? name))
           (let ([path (concat path name)]
                 [fake-path (concat fake-path fake-name)])
             (prop-set! fake-path 'base base)
             (prop-set! fake-path 'name name)
             (prop-set! fake-path 'real path)
             fake-path)]
          [(directory-exists? name)
           (let ([path (concat path name "/")]
                 [fake-path (concat fake-path fake-name "/")])
             (prop-set! fake-path 'base base)
             (prop-set! fake-path 'name name)
             (prop-set! fake-path 'real path)
             (parameterize ([cd name])
               (cons fake-path (map (lambda (name) (loop name name path fake-path))
                                    (dir-list)))))]
          [else (error 'get-tree/base "strange entry: ~a/~a"
                       (path->string (cd)) name)])))

(provide tree-path)
;; tree -> string
;; The path of the tree root -- if a file then identity, otherwise car.
(define (tree-path tree)
  (cond [(string? tree) tree]
        [(pair? tree) (car tree)]
        [else (error 'tree-path "got a bad tree: ~e" tree)]))

(provide tree-flatten)
;; tree [boolean] -> (list-of string)
(define (tree-flatten tree [only-files? #f])
  (let loop ([l '()] [tree (list tree)])
    (if (null? tree)
      (reverse l)
      (let ([1st (car tree)] [rest (cdr tree)])
        (if (pair? 1st)
          (loop (if only-files? l (cons (car 1st) l)) (append (cdr 1st) rest))
          (loop (cons 1st l) rest))))))

;; tree tree -> tree
;; Both trees should have the same root.  This is not a merge -- the trees
;; should not have equal files, directroy strings are taken from the first
;; tree.
(define (tree-add tree1 tree2)
  (cond [(not tree1) tree2]
        [(not tree2) tree1]
        [(not (and (pair? tree1) (pair? tree2)))
         (error 'tree-add "cannot add non-directories -- ~a and ~a"
                (tree-path tree1) (tree-path tree2))]
        [(not (equal? (car tree1) (car tree2)))
         (error 'tree-add "got incompatible entries -- ~a and ~a"
                (tree-path tree1) (tree-path tree2))]
        [else (let loop ([l1 (cdr tree1)]
                         [l2 (cdr tree2)]
                         [r (list (car tree1))])
                (cond [(and (null? l1) (null? l2)) (reverse r)]
                      [(null? l1) (loop l1 (cdr l2) (cons (car l2) r))]
                      [(null? l2) (loop (cdr l1) l2 (cons (car l1) r))]
                      [(string<? (tree-path (car l1)) (tree-path (car l2)))
                       (loop (cdr l1) l2 (cons (car l1) r))]
                      [(string>? (tree-path (car l1)) (tree-path (car l2)))
                       (loop l1 (cdr l2) (cons (car l2) r))]
                      [(and (pair? (car l1)) (pair? (car l2)))
                       (loop (cdr l1) (cdr l2)
                             (cons (tree-add (car l1) (car l2)) r))]
                      [(or (pair? (car l1)) (pair? (car l2)))
                       (error 'tree-add
                              "got incompatible file/dir entries -- ~a"
                              (tree-path (car l1)))]
                      [else
                       (error 'tree-add "a file appears in both trees -- ~a"
                              (tree-path (car l1)))]))]))

(provide add-trees)
;; tree list -> tree list
;; Adds up all input trees, generating a list of trees (in case of different
;; roots).
(define (add-trees trees)
  (let loop ([todo trees] [done '()])
    (cond [(null? todo) (reverse done)]
          [(not (car todo)) (loop (cdr todo) done)]
          [(assoc (caar todo) done) =>
           (lambda (t)
             (loop (cdr todo) (cons (tree-add t (car todo)) (remq t done))))]
          [else (loop (cdr todo) (cons (car todo) done))])))

(provide tree-subtract)
;; tree tree -> tree
;; All file entries that exist in tree2 are removed from tree1.
(define (tree-subtract tree1 tree2)
  (cond
    [(or (not tree1) (not tree2)) tree1]
    [(and (string? tree1) (string? tree2))
     (and (not (equal? tree1 tree2)) tree1)]
    [(and (pair? tree1) (pair? tree2))
     (if (equal? (car tree1) (car tree2))
       (let loop ([l1 (cdr tree1)] [l2 (cdr tree2)] [r '()])
         (cond [(or (null? l1) (null? l2))
                (let ([r (append (reverse r) l1)])
                  (and (pair? r) (cons (car tree1) r)))]
               [(string<? (tree-path (car l1)) (tree-path (car l2)))
                (loop (cdr l1) l2 (cons (car l1) r))]
               [(string>? (tree-path (car l1)) (tree-path (car l2)))
                (loop l1 (cdr l2) r)]
               [else (loop (cdr l1) (cdr l2)
                           (let ([sub (tree-subtract (car l1) (car l2))])
                             (if sub (cons sub r) r)))]))
       tree1)]
    [else (error 'tree-subtract
                 "got incompatible entries -- ~a ~a and ~a ~a"
                 (if (string? tree1) "file" "directory") (tree-path tree1)
                 (if (string? tree2) "file" "directory") (tree-path tree2))]))

;; tree -> tree
;; Removes empty directories and ones that contain only empty directories.
(define (remove-empty-trees tree)
  (if (string? tree)
    tree
    (let ([filtered (filtered-map remove-empty-trees (cdr tree))])
      (and (pair? filtered) (cons (car tree) filtered)))))

(provide tree-filter)
;; (string -> any) tree -> tree
;; If the filter returns '+ or '- this qualifies or disqualifies the
;; current tree immediately, otherwise recurse down directories.  If any other
;; result is returned for directories scanning continues, and for files they
;; are included if the result is not #f.
(define (tree-filter filter tree)
  (let ([filter (if (procedure? filter) filter (spec->filter filter))])
    (let loop ([tree tree])
      (let ([r (filter tree)])
        (case r
          [(+) tree] [(-) #f]
          [else (if (string? tree)
                  (and r tree)
                  (let ([filtered (filtered-map loop (cdr tree))])
                    ;; directories are removed if they're empty and if the
                    ;; predicate resulted in #f which means that we generally
                    ;; don't want the current tree
                    (if (or r (pair? filtered))
                      (cons (car tree) filtered)
                      #f)))])))))

;; return the base path of a tree
(define (tree-base tree)
  (prop-get (tree-path tree) 'base
            (lambda ()
              (error 'tree-base "no `base' property for ~e" tree))))

(provide print-tree)
(define (print-tree tree . mode)
  (let ([full?       (memq 'full mode)]
        ;; only-files is for files and empty dirs (used for untarring)
        [only-files? (memq 'only-files mode)])
    (let loop ([tree tree])
      (when tree
        (unless (and only-files? (pair? tree) (not (null? (cdr tree))))
          (when full? (printf "~a/" (tree-base tree)))
          (printf "~a\n" (tree-path tree)))
        (when (pair? tree) (for-each loop (cdr tree)))))))

;;; ===========================================================================
;;; Spec management

(define *spec-primitives* (make-parameter '()))
(define (register-spec-primitive! sym func)
  (*spec-primitives* (cons (cons sym func) (*spec-primitives*))))
(define (get-spec-primitive spec)
  (cond [(assq spec (*spec-primitives*)) => cdr] [else #f]))

;; Spec primitives

;; These are transformations that will convert a *simplified* expression to a
;; filter function.  Because of this, it is safe to have certain assumptions,
;; like `or' having at least two arguments etc, and it is also fine to not try
;; to do trivial optimizations (there is no need for them).  Also, the input to
;; these functions are functions (there is no point in a function that needs
;; raw arguments, since these can be implemented as macros).

(begin
  ;; `not' negates '+ <-> '- and #f <-> #t
  (register-spec-primitive! 
   '%not
   (lambda (pred)
     (lambda (t)
       (let ([r (pred t)])
         (case r [(+) '-] [(-) '+] [else (not r)])))))

  ;; `or' behaves like max for '- < #f < #t < '+
  (register-spec-primitive! 
   '%or
   (lambda preds
     (lambda (t)
       (let loop ([result '-] [preds preds])
         (if (or (eq? result '+) (null? preds))
             result
             (loop (let ([r ((car preds) t)])
                     (case r
                       [(+) '+] [(-) result]
                       [else (if (eq? result '-) r (or result r))]))
                   (cdr preds)))))))

  ;; `and' behaves like min for '- < #f < #t < '+
  (register-spec-primitive! 
   '%and
   (lambda preds
     (lambda (t)
       (let loop ([result '+] [preds preds])
         (if (or (eq? result '-) (null? preds))
             result
             (loop (let ([r ((car preds) t)])
                     (case r
                       [(-) '-] [(+) result]
                       [else (if (eq? result '+) r (and result r))]))
                   (cdr preds))))))))

;; Spec Macros

;; macros for primitive simplifications
(define (make-and/or-macro op)
  (let ([null-result (if (eq? op '%and) '%all '%none)]
        [best-result (if (eq? op '%and) '%none '%all)])
    ;; can return the same form -- expand-spec will not proceed in that case
    (lambda specs
      (let/ec return
        (let ([specs (mappend
                      (lambda (s)
                        (cond [(and (pair? s) (eq? (car s) op)) (cdr s)]
                              [(eq? s null-result) '()]
                              [(eq? s best-result) (return best-result)]
                              [else (list s)]))
                      specs)])
          (if (null? specs) null-result (cons op specs)))))))

(provide register-macros!)
(define (register-macros!)
  (register-spec! 'or (make-and/or-macro '%or))
  (register-spec! 'and (make-and/or-macro '%and))
  (register-spec! 
   'not
   (lambda specs
     ;; splice results back up, in case of (not) (which can result with a cond)
     (splice (map (lambda (spec)
                    (case spec
                      [(%all) '%none] [(%none) '%all] [else `(%not ,spec)]))
                  specs))))
  (register-spec! 'all '%all)
  (register-spec! 'none '%none)

  (register-spec! '+ 'or) ; `+' is `or'
  (register-spec! 
   '- ; set difference
   (lambda (spec . specs)
     `(and (or ,spec) (not (or ,@specs)))))
  
  (register-spec! 'error (lambda xs (apply error 'spec-error xs))))

;; Turns a string with globbing into a regexp string
(define (glob->regexp glob)
  (define len (string-length glob))
  (define range #f)
  (let loop ([res '()] [i 0])
    (define (next x) (loop (cons x res) (add1 i)))
    (if (= i len)
      (begin
        (when range
          (error 'glob->regexp "unterminated range in glob: ~e" glob))
        (let loop ([left res] [res '()])
          (if (null? left)
            (list->string res)
            (loop (cdr left)
                  ((if (char? (car left)) cons append) (car left) res)))))
      (let ([c (string-ref glob i)])
        (if range
          (begin (set! range
                       (case range
                         [(0) (case c ((#\^) 1) (else 2))]
                         [(1) 2]
                         [else (case c ((#\]) #f) (else 2))]))
                 (next c))
          (case c
            [(#\\) (set! i (add1 i))
                   (if (< i len)
                     (next (list #\\ (string-ref glob i)))
                     (error 'glob->regexp "glob ends in backslash: ~e" glob))]
            [(#\*) (next '(#\[ #\^ #\/ #\] #\*))]
            [(#\?) (next '(#\[ #\^ #\/ #\]))]
            [(#\[) (set! range 0) (next #\[)]
            [(#\. #\+ #\^ #\$ #\( #\) #\]) (next (list #\\ c))]
            ;; translate "{}" to "(?:)", "|" are left as-is "\|"
            [(#\{) (next '(#\( #\? #\:))]
            [(#\}) (next #\))]
            [else (next c)]))))))

(provide regexpify-spec)
;; Turns a string spec into a regexp to be matched against the `path' property.
(define (regexpify-spec str . force-rx?)
  (let* (;; initial "/" goes, so does a pointless initial "/**/"
         [rx (glob->regexp (regexp-replace #rx"^/(\\*\\*/)?" str ""))]
         ;; replace translated "/**/"s (they're never a prefix)
         [rx (regexp-replace* #rx"/\\[\\^/\\]\\*\\[\\^/\\]\\*/"
                              rx "/(?:.*/)?")]
         [rx (regexp (concat (if (regexp-match? #rx"^/" str) "^" "(?:^|/)")
                             rx (if (regexp-match? #rx"/$" str) "$" "/?$")))]
         [anchor (and (not (and (pair? force-rx?) (car force-rx?)))
                      (regexp-match? #rx"^/" str)
                      (regexp-replace #rx"^/([^][{}|*?]*)(.*)?$" str "\\1"))])
    ;; optimize anchored prefix strings
    (if anchor
      (let ([alen (string-length anchor)])
        (lambda (t)
          (let* ([p (tree-path t)] [plen (string-length p)])
            (let loop ([i 0])
              (cond
                [(or (= i alen) (= i plen)) (and (regexp-match? rx p) '+)]
                [(eq? (string-ref anchor i) (string-ref p i)) (loop (add1 i))]
                [else '-])))))
      rx)))

;; Turns a [composite] file spec into a filter function.  Wrap a filter spec
;; function in a cache.  This is not only for optimization, it is responsible
;; for making predicate composition behave like set operations because when a
;; directory's contents is skipped when the filter returns '+ or '-, the
;; contents is still marked.
(define (primitive-spec->filter spec)
  (define (add-query-cache! t r)
    (prop-set! (tree-path t) 'queries
               (cons (cons spec r) (prop-get (tree-path t) 'queries '()))))
  (define (make-cached filter)
    (lambda (t)
      (cond [(assoc spec (prop-get (tree-path t) 'queries '())) => cdr]
            [else (let ([r (filter t)])
                    (case r
                      [(+ -) (let loop ([t t])
                               (add-query-cache! t r)
                               (when (pair? t) (for-each loop (cdr t))))]
                      [else (add-query-cache! t r)])
                    r)])))
  (let loop ([spec spec])
    (cond
      [(procedure? spec) (make-cached spec)]
      [(regexp? spec) (loop (lambda (t)
                              (and (regexp-match? spec (tree-path t)) '+)))]
      [(string? spec) (loop (regexpify-spec spec))]
      [(eq? spec '%none) (lambda (t) '-)] ; no need to cache
      [(eq? spec '%all)  (lambda (t) '+)] ; no need to cache
      [(and (pair? spec) (get-spec-primitive (car spec)))
       ;; this is used with simplified expressions, so there is no point in
       ;; passing the raw arguments to the primitive, so just convert them
       ;; first.
       => (lambda (p)
            (make-cached (apply p (map primitive-spec->filter (cdr spec)))))]
      [else (error 'primitive-spec->filter "bad spec: ~.s" spec)])))

;; Toplevel entry point for converting a spec into a tree predicate function.
(define (spec->filter spec)
  (let ([specs (expand-spec spec)])
    (if (= 1 (length specs))
      (primitive-spec->filter (car specs))
      (error 'spec->filter
             "spec `~.s' did not expand to a single expression: ~.s"
             spec specs))))

;;; ===========================================================================
;;; Dependency checks

(define check-version
  (let ([version (version)] [1st? #t])
    (lambda (v file)
      (if 1st?
        (begin
          (unless (equal? version v)
            (fprintf (current-error-port)
                     "\nNOTE: bundling a different version from ~a\n\n"
                     "running process"))
          (set! version v)
          (set! 1st? #f))
        (unless (equal? version v)
          (error 'dependencies "bad version in ~s: ~s (expecting ~s)"
                 file v version))))))

(define (add-dependency-contents!)
  (define (racketpath path)
    (bytes->string/utf-8
     (apply bytes-append (cdr (mappend (lambda (p) (list #"/" p))
                                       (list* #"racket" #"collects" path))))))
  (define (read-depfile file)
    (let ([x (with-input-from-file file read)])
      (unless (and (pair? x) (check-version (car x) file))
        (error 'dependencies "bad contents in ~s: ~s" file x))
      (map (lambda (x)
             (match x
               [`(collects ,(and (? bytes?) s) ...) (racketpath s)]
               [`(ext collects ,(and (? bytes?) s) ...) (racketpath s)]
               [_ (error 'dependencies "bad dependency item in ~s: ~s"
                         file x)]))
           (cddr x))))
  (dprintf "Reading dependencies...")
  (let loop ([tree (tree-filter "*.dep" *racket-tree*)])
    (if (pair? tree)
      (for-each loop (cdr tree))
      (parameterize ([cd (prop-get tree 'base)])
        (prop-set! tree 'contents (read-depfile (prop-get tree 'real))))))
  (dprintf " done.\n")
  (set! add-dependency-contents! void))

(define bin-files-lists (delay null))

(provide set-bin-files-delayed-lists!)
(define (set-bin-files-delayed-lists! p)
  (set! bin-files-lists p))

(define (add-alts l)
  (if (null? l) 
      null
      (let ([v (regexp-replace #rx"[.]ss$" (car l) ".rkt")])
        (if (equal? v (car l))
            (cons (car l) (add-alts (cdr l)))
            (list* (car l) v (add-alts (cdr l)))))))

(define (check-dependencies spec distname)
  (add-dependency-contents!)
  (dprintf "Verifying dependencies for ~s..." distname)
  (let* ([all-files
          (sort* (add-alts (tree-flatten (tree-filter spec *racket-tree*))))]
         [deps0 (or (tree-filter `(and ,spec "*.dep") *racket-tree*)
                    (error 'check-dependencies
                           "got no .dep files for ~s" distname))]
         [deps0 (tree-flatten deps0 #t)])
    (let* ([missing (tree-filter 'must-be-empty *racket-tree*)]
           [missing (and (pair? missing) (tree-flatten missing #t))])
      (when (pair? missing)
        (dprintf "files missing from distribution:\n")
        (for ([m missing]) (dprintf "  ~a\n" m))
        (error 'dependencies "got files in must-be-empty (see above)")))
    (let loop ([files all-files]
               [deps (sort* (foldl (lambda (x y)
                                     (append (prop-get x 'contents) y))
                                   '()
                                   deps0))]
               [last-dep #f])
      (cond [(null? deps) #t]
            [(equal? (car deps) last-dep) (loop files (cdr deps) last-dep)]
            [(or (null? files) (string<? (car deps) (car files)))
             ;; Exception: foo.ss might be satisified by a platform dependent
             ;; compiled/foo_ss.zo (need to exist in all platform dependent
             ;; trees).  No need to optimize since this happens very
             ;; infrequently.
             (let ([dep (regexp-replace #rx"/([^/]+)\\.([^/]+)$" (car deps)
                                        "/compiled/\\1_\\2.zo")]
                   [alt-dep (and (regexp-match #rx"[.]rkt$" (car deps))
                                 (regexp-replace #rx"/([^/]+)\\.([^/]+)$" (car deps)
                                                 "/compiled/\\1_ss.zo"))])
               (if (andmap (lambda (files) (or (member dep files)
                                               (member alt-dep files)))
                           (force bin-files-lists))
                 (loop files (cdr deps) (car deps))
                 (error 'dependencies "unsatisfied dependency for ~s: ~s ~s"
                        distname (car deps)
                        (cons 'in: (filter (lambda (d)
                                             (member (car deps)
                                                     (prop-get d 'contents)))
                                           deps0)))))]
            [(string<? (car files) (car deps))
             (loop (cdr files) deps last-dep)]
            [else (loop (cdr files) (cdr deps) (car deps))])))
  (dprintf " done.\n"))

;;; ===========================================================================
;;; Start working

(define *platform-tree-lists* null)
(define *racket-tree* #f)

(provide get-racket-tree)
(define (get-racket-tree) *racket-tree*)

(provide verify!)
(define (verify!)
  (define features (filter string? (reverse (*environment*))))
  (tag (cons 'verifying (map string->symbol features))
    (check-dependencies 'distribution
                        (apply concat (cdr (mappend (lambda (x) (list "-" x))
                                                    features)))))
  '())

(provide checker-namespace-anchor)
(define-namespace-anchor checker-namespace-anchor)

(define racket/ #f)
(provide set-racket-tree!)
(define (set-racket-tree! racket/* racket-base/ racket/-name tree-lists)
  (set! racket/ racket/*)
  (set! *platform-tree-lists* tree-lists)
  (dprintf "Scanning main tree...")
  (set! *racket-tree*
        (let loop ([tree  (parameterize ([cd racket-base/])
                            (get-tree racket/-name "racket"))]
                   [trees (apply append *platform-tree-lists*)])
          (if (null? trees)
              (tree-filter '(not junk) tree)
              (loop (tree-subtract tree (car trees)) (cdr trees)))))
  (dprintf " done.\n"))