<commit_before>#lang scheme/base

(require scheme/match 
         scheme/contract 
         planet/cachepath 
         syntax/modread
         "dirs.rkt"
         "path-relativize.rkt")

;; in addition to infodomain/compiled/cache.rktd, getinfo will look in this 
;; file to find mappings. PLaneT uses this to put info about installed
;; planet packages.
(define user-infotable (get-planet-cache-path))

;; get-info : (listof path-or-string) -> info/#f
(define (get-info coll-path #:namespace [ns #f])
  (get-info/full (apply collection-path
                        (map (lambda (x) (if (path? x) (path->string x) x))
                             coll-path))
                 #:namespace ns))

;; HACK:
;; This require is not used.  It just requires the file, since
;; otherwise the reader guard below will be invoked on it too, and
;; that will make it throw up.  One possible solution for this would
;; be for the security guard to be provided with the file in question.
;; Another would be to force all info files to use `#lang' which means
;; that we'll be able to query their module-language via the
;; `get-info' protocol.
(require (prefix-in !!!HACK!!! setup/infotab/lang/reader)
         (prefix-in !!!HACK!!!2 (submod info reader)))

;; get-info/full : path -> info/#f
(define (get-info/full dir #:namespace [ns #f])
  (or (get-info/full/ext dir "rkt" ns)
      (get-info/full/ext dir "ss" ns)))

(define (get-info/full/ext dir ext ns)
  (define file (build-path dir (format "info.~a" ext)))
  (define (err fmt . args)
    (apply error 'get-info (string-append "info file " fmt " in ~a")
           (append args (list file))))
  (define (contents)
    (parameterize ([current-reader-guard
                    (lambda (x)
                      (if (or (eq? x 'setup/infotab/lang/reader)
                              (eq? x 'info/lang/reader)
                              (equal? x '(submod setup/infotab reader))
                              (equal? x '(submod info reader)))
                        x
                        (err "has illegal #lang or #reader")))])
      (with-input-from-file file
        (lambda ()
          (begin0 
           (with-module-reading-parameterization read)
           (unless (eof-object? (read))
             (err "has multiple expressions")))))))
  (and (file-exists? file)
       (match (contents)
         [(list 'module 'info
                (or '(lib "infotab.rkt" "setup")
                    '(lib "infotab.ss" "setup")
                    '(lib "setup/infotab.rkt")
                    '(lib "setup/infotab.ss")
                    '(lib "main.rkt" "info")
                    'setup/infotab
                    'info)
                expr ...)
          ;; No need to set a reader-guard, since we checked it
          ;; above (a guard will see other uses of #lang for stuff
          ;; that is required).
          ;; We are, however, trusting that the bytecode form of the
          ;; file (if any) matches the source.
          (parameterize ([current-namespace (or ns (info-namespace))])
            (dynamic-require file '#%info-lookup))]
         [else (err "does not contain a module of the right shape")])))

(define info-namespace
  ;; To avoid loading modules into the current namespace
  ;; when get-info is called, load info modules in a separate
  ;; namespace.
  (let ([ns-box (make-weak-box #f)])
    (lambda ()
      (or (weak-box-value ns-box)
          (let ([ns (make-base-empty-namespace)])
            (set! ns-box (make-weak-box ns))
            ns)))))

;; directory-record = (make-directory-record nat nat key path (listof symbol))
;; eg: (make-directory-record 1 0 '(lib "mzlib") #"mzlib" '(name))
(define-struct directory-record (maj min spec path syms))

(define-struct table (insert   ; directory-record (listof directory-record)
                               ;  -> (listof directory-record)
                      ht       ; hashtable[symbol -o> directory-record]
                      paths    ; (listof (cons path boolean))
                      )
  #:mutable)

(define preferred-table #f)
(define all-available-table #f)
(define no-planet-table #f)
(define no-user-table #f)

;; reset-relevant-directories-state! : -> void
(define (reset-relevant-directories-state!)
  (set! preferred-table
        (make-table
         (lambda (root-dir i l)
           (if (or root-dir (null? l))
             (cons i l)
             (match-let ([(struct directory-record (my-maj my-min _ _ _)) i]
                         [(struct directory-record (their-maj their-min _ _ _))
                          (car l)])
              (if (or (> my-maj their-maj)
                      (and (= my-maj their-maj) (>= my-min their-min)))
                (list i)
                l))))
         #f #f))
  (define (always root-dir i l) (cons i l))
  (set! all-available-table (make-table always #f #f))
  (set! no-planet-table (make-table always #f #f))
  (set! no-user-table (make-table always #f #f)))

(reset-relevant-directories-state!)

;; populate-table : table -> void
(define (populate-table! t)
  ;; Use the colls ht because a collection might be in multiple
  ;; collection paths, and we only want one
  (define-values (path->main-lib-relative
                  main-lib-relative->path)
    (make-relativize find-lib-dir
                     'lib
                     'path->main-lib-relative
                     'main-lib-relative->path))
  (let ([colls (make-hash)])
    (for ([f+root-dir (reverse (table-paths t))])
      (let ([f (car f+root-dir)]
            [root-dir (cdr f+root-dir)])
        (define-values (path->info-relative
                        info-relative->path)
          (make-relativize (lambda () root-dir)
                           'info
                           'path->info-relative
                           'info-relative->path))
        (when (file-exists? f)
          (for ([i (let ([l (with-input-from-file f read)])
                     (cond [(list? l) l]
                           [(eof-object? l) '()] ;; allow completely empty files
                           [else (error 'find-relevant-directories
                                        "bad info-domain cache file: ~a" f)]))])
            (match i
              [(list (and pathbytes (or (? bytes?) (list (or 'info 'lib) (? bytes?) ...)))
                     (list (? symbol? fields) ...)
                     key ;; anything is okay here
                     (? integer? maj)
                     (? integer? min))
               (let ([old-items (hash-ref colls key null)]
                     [new-item
                      (make-directory-record
                       maj min key
                       (if (bytes? pathbytes)
                           (let ([p (bytes->path pathbytes)])
                             (if (and (relative-path? p) root-dir)
                                 ;; `raco setup' doesn't generate relative paths anyway,
                                 ;; but it's ok to support them:
                                 (build-path root-dir p)
                                 p))
                           (if (eq? (car pathbytes) 'info)
                               (info-relative->path pathbytes)
                               (main-lib-relative->path pathbytes)))
                       fields)])
                 (hash-set! colls key
                            ((table-insert t) root-dir new-item old-items)))]
              [_ (error 'find-relevant-directories
                        "bad info-domain cache entry: ~e in: ~a" i f)])))))
    ;; For each coll, invert the mapping, adding the col name to the list
    ;; for each sym:
    (for* ([(key vals) colls]
           [val vals])
      (match val
        [(struct directory-record (maj min spec path syms))
         (for ([sym syms])
           (hash-set! (table-ht t) sym
                      (cons val (hash-ref (table-ht t) sym null))))]
        [_ (error 'get-info<commit_msg>change `find-relative-directories' to normalize completed paths<commit_after>#lang scheme/base

(require scheme/match 
         scheme/contract 
         planet/cachepath 
         syntax/modread
         "dirs.rkt"
         "path-relativize.rkt")

;; in addition to infodomain/compiled/cache.rktd, getinfo will look in this 
;; file to find mappings. PLaneT uses this to put info about installed
;; planet packages.
(define user-infotable (get-planet-cache-path))

;; get-info : (listof path-or-string) -> info/#f
(define (get-info coll-path #:namespace [ns #f])
  (get-info/full (apply collection-path
                        (map (lambda (x) (if (path? x) (path->string x) x))
                             coll-path))
                 #:namespace ns))

;; HACK:
;; This require is not used.  It just requires the file, since
;; otherwise the reader guard below will be invoked on it too, and
;; that will make it throw up.  One possible solution for this would
;; be for the security guard to be provided with the file in question.
;; Another would be to force all info files to use `#lang' which means
;; that we'll be able to query their module-language via the
;; `get-info' protocol.
(require (prefix-in !!!HACK!!! setup/infotab/lang/reader)
         (prefix-in !!!HACK!!!2 (submod info reader)))

;; get-info/full : path -> info/#f
(define (get-info/full dir #:namespace [ns #f])
  (or (get-info/full/ext dir "rkt" ns)
      (get-info/full/ext dir "ss" ns)))

(define (get-info/full/ext dir ext ns)
  (define file (build-path dir (format "info.~a" ext)))
  (define (err fmt . args)
    (apply error 'get-info (string-append "info file " fmt " in ~a")
           (append args (list file))))
  (define (contents)
    (parameterize ([current-reader-guard
                    (lambda (x)
                      (if (or (eq? x 'setup/infotab/lang/reader)
                              (eq? x 'info/lang/reader)
                              (equal? x '(submod setup/infotab reader))
                              (equal? x '(submod info reader)))
                        x
                        (err "has illegal #lang or #reader")))])
      (with-input-from-file file
        (lambda ()
          (begin0 
           (with-module-reading-parameterization read)
           (unless (eof-object? (read))
             (err "has multiple expressions")))))))
  (and (file-exists? file)
       (match (contents)
         [(list 'module 'info
                (or '(lib "infotab.rkt" "setup")
                    '(lib "infotab.ss" "setup")
                    '(lib "setup/infotab.rkt")
                    '(lib "setup/infotab.ss")
                    '(lib "main.rkt" "info")
                    'setup/infotab
                    'info)
                expr ...)
          ;; No need to set a reader-guard, since we checked it
          ;; above (a guard will see other uses of #lang for stuff
          ;; that is required).
          ;; We are, however, trusting that the bytecode form of the
          ;; file (if any) matches the source.
          (parameterize ([current-namespace (or ns (info-namespace))])
            (dynamic-require file '#%info-lookup))]
         [else (err "does not contain a module of the right shape")])))

(define info-namespace
  ;; To avoid loading modules into the current namespace
  ;; when get-info is called, load info modules in a separate
  ;; namespace.
  (let ([ns-box (make-weak-box #f)])
    (lambda ()
      (or (weak-box-value ns-box)
          (let ([ns (make-base-empty-namespace)])
            (set! ns-box (make-weak-box ns))
            ns)))))

;; directory-record = (make-directory-record nat nat key path (listof symbol))
;; eg: (make-directory-record 1 0 '(lib "mzlib") #"mzlib" '(name))
(define-struct directory-record (maj min spec path syms))

(define-struct table (insert   ; directory-record (listof directory-record)
                               ;  -> (listof directory-record)
                      ht       ; hashtable[symbol -o> directory-record]
                      paths    ; (listof (cons path boolean))
                      )
  #:mutable)

(define preferred-table #f)
(define all-available-table #f)
(define no-planet-table #f)
(define no-user-table #f)

;; reset-relevant-directories-state! : -> void
(define (reset-relevant-directories-state!)
  (set! preferred-table
        (make-table
         (lambda (root-dir i l)
           (if (or root-dir (null? l))
             (cons i l)
             (match-let ([(struct directory-record (my-maj my-min _ _ _)) i]
                         [(struct directory-record (their-maj their-min _ _ _))
                          (car l)])
              (if (or (> my-maj their-maj)
                      (and (= my-maj their-maj) (>= my-min their-min)))
                (list i)
                l))))
         #f #f))
  (define (always root-dir i l) (cons i l))
  (set! all-available-table (make-table always #f #f))
  (set! no-planet-table (make-table always #f #f))
  (set! no-user-table (make-table always #f #f)))

(reset-relevant-directories-state!)

;; populate-table : table -> void
(define (populate-table! t)
  ;; Use the colls ht because a collection might be in multiple
  ;; collection paths, and we only want one
  (define-values (path->main-lib-relative
                  main-lib-relative->path)
    (make-relativize find-lib-dir
                     'lib
                     'path->main-lib-relative
                     'main-lib-relative->path))
  (let ([colls (make-hash)])
    (for ([f+root-dir (reverse (table-paths t))])
      (let ([f (car f+root-dir)]
            [root-dir (cdr f+root-dir)])
        (define-values (path->info-relative
                        info-relative->path)
          (make-relativize (lambda () root-dir)
                           'info
                           'path->info-relative
                           'info-relative->path))
        (when (file-exists? f)
          (for ([i (let ([l (with-input-from-file f read)])
                     (cond [(list? l) l]
                           [(eof-object? l) '()] ;; allow completely empty files
                           [else (error 'find-relevant-directories
                                        "bad info-domain cache file: ~a" f)]))])
            (match i
              [(list (and pathbytes (or (? bytes?) (list (or 'info 'lib) (? bytes?) ...)))
                     (list (? symbol? fields) ...)
                     key ;; anything is okay here
                     (? integer? maj)
                     (? integer? min))
               (let ([old-items (hash-ref colls key null)]
                     [new-item
                      (make-directory-record
                       maj min key
                       (if (bytes? pathbytes)
                           (let ([p (bytes->path pathbytes)])
                             (if (and (relative-path? p) root-dir)
                                 ;; `raco setup' doesn't generate relative paths anyway,
                                 ;; but it's ok to support them:
                                 (simplify-path (build-path root-dir p))
                                 p))
                           (if (eq? (car pathbytes) 'info)
                               (info-relative->path pathbytes)
                               (main-lib-relative->path pathbytes)))
                       fields)])
                 (hash-set! colls key
                            ((table-insert t) root-dir new-item old-items)))]
              [_ (error 'find-relevant-directories
                        "bad info-domain cache entry: ~e in: ~a" i f)])))))
    ;; For each coll, invert the mapping, adding the col name to the list
    ;; for each sym:
    (for* ([(key vals) colls]
           [val vals])
      (match val
        [(struct directory-record (maj min spec path syms))
         (for ([sym syms])
           (hash-set! (table-ht t) sym
                      (cons val (hash-ref (table-ht t) sym null))))]
        [_ (error 'get-info
{'fraction_non_alphanumeric': 0.1300125313283208, 'fraction_numerical': 0.0005012531328320802, 'mean_word_length': 1.5677284427284428, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 43, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 20, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1351075', 'n_tokens_mistral': 4678, 'n_tokens_neox': 4463, 'n_words': 1415}