1#lang racket/base
2(require racket/gui/base
3         racket/class
4         racket/path
5         racket/file
6         racket/set
7         setup/collects
8         setup/dirs
9         setup/getinfo
10         syntax/modread
11         syntax/modcode
12         syntax/modresolve
13         string-constants
14         framework
15         compiler/compile-file
16         compiler/module-suffix
17
18         "create-htdp-executable.rkt")
19
20(provide get-teachpack-from-user)
21
22(define user-installed-teachpacks-collection "installed-teachpacks")
23(define teachpack-installation-dir
24  (build-path (find-user-collects-dir) user-installed-teachpacks-collection))
25
26(define (get-teachpack-from-user parent tp-dirs labels tp-syms [already-installed-teachpacks '()])
27  (define tpss (map tp-dir->tps tp-syms))
28
29  (define label+mpss
30    (let ([all-filenames
31           (apply
32            append
33            (map (λ (tps)
34                   (map (λ (tp) (list-ref tp 0)) tps))
35                 tpss))])
36      (for/list ([tps (in-list tpss)])
37        (for/list ([tp (in-list tps)])
38          (define filename (list-ref tp 0))
39          (define mp (list-ref tp 1))
40          (list (path->string
41                 (or (shrink-path-wrt filename all-filenames)
42                     (let-values ([(base name dir?) (split-path filename)])
43                       name)))
44                mp)))))
45
46  (define already-installed-labels
47    (for/list ([already-installed-teachpack (in-list already-installed-teachpacks)])
48      (let/ec k
49        (for ([label+mps (in-list label+mpss)])
50          (for ([label+mp (in-list label+mps)])
51            (when (equal? (list-ref label+mp 1) already-installed-teachpack)
52              (k (list-ref label+mp 0)))))
53        ;; shouldn't happen, but this will be a slightly graceful fallback, I hope
54        (format "~s" already-installed-teachpack))))
55
56  (define pre-installed-tpss
57    (for/list ([label+mps (in-list label+mpss)])
58      (sort label+mps string<? #:key car)))
59
60  (define dlg (new (frame:focus-table-mixin dialog%)
61                   [parent parent]
62                   [label (string-constant drscheme)]))
63  (define hp (new horizontal-panel% [parent dlg]))
64  (define answer #f)
65  (define compiling? #f)
66
67  (define pre-installed-gbs (map (λ (tps label)
68                                   (new group-box-panel%
69                                        [label label]
70                                        [parent hp]))
71                                 tpss labels))
72  (define user-installed-gb (new group-box-panel%
73                                 [label (string-constant teachpack-user-installed)]
74                                 [parent hp]))
75
76  (define pre-installed-lbs
77    (map (λ (pre-installed-gb pre-installed-tps)
78           (define lb
79             (new list-box%
80                  [label #f]
81                  [choices (map (λ (x) (gui-utils:trim-string (list-ref x 0) 200))
82                                pre-installed-tps)]
83                  [stretchable-height #t]
84                  [min-height 300]
85                  [min-width 200]
86                  [callback
87                   (λ (this evt)
88                     (case (send evt get-event-type)
89                       [(list-box-dclick)
90                        (update-button-and-conflict)
91                        (selected this)]
92                       [else
93                        (for ([x (in-list (cons user-installed-lb
94                                                pre-installed-lbs))]
95                              #:unless (eq? x this))
96                          (clear-selection x))
97                        (update-button-and-conflict)]))]
98                  [parent pre-installed-gb]))
99           (for ([i (in-naturals)]
100                 [tp (in-list pre-installed-tps)])
101             (send lb set-data i (list-ref tp 1)))
102           lb)
103         pre-installed-gbs
104         pre-installed-tpss))
105
106  (define user-installed-lb
107    (new list-box%
108         [label #f]
109         [choices '()]
110         [stretchable-height #t]
111         [min-width 200]
112         [callback
113          (λ (x evt)
114            (case (send evt get-event-type)
115              [(list-box-dclick)
116               (update-button-and-conflict)
117               (selected user-installed-lb)]
118              [else
119               (for ([pre-installed-lb (in-list pre-installed-lbs)])
120                 (clear-selection pre-installed-lb))
121               (update-button-and-conflict)]))]
122         [parent user-installed-gb]))
123
124  (define (selected lb)
125    (when (send lb get-selection)
126      (when (and viable-action?
127                 (not conflict-tp))
128        (unless compiling?
129          (set! answer (figure-out-answer))
130          (send dlg show #f)))))
131
132  (define (clear-selection lb)
133    (for-each
134     (λ (x) (send lb select x #f))
135     (send lb get-selections)))
136
137  (define add-button (new button%
138                          [parent user-installed-gb]
139                          [label (string-constant add-teachpack-to-list...)]
140                          [callback (λ (x y) (install-teachpack))]))
141
142  (define (install-teachpack)
143    (let ([file (get-file (string-constant select-a-teachpack) dlg)])
144      (when file
145        (let-values ([(base name dir) (split-path file)])
146          (let ([dest-file (build-path teachpack-installation-dir name)])
147            (when (or (not (file-exists? dest-file))
148                      (equal? 1
149                              (message-box/custom
150                               (string-constant drscheme)
151                               (format
152                                (string-constant teachpack-already-installed)
153                                (path->string name))
154                               (string-constant overwrite)
155                               (string-constant cancel)
156                               #f
157                               dlg
158                               '(default=2 caution))))
159              (make-directory* teachpack-installation-dir)
160              (when (file-exists? dest-file)
161                (delete-file dest-file))
162              (copy-file file dest-file)
163
164              ;; compiling the teachpack should be the last thing in this GUI callback
165              (compile-new-teachpack dest-file)))))))
166
167  (define (compile-new-teachpack filename)
168    (let-values ([(_1 short-name _2) (split-path filename)])
169      (cond
170        [(cannot-compile? filename)
171         (post-compilation-gui-cleanup short-name)]
172        [else
173         (send compiling-message set-label
174               (format (string-constant compiling-teachpack)
175                       (path->string short-name)))
176         (starting-compilation)
177         (let ([nc (make-custodian)]
178               [exn #f])
179           (let ([t
180                  (parameterize ([current-custodian nc])
181                    (thread (λ ()
182                              (with-handlers ((exn? (λ (x) (set! exn x))))
183                                (parameterize ([current-namespace (make-base-namespace)])
184                                  (with-module-reading-parameterization
185                                   (lambda ()
186                                     (compile-file filename))))))))])
187             (thread
188              (λ ()
189                (thread-wait t)
190                (queue-callback
191                 (λ ()
192                   (cond
193                     [exn
194                      (message-box (string-constant drscheme)
195                                   (exn-message exn))
196                      (delete-file filename)
197                      (update-user-installed-lb)]
198                     [else
199                      (post-compilation-gui-cleanup short-name)])
200                   (done-compilation)
201                   (send compiling-message set-label "")))))))])))
202
203  (define (post-compilation-gui-cleanup short-name)
204    (update-user-installed-lb)
205    (for ([pre-installed-lb (in-list pre-installed-lbs)])
206      (clear-selection pre-installed-lb))
207    (send user-installed-lb set-string-selection (path->string short-name)))
208
209  (define (starting-compilation)
210    (set! compiling? #t)
211    (update-button-and-conflict)
212    (send cancel-button enable #f))
213
214  (define (done-compilation)
215    (set! compiling? #f)
216    (update-button-and-conflict)
217    (send cancel-button enable #t))
218
219  (define (update-user-installed-lb)
220    (let ([files
221           (if (directory-exists? teachpack-installation-dir)
222               (map path->string
223                    (filter
224                     (λ (x) (file-exists? (build-path teachpack-installation-dir x)))
225                     (directory-list teachpack-installation-dir)))
226               '())])
227      (send user-installed-lb set (sort files string<=?))))
228
229  (define viable-action? #f)
230  (define conflict-tp #f)
231
232  (define (update-button-and-conflict)
233    ;; figuring out if there is a conflict.
234    (define-values (tp-req tp-label) (figure-out-answer/f))
235    (set! conflict-tp #f)
236    (define conflict-name #f)
237    (define conflict-label #f)
238    (when tp-req
239      (let/ec k
240        (for ([existing-tp (in-list already-installed-teachpacks)]
241              [existing-tp-label (in-list already-installed-labels)])
242          (unless (equal? existing-tp tp-req)
243            (define conflict (teachpacks-conflict existing-tp tp-req))
244            (when conflict
245              (set! conflict-tp existing-tp)
246              (set! conflict-name conflict)
247              (set! conflict-label existing-tp-label)
248              (k (void)))))))
249    (cond
250      [conflict-tp
251       (send conflict-txt lock #f)
252       (send conflict-txt begin-edit-sequence)
253       (send conflict-txt erase)
254       ;; answer must be non #f here
255       ;; also conflict-message must be non #f, too
256       (send conflict-txt insert
257             (format (string-constant teachpack-conflict)
258                     conflict-label
259                     tp-label
260                     conflict-name))
261       (send conflict-txt change-style red-sd 0 (send conflict-txt last-position))
262       (send conflict-txt end-edit-sequence)
263       (send conflict-txt lock #t)]
264      [else
265       (when conflict-txt
266         (send conflict-txt lock #f)
267         (send conflict-txt begin-edit-sequence)
268         (send conflict-txt erase)
269         (send conflict-txt end-edit-sequence)
270         (send conflict-txt lock #t))])
271
272    (set! viable-action?
273          (or (pair? (send user-installed-lb get-selections))
274              (ormap (λ (pre-installed-lb)
275                       (pair? (send pre-installed-lb get-selections)))
276                     pre-installed-lbs)))
277
278    ;; updating buttons
279    (send ok-button enable
280          (and viable-action?
281               (not compiling?)
282               (not conflict-tp)))
283
284    (send replace-button show (and viable-action?
285                                   (not compiling?)
286                                   conflict-tp))
287    (send replace-button set-label (if (and viable-action? conflict-tp)
288                                       (format (string-constant remove-and-add-teachpack)
289                                               conflict-label tp-label)
290                                       "")))
291
292
293  (define red-sd (new style-delta%))
294  (send red-sd set-delta-foreground (make-object color% 200 0 0))
295
296  (define conflict-txt
297    (and (not (null? already-installed-teachpacks))
298         (let ([t (new text:hide-caret/selection%)])
299           (send t lock #t)
300           (send t auto-wrap #t)
301           (send t set-autowrap-bitmap #f)
302           t)))
303  (define conflict-ed
304    (and conflict-txt
305         (new editor-canvas%
306              [parent dlg]
307              [editor conflict-txt]
308              [style '(auto-vscroll no-hscroll no-border transparent)]
309              [line-count 2])))
310
311  (define button-panel (new horizontal-panel%
312                            [parent dlg]
313                            [alignment '(right center)]
314                            [stretchable-height #f]))
315  (define compiling-message (new message%
316                                 [parent button-panel]
317                                 [label ""]
318                                 [auto-resize #t]))
319  (define replace-button
320    (new button%
321         [parent button-panel]
322         [label ""]
323         [stretchable-width #t]
324         [callback (λ (x y)
325                     (set! answer (figure-out-answer))
326                     (send dlg show #f))]))
327  (send replace-button show #f)
328  (define-values (ok-button cancel-button)
329    (gui-utils:ok/cancel-buttons button-panel
330                                 (λ (b e)
331                                   (set! answer (figure-out-answer))
332                                   (send dlg show #f))
333                                 (λ (b e)
334                                   (send dlg show #f))
335                                 (string-constant ok) (string-constant cancel)))
336
337  (define (figure-out-answer)
338    (define-values (tp-req tp-label) (figure-out-answer/f))
339    (or tp-req
340        (error 'figure-out-answer "no selection!")))
341
342  (define (figure-out-answer/f)
343    (let/ec done
344      (for ([pre-installed-lb (in-list pre-installed-lbs)]
345            [tp-dir (in-list tp-dirs)])
346        (define sel (send pre-installed-lb get-selection))
347        (when sel
348          (done (send pre-installed-lb get-data sel)
349                (send pre-installed-lb get-string sel))))
350      (when (send user-installed-lb get-selection)
351        (define str (send user-installed-lb get-string
352                          (send user-installed-lb get-selection)))
353        (done `(lib ,str ,user-installed-teachpacks-collection)
354              str))
355      (done #f #f)))
356
357
358  (send ok-button enable #f)
359  (update-user-installed-lb)
360
361  (send dlg show #t)
362  (values conflict-tp answer))
363
364
365(define (tp-dir->tps tp-sym)
366  (define rx:module-suffix (get-module-suffix-regexp))
367  (filter
368   values
369   (for*/list ([dir (in-list (find-relevant-directories (list tp-sym)))]
370               #:when (let ([inf (get-info/full dir)])
371                        (and inf (inf tp-sym (λ () #f))))
372               [file-or-dir (in-list
373                             (let ([files ((get-info/full dir) tp-sym)])
374                               (cond
375                                 [(eq? files 'all)
376                                  (for/list ([x (in-list (directory-list dir))]
377                                             #:when
378                                             (regexp-match rx:module-suffix
379                                                           (path->string x))
380                                             #:unless
381                                             (member (path->string x) '("info.rkt" "info.ss")))
382                                    x)]
383                                 [(list? files) files]
384                                 [else '()])))])
385     (let/ec k
386       (unless (path? file-or-dir) (k #f))
387       (define candidate (build-path dir file-or-dir))
388       (unless (file-exists? candidate) (k #f))
389       (define mp (path->module-path candidate))
390       (when (path-string? mp) (k #f))
391       (list candidate mp)))))
392
393
394(define (teachpacks-conflict tp1 tp2)
395  (define tp1-exports (get-exports tp1))
396  (define tp2-exports (get-exports tp2))
397  (define conflicts
398    (sort (set->list (set-intersect tp1-exports tp2-exports))
399          symbol<?))
400  (if (null? conflicts)
401      #f
402      (car conflicts)))
403
404(define (get-exports tp)
405  (with-handlers ([exn:fail? (λ (x) (list->set '()))])
406    (define-values (vars stx) (module-compiled-exports (get-module-code (resolve-module-path tp #f))))
407    (set-union (phase0-exports vars) (phase0-exports stx))))
408
409(define (phase0-exports which)
410  (define a (assoc 0 which))
411  (list->set (map car (if a (cdr a) '()))))
412
413(module+ test
414  (require rackunit)
415  (check-equal?
416   (teachpacks-conflict '(lib "teachpack/htdp/guess.rkt")
417                        '(lib "teachpack/htdp/lkup-gui.rkt"))
418   #f)
419
420  (check-equal?
421   (and (teachpacks-conflict '(lib "teachpack/2htdp/image.rkt")
422                             '(lib "teachpack/htdp/image.rkt"))
423        #t)
424   #t))
425
426
427(module+ main
428  (get-teachpack-from-user
429   #f
430   (list '(lib "teachpack/htdp/image.rkt"))))
431