Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 144 lines (112 sloc) 4.789 kB
ba81d39 adding files
Danny Yoo authored
1 #lang scheme/base
2 (require scheme/class
3 scheme/gui/base
4 scheme/list
8f4643e Trying to do server-side compilation with resources.
Danny Yoo authored
5 scheme/port
ba81d39 adding files
Danny Yoo authored
6 mrlib/cache-image-snip
057efe0 Image lifting on stxs implemented but not rigorously tested.
Danny Yoo authored
7 scheme/contract
8f4643e Trying to do server-side compilation with resources.
Danny Yoo authored
8 "utils.ss"
70e740c continuing to refactor.
dyoo authored
9 "resource.ss"
1898170 Moving the moby/runtime modules into the moby subdirectory of collect…
Danny Yoo authored
10 "collects/moby/runtime/stx.ss")
ba81d39 adding files
Danny Yoo authored
11
12 (define-struct named-bitmap (name bitmap))
13
14 ;; Image lifting
15
16
70e740c continuing to refactor.
dyoo authored
17
18
19
ba81d39 adding files
Danny Yoo authored
20 (provide/contract [struct named-bitmap [(name string?)
21 (bitmap (is-a?/c bitmap%))]]
70e740c continuing to refactor.
dyoo authored
22 [named-bitmap->resource (named-bitmap? . -> . (is-a?/c resource<%>))]
ba81d39 adding files
Danny Yoo authored
23 [named-bitmap-save (named-bitmap? path-string? . -> . any)]
24 [lift-images! ((is-a?/c text%)
057efe0 Image lifting on stxs implemented but not rigorously tested.
Danny Yoo authored
25 . -> . (listof named-bitmap?))]
26
27 [lift-images/stx (stx? . -> . (values stx? (listof named-bitmap?)))]
28 [lift-images/stxs ((listof stx?) . -> . (values (listof stx?) (listof named-bitmap?)))])
ba81d39 adding files
Danny Yoo authored
29
70e740c continuing to refactor.
dyoo authored
30
31 (define named-bitmap-resource%
32 (class* object% (resource<%>)
33 (init-field named-bitmap)
34 (super-new)
35
36 (define/public (save! a-path)
8f4643e Trying to do server-side compilation with resources.
Danny Yoo authored
37 (named-bitmap-save named-bitmap a-path))
38
39 (define/public (get-name)
40 (named-bitmap-name named-bitmap))
41
42 (define/public (get-bytes)
43 (with-temporary-directory
44 (lambda (a-dir)
45 (save! a-dir)
46 (call-with-input-file (build-path a-dir (get-name))
47 (lambda (ip)
48 (port->bytes ip))))))))
49
70e740c continuing to refactor.
dyoo authored
50
51 ;; Turns a named bitmap into a resource.
52 (define (named-bitmap->resource a-named-bitmap)
53 (new named-bitmap-resource% [named-bitmap a-named-bitmap]))
54
55
56
57
58
ba81d39 adding files
Danny Yoo authored
59 ;; lift-images!: text -> (listof named-bitmap)
788b866 Documenting known bug.
Danny Yoo authored
60 ;; Lifts up the image snips in the text.
6c16b03 exposing image url loading with open-image-url
Danny Yoo authored
61 ;; The snips in the text will be replaced with the expression (open-image-url <path>)
788b866 Documenting known bug.
Danny Yoo authored
62 ;; where path refers to the file name of the named bitmap.
ba81d39 adding files
Danny Yoo authored
63 ;; Mutates the text, and produces a list of bitmap objects that should be saved.
64 (define (lift-images! a-text)
65 (let loop ([a-snip (send a-text find-first-snip)])
66 (cond
67 [(not a-snip)
68 empty]
69 [(image-snip? a-snip)
70 (let* ([file-name (make-image-name)]
71 [bitmap (send a-snip get-bitmap)]
72 [replacement-snip (make-object string-snip%
6c16b03 exposing image url loading with open-image-url
Danny Yoo authored
73 (format "(open-image-url ~s)"
e1a2fb6 Got cows to fall.
Danny Yoo authored
74 file-name))])
ba81d39 adding files
Danny Yoo authored
75 (send a-text set-position
76 (send a-text get-snip-position a-snip)
77 (+ (send a-text get-snip-position a-snip)
78 (send a-snip get-count)))
79 (send a-text insert replacement-snip)
80 (cons (make-named-bitmap file-name bitmap)
81 (loop (send replacement-snip next))))]
82 [else
83 (loop (send a-snip next))])))
84
85
057efe0 Image lifting on stxs implemented but not rigorously tested.
Danny Yoo authored
86 ;; lift-images/stx: stx -> (values stx (listof named-bitmap))
87 ;; Lift out the image snips in an stx.
88 (define (lift-images/stx a-stx)
89 (cond
90 [(stx:list? a-stx)
91 (let-values ([(lifted-elts named-bitmaps)
92 (lift-images/stxs (stx-e a-stx))])
76a4e2b replacing constructors for syntax with use of the single function dat…
Danny Yoo authored
93 (values (datum->stx #f lifted-elts (stx-loc a-stx))
057efe0 Image lifting on stxs implemented but not rigorously tested.
Danny Yoo authored
94 named-bitmaps))]
a18d159 Reindenting all changed code.
Danny Yoo authored
95
057efe0 Image lifting on stxs implemented but not rigorously tested.
Danny Yoo authored
96 [(stx:atom? a-stx)
97 (cond [(image-snip? (stx-e a-stx))
98 (let* ([filename (make-image-name)]
99 [bitmap (send (stx-e a-stx) get-bitmap)]
76a4e2b replacing constructors for syntax with use of the single function dat…
Danny Yoo authored
100 [replacement-stx (datum->stx #f `(open-image-url ,filename)
a18d159 Reindenting all changed code.
Danny Yoo authored
101 (stx-loc a-stx))])
057efe0 Image lifting on stxs implemented but not rigorously tested.
Danny Yoo authored
102 (values replacement-stx (list (make-named-bitmap filename bitmap))))]
103 [else
104 (values a-stx empty)])]))
105
106
107 ;; lift-images/stxs: (listof stx) -> (values (listof stx) (listof named-bitmap))
108 (define (lift-images/stxs stxs)
109 (cond
110 [(empty? stxs)
111 (values empty empty)]
112 [else
113 (let-values ([(lifted-stx named-bitmaps)
114 (lift-images/stx (first stxs))]
115 [(rest-lifted-stxs rest-named-bitmaps)
116 (lift-images/stxs (rest stxs))])
117 (values (cons lifted-stx rest-lifted-stxs)
118 (append named-bitmaps rest-named-bitmaps)))]))
a18d159 Reindenting all changed code.
Danny Yoo authored
119
057efe0 Image lifting on stxs implemented but not rigorously tested.
Danny Yoo authored
120
121
ba81d39 adding files
Danny Yoo authored
122 ;; named-bitmap-save: named-bitmap path-string -> void
123 ;; Saves the named bitmap under the given directory.
124 (define (named-bitmap-save a-named-bitmap a-dir)
125 (let ([a-path
126 (build-path a-dir (named-bitmap-name a-named-bitmap))])
127 (send (named-bitmap-bitmap a-named-bitmap) save-file (path->string a-path)
128 'png)))
129
130
131 ;; make-image-name: -> string
132 ;; Makes a new image name.
133 (define make-image-name
134 (let ([i 0])
135 (lambda ()
136 (begin0 (string-append "image-" (number->string i) ".png")
137 (set! i (add1 i))))))
138
139
140 ;; image-snip?: snip -> boolean
141 ;; Returns true if this looks like an image snip.
142 (define (image-snip? a-snip)
143 (or (is-a? a-snip image-snip%)
144 (is-a? a-snip cache-image-snip%)))
Something went wrong with that request. Please try again.