forked from oplS15projects/Racket-QA
-
Notifications
You must be signed in to change notification settings - Fork 0
/
master-gui.rkt
237 lines (191 loc) · 9.37 KB
/
master-gui.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; File: master-gui.rkt
;; Author: Roy Van Liew
;; Email: roy_vanliew@student.uml.edu
;; File Description: GUI for all four components
;;
;; Last Modified 04/25/2015 2:15 am by James Kuczynski
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#lang racket/gui
(require "Common/user-settings-directory.rkt") ; Filepath utilities
(require "./Racket-Doc/src/MainGui.rkt")
(require "Test-Automation/scheduler_ui.rkt")
(require "QA-Email/email-db-ui.rkt")
(require "Racket-Doc/src/MainGui.rkt")
(require "about-me.rkt")
(require setup/dirs)
(require web-server/servlet web-server/servlet-env)
(require xrepl)
(require racket/enter)
(define bottle-racket-icon (read-bitmap "demo/bottle-racket.png"))
(define test-capture-icon (read-bitmap "demo/test-capture.png"))
(define scheduler-icon (read-bitmap "demo/clock-icon-4.png"))
(define racket-doc-icon (read-bitmap "demo/racket-doc.png"))
(define mailing-list-icon (read-bitmap "demo/mailing-list.png"))
(define about-me-icon (read-bitmap "demo/question.png"))
;; Icon for question mark is Simple Question Mark Icon #069497
(define caption-width 150)
(define RACKET-PATH-UNFIXED
(string-append (path->string (find-console-bin-dir))
(cond ((eq? (system-type) 'windows) "racket.exe")
((eq? (system-type) 'unix) "/racket")
((eq? (system-type) 'macosx) "/racket")
(else (error "Platform not supported")))))
(define RACKET-PATH
(cond ((eq? (system-type) 'windows) (valid-path-windows RACKET-PATH-UNFIXED))
((eq? (system-type) 'unix) (valid-path-linux RACKET-PATH-UNFIXED))
((eq? (system-type) 'macosx) (valid-path-linux RACKET-PATH-UNFIXED))
(else (error "Platform not supported"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Window Display - Description at the top
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define main-window (new frame% (label "Racket-QA") (width 600)))
(define background (read-bitmap "racketqa-logo.png"))
(define image-loaded (new message% [parent main-window] [label background]))
(define buttons-v-pane (new vertical-pane% [parent main-window] [alignment '(center center)]
[vert-margin 5] [spacing 5] [border 10]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Window Display - Button for launching Bottle-Racket
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define bottle-racket-h-pane
(new horizontal-pane%
(parent buttons-v-pane)
(spacing 10)
(alignment '(left center))))
(new button% [parent bottle-racket-h-pane] [label bottle-racket-icon]
[callback (lambda (button event)
;; Configure necessary paths to call the Bottle-Racket script
(define master-gui-directory (current-directory))
(define bottle-racket-relative-path "Bottle-Racket/bottle-racket.rkt")
(define bottle-racket-full-path (string-append (cleanse-path-string
(string-append (get-dirpath-from-filepath (current-directory))
"/" bottle-racket-relative-path))))
(define bottle-racket-fixed-path (cond ((eq? (system-type) 'windows) (valid-path-windows bottle-racket-full-path))
((eq? (system-type) 'unix) (valid-path-linux bottle-racket-full-path))
((eq? (system-type) 'macosx) (valid-path-linux bottle-racket-full-path))
(else (error "Platform not supported"))))
;; Debugging
(display "Clicked Bottle-Racket.\n")
(display bottle-racket-full-path)
(display "\n")
(display bottle-racket-fixed-path)
;; Make the system call to Bottle-Racket.
(current-directory (get-dirpath-from-filepath bottle-racket-full-path)) ;; Change to Bottle-Racket directory.
(system (string-append RACKET-PATH " " bottle-racket-fixed-path))
(current-directory master-gui-directory) ;; Go back to the main page directory when finished.
) ; end lambda
] ; end callback
) ;; end button
(new message%
(parent bottle-racket-h-pane)
(min-width caption-width)
(stretchable-width #f)
(label "Bottle-Racket ")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Window Display - Button for launching Test-Capture
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new button% [parent bottle-racket-h-pane] [label test-capture-icon]
[callback (lambda (button event)
;; Configure necessary paths to call the test-capture script
(define master-gui-directory (current-directory))
(define test-capture-relative-path "Bottle-Racket/test-capture.rkt")
(define test-capture-full-path (string-append (cleanse-path-string
(string-append (get-dirpath-from-filepath (current-directory))
"/" test-capture-relative-path))))
(define test-capture-fixed-path (cond ((eq? (system-type) 'windows) (valid-path-windows test-capture-full-path))
((eq? (system-type) 'unix) (valid-path-linux test-capture-full-path))
((eq? (system-type) 'macosx) (valid-path-linux test-capture-full-path))
(else (error "Platform not supported"))))
;; Debugging
(display "Clicked Test-Capture.\n")
(display test-capture-full-path)
(display "\n")
(display test-capture-fixed-path)
;; Make the system call to test-capture.
(current-directory (get-dirpath-from-filepath test-capture-full-path)) ;; Change to Bottle-Racket directory.
(system (string-append RACKET-PATH " " test-capture-fixed-path))
(current-directory master-gui-directory) ;; Go back to the main page directory when finished.
) ; end lambda
] ; end callback
) ;; end button
(new message%
(parent bottle-racket-h-pane)
(min-width caption-width)
(stretchable-width #f)
(label "Test-Capture "))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Window Display - Button for launching Scheduler
;; Paths currently mixed on Windows
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define scheduler-h-pane
(new horizontal-pane%
(parent buttons-v-pane)
(spacing 10)
(alignment '(left center))))
(new button% [parent scheduler-h-pane] [label scheduler-icon]
[callback (lambda (button event) (launch-scheduler))])
(new message%
(parent scheduler-h-pane)
(min-width caption-width)
(stretchable-width #f)
(label "Test Scheduler "))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Window Display - Button for launching Racket-Doc
;; Paths currently mixed on Windows
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new button% [parent scheduler-h-pane] [label racket-doc-icon]
[callback (lambda (button event)
(display "Clicked Racket-Doc.\n")
(send frame show #t)
) ; end lambda
] ; end callback
) ;; end button
(new message%
(parent scheduler-h-pane)
(min-width caption-width)
(stretchable-width #f)
(label "Racket-Doc "))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Window Display - Button for Mailing List Configuration
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define mailing-list-h-pane
(new horizontal-pane%
(parent buttons-v-pane)
(spacing 10)
(alignment '(left center))))
(new button% [parent mailing-list-h-pane] [label mailing-list-icon]
[callback (lambda (button event) (open-manage-mailing-list-dialog))])
(new message%
(parent mailing-list-h-pane)
(min-width caption-width)
(stretchable-width #f)
(label "Manage Mailing List "))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Window Display - Button for "About Me" Section
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (aboutMeCallback button event)
(display "in callback")
(serve/servlet start-about-me-web-page
#:quit? #t
#:listen-ip "127.0.0.1"
;#:port 8080
#:servlet-path "/")
(display (current-thread))
;(kill-thread (current-thread))
)
(new button% [parent mailing-list-h-pane] [label about-me-icon]
[callback aboutMeCallback] ; end callback
) ;; end button
(new message%
(parent mailing-list-h-pane)
(min-width caption-width)
(stretchable-width #f)
(label "About-Me "))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Window Display - Displaying the Window
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(send main-window center)
(send main-window show #t)