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