1#lang racket/base
2(require racket/list
3         racket/match
4         racket/format
5         racket/function
6         racket/path
7         "../path.rkt"
8         "dirs.rkt"
9         "pkg-db.rkt"
10         "print.rkt")
11
12(provide pkg-show)
13
14(define (pkg-show indent only-pkgs
15                  #:prefix-line [prefix-line #f]
16                  #:directory? [dir? #f]
17                  #:auto? [show-auto? #f]
18                  #:full-checksum? [full-checksum #f]
19                  #:long? [long? #t]
20                  #:rx? [rx? #f]
21                  #:name [name 'pkg-show])
22  (when rx?
23    (when (not only-pkgs)
24      (pkg-error "regular-expression mode requires at least one pattern"))
25    (for ([str (in-list only-pkgs)])
26      (regexp str (lambda (s)
27                    (pkg-error (~a "bad regular-expression pattern;\n"
28                                   " " s "\n"
29                                   "  in: " str))))))
30  (define db (read-pkg-db))
31  (define pkgs (sort (hash-keys db) string-ci<=?))
32  (define auto-shown? #f)
33  (define to-show
34    (for/list ([pkg (in-list pkgs)]
35               #:unless (and only-pkgs
36                             (not (memf (λ (v) (if rx? (regexp-match? v pkg) (equal? v pkg)))
37                                        only-pkgs)))
38               #:when (or show-auto? only-pkgs
39                          (not (pkg-info-auto? (hash-ref db pkg)))))
40      (match-define (pkg-info orig-pkg checksum auto?) (hash-ref db pkg))
41      (when auto? (set! auto-shown? #t))
42      (append
43       (list (format "~a~a~a"
44                     indent
45                     pkg
46                     (if auto? "*" ""))
47             (if (or checksum long?)
48                 (format "~a" checksum)
49                 "")
50             (let ([src (case (car orig-pkg)
51                          [(link static-link clone)
52                           (list* (car orig-pkg)
53                                  (path->string
54                                   (simple-form-path
55                                    (path->complete-path (cadr orig-pkg)
56                                                         (pkg-installed-dir))))
57                                  (cddr orig-pkg))]
58                          [else orig-pkg])])
59               (if long?
60                   (~s src)
61                   (apply ~a #:separator " " src))))
62       (if dir?
63           (let ([p (path->string
64                     (simple-form-path
65                      (pkg-directory* pkg #:db db)))])
66             (list (if long?
67                       (~s p)
68                       (~a p))))
69           empty))))
70  (when prefix-line
71    (printf "~a\n" prefix-line))
72    (if (null? to-show)
73        (printf " [none]\n")
74        (let* ([col-headers (list* (format "~aPackage~a"
75                                          indent
76                                          (if auto-shown? "[*=auto]" ""))
77                                   "Checksum"
78                                   "Source"
79                                   (if dir? '("Directory") '()))]
80               [checksum-index (for/first ([hdr (in-list col-headers)]
81                                           [i   (in-naturals)]
82                                           #:when (string=? hdr "Checksum")) i)]
83               [exact-columns (if (and full-checksum checksum-index)
84                                (list checksum-index)
85                                '())])
86          (table-display
87           #:exact-columns exact-columns
88           long?
89           (list* 'right 'right 'middle
90                  (if dir? '(left) '()))
91           (list* col-headers to-show))))
92    (unless (or only-pkgs show-auto?)
93      (define n (for/sum ([pkg (in-list pkgs)]
94                          #:when (pkg-info-auto? (hash-ref db pkg)))
95                  1))
96      (unless (zero? n)
97        (printf "~a[~a auto-installed package~a not shown]\n"
98                indent
99                n
100                (if (= n 1) "" "s")))))
101
102(define (table-display long? dots-poses l #:exact-columns [exact-columns '()])
103  (define how-many-cols (length (first l)))
104  (define full-max-widths
105    (for/list ([col (in-range how-many-cols)])
106      (apply max (map (compose string-length (curryr list-ref col)) l))))
107  (define sep (if long? 4 2))
108  (define COLUMNS (or (cond
109                       [long? 80]
110                       [(getenv "COLUMNS")
111                        => (lambda (s)
112                             (define v (string->number s))
113                             (and (exact-positive-integer? v) v))]
114                       [else #f])
115                      80))
116  (define max-widths
117    (cond
118      [(or long?
119           ((apply + full-max-widths) . < . (- COLUMNS (* sep (sub1 how-many-cols)))))
120       full-max-widths]
121      [else
122       (define avail (- COLUMNS
123                        (car full-max-widths)
124                        (* sep (sub1 how-many-cols))))
125       (cons (car full-max-widths)
126             (for/list ([(c i) (in-indexed (in-list (cdr full-max-widths)))])
127               (if (memq (+ i 1) exact-columns)
128                 c
129                 (let ([frac
130                        ;; Give last column twice the space:
131                        (if (= i (sub1 how-many-cols))
132                            (/ 2 how-many-cols)
133                            (/ 1 how-many-cols))])
134                   (max 3
135                        (floor (* avail frac)))))))]))
136  (for ([row (in-list l)])
137    (for ([col (in-list row)]
138          [i (in-naturals 1)]
139          [width (in-list max-widths)]
140          [dots-pos (in-list dots-poses)])
141      (define col-width (string-length col))
142      (printf "~a~a"
143              (if (or (col-width . <= . width)
144                      (memq (- i 1) exact-columns))
145                  col
146                  (case dots-pos
147                   [(right)
148                    ;; Checksum: show prefix:
149                    (~a (substring col 0 (- width 3))
150                        "...")]
151                   [(middle)
152                    ;; Source
153                    ;; To start "..." at a space:
154                    (define m (regexp-match-positions #rx" " col))
155                    (define left
156                      (cond
157                       [(and m
158                             ((caar m) . < . (- width 3)))
159                        ;; Dots at space:
160                        (caar m)]
161                       [else
162                        ;; Put dots in middle:
163                        (quotient (- width 3) 2)]))
164                    (~a (substring col 0 left)
165                        "..."
166                        (substring col (+ (- col-width width)
167                                          3 left)))]
168                   [(left)
169                    ;; Put dots at start:
170                    (~a "..."
171                        (substring col (min col-width (- col-width width -3))))]))
172              (if (= i how-many-cols)
173                ""
174                (let ([len (min (string-length col)
175                                width)])
176                  (make-string (+ (- width len) sep) #\space)))))
177    (printf "\n")))
178