1  #lang racket/base
 2  (require racket/gui/base
 3           racket/class
 4           racket/file
 5           setup/main-collects)
 6  (require (for-syntax racket/base
 7                       syntax/path-spec
 8                       compiler/cm-accomplice
 9                       setup/main-collects))
10  
11  (provide include-bitmap
12           include-bitmap/relative-to)
13  
14  (define-syntax (-include-bitmap stx)
15    (syntax-case stx ()
16      [(_ orig-stx source path-spec type)
17       (let* ([c-file (resolve-path-spec #'path-spec #'source #'orig-stx)]
18              [content
19               (with-handlers ([exn:fail?
20                                (lambda (exn)
21                                  (error 'include-bitmap
22                                         "could not load ~e: ~a"
23                                         c-file
24                                         (if (exn? exn)
25                                             (exn-message exn)
26                                             (format "~e" exn))))])
27                 (with-input-from-file c-file
28                   (lambda ()
29                     (read-bytes (file-size c-file)))))])
30         (register-external-file c-file)
31         (with-syntax ([content content]
32                       [c-file (path->main-collects-relative c-file)])
33           (syntax/loc stx
34             (get-or-load-bitmap content 'path-spec type))))]))
35  
36  (define-syntax (include-bitmap/relative-to stx)
37    (syntax-case stx ()
38      [(_ source path-spec) #`(-include-bitmap #,stx source path-spec 'unknown/mask)]
39      [(_ source path-spec type) #`(-include-bitmap #,stx source path-spec type)]))
40  
41  (define-syntax (include-bitmap stx)
42    (syntax-case stx ()
43      [(_ path-spec) #`(-include-bitmap #,stx #,stx path-spec 'unknown/mask)]
44      [(_ path-spec type) #`(-include-bitmap #,stx #,stx path-spec type)]))
45  
46  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
47  ;; Run-time support
48  
49  (define cached (make-hash))
50  
51  (define (get-or-load-bitmap content orig type)
52    (hash-ref cached 
53              (cons content type)
54              (λ ()
55                (define-values (in out) (make-pipe))
56                (thread
57                 (λ () 
58                   (display content out)
59                   (close-output-port out)))
60                
61                (define bm (make-object bitmap% in type))
62                (unless (send bm ok?)
63                  (error 'include-bitmap
64                         "unable to parse image, originated from: ~a"
65                         (path->string (main-collects-relative->path orig))))
66                (hash-set! cached (cons content type) bm)
67                bm)))