├── LICENSE
├── README.md
├── clipboard.rkt
├── commons.rkt
├── csv-import-example.rkt
├── csv-import.rkt
├── dialogs.rkt
├── gui.rkt
├── hash.rkt
├── io.rkt
├── menu-bar.rkt
├── sql.rkt
├── system.rkt
└── xml.rkt
/LICENSE:
--------------------------------------------------------------------------------
1 | MIT License
2 |
3 | Copyright (c) 2022 Dexter Santucci
4 |
5 | Permission is hereby granted, free of charge, to any person obtaining a copy
6 | of this software and associated documentation files (the "Software"), to deal
7 | in the Software without restriction, including without limitation the rights
8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 |
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 |
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.
22 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # Racket Commons
2 |
3 | A collection of useful procedures divided into modules for Racket.
4 |
5 | ## Version history
6 |
7 | - v1.0.24 - added clean-var, inspect macro
8 | - v1.0.23 - added sort-filepaths-by-inc-size amd formatted-file-size to common module
9 | - v1.0.22 - improved group procedure safety in common module
10 | - v1.0.21 - updated get-latest-version
11 | - v1.0.20 - sorted provide in common module
12 | - v1.0.19 - added get-current-executable-path
13 | - v1.0.18 - added non-empty-or-none-string?
14 | - v1.0.17 - added get-latest-version-number
15 | - v1.0.16 - added non-empty-list-of-numbers?
16 | - v1.0.15 - added media-file?.
17 | - v1.0.14 - added list! and maybe-hash
18 | - v1.0.13 - updated transpose and improved unit test coverage.
19 | - v1.0.12 - added remove-indexed-items.
20 | - v1.0.11 - added system->ports.
21 | - v1.0.10 - added string->list-of-numbers.
22 | - v1.0.9 - added dies.
23 | - v1.0.8 - added string-contains-one-of?.
24 | - v1.0.7 - added str-list-contains.
25 | - v1.0.6 - added strip-newlines-returns.
26 | - v1.0.5 - added string-replace3.
27 | - v1.0.5 - added auto-quote.
28 | - v1.0.4 - added take-up-to and group (cuts a list into chunks).
29 | - v1.0.3 - added remove-non-alphanumeric-or-underscore.
30 | - v1.0.2 - added string-chop.
31 | - v1.0.1 - added non-empty-list-of-strings?.
32 | - v1.0 - initial release.
33 |
34 | ## Commons procedures
35 |
36 |
37 | (provide all-but-last ; (all-but-last l)
38 | auto-quote ; (auto-quote str)
39 | clean-var-name ; (clean-var-name var)
40 | chop ; (chop l n)
41 | combine-with ; (combine-with f l1 l2)
42 | comp_ ; (comp_ stx) [MACRO]
43 | curry-ref ; (curry-ref ... ) [MACRO]
44 | currym ; (currym func param1 param3)
45 | define-command-line-params ; (define-command-line-params ... ) [MACRO]
46 | dies ; (dies s1 s2 ...)
47 | each-of-each ; (each-of-each l)
48 | echo ; (echo s1 s2 ...)
49 | filter-zip ; (filter-zip pred-list list)
50 | first-letter ; (first-letter s)
51 | first-of-each ; (first-of-each l)
52 | first-two-of-each ; (first-two-of-each l)
53 | formatted-file-size ; (formatted-file-size filepath)
54 | get-current-executable-path ; (get-current-executable-path)
55 | get-file-content-type ; (get-file-content-type filepath)
56 | get-latest-version-number ; (get-latest-version-number versions prefix)
57 | get-matching-seconds ; (get-matching-seconds lst key)
58 | get-unique-prefix-line ; (get-unique-prefix-line lst prefix)
59 | grep ; (grep lines regex-pattern)
60 | grepl ; (grepl lines prefix)
61 | group ; (group n lst)
62 | if-defined ; (if-defined stx) [MACRO]
63 | inspect ; (inspect x ...)
64 | label->filename ; (label->filename label ext)
65 | license-almost-expired? ; (license-almost-expired? license-month)
66 | license-expired? ; (license-expired? license-year)
67 | list! ; (list! v)
68 | list-of-one? ; (list-of-one? l)
69 | list-to-string-lines ; (list-to-string-lines l)
70 | mask ; (mask l1 l2)
71 | mask-not ; (mask-not l1 l2)
72 | media-file? ; (media-file? f)
73 | multi-replace-line ; (multi-replace-line line source-list destination)
74 | multi-replace-lines ; (multi-replace-lines lines source-list destination)
75 | non-empty-list-of-list? ; (non-empty-list-of-list? l)
76 | non-empty-list-of-numbers? ; (non-empty-list-of-numbers? l)
77 | non-empty-list-of-strings? ; (non-empty-list-of-strings? l)
78 | non-empty-list? ; (non-empty-list? l)
79 | non-empty-or-none-string? ; (non-empty-or-none-string? s)
80 | pad ; (pad l len default)
81 | pad* ; (pad* l default)
82 | print-list ; (print-list l)
83 | remove-indexed-items ; (remove-indexed-items items indexes)
84 | remove-non-alphanumeric-or-underscore ; (remove-non-alphanumeric-or-underscore s)
85 | remove-nth ; (remove-nth lst n)
86 | replace-filename-in-path ; (replace-filename-in-path full-path new-filename)
87 | rest-of-each ; (rest-of-each l)
88 | second-last ; (second-last l)
89 | second-of-each ; (second-of-each l)
90 | second-true? ; (second-true? l)
91 | second? ; (second? l)
92 | sort-filepaths-by-inc-size ; (sort-filepaths-by-inc-size filepaths)
93 | str-list-contains ; (str-list-contains l s)
94 | str-list-contains? ; (str-list-contains? l s)
95 | string->label ; (string->label s)
96 | string->list-of-numbers ; (string->list-of-numbers str)
97 | string-chop ; (string-chop s len)
98 | string-contains-one-of? ; (string-contains-one-of? s l)
99 | string-nth ; (string-nth str nth (sep #px"\\s+"))
100 | string-replace-list ; (string-replace-list source pattern-list destination)
101 | string-replace2 ; (string-replace2 s from1 to1 from2 to2)
102 | string-replace3 ; (string-replace3 s from1 to1 from2 to2 from3 to3)
103 | strip-newlines-returns ; (strip-newlines-returns str)
104 | swap-columns-and-rows ; (swap-columns-and-rows l)
105 | swap-columns-to-rows-vector ; (swap-columns-to-rows-vector v)
106 | system->ports ; (system->ports command)
107 | take-everything-after-including ; (take-everything-after-including l starts-with)
108 | take-everything-starts-with ; (take-everything-starts-with l prefix)
109 | take-everything-until-including ; (take-everything-until-including l starts-with)
110 | take-up-to ; (take-up-to n lst)
111 | transpose ; (transpose l)
112 | zip) ; (zip l1 l2)
113 |
114 |
115 | ## IO procedures
116 |
117 |
118 | (provide add-file-extension ; (add-file-extension filename extension)
119 | add-file-extensions ; (add-file-extensions filenames extension)
120 | copy-file-to-folders ; (copy-file-to-folders source-path destination-list overwrite?)
121 | copy-or-die ; (copy-or-die src dest)
122 | create-folders-or-die ; (create-folders-or-die paths)
123 | create-list-of-files ; (create-list-of-files filenames content)
124 | directories-exist? ; (directories-exist? list-of-dirs)
125 | directory-list-str ; (directory-list-str path)
126 | display-error-count ; (display-error-count result msg)
127 | filename-path->string ; (filename-path->string filename-path)
128 | find-files# ; (find-files# pred path)
129 | file-path? ; (file-path? path)
130 | file-paths? ; (file-paths? paths)
131 | folder-path? ; (folder-path? path)
132 | folder-paths? ; (folder-paths? paths)
133 | get-error-count ; (get-error-count result msg)
134 | get-file-extension ; (get-file-extension filename-path)
135 | get-file-extensions ; (get-file-extensions filenames)
136 | get-file-lines ; (get-file-lines path)
137 | get-file-list-from-prefix-ext ; (get-file-list-from-prefix-ext path prefix extension)
138 | get-filename ; (get-filename filename-w-ext)
139 | get-filenames ; (get-filenames filenames-w-ext)
140 | get-file-name ; (get-file-name path)
141 | get-last-path-part ; (get-last-path-part path)
142 | list->file ; (list->file l file)
143 | make-backup-file ; (make-backup-file path)
144 | maybe-copy-file ; (maybe-copy-file source destination error-message exists-ok?)
145 | move-or-die ; (move-or-die src dest)
146 | path! ; (path! path-or-string)
147 | path<? ; (path<? p1 p2)
148 | process-text-files ; (process-text-files process file-list)
149 | replace-filename-in-path ; (replace-filename-in-path full-path new-filename)
150 | run-if-not-exists ; (run-if-not-exists list-of-files operation)
151 | sort-paths ; (sort-paths paths)
152 | write-file-lines) ; (write-file-lines lines path)
153 |
154 |
155 | ## Dialogs procedures
156 |
157 |
158 | (provide centered-listbox-dialog ; (centered-listbox-dialog title message initial-listbox-contents style width-ratio height-ratio)
159 | die ; (die msg)
160 | die# ; (die# msg)
161 | get-directory-list ; (get-directory-list title msg path)
162 | get-directory-list-w-prefix ; (get-directory-list-w-prefix title msg path folder_prefix)
163 | get-single-directory ; (get-single-directory title msg path)
164 | get-string-or-die ; (get-string-or-die msg error)
165 | hide-loading ; (hide-loading)
166 | listbox-dialog ; (listbox-dialog title message initial-listbox-contents style)
167 | listbox-dialog# ; (listbox-dialog# title message headers initial-listbox-contents selection-type width height)
168 | listbox-selectall ; (listbox-selectall list-box item-count select?)
169 | my-get-file-list ; (my-get-file-list message path filetype_name filetype_pattern)
170 | msgbox ; (msgbox message)
171 | populate-listbox ; (populate-listbox listbox listbox-contents)
172 | show-error-message ; (show-error-message message)
173 | show-loading ; (show-loading)
174 | show-confirmation-dialog ; (show-confirmation-dialog message)
175 | show-warning-message) ; (show-warning-message message)
176 |
177 |
178 | ## GUI procedures
179 |
180 |
181 | (provide get-bitmap ; (get-bitmap filename width height)
182 | is-checked? ; (is-checked? check-box)
183 | make-elastic-frame) ; (make-elastic-frame appname)
184 |
185 |
186 | ## Menu-bar procedures
187 |
188 | This is intended to be a good copy-paste candidate when one needs a simple, standard-looking menu bar.
189 |
190 | (provide menu-bar
191 | ------------------------
192 | file-menu
193 | file-new
194 | file-open
195 | file-save
196 | file-save-as
197 | file-exit
198 | edit-menu
199 | edit-copy
200 | edit-paste
201 | edit-select-all
202 | help-menu
203 | help-about)
204 |
205 |
206 | ## SQL procedures
207 |
208 |
209 | (provide query-execute ; (query-execute db query)
210 | query-record ; (query-record db query)
211 | query-string ; (query-string db query)
212 | get-query-headers ; (get-query-headers query) ('AS' required)
213 | get-query-headers# ; (get-query-headers# query) ('AS' not required, ignores subqueries)
214 | get-query-headers* ; (get-query-headers* db query) ('AS' not required, but does not support complex sub-queries)
215 | get-query-results ; (get-query-results db query wildcard-list)
216 | list->file ; (list->file l file)
217 | ml->sl ; (ml->sl l)
218 | sql-ml->sl ; (sql-ml->sl l)
219 | get-tables ; (get-tables db)
220 | get-tables* ; (get-tables* db-schema)
221 | get-table-columns ; (get-table-columns db table)
222 | get-table-columns-and-types ; (get-table-columns-and-types db table)
223 | get-db-schema ; (get-db-schema db tables)
224 | make-select-query ; (make-select-query db table columns)
225 | table-contains? ; (table-contains? db column table)
226 | which-tables-contain? ; (which-tables-contain? db tables column)
227 | which-tables-contain?* ; (which-tables-contain?* db-schema column)
228 | write-db-schema-to-file ; (write-db-schema-to-file db tables file)
229 | read-db-schema-from-file ; (read-db-schema-from-file file)
230 | update-db-schema ; (update-db-schema db db-schema)
231 | get-tables-that-contain-each-column-in-query) ; (get-tables-that-contain-each-column-in-query db db-schema query)
232 |
233 |
234 | ## Hash procedures
235 |
236 |
237 |
238 | (provide hash->string-list ; (hash->string-list h)
239 | hash->sorted-string-list ; (hash->sorted-string-list h)
240 | hash->flat-sorted-string-list ; (hash->flat-sorted-string-list h)
241 | maybe-hash) ; (maybe-hash cond possible-hash)
242 |
243 |
244 | ## Clipboard procedures
245 |
246 |
247 | (provide get-clipboard ; (get-clipboard-text)
248 | set-clipboard-text) ; (set-clipboard-text s)
249 |
250 |
251 | ## CSV-import procedures
252 |
253 | See csv-import-example.rkt for a sample implementation of the following module.
254 |
255 |
256 | (provide import-csv) ; (import-csv file processor-func (delimiter #\,))
257 |
258 |
259 | ## XML procedures
260 |
261 |
262 | (provide get-xml-value-from-id) ; (get-xml-value-from-id file pattern)
263 |
264 |
265 | ## System procedures
266 |
267 |
268 | (provide execute-async ; (execute-async startup-path program-binary-path command-line-parameters)
269 | system->ports) ; (system->ports command)
270 |
271 |
272 | ## License
273 | Racket Commons is free software; see [LICENSE](https://github.com/DexterLagan/racket-commons/blob/main/LICENSE) for more details.
274 |
--------------------------------------------------------------------------------
/clipboard.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/gui
2 |
3 | (provide get-clipboard ; (get-clipboard-text)
4 | set-clipboard-text) ; (set-clipboard-text s)
5 |
6 | ;;; defs
7 |
8 | ; returns the contents of the cliboard as text
9 | (define (get-clipboard-text)
10 | (send the-clipboard get-clipboard-string 0))
11 |
12 | ; set the contents of the cliboard as text
13 | (define (set-clipboard-text s)
14 | (send the-clipboard set-clipboard-string s 0))
15 |
16 |
17 | ; EOF
18 |
--------------------------------------------------------------------------------
/commons.rkt:
--------------------------------------------------------------------------------
1 | #lang racket
2 | (require racket/date)
3 | (provide all-but-last ; (all-but-last l)
4 | auto-quote ; (auto-quote str)
5 | clean-var-name ; (clean-var-name var)
6 | chop ; (chop l n)
7 | combine-with ; (combine-with f l1 l2)
8 | comp_ ; (comp_ stx) [MACRO]
9 | curry-ref ; (curry-ref ... ) [MACRO]
10 | currym ; (currym func param1 param3)
11 | define-command-line-params ; (define-command-line-params ... ) [MACRO]
12 | dies ; (dies s1 s2 ...)
13 | each-of-each ; (each-of-each l)
14 | echo ; (echo s1 s2 ...)
15 | filter-zip ; (filter-zip pred-list list)
16 | first-letter ; (first-letter s)
17 | first-of-each ; (first-of-each l)
18 | first-two-of-each ; (first-two-of-each l)
19 | formatted-file-size ; (formatted-file-size filepath)
20 | get-current-executable-path ; (get-current-executable-path)
21 | get-file-content-type ; (get-file-content-type filepath)
22 | get-latest-version-number ; (get-latest-version-number versions prefix)
23 | get-matching-seconds ; (get-matching-seconds lst key)
24 | get-unique-prefix-line ; (get-unique-prefix-line lst prefix)
25 | grep ; (grep lines regex-pattern)
26 | grepl ; (grepl lines prefix)
27 | group ; (group n lst)
28 | if-defined ; (if-defined stx) [MACRO]
29 | inspect ; (inspect x ...)
30 | label->filename ; (label->filename label ext)
31 | license-almost-expired? ; (license-almost-expired? license-month)
32 | license-expired? ; (license-expired? license-year)
33 | list! ; (list! v)
34 | list-of-one? ; (list-of-one? l)
35 | list-to-string-lines ; (list-to-string-lines l)
36 | mask ; (mask l1 l2)
37 | mask-not ; (mask-not l1 l2)
38 | media-file? ; (media-file? f)
39 | multi-replace-line ; (multi-replace-line line source-list destination)
40 | multi-replace-lines ; (multi-replace-lines lines source-list destination)
41 | non-empty-list-of-list? ; (non-empty-list-of-list? l)
42 | non-empty-list-of-numbers? ; (non-empty-list-of-numbers? l)
43 | non-empty-list-of-strings? ; (non-empty-list-of-strings? l)
44 | non-empty-list? ; (non-empty-list? l)
45 | non-empty-or-none-string? ; (non-empty-or-none-string? s)
46 | pad ; (pad l len default)
47 | pad* ; (pad* l default)
48 | print-list ; (print-list l)
49 | remove-indexed-items ; (remove-indexed-items items indexes)
50 | remove-non-alphanumeric-or-underscore ; (remove-non-alphanumeric-or-underscore s)
51 | remove-nth ; (remove-nth lst n)
52 | replace-filename-in-path ; (replace-filename-in-path full-path new-filename)
53 | rest-of-each ; (rest-of-each l)
54 | second-last ; (second-last l)
55 | second-of-each ; (second-of-each l)
56 | second-true? ; (second-true? l)
57 | second? ; (second? l)
58 | sort-filepaths-by-inc-size ; (sort-filepaths-by-inc-size filepaths)
59 | str-list-contains ; (str-list-contains l s)
60 | str-list-contains? ; (str-list-contains? l s)
61 | string->label ; (string->label s)
62 | string->list-of-numbers ; (string->list-of-numbers str)
63 | string-chop ; (string-chop s len)
64 | string-contains-one-of? ; (string-contains-one-of? s l)
65 | string-nth ; (string-nth str nth (sep #px"\\s+"))
66 | string-replace-list ; (string-replace-list source pattern-list destination)
67 | string-replace2 ; (string-replace2 s from1 to1 from2 to2)
68 | string-replace3 ; (string-replace3 s from1 to1 from2 to2 from3 to3)
69 | strip-newlines-returns ; (strip-newlines-returns str)
70 | swap-columns-and-rows ; (swap-columns-and-rows l)
71 | swap-columns-to-rows-vector ; (swap-columns-to-rows-vector v)
72 | system->ports ; (system->ports command)
73 | take-everything-after-including ; (take-everything-after-including l starts-with)
74 | take-everything-starts-with ; (take-everything-starts-with l prefix)
75 | take-everything-until-including ; (take-everything-until-including l starts-with)
76 | take-up-to ; (take-up-to n lst)
77 | transpose ; (transpose l)
78 | ;write-log ; (write-log s1 s2 ...)
79 | zip)
80 |
81 | (module+ test
82 | (require rackunit))
83 |
84 | ;;; purpose
85 |
86 | ; a library of common useful functions
87 |
88 | ;
89 | ;
90 | ; ; ;;
91 | ; ;; ;;
92 | ; ;; ;; ;;;; ;;;; ;; ;; ;;; ;;;;
93 | ; ;; ;; ; ;; ;; ; ; ; ;
94 | ; ;;; ; ;;; ; ; ; ; ;;;
95 | ; ; ; ; ; ; ; ; ; ; ;;
96 | ; ; ; ; ; ; ;; ; ; ; ;
97 | ; ; ; ;;; ; ;;;; ;;; ;;; ;;;;
98 | ;
99 | ;
100 | ;
101 |
102 | ;; returns a function that composes parameters in order,
103 | ;; using a placeholder _ for passing values between functions.
104 | (require (for-syntax racket/base))
105 | (define-syntax (comp_ stx)
106 | ; macro to compose functions passing an '_' parameter
107 | (syntax-case stx ()
108 | ((_ f1 ...)
109 | (with-syntax ([x-var (datum->syntax stx '_)])
110 | #'(apply compose1 (reverse (list (λ (x-var) f1) ...)))))))
111 | ; unit test
112 | (module+ test
113 | (check-equal? ((comp_ (string-trim _)
114 | (string-downcase _)
115 | (string-replace _ " " "-")
116 | ) "Hello World")
117 | "hello-world"))
118 |
119 | ;; helper function turns variable names into readable formatted string
120 | ;; i.e. *harmony-binary-path* -> "Harmony Binary Path"
121 | (define (clean-var-name var)
122 | ((comp_ (string-replace (symbol->string _) "-" " ")
123 | (string-replace _ "*" "")
124 | (string-titlecase _))
125 | var))
126 |
127 | ;; macro displays any number of variables and their values
128 | (define-syntax-rule (inspect x ...)
129 | (begin (printf " ~a: '~a'\n" (clean-var-name 'x) x) ...))
130 |
131 | ;
132 | ;
133 | ; ;;;; ;;;
134 | ; ; ;; ;;
135 | ; ; ; ;;; ;;;;; ;;;;
136 | ; ; ; ; ; ;; ;
137 | ; ; ; ;;;;; ;; ;;;
138 | ; ; ; ; ;; ;;
139 | ; ; ;; ; ;; ;
140 | ; ;;;; ;;;; ;; ;;;;
141 | ;
142 | ;
143 | ;
144 |
145 | ;; returns the current executable's path
146 | ;; sample result: C:\Users\baxter\OneDrive\Documents\Projects\Racket\Common\superlative.exe
147 | (define (get-current-executable-path)
148 | (find-system-path 'run-file))
149 |
150 | ;; helper function returns #t if given string isn't empty or "None"
151 | (define (non-empty-or-none-string? s)
152 | (and (non-empty-string? s)
153 | (not (string=? s "None"))))
154 | ; unit test
155 | (module+ test
156 | (check-false (non-empty-or-none-string? ""))
157 | (check-false (non-empty-or-none-string? "None"))
158 | (check-true (non-empty-or-none-string? "Something")))
159 |
160 | ;; macro executes the second form if symbol is defined, the third if not
161 | ;; i.e. (if-defined some-symbol (display "defined") (display "not defined"))
162 | (define-syntax (if-defined stx)
163 | (syntax-case stx ()
164 | [(_ id iftrue iffalse)
165 | (let ([where (identifier-binding #'id)])
166 | (if where #'iftrue #'iffalse))]))
167 |
168 | ;; writes an entry in a log file
169 | ;; the file is created if it doesn't exist, updated otherwise
170 | ;; i.e. (write-log "hello, " world ", you're beautiful")
171 | (if-defined *log-file* (void) (define *log-file* "c:\\temp\\csv-exporter.log"))
172 | (define write-log
173 | (λ args
174 | (display-lines-to-file (list (apply ~a args))
175 | *log-file*
176 | #:separator "\r\n"
177 | #:exists 'append)))
178 |
179 | ;; forces any value as a list
180 | (define (list! v)
181 | (if (list? v) v
182 | (list v)))
183 |
184 | ;; replace a filename in a full path with another filename
185 | (define (replace-filename-in-path full-path new-filename)
186 | (string-append (path->string (path-only full-path)) new-filename))
187 | ; unit test
188 | (module+ test
189 | (check-equal? (replace-filename-in-path (string->path "C:\\test\\path\\some-folder") "package-name")
190 | "C:\\test\\path\\package-name"
191 | "get-package-path-string"))
192 |
193 | ;; returns the nth part of a string split on the given separator (whitespaces by default)
194 | (define (string-nth str nth [sep #px"\\s+"])
195 | (if (non-empty-string? str)
196 | (let ((parts (string-split str sep)))
197 | (if (>= (length parts) nth)
198 | (list-ref parts (- nth 1))
199 | #f))
200 | #f))
201 | ; unit test
202 | (module+ test
203 | (check-equal? (string-nth "hello beautiful world" 2)
204 | "beautiful"
205 | "string-nth")
206 | (check-equal? (string-nth "hello beautiful world" 4)
207 | #f
208 | "string-nth")
209 | (check-equal? (string-nth "hello_beautiful_world" 3 "_")
210 | "world"
211 | "string-nth"))
212 |
213 |
214 | ;; mask l1 onto l2
215 | (define (mask l1 l2)
216 | (if (= (length l1) (length l2))
217 | (let ((results (map (λ (a b) (if a b #f)) l1 l2)))
218 | (filter identity results))
219 | null))
220 | ; unit test
221 | (module+ test
222 | (check-equal? (mask '(#t #t #f #f #t)
223 | '(1 2 3 4 5))
224 | '(1 2 5)
225 | "mask"))
226 |
227 | ;; reverse mask l1 onto l2
228 | (define (mask-not l1 l2)
229 | (if (= (length l1) (length l2))
230 | (let ((results (map (λ (a b) (if a #f b)) l1 l2)))
231 | (filter identity results))
232 | null))
233 | ; unit test
234 | (module+ test
235 | (check-equal? (mask-not '(#t #t #f #f #t)
236 | '(1 2 3 4 5))
237 | '(3 4)
238 | "reverse-mask"))
239 |
240 | ;; returns a chopped list of n lists
241 | (define (chop l n)
242 | (if (null? l) null
243 | (cons (take l n) (chop (drop l n) n))))
244 |
245 | ;; returns a list of matches (second list item) given one first list item
246 | ;; in a list of lists
247 | (define (get-matching-seconds lst key)
248 | (if (and (non-empty-list? lst)
249 | (non-empty-string? key))
250 | (filter identity ; anything not false
251 | (map (λ (element)
252 | (if (string=? key (first element))
253 | (second element)
254 | #f))
255 | lst))
256 | #f))
257 | ; unit test
258 | (module+ test
259 | (check-equal? (get-matching-seconds '(("Varian_Nose_TX" "some-path")
260 | ("XAVIER_Cheek_TX" 'some-other-thing)
261 | ("XAVIER_Nose_TX" "yet-another-path"))
262 | "XAVIER_Cheek_TX")
263 | '('some-other-thing))
264 | (check-equal? (get-matching-seconds '(("key" "first-string")
265 | ("not-key" "more-string")
266 | ("key" "third-string")
267 | ("other-key" "last-string"))
268 | "key")
269 | '("first-string" "third-string"))
270 | (check-equal? (get-matching-seconds null "key") #f)
271 | (check-equal? (get-matching-seconds '(("key" "first-string")
272 | ("not-key" "more-string")
273 | ("key" "third-string")
274 | ("other-key" "last-string"))
275 | "") #f))
276 |
277 | ;; predicate returns true if list contains one element
278 | (define (list-of-one? l)
279 | (and (list? l)
280 | (= 1 (length l))))
281 | ; unit test
282 | (module+ test
283 | (check-equal? (list-of-one? '()) #f)
284 | (check-equal? (list-of-one? '(1)) #t)
285 | (check-equal? (list-of-one? '(1 2)) #f)
286 | (check-equal? (list-of-one? 'test) #f))
287 |
288 | ;; returns true if a list is not empty, false otherwise
289 | (define (non-empty-list? l)
290 | (if (list? l)
291 | (not (empty? l))
292 | #f))
293 | ; unit test
294 | (module+ test
295 | (check-false (non-empty-list? #f))
296 | (check-false (non-empty-list? '()))
297 | (check-true (non-empty-list? '(1 2)))
298 | (check-true (non-empty-list? '("a" "b" "c"))))
299 |
300 | ;; predicate returns true if all lists given are non-empty and of equal length
301 | (define non-empty-same-length?
302 | (λ args (and (andmap non-empty-list? args)
303 | (apply = (map length args)))))
304 |
305 | ;; Check that license is valid for a given license year limit
306 | (define (license-expired? license-year)
307 | (let ((this-year (date-year (current-date))))
308 | (if (<= this-year license-year) #f #t)))
309 |
310 | ;; Check that license is valid for a given license year limit
311 | (define (license-almost-expired? license-month)
312 | (let ((this-month (date-month (current-date))))
313 | (if (>= this-month license-month) #t #f)))
314 |
315 | ;; Curries a function that takes 3 parameters by its middle parameter
316 | (define (currym func param1 param3)
317 | (lambda (param2)
318 | (func param1 param2 param3)))
319 | ;; unit test
320 | (module+ test
321 | (check-equal? ((currym ~a 'a 'c) 'b) "abc"))
322 |
323 | ;; Macro that curries a function by replacing the referred parameter
324 | ;; by the single parameter provided to the curried function
325 | (define-syntax curry-ref
326 | (syntax-rules ()
327 | ((curry-ref id params ref)
328 | (lambda args
329 | (apply id (list-set params ref (car args)))))))
330 |
331 | ;; macro that defines whichever parameters are fed to it and fills them in from command line
332 | (define-syntax define-command-line-params
333 | (syntax-rules ()
334 | ((define-command-line-params appname param1 ...)
335 | (define-values (param1 ...)
336 | (command-line #:program appname
337 | #:args (param1 ...)
338 | (values param1 ...))))))
339 |
340 | ;; Fancy varargs println
341 | (define echo
342 | (lambda args
343 | (displayln (apply ~a args))))
344 |
345 | ;; displays an error message and quit with an error code
346 | (define dies
347 | (lambda args
348 | (displayln (apply ~a args))
349 | (exit 1)))
350 |
351 | ;; General list printing
352 | (define (print-list l)
353 | (for-each displayln l))
354 |
355 | ;; Concatenate all strings in a list to a single string with line feeds
356 | (define (list-to-string-lines l)
357 | (if (non-empty-list? l)
358 | (let* ((parts (map (curryr string-append "\n") l)))
359 | (apply string-append parts))
360 | ""))
361 | ; unit test
362 | (module+ test
363 | (check-equal? (list-to-string-lines '("Sweet" "Jesus")) "Sweet\nJesus\n"))
364 |
365 | ;; Shortcut for string-append
366 | (define ++ string-append)
367 |
368 | ;; Like prefix but one letter
369 | (define (first-letter s)
370 | (string-ref s 0))
371 |
372 | ;; Name says it all
373 | (define (second-last l)
374 | (second (reverse l)))
375 |
376 | ;; Zip two lists
377 | (define zip
378 | (lambda (l1 l2) (map list l1 l2)))
379 |
380 | ;; Find the first orrurence of source-list in str and
381 | ;; return str with this occurence replaced by destination
382 | (define (string-replace-list source pattern-list destination)
383 | (if (and (non-empty-string? source)
384 | (list? pattern-list)
385 | (not (null? pattern-list))
386 | (string? destination))
387 | (if (string-contains? source (car pattern-list)) ; if pattern is found in source
388 | (string-replace source (car pattern-list) destination) ; replace pattern and return result
389 | (string-replace-list source (rest pattern-list) destination)) ; else call proc recursively
390 | source)) ; else return original string
391 | ; unit test
392 | (module+ test
393 | (check-equal? (string-replace-list
394 | "sweet jesus lord"
395 | '("sweet" "lord")
396 | "awesome")
397 | "awesome jesus lord"))
398 |
399 | ;; Replace a list of strings by a single destination in a line
400 | (define (multi-replace-line line source-list destination)
401 | (if (and (non-empty-string? line)
402 | (list? source-list)
403 | (non-empty-string? destination))
404 | (curryr string-replace-list line source-list destination)
405 | null))
406 | ; unit test
407 | (module+ test
408 | (check-equal?
409 | (multi-replace-line ""
410 | '("test1.plt" "test2.plt")
411 | "test4.plt")
412 | ""))
413 |
414 | ;; Replace a list of strings by a single destination in a list of lines
415 | (define (multi-replace-lines lines source-list destination)
416 | (if (and (list? lines)
417 | (list? source-list)
418 | (non-empty-string? destination))
419 | (map (curryr string-replace-list source-list destination) lines)
420 | null))
421 | ; unit test
422 | (module+ test
423 | (check-equal?
424 | (multi-replace-lines '(""
425 | ""
426 | "")
427 | '("test1.plt" "test2.plt")
428 | "test4.plt")
429 | '(""
430 | ""
431 | "")))
432 |
433 | ;; combine two lists using the provided function as glue
434 | (define (combine-with f l1 l2)
435 | (let ((combiner (lambda (a1 a2 acc) (cons (f a1 a2) acc))))
436 | (foldr combiner '() l1 l2)))
437 | ; unit test
438 | (module+ test
439 | (check-equal? (combine-with string-append '("a" "b" "c") '("d" "e" "f")) '("ad" "be" "cf")))
440 |
441 | ;; returns all the lines, including the one starting with, drop the rest
442 | (define (take-everything-until-including l starts-with)
443 | (dropf-right l (λ (s) (not (string-prefix? s starts-with)))))
444 |
445 | ;; returns all the lines that start with the given prefix
446 | (define (take-everything-starts-with l prefix)
447 | (filter (λ (s) (string-prefix? s prefix)) l))
448 |
449 | ;; returns all the lines after the line that starts with given prefix
450 | (define (take-everything-after-including l starts-with)
451 | (dropf l (λ (s) (not (string-prefix? s starts-with)))))
452 |
453 | ;; returns the matching unique line starting with prefix
454 | ;; ensures a single element line exists in the list
455 | ;; ensures the prefix exists
456 | ;; returns false otherwise
457 | (define (get-unique-prefix-line lst prefix)
458 | (if (not (list? lst)) #f
459 | (let ((bin-line (grepl lst prefix)))
460 | (if (and (list? bin-line)
461 | (= (length bin-line) 1))
462 | (string-replace (first bin-line) prefix "")
463 | #f))))
464 |
465 | ;; generate a filename from a title
466 | ;; i.e. The Lion Guard --> the-lion-guard
467 | (define (label->filename label ext)
468 | (string-append
469 | (string-downcase
470 | (string-replace label " " "-"))
471 | ext))
472 |
473 | ;; grep using a regex
474 | (define (grep lines regex-pattern)
475 | (filter (λ (line) (regexp-match? regex-pattern line)) lines))
476 |
477 | ;; grep using a prefix only
478 | (define (grepl lines prefix)
479 | (filter (λ (line) (string-prefix? line prefix)) lines))
480 |
481 | ;; transpose a list of lists
482 | ;; returns the transposed list of lists if lists are equal lengths, #f otherwise
483 | (define (transpose l)
484 | (let/cc return
485 | (unless (and (non-empty-list? l)
486 | (non-empty-list? (first l)))
487 | (return #f))
488 | ; consider first list as the length to match
489 | (define standard-length
490 | (length (first l)))
491 | (if (andmap (λ (line)
492 | (equal? (length line) standard-length))
493 | l)
494 | (apply map list l)
495 | #f)))
496 | ; unit test
497 | (module+ test
498 | (check-equal? (transpose '((1 2 3) (4 5 6)))
499 | '((1 4) (2 5) (3 6)))
500 | (check-equal? (transpose '((1 2 3) (4 5 6 7)))
501 | #f)
502 | (check-equal? (transpose '("hello" (4 5 6 7)))
503 | #f))
504 |
505 | ;; searches a string in a list. Returns #t if found, #f otherwise
506 | (define (str-list-contains? l s)
507 | (ormap (λ (search)
508 | (string-contains? search s))
509 | l))
510 | ; unit test
511 | (module+ test
512 | (check-true (str-list-contains? '("a" "b" "c") "b"))
513 | (check-false (str-list-contains? '("a" "b" "c") "e")))
514 |
515 | ;; searches a string in a list. Returns the string if found, #f otherwise
516 | ;; same as previous procedure, but returns the line containing the needle instead
517 | (define (str-list-contains l s)
518 | (define results
519 | (filter-map (λ (str)
520 | (if (string-contains? str s)
521 | str
522 | #f))
523 | l))
524 | (if (non-empty-list? results)
525 | (first results)
526 | #f))
527 | ; unit test
528 | (module+ test
529 | (check-equal? (str-list-contains '("a" "b" "c") "b") "b")
530 | (check-equal? (str-list-contains '("a" "b" "c") "e") #f)
531 | (check-equal? (str-list-contains '("sweet" "cool stuff" "naice") "cool") "cool stuff"))
532 |
533 | ;; returns #t if the string contains one of the listed strings, #f otherwise
534 | (define (string-contains-one-of? s l)
535 | (and (non-empty-list? l)
536 | (ormap (λ (str)
537 | (string-contains? s str))
538 | l)))
539 | ; unit test
540 | (module+ test
541 | (check-true (string-contains-one-of? "b" '("a" "b" "c")))
542 | (check-false (string-contains-one-of? "e" '("a" "b" "c")))
543 | (check-true (string-contains-one-of? "souris usb" '("batterie" "adaptateur" "clé" "clavier" "dalle" "souris" "encadrement" "capot" "haut parleur" "carte pci"))))
544 |
545 | (define (first-of-each l) ; -> list of atoms!
546 | (if (null? (car l)) null; make sure there is a first
547 | (map car l)))
548 | ;(first-of-each '((1 2 3) (a b c) ("str1" "str2" "str3")))
549 | ;'(1 a "str1")
550 |
551 | (define (first-two-of-each l) ; -> list of lists
552 | (cond [(null? (caar l)) null] ; if the first item of the first list if there
553 | [(null? (second (car l))) null]; if the second item of the first list
554 | [else (let ((first-two (lambda (l) (list (car l) (second l)))))
555 | (map first-two l))]))
556 | ;(first-two-of-each '((1 2 3) (a b c) ("str1" "str2" "str3")))
557 | ;'((1 2) (a b) ("str1" "str2"))
558 |
559 | (define (rest-of-each l) ; -> list of lists!
560 | (if (null? (car l)) null
561 | (map cdr l)))
562 | ;(rest-of-each '((1 2 3) (a b c) ("str1" "str2" "str3")))
563 | ;'((2 3) (b c) ("str2" "str3"))
564 |
565 | (define (second-of-each l) ; -> list of atoms!
566 | (first-of-each
567 | (rest-of-each l)))
568 | ;(second-of-each '((1 2 3) (a b c) ("str1" "str2" "str3")))
569 | ;'(2 b "str2")
570 |
571 | (define (each-of-each l) ; a.k.a. swap columns and rows
572 | (if (null? (car (cdr l))) null
573 | (cons (first-of-each l) (each-of-each (rest-of-each l)))))
574 | ;(each-of-each '((1 2 3) (a b c) ("str1" "str2" "str3")))
575 | ;'((1 a "str1") (2 b "str2") (3 c "str3"))
576 |
577 | ; Better version of each-of-each
578 | (define (swap-columns-and-rows l)
579 | (apply map list l))
580 |
581 | ; Same as swap-columns-and-rows but works with vectors
582 | (define (swap-columns-to-rows-vector v)
583 | (apply vector-map vector (vector->list v)))
584 |
585 | ; Filters a list by another list of booleans
586 | (define (filter-zip pred-list list)
587 | (if (null? list) null
588 | (let ((bool (car pred-list))
589 | (elem (car list)))
590 | (if bool (cons elem (filter-zip (cdr pred-list) (cdr list)))
591 | (filter-zip (cdr pred-list) (cdr list))))))
592 |
593 | ; Pad a list with default. Returns list if length is same or inferior to the list's
594 | (define (pad l len default)
595 | (if (< (- len (length l)) 1) l
596 | (append l (make-list (- len (length l)) default))))
597 | ; Test
598 | (module+ test
599 | (check-equal? (pad '(1 2 3 4) 6 0) '(1 2 3 4 0 0)))
600 |
601 | ; Automatically pad each list of a list to the longest list using default as padding (can be "", 0, null or anything)
602 | (define (pad* l default)
603 | (let* ((lengths (map length l))
604 | (max-length (apply max lengths)))
605 | (map (curryr pad max-length default) l)))
606 | ; Test
607 | (module+ test
608 | (check-equal? (pad* '((1 2 3) (1 2 3 4 5) (1 2 3) (1 2)) 9) '((1 2 3 9 9) (1 2 3 4 5) (1 2 3 9 9) (1 2 9 9 9))))
609 |
610 | ;; convert a string so it complies to a label-string's requirements
611 | ;; (200 chars max string)
612 | (define (string->label s)
613 | (~a s #:max-width 200 #:limit-marker "..."))
614 | (module+ test
615 | (check-equal? (string->label "The expense is accounted for when a vendor bill is validated, except in anglo-saxon accounting with perpetual inventory valuation in which case the expense (Cost of Goods Sold account) is recognized at the customer invoice validation.")
616 | "The expense is accounted for when a vendor bill is validated, except in anglo-saxon accounting with perpetual inventory valuation in which case the expense (Cost of Goods Sold account) is recognize..."))
617 |
618 | ;; all but last
619 | (define (all-but-last l)
620 | (reverse (cdr (reverse l))))
621 |
622 | ; Predicate that returns true if the list has a second element
623 | (define (second? l)
624 | (if (list? l)
625 | (if (>= (length l) 2)
626 | (if (second l) #t #f)
627 | #f) #f))
628 | ; unit test
629 | (module+ test
630 | (check-equal? (second? '(1)) #f)
631 | (check-equal? (second? '(1 2)) #t)
632 | (check-equal? (second? '(1 2 3)) #t))
633 |
634 | ; Predicate that returns true if the second element of the list is '#true (and nothing else!)
635 | (define (second-true? l)
636 | (if (second? l)
637 | (if (equal? (second l) #t) #t #f)
638 | #f))
639 | ; unit test
640 | (module+ test
641 | (check-equal? (second-true? '(1 anything)) #f)
642 | (check-equal? (second-true? '(1 #t)) #t))
643 |
644 | ; Replace two strings, not just one
645 | (define (string-replace2 s from1 to1 from2 to2)
646 | (string-replace (string-replace s from1 to1) from2 to2))
647 |
648 | ; Replace three strings, not just two
649 | (define (string-replace3 s from1 to1 from2 to2 from3 to3)
650 | (string-replace (string-replace (string-replace s from1 to1) from2 to2) from3 to3))
651 |
652 | ;; returns true if l is a non-empty list of list, #f otherwise
653 | (define (non-empty-list-of-list? l)
654 | (and (non-empty-list? l)
655 | (non-empty-list? (car l))))
656 | ; unit test
657 | (module+ test
658 | (check-false (non-empty-list-of-list? '("" "")))
659 | (check-false (non-empty-list-of-list? '("abc" "")))
660 | (check-false (non-empty-list-of-list? '("" "abc")))
661 | (check-false (non-empty-list-of-list? '(1 2 3)))
662 | (check-false (non-empty-list-of-list? '("abc" #f)))
663 | (check-false (non-empty-list-of-list? '("abc" '("test") #f "abc")))
664 | (check-false (non-empty-list-of-list? '("abc" 12 "cde")))
665 | (check-true (non-empty-list-of-list? '(("test"))))
666 | (check-true (non-empty-list-of-list? '(("test" "test2"))))
667 | (check-true (non-empty-list-of-list? '(("test" "test2") ("test3" "test4")))))
668 |
669 | ;; returns true if l is a non-empty list of strings, #f otherwise
670 | (define (non-empty-list-of-strings? l)
671 | (and (non-empty-list? l)
672 | (andmap non-empty-string? l)))
673 | ; unit test
674 | (module+ test
675 | (check-false (non-empty-list-of-strings? '("")))
676 | (check-false (non-empty-list-of-strings? '("abc" "")))
677 | (check-false (non-empty-list-of-strings? '("" "abc")))
678 | (check-false (non-empty-list-of-strings? '(1 2 3)))
679 | (check-false (non-empty-list-of-strings? '("abc" #f)))
680 | (check-false (non-empty-list-of-strings? '("abc" "def" #f "abc")))
681 | (check-false (non-empty-list-of-strings? '("abc" 12 "cde")))
682 | (check-true (non-empty-list-of-strings? '("abc" "def" "ghf"))))
683 |
684 | ;; returns #t if a list of numbers, #f otherwise
685 | (define (non-empty-list-of-numbers? l)
686 | (and (list? l)
687 | (not (empty? l))
688 | (andmap number? l)))
689 | ; unit test
690 | (module+ test
691 | (check-false (non-empty-list-of-numbers? #f))
692 | (check-false (non-empty-list-of-numbers? '()))
693 | (check-true (non-empty-list-of-numbers? '(1 2)))
694 | (check-false (non-empty-list-of-numbers? '("a" "b" "c"))))
695 |
696 | ;; chops a string at the desired length
697 | (define (string-chop s len)
698 | (and (non-empty-string? s)
699 | (if (> (string-length s) len)
700 | (substring s 0 len)
701 | s)))
702 | ;unit test
703 | (module+ test
704 | (check-equal? (string-chop "12345" 3) "123")
705 | (check-equal? (string-chop "123" 5) "123")
706 | (check-equal? (string-chop 12345 3) #f))
707 |
708 | ;; returns a string with non-alphanumeric characters removed, leaves underscores alone
709 | (define (remove-non-alphanumeric-or-underscore s)
710 | (define (alphanum? c)
711 | (or (char-numeric? c)
712 | (char-alphabetic? c)
713 | (eq? c #\_)))
714 | (list->string (filter alphanum? (string->list s))))
715 | (module+ test
716 | (check-equal? (remove-non-alphanumeric-or-underscore "a0 9-14_*&(") "a0914_"))
717 |
718 | ;; returns a string with non-alphanumeric characters removed, leaves underscores alone
719 | (define (remove-non-alphanumeric-or-underscore s)
720 | (define (alphanum? c)
721 | (or (char-numeric? c)
722 | (char-alphabetic? c)
723 | (eq? c #\_)))
724 | (list->string (filter alphanum? (string->list s))))
725 | (module+ test
726 | (check-equal? (remove-non-alphanumeric-or-underscore "a0 9-14_*&(") "a0914_"))
727 |
728 | ;; returns a list of up to n items off the given list lst
729 | (define (take-up-to n lst)
730 | (if (or (zero? n) (null? lst))
731 | '()
732 | (cons (car lst) (take-up-to (- n 1) (cdr lst)))))
733 | (module+ test
734 | (check-equal? (take-up-to 0 '("a" "b" "c")) '())
735 | (check-equal? (take-up-to 2 '("a" "b" "c")) '("a" "b"))
736 | (check-equal? (take-up-to 1 '("a" "b" "c")) '("a"))
737 | (check-equal? (take-up-to 4 '("a" "b" "c")) '("a" "b" "c")))
738 |
739 | ;; split/group a list into n equal chunks.
740 | ;; returns a list of lists.
741 | (define (group n lst)
742 | (let/cc return
743 | (when (non-empty-string? n)
744 | (set! n (string->number n)))
745 | (unless (number? n)
746 | (return (list lst)))
747 | (define (loop grouped lst l)
748 | (cond
749 | [(empty? lst)
750 | (reverse grouped)]
751 | [(<= l n)
752 | (loop (cons lst grouped) '() 0)]
753 | [else (let-values ([(taken dropped) (split-at lst n)])
754 | (loop (cons taken grouped)
755 | dropped
756 | (- l n)))]))
757 | (let ([l (length lst)])
758 | (if (>= n l) ; ERROR: >=: contract violation
759 | ; expected: real?
760 | ; given: "8"
761 | (list lst)
762 | (loop '() lst l)))))
763 | ; unit test
764 | (module+ test
765 | (check-equal? (group 3 '(1 2 3)) '((1 2 3)))
766 | (check-equal? (group 'x '(1 2 3)) '((1 2 3)))
767 | (check-equal? (group 3 '("sweet" "naice" "cool" "extra")) '(("sweet" "naice" "cool") ("extra")))
768 | (check-equal? (group 2 '("sweet" "naice" "cool" "extra")) '(("sweet" "naice") ("cool" "extra")))
769 | (check-equal? (group "2" '("sweet" "naice" "cool" "extra")) '(("sweet" "naice") ("cool" "extra"))))
770 |
771 | ;; utility function double-quotes a string if it contains a comma, and doubles double-quotes
772 | (define (auto-quote str)
773 | (if (string-contains? str ",")
774 | (string-append "\"" (string-replace str "\"" "\"\"") "\"")
775 | (string-replace str "\"" "\"\"")))
776 | ; unit test
777 | (module+ test
778 | (check-equal? (auto-quote "no quotes!") "no quotes!")
779 | (check-equal? (auto-quote "there is a comma in this string, I should quote it")
780 | "\"there is a comma in this string, I should quote it\"")
781 | (check-equal? (auto-quote "there is a comma and \"double-quotes\" in this string, I should double-quote it")
782 | "\"there is a comma and \"\"double-quotes\"\" in this string, I should double-quote it\""))
783 |
784 | ;; strips both newlines and line feeds
785 | (define (strip-newlines-returns str)
786 | (string-replace2 str
787 | "\n" ""
788 | "\r" ""))
789 |
790 |
791 | ;; returns a list of numbers, given a string containing a list of numbers
792 | ;; returns #f otherwise
793 | (define (string->list-of-numbers str)
794 | (let/cc return
795 | ((comp_ (string-split _ ",")
796 | (if (or (null? _)
797 | (< (length _) 2))
798 | (return #f)
799 | (map string-trim _))
800 | (map string->number _)
801 | (if (andmap number? _)
802 | _
803 | #f))
804 | str)))
805 | ; unit test
806 | (module+ test
807 | (check-equal? (string->list-of-numbers "0,2") '(0 2))
808 | (check-equal? (string->list-of-numbers "1, 2, 3") '(1 2 3))
809 | (check-equal? (string->list-of-numbers "1,") #f)
810 | (check-equal? (string->list-of-numbers ",2") #f)
811 | (check-equal? (string->list-of-numbers "hello") #f)
812 | (check-equal? (string->list-of-numbers "a,b") #f)
813 | (check-equal? (string->list-of-numbers "1,a") #f)
814 | (check-equal? (string->list-of-numbers "b,2") #f))
815 |
816 | ;; removes items from a list which are matching the given indexes
817 | (define (remove-indexed-items items indexes)
818 | (filter (λ (item)
819 | (not (member (index-of items item)
820 | indexes)))
821 | items))
822 | ; unit test
823 | (module+ test
824 | (check-equal? (remove-indexed-items '(1 2 3 4) '(0 1)) '(3 4))
825 | (check-equal? (remove-indexed-items '("001" "002" "003" "004") '(1 3)) '("001" "003")))
826 |
827 | ;; matches media files, returns #t otherwise.
828 | ;; to be used in combination with find-files
829 | (define (media-file? f)
830 | (let/cc return
831 | ; ignore directories
832 | (unless (file-exists? f)
833 | (return #f))
834 | ; get extension
835 | (define ext
836 | (path-get-extension f))
837 | ; match media file extensions
838 | (or (eq? ext #".tga")
839 | (eq? ext #".png")
840 | (eq? ext #".sgi")
841 | (eq? ext #".exr")
842 | (eq? ext #".mov")
843 | (eq? ext #".jpg")
844 | (eq? ext #".jpeg")
845 | (eq? ext #".psd")
846 | (eq? ext #".psb")
847 | (eq? ext #".gif")
848 | (eq? ext #".mp4")
849 | (eq? ext #".avi"))))
850 |
851 | ;; determines the last version number, given a list of versions and the expected prefix
852 | ;; sample version list: '("SOMEPREFIX_SOMETHING_V1" "SOMEPREFIX_SOMETHING_V2" "SOMEPREFIX_SOMETHING_V3" "OTHERPREFIX_SOMETHINGELSE_V1")
853 | ;; sample prefix: "SOMEPREFIX_SOMETHING_V"
854 | (define/contract (get-latest-version-number versions prefix)
855 | (list? string? . -> . number?)
856 | (let/cc return
857 | ; if empty list, return 0
858 | (unless (non-empty-list? versions)
859 | (return 0))
860 | ; if stump not found in the list of versions, return 0
861 | (unless (str-list-contains? versions prefix)
862 | (return 0))
863 | ; grab only the version names containing the target stump
864 | (define target-versions
865 | (filter (curryr string-contains? prefix)
866 | versions))
867 | ; remove stump from object-version-names
868 | (define version-number-strings?
869 | (map (curryr string-replace prefix "")
870 | target-versions))
871 | ; convert to a list of numbers
872 | (define version-numbers?
873 | (if (non-empty-list-of-strings? version-number-strings?)
874 | (map string->number version-number-strings?)
875 | '(0)))
876 | ; sort list of resulting numbers
877 | (if (non-empty-list-of-numbers? version-numbers?)
878 | (car (sort version-numbers? >))
879 | 0)))
880 | ; unit test
881 | (module+ test
882 | (check-equal? (get-latest-version-number '() "GOODSTUMP_V")
883 | 0)
884 | (check-equal? (get-latest-version-number '("GOODSTUMP_V1" "GOODSTUMP_V2" "GOODSTUMP_V3" "BADSTUMP_V1") "GOODSTUMP_V")
885 | 3)
886 | (check-equal? (get-latest-version-number '("GOODSTUMP_V1" "GOODSTUMP_V2" "GOODSTUMP_V3" "BADSTUMP_V1") "BADSTUMP_V")
887 | 1)
888 | (check-equal? (get-latest-version-number '("GOODSTUMP_V1" "GOODSTUMP_V2" "GOODSTUMP_V3" "BADSTUMP_V1") "OTHERSTUMP_V")
889 | 0))
890 |
891 | ;; helper function returns a list of the given filepaths in increasing order of size
892 | (define/contract (sort-filepaths-by-inc-size filepaths)
893 | (non-empty-list? . -> . (or/c non-empty-list? boolean?))
894 | (let/cc return
895 | ; build a sorted list of filepaths by their respective sizes
896 | (define sorted-files
897 | (let ((file+sizes
898 | (map (λ (filepath)
899 | (if (file-exists? filepath)
900 | (list filepath (file-size filepath))
901 | (return #f))) ; return an error if one of the filepaths isn't a file
902 | filepaths)))
903 | (sort file+sizes #:key cdr <)))
904 | ; deduce a flat list of the filepaths in order of size
905 | (if (non-empty-list? sorted-files)
906 | (map car sorted-files)
907 | #f)))
908 |
909 | ;; helper function returns a string with the correctly formatted file size of the given filepath (i.e. 1,234,567 KB)
910 | ;; function returns "0 KB" if the file does not exist
911 | (define/contract (formatted-file-size filepath)
912 | ((or/c path? path-string?) . -> . non-empty-string?)
913 | (if (file-exists? filepath)
914 | (string-append (~r (file-size filepath) #:groups '(3) #:group-sep ",") " KB")
915 | "0 KB"))
916 |
917 |
918 | ; EOF
919 |
--------------------------------------------------------------------------------
/csv-import-example.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/gui
2 | (require "dialogs.rkt"
3 | "commons.rkt"
4 | "csv-import.rkt"
5 | csv-reading)
6 |
7 | (provide partners-import) ; (import-contact name email company-name company-type buyer-name salesperson-name customer-axis-name customer-type customer-subtype code-site code-site-description street city country-name phone sage-ref siret)
8 |
9 | ;;; purpose
10 |
11 | ; import a CSV file containing partners into Odoo (an open-source ERP)
12 |
13 | ;;; consts
14 |
15 | (define *appname* "Sample CSV Importer")
16 | (define *total-lines* 0)
17 | (define *lines-processed* 0)
18 |
19 | ;;; defs
20 |
21 | ;; extract and process a list of CSV line's fields
22 | (define (line-processor l)
23 | ; extract CSV columns
24 | (define company-type (list-ref l 0)) ; 0 Company Type
25 | (define sage-ref (list-ref l 1)) ; 1 Référence
26 | (define name (list-ref l 2)) ; 2 Nom affiché
27 | (define street (list-ref l 3)) ; 3 Rue
28 | (define postal-code (list-ref l 4)) ; 4 Code Postal
29 | (define city (list-ref l 5)) ; 5 Ville
30 | (define country (list-ref l 6)) ; 6 Pays
31 | (define company-group (list-ref l 7)) ; 7 Groupe de Sociétés
32 | (define site-code (list-ref l 8)) ; 8 Code Site
33 | (define site-code-desc (list-ref l 9)) ; 9 Description code site
34 | (define tva (list-ref l 10)) ; 10 N° TVA
35 | (define siret (list-ref l 11)) ; 11 SIRET
36 | (define phone (list-ref l 12)) ; 12 Téléphone
37 | (define email (list-ref l 13)) ; 13 Email
38 | (define etiquette (list-ref l 14)) ; 14 Étiquettes
39 | (define contact-name (list-ref l 15)) ; 15 Contact/Nom
40 | (define salesperson (list-ref l 16)) ; 16 Vendeur
41 | (define buyer (list-ref l 17)) ; 17 Buyer
42 | (define fiscal-pos (list-ref l 18)) ; 18 Position fiscale
43 | (define price-list (list-ref l 19)) ; 19 Liste de prix
44 | (define customer-axis (list-ref l 20)) ; 20 Customer axis
45 | (define customer-type (list-ref l 21)) ; 21 Customer type
46 | (define customer-subtype (list-ref l 22)) ; 22 Customer Subtype
47 | (define commercial-team (list-ref l 23)) ; 23 Équipe Commerciale
48 | ; create the partner
49 | (define result (get/create-partner name
50 | email
51 | name
52 | company-type
53 | buyer
54 | salesperson
55 | customer-axis
56 | customer-type
57 | customer-subtype
58 | site-code
59 | site-code-desc
60 | street
61 | city
62 | postal-code
63 | country
64 | phone
65 | sage-ref
66 | siret
67 | tva
68 | company-group
69 | etiquette
70 | contact-name
71 | fiscal-pos
72 | price-list
73 | commercial-team))
74 | (set! *lines-processed* (add1 *lines-processed*))
75 | (echo *lines-processed* " out of " *total-lines* " lines processed.")
76 | result)
77 |
78 | ;;; main
79 |
80 | ;; import partners from a CSV file:
81 | ;; - check access rights to the target model;
82 | ;; - ask file from user;
83 | ;; - count file lines;
84 | ;; - import file lines;
85 | ;; - display result string.
86 | (define (partners-import)
87 | (let/cc return
88 | ; check access rights to the partner model
89 | (unless (check-access-rights *partner* '(create write))
90 | (show-error-message "No create right on partner model. Aborting.")
91 | (return #f))
92 | ; ask user for file
93 | (define file (get-file))
94 | (unless file
95 | (return #t))
96 | ; count file lines
97 | (set! *total-lines* (- (length (file->lines file)) 1))
98 | (when (= *total-lines* 0)
99 | (show-error-message "Empty file. Aborting."))
100 | ; process CSV file
101 | (define results (import-csv file line-processor))
102 | ; process results
103 | (if results
104 | ; display import log
105 | (void (message-box *appname* (string-join results "\n")))
106 | (return #f))))
107 | ; unit test
108 | ;(partners-import)
109 |
110 |
111 | ; EOF
112 |
--------------------------------------------------------------------------------
/csv-import.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 | (require csv-reading
3 | "pmap.rkt") ; see pmap package from the same author
4 | (provide import-csv) ; (import-csv file processor-func (delimiter #\,))
5 |
6 | ;;; purpose
7 |
8 | ; an easy-to-use library to import data from CSV files
9 |
10 | ;;; version history
11 |
12 | ; v1.1 - parallelized using pmap
13 | ; v1.0 - initial version
14 |
15 | ;;; defs
16 |
17 | ;; imports the given CSV file using the provided processor-func and optional, default comma delimiter
18 | ;; returns a list of results from the application of the processor-func
19 | (define (import-csv file processor-func (delimiter #\,))
20 | (let/cc return
21 | ; if no file, return
22 | (unless file
23 | (return #f))
24 | ; create a CSV parser with Excel's default UTF8 CSV specs
25 | (define make-partner-csv-reader
26 | (make-csv-reader-maker
27 | (list (cons 'separator-chars (list delimiter))
28 | (cons 'strip-leading-whitespace? #t)
29 | (cons 'strip-trailing-whitespace? #t))))
30 | ; create a reader for our CSV file
31 | (define reader
32 | (make-partner-csv-reader (open-input-file file)))
33 | ; skip headers
34 | (reader)
35 | ; process lines, gather results
36 | (csv-map processor-func reader)))
37 |
38 | ;; parallel version of the previous procedure
39 | ;; returns a list of results from the application of the processor-func
40 | (define (import-csv! file processor-func (delimiter #\,))
41 | (let/cc return
42 | ; if no file, return
43 | (unless file
44 | (return #f))
45 | ; create a CSV parser with Excel's default UTF8 CSV specs
46 | (define make-partner-csv-reader
47 | (make-csv-reader-maker
48 | (list (cons 'separator-chars (list delimiter))
49 | (cons 'strip-leading-whitespace? #t)
50 | (cons 'strip-trailing-whitespace? #t))))
51 | ; create a reader for our CSV file
52 | (define reader
53 | (make-partner-csv-reader (open-input-file file)))
54 | ; skip headers
55 | (reader)
56 | ; read csv as a list
57 | (define csv-lines (csv->list reader))
58 | ; process lines in parallel, gather results
59 | (pmap processor-func csv-lines)))
60 |
61 |
62 |
63 | ; EOF
64 |
--------------------------------------------------------------------------------
/dialogs.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/gui
2 | (require mrlib/path-dialog)
3 | (provide centered-listbox-dialog ; (centered-listbox-dialog title message initial-listbox-contents style width-ratio height-ratio)
4 | die ; (die msg)
5 | die# ; (die# msg)
6 | get-directory-list ; (get-directory-list title msg path)
7 | get-directory-list-w-prefix ; (get-directory-list-w-prefix title msg path folder_prefix)
8 | get-single-directory ; (get-single-directory title msg path)
9 | get-string-or-die ; (get-string-or-die msg error)
10 | hide-loading ; (hide-loading)
11 | listbox-dialog ; (listbox-dialog title message initial-listbox-contents style)
12 | listbox-dialog# ; (listbox-dialog# title message headers initial-listbox-contents selection-type width height)
13 | listbox-selectall ; (listbox-selectall list-box item-count select?)
14 | my-get-file-list ; (my-get-file-list message path filetype_name filetype_pattern)
15 | msgbox ; (msgbox message)
16 | populate-listbox ; (populate-listbox listbox listbox-contents)
17 | show-error-message ; (show-error-message message)
18 | show-loading ; (show-loading)
19 | show-confirmation-dialog ; (show-confirmation-dialog message)
20 | show-warning-message) ; (show-warning-message message)
21 | (module+ test
22 | (require rackunit))
23 |
24 | ;;; purpose
25 |
26 | ; a library of useful dialogs and interactive message boxes
27 |
28 | ;;; version history
29 |
30 | ; v1.0 - this version.
31 |
32 | ;;; defs
33 |
34 | ;; displays a text message box
35 | (define msgbox
36 | (λ args
37 | (void (message-box *appname*
38 | (string-append (apply ~a args) " ")
39 | #f
40 | (list 'ok)))))
41 |
42 | ;; displays an error message before quitting
43 | (define die
44 | (λ args
45 | (show-error-message (apply ~a args))
46 | (exit 1)))
47 |
48 | ;; command line version of die
49 | (define die#
50 | (λ args
51 | (displayln (apply ~a args))
52 | (exit 1)))
53 |
54 | ;; show a confirmation dialog. Returns true if user confirmed, false otherwise
55 | (define show-confirmation-dialog
56 | (λ args
57 | (eq? (message-box *appname* (apply ~a args) #f (list 'yes-no))
58 | 'yes)))
59 |
60 | ;; ask user to enter a string, quit with the given error message if none provided
61 | (define (get-string-or-die msg error)
62 | (define input
63 | (get-text-from-user *appname* msg))
64 | (unless (non-empty-string? input)
65 | (die error))
66 | (string-trim input))
67 |
68 | ;; a generic loading dialog
69 | (define loading-dialog
70 | (let* ((new-dialog (new dialog%
71 | [label "Loading"]
72 | [parent #f]
73 | [width 225]
74 | [height 80]
75 | [min-width 225]
76 | [min-height 80]
77 | [stretchable-width #f]
78 | [stretchable-height #f]))
79 | (new-panel (new vertical-panel% [parent new-dialog]
80 | [alignment '(center center)]))
81 | (new-message (new message% [parent new-panel]
82 | [label "Please wait..."])))
83 | new-dialog))
84 |
85 | ; Helper function to show the loading dialog
86 | (define (show-loading)
87 | (send loading-dialog show-without-yield))
88 |
89 | ; Helper function to hide the loading dialog
90 | (define (hide-loading)
91 | (send loading-dialog show #f))
92 |
93 | ;; Generic warning message dialog
94 | (define show-warning-message
95 | (λ args
96 | (void (message-box "Warning"
97 | (string-append (apply ~a args) " ")
98 | #f
99 | (list 'ok 'caution)))))
100 |
101 | ;; displays an error dialog
102 | (define show-error-message
103 | (λ args
104 | (message-box *appname* (apply ~a args) #f '(ok stop))))
105 |
106 | ; Ask user to select a list of scenes - could be used to obtain scene list.
107 | ; Example: (getfilelist "Please select a list of scenes." "C:\\" "Harmony Scene" "scene-*")
108 | (define (my-get-file-list message path filetype_name filetype_pattern)
109 | (get-file-list message
110 | #f ;parent
111 | (string->path path) ;directory
112 | #f ;filename
113 | #f ;extension
114 | null ;style
115 | (list (list filetype_name filetype_pattern)) )) ;filters
116 |
117 | ;; Ask user to select a list of scenes - could be used to obtain scene list.
118 | ;; Example:
119 | ;; (get-directory-list appname "Please select a list of scenes:" (string-append filesystem "\\" job)
120 | ;; "scene-")
121 | (define dir-ok?
122 | (λ (x) (non-empty-string? x)))
123 |
124 | (define (get-single-directory title msg path)
125 | (begin
126 | (define pathdialog (new path-dialog%
127 | [label title]
128 | [message msg]
129 | [directory path]
130 | [dir? #t]
131 | [ok? dir-ok?]
132 | [filters null]))
133 | (send pathdialog run)))
134 |
135 | ;; Ask user to select a list of scenes - could be used to obtain scene list.
136 | ;; Example:
137 | ;; (get-directory-list appname "Please select a list of scenes:" (string-append filesystem "\\" job)
138 | ;; "scene-")
139 | (define (get-directory-list title msg path)
140 | (begin
141 | (define pathdialog (new path-dialog%
142 | [label title]
143 | [message msg]
144 | [directory path]
145 | [dir? #t]
146 | [multi? #t]
147 | [ok? dir-ok?]
148 | [filters null]))
149 | (send pathdialog run)))
150 |
151 | ;; Ask user to select a list of scenes - could be used to obtain scene list.
152 | ;; Example:
153 | ;; (get-directory-list appname "Please select a list of scenes:" (string-append filesystem "\\" job)
154 | ;; "scene-")
155 | (define (get-directory-list-w-prefix title msg path folder_prefix)
156 | (begin
157 | (define pathdialog (new path-dialog%
158 | [label title]
159 | [message msg]
160 | [directory path]
161 | [dir? #t]
162 | [multi? #t]
163 | [filters null]
164 | ; [show-dir? (λ (x) (string-prefix? x folder_prefix))]
165 | [ok? (λ (x) (string-prefix? x folder_prefix))]
166 | ))
167 | (send pathdialog run)))
168 |
169 | ; Helper function to select/deselect all items in a list-box
170 | (define (listbox-selectall list-box item-count select?)
171 | (let ((select-item (lambda (item) (send list-box select item select?))))
172 | (for ([x (in-range item-count)]) (select-item x))))
173 |
174 | ; Helper function to populate a list-box control
175 | (define (populate-listbox listbox listbox-contents)
176 | (send listbox set listbox-contents))
177 |
178 | ; List-box dialog with 'select all' and a name filter
179 | (define (listbox-dialog title message initial-listbox-contents style)
180 | (let* ((dialog (new dialog%
181 | [label title]
182 | [parent #f]
183 | [width 320]
184 | [height 480]
185 | [min-width 320]
186 | [min-height 480]))
187 | ;[stretchable-width #f]
188 | ;[stretchable-height #f]
189 |
190 | ; Currenr listbox contents
191 | (current-listbox-contents initial-listbox-contents)
192 | (current-selected-contents null)
193 |
194 | ; Control defs
195 | (top-panel (new vertical-panel% [parent dialog]
196 | [alignment '(center center)]))
197 |
198 | (new-message (new message% [parent top-panel]
199 | [label message]))
200 |
201 | (new-listbox
202 | (new list-box%
203 | [label #f]
204 | [choices initial-listbox-contents]
205 | [parent top-panel]
206 | [style (list style)]
207 | [callback
208 | (lambda (l e)
209 | (let ((event-type (send e get-event-type)))
210 | (if (equal? event-type 'list-box-dclick)
211 | (let* ((current-listbox-selection (send l get-selections))
212 | (selected-contents (map (curry list-ref current-listbox-contents)
213 | current-listbox-selection)))
214 | (begin
215 | (set! current-selected-contents selected-contents)
216 | (send dialog show #f)))
217 | null)))]))
218 |
219 | (bottom-panel (new horizontal-panel%
220 | [parent dialog]
221 | [alignment '(center bottom)]
222 | [stretchable-height #f]))
223 |
224 | (bottom-left-panel (new horizontal-panel%
225 | [parent bottom-panel]
226 | [alignment '(left bottom)]))
227 |
228 | (bottom-right-panel (new horizontal-panel%
229 | [parent bottom-panel]
230 | [alignment '(right bottom)]))
231 |
232 | ; Callbacks
233 | (selectall-button-callback
234 | (lambda (b e)
235 | (listbox-selectall new-listbox (length current-listbox-contents) #t)))
236 |
237 | (cancel-button-callback
238 | (lambda (b e)
239 | (begin
240 | (set! current-selected-contents #f)
241 | (send dialog show #f))))
242 |
243 | (ok-button-callback
244 | (lambda (b e)
245 | (let* ((current-listbox-selection (send new-listbox get-selections))
246 | (selected-contents (map (curry list-ref current-listbox-contents)
247 | current-listbox-selection)))
248 | (begin
249 | (set! current-selected-contents selected-contents)
250 | (send dialog show #f)))))
251 |
252 | (filter-textfield-callback
253 | (lambda (t e)
254 | (let ((new-listbox-contents
255 | (filter (curryr string-contains? (send t get-value)) initial-listbox-contents)))
256 | (begin
257 | (set! current-listbox-contents new-listbox-contents)
258 | (populate-listbox new-listbox new-listbox-contents)))))
259 |
260 | ; Buttons defs
261 | (filter-textfield (new text-field%
262 | [label "Filter: "]
263 | [parent bottom-left-panel]
264 | [callback filter-textfield-callback]))
265 |
266 | (selectall-button (new button%
267 | [label "Select All"]
268 | [enabled (if (equal? style 'single) #f #t)] ; Enable or disable
269 | [parent bottom-left-panel] ; the Select All button
270 | [callback selectall-button-callback])) ; depending on style
271 |
272 | (cancel-button (new button%
273 | [label "Cancel"]
274 | [parent bottom-right-panel]
275 | [callback cancel-button-callback]))
276 |
277 | (ok-button (new button%
278 | [label "OK"]
279 | [parent bottom-right-panel]
280 | [callback ok-button-callback])))
281 | (begin
282 | (send dialog show #t)
283 | current-selected-contents))) ; Return list of selected items (null if cancel pressed)
284 |
285 | ; Unit test
286 | ;(listbox-dialog "PaletteCopier"
287 | ; "Please select destination elements:"
288 | ; (list "Naice" "Sweet" "Dude")
289 | ; 'multiple)
290 |
291 | ;; List-box dialog with 'select all', name filter and support for columns
292 | ;; Returns list of selected items, null otherwise
293 | ;; initial-listbox-contents is a list of columns
294 | (define (listbox-dialog# title message headers initial-listbox-contents selection-type width height)
295 | (let* ((dialog (new dialog%
296 | [label title]
297 | [parent #f]
298 | [border 10]
299 | [spacing 10]
300 | [style (list 'resize-border)]
301 | [width width]
302 | [height height]
303 | [min-width width]
304 | [min-height height]))
305 | ;[stretchable-width #f]
306 | ;[stretchable-height #f]
307 |
308 | ; Currenr listbox contents
309 | (current-listbox-contents initial-listbox-contents)
310 | (current-selected-contents null)
311 |
312 | ; Control defs
313 | (top-panel (new vertical-panel% [parent dialog]
314 | [alignment '(center center)]))
315 |
316 | (new-message (new message% [parent top-panel]
317 | [label message]))
318 |
319 | (new-listbox (new list-box%
320 | [label #f]
321 | [columns headers]
322 | [choices '()]
323 | [parent top-panel]
324 | [style (cons selection-type
325 | '(variable-columns
326 | clickable-headers
327 | column-headers
328 | reorderable-headers))]
329 | [callback
330 | (lambda (l e)
331 | (let ((event-type (send e get-event-type)))
332 | (if (equal? event-type 'list-box-dclick)
333 | (let* ((current-listbox-selection (send l get-selections))
334 | (selected-contents (map (curry list-ref current-listbox-contents)
335 | current-listbox-selection)))
336 | (begin
337 | (set! current-selected-contents selected-contents)
338 | (send dialog show #f)))
339 | null)))]))
340 |
341 | (bottom-panel
342 | (new horizontal-panel%
343 | [parent dialog]
344 | [alignment '(center bottom)]
345 | [stretchable-height #f]))
346 |
347 | (bottom-left-panel
348 | (new horizontal-panel%
349 | [parent bottom-panel]
350 | [alignment '(left bottom)]))
351 |
352 | (bottom-right-panel
353 | (new horizontal-panel%
354 | [parent bottom-panel]
355 | [alignment '(right bottom)]))
356 |
357 | ; Callbacks
358 | (selectall-button-callback
359 | (lambda (b e)
360 | (listbox-selectall new-listbox (length current-listbox-contents) #t)))
361 |
362 | (cancel-button-callback
363 | (lambda (b e)
364 | (begin
365 | (set! current-selected-contents #f)
366 | (send dialog show #f))))
367 |
368 | (ok-button-callback
369 | (lambda (b e)
370 | (let* ((current-listbox-selection (send new-listbox get-selections))
371 | (selected-contents
372 | (map (curry list-ref current-listbox-contents)
373 | current-listbox-selection)))
374 | (begin
375 | (set! current-selected-contents selected-contents)
376 | (send dialog show #f)))))
377 |
378 | (filter-textfield-callback
379 | (lambda (t e)
380 | ; grab user input in text field
381 | (define search-str
382 | (send t get-value))
383 | ; utility func to find out if a list contains a string anywhere
384 | (define (str-list-contains? l)
385 | (ormap (λ (s)
386 | (string-contains? s search-str))
387 | l))
388 | ; filter list and re-populate listbox
389 | (let ((new-listbox-contents
390 | (filter str-list-contains? initial-listbox-contents)))
391 | (begin
392 | (set! current-listbox-contents new-listbox-contents)
393 | (populate-listbox# new-listbox new-listbox-contents)))))
394 |
395 | ; Buttons defs
396 | (filter-textfield
397 | (new text-field%
398 | [label "Filter: "]
399 | [parent bottom-left-panel]
400 | [callback filter-textfield-callback]))
401 |
402 | (selectall-button
403 | (new button%
404 | [label "Select All"]
405 | [enabled (if (equal? selection-type 'single) #f #t)] ; Enable or disable the Select All button depending on global style
406 | [parent bottom-left-panel]
407 | [callback selectall-button-callback]))
408 |
409 | (cancel-button
410 | (new button%
411 | [label "Cancel"]
412 | [parent bottom-right-panel]
413 | [callback cancel-button-callback]))
414 |
415 | (ok-button
416 | (new button%
417 | [label "OK"]
418 | [parent bottom-right-panel]
419 | [callback ok-button-callback])))
420 | (begin
421 | (populate-listbox# new-listbox headers initial-listbox-contents)
422 | (send dialog show #t)
423 | current-selected-contents)))
424 |
425 | ; Unit test
426 | ;(listbox-dialog# "Some Title"
427 | ; "Please select stuff:"
428 | ; (list "Field" "Value")
429 | ; (list (list "Naice" "Sweet")
430 | ; (list "Dude" "Naice"))
431 | ; 'multiple 480 640)
432 |
433 | ; Display a generic, centered dialog using the width and height ratios (2 by default)
434 | (define (centered-listbox-dialog title message initial-listbox-contents style width-ratio height-ratio)
435 | (let* ((dialog (let*-values ([(display-width display-height) (get-display-size)]
436 | [(dialog-width) (round (/ display-width width-ratio))]
437 | [(dialog-height) (round (/ display-height height-ratio))])
438 | (new dialog%
439 | [label title]
440 | [x (- (round (/ display-width 2)) (round (/ dialog-width 2)))]
441 | [y (- (round (/ display-height 2)) (round (/ dialog-height 2)))]
442 | [width dialog-width]
443 | [height dialog-height])))
444 |
445 | ; Control defs
446 | (top-panel (new vertical-panel% [parent dialog]
447 | [alignment '(center center)]))
448 |
449 | (new-message (new message% [parent top-panel]
450 | [label message]))
451 |
452 | (new-listbox (new list-box%
453 | [label #f]
454 | [choices initial-listbox-contents]
455 | [parent top-panel]
456 | [style (list style)]))
457 |
458 | (bottom-panel (new horizontal-panel%
459 | [parent dialog]
460 | [alignment '(center bottom)]
461 | [stretchable-height #f]))
462 |
463 | (bottom-left-panel (new horizontal-panel%
464 | [parent bottom-panel]
465 | [alignment '(left bottom)]))
466 |
467 | (bottom-right-panel (new horizontal-panel%
468 | [parent bottom-panel]
469 | [alignment '(right bottom)]))
470 |
471 | ; Currenr listbox contents
472 | (current-listbox-contents initial-listbox-contents)
473 | (current-selected-contents null)
474 |
475 | ; Callbacks
476 | (selectall-button-callback (lambda (b e) (listbox-selectall new-listbox (length current-listbox-contents) #t)))
477 |
478 | (cancel-button-callback (lambda (b e) (begin
479 | (set! current-selected-contents #f)
480 | (send dialog show #f))))
481 |
482 | (ok-button-callback (lambda (b e) (let* ((current-listbox-selection (send new-listbox get-selections))
483 | (selected-contents (map (curry list-ref current-listbox-contents) current-listbox-selection)))
484 | (begin
485 | (set! current-selected-contents selected-contents)
486 | (send dialog show #f)))))
487 |
488 | (filter-textfield-callback (lambda (t e) (let ((new-listbox-contents (filter (curryr string-contains? (send t get-value)) initial-listbox-contents)))
489 | (begin
490 | (set! current-listbox-contents new-listbox-contents)
491 | (populate-listbox new-listbox new-listbox-contents)))))
492 |
493 | ; Buttons defs
494 | (filter-textfield (new text-field%
495 | [label "Filter: "]
496 | [parent bottom-left-panel]
497 | [callback filter-textfield-callback]))
498 |
499 | (selectall-button (new button%
500 | [label "Select All"]
501 | [enabled (if (equal? style 'single) #f #t)] ; Enable or disable the Select All button depending on global style
502 | [parent bottom-left-panel]
503 | [callback selectall-button-callback]))
504 |
505 | (cancel-button (new button%
506 | [label "Cancel"]
507 | [parent bottom-right-panel]
508 | [callback cancel-button-callback]))
509 |
510 | (ok-button (new button%
511 | [label "OK"]
512 | [parent bottom-right-panel]
513 | [callback ok-button-callback])))
514 | (begin
515 | (send dialog show #t)
516 | current-selected-contents))) ; Return list of selected items (null if cancel pressed)
517 | ; unit test
518 | ;(centered-listbox-dialog "Title" "Message" '("Sweet" "Dude" "Naice") 'single 3 1)
519 |
520 | ; EOF
521 |
--------------------------------------------------------------------------------
/gui.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/gui
2 |
3 | (provide get-bitmap ; (get-bitmap filename width height)
4 | is-checked? ; (is-checked? check-box)
5 | make-elastic-frame) ; (make-elastic-frame appname)
6 |
7 | ;;; purpose
8 |
9 | ; to provide a collection of useful gui functions
10 |
11 | ;;; version history
12 |
13 | ; v1.0 - this version.
14 |
15 | ;;; defs
16 |
17 | ;; returns true if check-box is checked, false otherwise
18 | (define (is-checked? cb)
19 | (send cb get-value))
20 |
21 | ;; generates a small frame to fill with controls
22 | (define (make-elastic-frame appname)
23 | (new (class frame% (super-new)
24 | (define/augment (on-close)
25 | (exit 0)))
26 | [label appname]
27 | [width 0]
28 | [height 0]
29 | [stretchable-width 1024]
30 | [stretchable-height #f]))
31 |
32 | ;; generate a bitmap from a filename
33 | (define (get-bitmap filename width height)
34 | (let ((b (make-object bitmap% width height #f #t 1.0)))
35 | ; (make-object bitmap% (/ button-size 2) (/ button-size 2))
36 | (send b load-file filename)
37 | b))
38 |
39 |
40 | ; EOF
41 |
--------------------------------------------------------------------------------
/hash.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 | (require racket/format
3 | racket/list
4 | racket/string)
5 |
6 | (provide hash->string-list ; (hash->string-list h)
7 | hash->sorted-string-list ; (hash->sorted-string-list h)
8 | hash->flat-sorted-string-list ; (hash->flat-sorted-string-list h)
9 | maybe-hash) ; (maybe-hash cond possible-hash)
10 |
11 | (module+ test
12 | (require rackunit))
13 |
14 | ;;; purpose
15 |
16 | ; to provide several useful hash functions.
17 |
18 | ;;; defs
19 |
20 | ;; used along hash-union can conditionally and funcitonally build a hash bit by bit
21 | (define (maybe-hash cond possible-hash)
22 | (and (hash? possible-hash)
23 | (if cond possible-hash (hash))))
24 |
25 | ;; converts a hash table to a list of list of strings
26 | (define (hash->string-list h)
27 | (map (λ (i) (list (~a (car i)) (~a (cdr i)))) (hash->list h)))
28 | ; unit test
29 | (module+ test
30 | (check-equal? (hash->string-list
31 | (hash 'a 1 'b 2))
32 | '(("b" "2") ("a" "1"))))
33 |
34 | ;; converts a hash table to a list of list of strings
35 | (define (hash->sorted-string-list h)
36 | (let ((unsorted (map (λ (i)
37 | (if (hash? (cdr i))
38 | (list (~a (car i)) (hash->sorted-string-list (cdr i)))
39 | (list (~a (car i)) (~a (cdr i)))))
40 | (hash->list h))))
41 | (sort unsorted (λ (x y) (stringsorted-string-list
45 | (hash 'a 1 'b 2))
46 | '(("a" "1") ("b" "2")))
47 | (check-equal? (hash->sorted-string-list
48 | (hash 'a 1 'b (hash 'c 2 'd 3)))
49 | '(("a" "1") ("b" (("c" "2") ("d" "3"))))))
50 |
51 | ;; converts a hash table to a flat list of strings, ignoring first items in second lists
52 | (define (hash->flat-sorted-string-list h)
53 | (let ((unsorted (map (λ (i)
54 | (if (hash? (cdr i))
55 | (flatten (list (~a (car i)) (hash->sorted-string-list (cdr i))))
56 | (list (~a (car i)) (~a (cdr i)))))
57 | (hash->list h))))
58 | (sort unsorted (λ (x y) (stringflat-sorted-string-list
62 | (hash 'a 1 'b 2))
63 | '(("a" "1") ("b" "2")))
64 | (check-equal? (hash->flat-sorted-string-list
65 | (hash 'a 1 'b (hash 'c 2 'd 3)))
66 | '(("a" "1") ("b" "c" "2" "d" "3"))))
67 |
68 |
69 | ; EOF
70 |
--------------------------------------------------------------------------------
/io.rkt:
--------------------------------------------------------------------------------
1 | #lang racket
2 | (require "commons.rkt") ; (multi-replace-lines lines source-list destination)
3 | (provide add-file-extension ; (add-file-extension filename extension)
4 | add-file-extensions ; (add-file-extensions filenames extension)
5 | copy-file-to-folders ; (copy-file-to-folders source-path destination-list overwrite?)
6 | copy-or-die ; (copy-or-die src dest)
7 | create-folders-or-die ; (create-folders-or-die paths)
8 | create-list-of-files ; (create-list-of-files filenames content)
9 | directories-exist? ; (directories-exist? list-of-dirs)
10 | directory-list-str ; (directory-list-str path)
11 | display-error-count ; (display-error-count result msg)
12 | filename-path->string ; (filename-path->string filename-path)
13 | find-files# ; (find-files# pred path)
14 | file-path? ; (file-path? path)
15 | file-paths? ; (file-paths? paths)
16 | folder-path? ; (folder-path? path)
17 | folder-paths? ; (folder-paths? paths)
18 | get-error-count ; (get-error-count result msg)
19 | get-file-extension ; (get-file-extension filename-path)
20 | get-file-extensions ; (get-file-extensions filenames)
21 | get-file-lines ; (get-file-lines path)
22 | get-file-list-from-prefix-ext ; (get-file-list-from-prefix-ext path prefix extension)
23 | get-filename ; (get-filename filename-w-ext)
24 | get-filenames ; (get-filenames filenames-w-ext)
25 | get-file-name ; (get-file-name path)
26 | get-last-path-part ; (get-last-path-part path)
27 | list->file ; (list->file l file)
28 | make-backup-file ; (make-backup-file path)
29 | maybe-copy-file ; (maybe-copy-file source destination error-message exists-ok?)
30 | move-or-die ; (move-or-die src dest)
31 | path! ; (path! path-or-string)
32 | pathstring filename-path)
67 | ; filename-path))) ; convert path to string if necessary
68 | ; (or (string-suffix? filename-text ".sgi")
69 | ; (string-suffix? filename-text ".tga")
70 | ; (string-suffix? filename-text ".dpx"))))
71 | ;
72 | ; (find-files# frame? "\\\\zeus\\usadata0\\Proteus\\usadata0\\833T-303\\scene-026\\frames"))
73 |
74 | ;; returns a string list of filenames from the path
75 | (define (directory-list-str path)
76 | (map (λ (path) (path->string path))
77 | (directory-list path #:build? #t)))
78 |
79 | ;; convert filename path to string if necessary
80 | (define (filename-path->string filename-path)
81 | (if (path? filename-path) (path-element->string filename-path) filename-path))
82 |
83 | ;; create a list of files with the same provided content
84 | (define (create-list-of-files filenames content)
85 | (let ((create-text-file (λ (file) (display-lines-to-file content file
86 | #:separator #"\n"
87 | #:mode 'binary
88 | #:exists 'replace))))
89 | (map create-text-file filenames)))
90 |
91 | ;; Runs a file operation only if the first file in the list doesn't exist
92 | (define (run-if-not-exists list-of-files operation)
93 | (if (not (file-exists? (first list-of-files)))
94 | (operation)
95 | (display "Files already exist. Skipping...\n")))
96 | ; unit test
97 | ; (run-if-not-exists list-of-files (create-list-of-files list-of-files file-lines))
98 |
99 | ;; Displays a file operation's error count with custom message from its result.
100 | (define (get-error-count result msg)
101 | (if (null? result) (string-append "No " msg ".")
102 | (string-append (number->string (length result)) " " msg " with "
103 | (number->string (count (λ (r) (equal? r 'error)) result)) " error(s).")))
104 | ; unit test
105 | ;(check-equal? (get-error-count (process-text-files my-process list-of-files) "files processed")
106 | ; "3 text files processed with 0 error(s).")
107 |
108 | ;; Displays a file operation's error count with custom message from its result.
109 | (define (display-error-count result msg)
110 | (if (null? result) (display (string-append "No " msg "."))
111 | (display
112 | (string-append (number->string (length result)) " " msg " with "
113 | (number->string (count (λ (r) (equal? r 'error)) result)) " error(s)."))))
114 | ; unit test
115 | ;(display-error-count (process-text-files my-process list-of-files) "files processed")
116 | ; --> "X text files processed with 0 error(s)."
117 |
118 | ;; applies an operation to a list of files, line by line :
119 | ; - load each file as a list;
120 | ; - apply the process to the list;
121 | ; - save the file.
122 | (define (process-text-files process file-list)
123 | (if (and (procedure? process)
124 | (non-empty-list? file-list))
125 | (let ((process (λ (file)
126 | (let* ((file-lines (file->lines file #:line-mode 'any #:mode 'binary))
127 | (new-lines (map process file-lines)))
128 | (begin (make-backup-file file) ; make a backup file before update
129 | (display-lines-to-file new-lines file
130 | #:separator #"\n"
131 | #:mode 'binary
132 | #:exists 'replace))))))
133 | (map process file-list))
134 | null))
135 | ; unit test
136 | ;(define (my-process line) (string-replace line "source" "destination"))
137 | ;(display-error-count (process-text-files my-process list-of-files) "text files processed")
138 | ; --> "3 text files processed with 0 error(s)."
139 |
140 | ; Predicate that tests of all items in the list are paths of directories and exist
141 | (define (directories-exist? list-of-dirs)
142 | (if (list? list-of-dirs)
143 | (if (andmap path? list-of-dirs)
144 | (andmap directory-exists? list-of-dirs)
145 | #f)
146 | #f))
147 |
148 | ; Writes a backup file in the same folder - supports paths and string-paths
149 | (define (make-backup-file path)
150 | (if (path-for-some-system? path)
151 | (copy-file path (string->path (string-append (path->string path) ".old")) #t)
152 | (copy-file path (string-append path ".old") #t)))
153 |
154 | ; Add a file extension to a string if string isn't empty
155 | (define (add-file-extension filename extension)
156 | (if (non-empty-string? filename)
157 | (string-append filename extension)
158 | ""))
159 |
160 | ; Add a file extension to a list of strings if not empty
161 | (define (add-file-extensions filenames extension)
162 | (if (non-empty-list? filenames)
163 | (map (curryr string-append extension) filenames)
164 | null))
165 |
166 | ; Copy one file to multiple folders
167 | (define (copy-file-to-folders source-path destination-list overwrite?)
168 | (let ((copy-func (lambda (dest)
169 | (begin ; Delete file prior to copy as copy-file doesn't seem to overwrite files
170 | (if (and overwrite? (file-exists? dest)) (delete-file dest) null)
171 | (copy-file source-path dest overwrite?))))
172 | (dest-list (map
173 | (curry ; curry fonction to build destination path
174 | (lambda (source destination)
175 | (build-path destination (last (explode-path source))))
176 | source-path)
177 | destination-list)))
178 | (for-each copy-func dest-list)))
179 |
180 | ; returns the last part of a path (the file name)
181 | (define (get-last-path-part path)
182 | (if (non-empty-string? path)
183 | (if (string-contains? path "\\")
184 | (last (string-split path "\\"))
185 | (last (string-split path "/")))
186 | ""))
187 | ; unit test
188 | (module+ test
189 | (check-equal?
190 | (get-last-path-part "/USA_DB/jobs/833T-201/palette-library/00C_BNTWNB_Baron_Thug_Twin_B.plt")
191 | "00C_BNTWNB_Baron_Thug_Twin_B.plt")
192 | (check-equal?
193 | (get-last-path-part "00C_BNTWNB_Baron_Thug_Twin_B.plt")
194 | "00C_BNTWNB_Baron_Thug_Twin_B.plt")
195 | (check-equal?
196 | (get-last-path-part "")
197 | ""))
198 |
199 | ; returns the filename without extension
200 | (define (get-filename filename-w-ext)
201 | (if (non-empty-string? filename-w-ext)
202 | (first (string-split filename-w-ext "."))
203 | ""))
204 | ; unit test
205 | (module+ test
206 | (check-equal? (get-filename "00C_BNTWNB_Baron_Thug_Twin_B.plt") "00C_BNTWNB_Baron_Thug_Twin_B")
207 | (check-equal? (get-filename "") ""))
208 |
209 | ; returns a list of filenames without their extension
210 | (define (get-filenames filenames-w-ext)
211 | (if (list? filenames-w-ext)
212 | (map get-filename filenames-w-ext)
213 | null))
214 | ; unit test
215 | (module+ test
216 | (check-equal?
217 | (get-filenames '("00C_BNTWNB_Baron_Thug_Twin_A.plt" "00C_BNTWNB_Baron_Thug_Twin_B.plt"))
218 | '("00C_BNTWNB_Baron_Thug_Twin_A" "00C_BNTWNB_Baron_Thug_Twin_B"))
219 | (check-equal? (get-filenames '()) null))
220 |
221 | ;; returns filename extension
222 | (define (get-file-extension filename-path)
223 | (let ((filename-text (filename-path->string filename-path))) ; convert path to string if necessary
224 | (string-append "." (last (string-split filename-text ".")))))
225 | ; unit test
226 | (module+ test
227 | (check-equal? (get-file-extension "final-0001.cgi") ".cgi"))
228 |
229 | ;; returns filename extensions from a list of filenames
230 | (define (get-file-extensions filenames)
231 | (if (non-empty-list? filenames) (map get-file-extension filenames)
232 | null))
233 | ; unit test
234 | (module+ test
235 | (check-equal? (get-file-extensions (list "final-0001.cgi" "frame-0590.tga")) (list ".cgi" ".tga")))
236 |
237 | ;; automatically converts a string to path if it's a string, else keeps the path
238 | (define (path! path-or-string)
239 | (if (path-for-some-system? path-or-string) path-or-string (string->path path-or-string)))
240 |
241 | ;; returns a list of lines from a file - supports paths and string-paths
242 | (define (get-file-lines path)
243 | (file->lines (path! path) #:mode 'binary #:line-mode 'any))
244 | ; unit test
245 | ;(get-file-lines "C:\\TEMP\\_TX-palette-changes\\scene-382\\elements\\VRNSTCU_Staff_2\\PALETTE_LIST")
246 |
247 | ;; writes a list of file lines to disk - supports paths and string-paths
248 | (define (write-file-lines lines path)
249 | (display-lines-to-file lines (path! path) #:mode 'binary #:exists 'replace))
250 |
251 | ;; returns a list of files which match a prefix and an extension from a root path
252 | (define (get-file-list-from-prefix-ext path prefix extension)
253 | (define (file-pred filepath)
254 | (let ((filename (path->string (file-name-from-path filepath))))
255 | (if (and (string-prefix? filename prefix)
256 | (string-suffix? filename extension)) #t #f)))
257 | (find-files file-pred path))
258 |
259 | ; Predicate that tests of all items in the list are paths of directories and exist
260 | (define (directories-exist? l)
261 | (if (list? l)
262 | (if (andmap path? l)
263 | (andmap directory-exists? l)
264 | #f)
265 | #f))
266 |
267 | ;; replace a filename in a full path with another filename
268 | (define (replace-filename-in-path full-path new-filename)
269 | (string-append (path->string (path-only full-path)) new-filename))
270 | ; unit test
271 | (module+ test
272 | (check-equal? (replace-filename-in-path (string->path "C:\\test\\path\\some-folder") "package-name")
273 | "C:\\test\\path\\package-name"
274 | "get-package-path-string"))
275 |
276 | ;; returns the name of a folder from its path as string
277 | (define (get-file-name path)
278 | (path->string (last (explode-path path))))
279 |
280 | ;; helper function to sort paths - converts two paths to a string and compare them
281 | (define (pathstring p1) (path->string p2))
284 | #f))
285 |
286 | ;; sort a list of paths alphabetically
287 | (define (sort-paths paths)
288 | (if (andmap path? paths)
289 | (sort paths pathpath path)))))
328 |
329 | ;; predicate returns true if argument is a list of paths which point to existing files.
330 | (define (folder-paths? paths)
331 | (and (list? paths)
332 | (not (null? paths))
333 | (andmap folder-path? paths)))
334 |
335 | ;; attempts to cleanly copy a file with exception handling
336 | ;; displays an error if copy fails
337 | (define (maybe-copy-file source destination error-message exists-ok?)
338 | (when (and (non-empty-string? source) (file-exists? source))
339 | (with-handlers ([exn:fail:filesystem? (λ (e) (show-error-message error-message))])
340 | (when (and exists-ok? (file-exists? destination)) (delete-file destination)) ; Racket bugfix
341 | (copy-file source destination exists-ok?))))
342 |
343 | ;; write a list to file as is
344 | (define (list->file l file)
345 | (write-to-file l file #:exists 'replace #:mode 'text))
346 |
347 |
348 | ; EOF
349 |
--------------------------------------------------------------------------------
/menu-bar.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/gui
2 | (provide menu-bar
3 | ------------------------
4 | file-menu
5 | file-new
6 | file-open
7 | file-save
8 | file-save-as
9 | file-exit
10 | edit-menu
11 | edit-copy
12 | edit-paste
13 | edit-select-all
14 | help-menu
15 | help-about)
16 |
17 | ;;; purpose
18 |
19 | ; to provide a nice default menu bar.
20 |
21 | ;;; utilities
22 |
23 | ;; makes a separator
24 | (define (------------------------)
25 | (void (new separator-menu-item% (parent file-menu))))
26 |
27 | ;;; defs
28 |
29 | ;; main menu bar
30 | (define menu-bar
31 | (new menu-bar% (parent main-window)))
32 |
33 | ;; [file] menu
34 | (define file-menu
35 | (new menu% (parent menu-bar)
36 | (label "&File")))
37 |
38 | ; new menu item
39 | (define file-new
40 | (new menu-item% (parent file-menu)
41 | (label "&New")
42 | (callback (λ (c e) (void)))))
43 |
44 | (------------------------)
45 |
46 | ; open menu item
47 | (define file-open
48 | (new menu-item% (parent file-menu)
49 | (label "&Open...")
50 | (callback (λ (c e) (void)))))
51 |
52 | ; save menu item
53 | (define file-save
54 | (new menu-item% (parent file-menu)
55 | (label "&Save")
56 | (callback (λ (c e) (void)))))
57 |
58 | ; save as menu item
59 | (define file-save-as
60 | (new menu-item% (parent file-menu)
61 | (label "Save &As...")
62 | (callback (λ (c e) (void)))))
63 |
64 | (------------------------)
65 |
66 | ; exit menu item
67 | (define file-exit
68 | (new menu-item% (parent file-menu)
69 | (label "&Exit")
70 | (callback file-exit-callback)))
71 |
72 | ;; [edit] menu
73 | (define edit-menu
74 | (new menu% (parent menu-bar)
75 | (label "Edit")))
76 |
77 | ; copy menu item
78 | (define edit-copy
79 | (new menu-item% (parent edit-menu)
80 | (label "&Copy")
81 | (callback (λ (c e) (void)))))
82 |
83 | ; paste menu item
84 | (define edit-paste
85 | (new menu-item% (parent edit-menu)
86 | (label "&Paste")
87 | (callback (λ (c e) (void)))))
88 |
89 | ; select all menu item
90 | (define edit-select-all
91 | (new menu-item% (parent edit-menu)
92 | (label "Select &All")
93 | (callback (λ (c e) (void)))))
94 |
95 | ;; [help] menu
96 | (define help-menu
97 | (new menu% (parent menu-bar)
98 | (label "Help")))
99 |
100 | ; about menu item
101 | (define help-about
102 | (new menu-item% (parent help-menu)
103 | (label "&About...")
104 | (callback help-about-callback)))
105 |
106 |
107 | ; EOF
108 |
--------------------------------------------------------------------------------
/sql.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/gui
2 | (require db)
3 | (require srfi/19)
4 | (require db/util/datetime)
5 | (require "commons.rkt")
6 | (provide query-execute ; (query-execute db query)
7 | query-record ; (query-record db query)
8 | query-string ; (query-string db query)
9 | get-query-headers ; (get-query-headers query) ('AS' required)
10 | get-query-headers# ; (get-query-headers# query) ('AS' not required, ignores subqueries)
11 | get-query-headers* ; (get-query-headers* db query) ('AS' not required, but does not support complex sub-queries)
12 | get-query-results ; (get-query-results db query wildcard-list)
13 | list->file ; (list->file l file)
14 | ml->sl ; (ml->sl l)
15 | sql-ml->sl ; (sql-ml->sl l)
16 | get-tables ; (get-tables db)
17 | get-tables* ; (get-tables* db-schema)
18 | get-table-columns ; (get-table-columns db table)
19 | get-table-columns-and-types ; (get-table-columns-and-types db table)
20 | get-db-schema ; (get-db-schema db tables)
21 | make-select-query ; (make-select-query db table columns)
22 | table-contains? ; (table-contains? db column table)
23 | which-tables-contain? ; (which-tables-contain? db tables column)
24 | which-tables-contain?* ; (which-tables-contain?* db-schema column)
25 | write-db-schema-to-file ; (write-db-schema-to-file db tables file)
26 | read-db-schema-from-file ; (read-db-schema-from-file file)
27 | update-db-schema ; (update-db-schema db db-schema)
28 | get-tables-that-contain-each-column-in-query) ; (get-tables-that-contain-each-column-in-query db db-schema query)
29 | (module+ test
30 | (require rackunit))
31 |
32 | ;;; purpose
33 |
34 | ; to provide a collection of useful procedures for handling SQL connections and queries
35 |
36 | ;;; notes
37 |
38 | ; Sample queries :
39 |
40 | ; Straight execution
41 | ;(query-exec nodixianet "create temporary table the_numbers (n integer, d varchar(20))")
42 |
43 | ; Read more than one row
44 | ;(query-rows pgc "select n, d from the_numbers where n % 2 = 0")
45 |
46 | ; Read just one row
47 | ;(query-row pgc "select * from the_numbers where n = 0")
48 |
49 | ; Read just one column as list
50 | ;(query-list pgc "select d from the_numbers order by n")
51 |
52 | ; Read just one value
53 | ;(query-value pgc "select count(*) from the_numbers")
54 |
55 | ; If query returns zero or more rows, use
56 | ;(query-maybe-row pgc "select d from the_numbers where n = 5") --> #f if row, row if any
57 | ;(query-maybe-value pgc "select d from the_numbers where n = 5") --> #f if value, value if any
58 |
59 | ; Parametrized queries:
60 | ;(query-value pgc "select d from the_numbers where n = $1" 2)
61 | ;(query-list pgc "select n from the_numbers where n > $1 and n < $2" 0 3)
62 |
63 | ;;; defs
64 |
65 | ;; write a list to file as is
66 | (define (list->file l file)
67 | (write-to-file l file #:exists 'replace #:mode 'text))
68 |
69 | ; Returns a list of list of tables that contain the specified column
70 | (define (get-tables-that-contain-each-column-in-query db db-schema query)
71 | (let* ((query-columns (get-query-headers* db query))
72 | (tables-that-contain-one-of-the-columns (map (curry which-tables-contain?* db-schema) query-columns)))
73 | tables-that-contain-one-of-the-columns))
74 | ; Test
75 | ;(get-tables-that-contain-each-column-in-query "SELECT produit_num, produit_idp FROM produit WHERE produit_num = 0")
76 |
77 | ; Update a db schema by reading it from the database (the associated table list is also refreshed with a restart)
78 | (define (update-db-schema db db-schema)
79 | (begin
80 | (displayln "Updating db schema. This can take a while...")
81 | (set! db-schema (get-db-schema db null))
82 | (displayln "All done!")))
83 |
84 | ; Returns a list of table names and their respective column list. If [tables] is null, the table list is read from the database
85 | (define (get-db-schema db tables)
86 | (let* ((table-list (if (null? tables) (get-tables db) tables)) ; gather table list from db if none provided
87 | (column-list (map (curry get-table-columns db) table-list)))
88 | (zip table-list column-list)))
89 |
90 | ; Writes the full database schema to file. [tables] is optional and the function can gather the table list directly if it is not specified
91 | (define (write-db-schema-to-file db tables file)
92 | (let* ((table-list (if (null? tables) (get-tables db) tables)) ; gather table list from db if none provided
93 | (tables-and-columns (get-db-schema db table-list)))
94 | (list->file tables-and-columns file)))
95 | ; Test
96 | ;(write-db-schema-to-file db nodixia-tables "nodixianet.schema")
97 |
98 | ; Reads a database schema from file
99 | (define (read-db-schema-from-file file)
100 | (with-input-from-file file read))
101 |
102 | ; Return a list of tables from db
103 | (define (get-tables db)
104 | (flatten (sql-ml->sl (query-rows db "SHOW TABLES"))))
105 |
106 | ; Same as get-tables but uses cached db schema for best performance
107 | (define (get-tables* db-schema)
108 | (if (list? db-schema)
109 | (first-of-each db-schema)
110 | null))
111 |
112 | ; Return a list of columns from a table
113 | (define (get-table-columns db table)
114 | (first-of-each (sql-ml->sl (query-rows db (format "SHOW COLUMNS FROM ~a" table)))))
115 |
116 | ; Return a list of columns and types from a table
117 | (define (get-table-columns-and-types db table)
118 | (sql-ml->sl (query-rows db (format "SHOW COLUMNS FROM ~a" table))))
119 |
120 | ; Predicate that returns true if the specified column name exists in the specified table
121 | (define (table-contains? db column table)
122 | (if (and (non-empty-string? table) (non-empty-string? column))
123 | (let ((columns (get-table-columns db table)))
124 | (if (member column columns) #t #f)) #f))
125 | ; Test
126 | ;(table-contains? db "produit" "produit_num")
127 |
128 | ; Predicate that returns true if the list has a second element
129 | (define (second? l)
130 | (if (list? l)
131 | (if (>= (length l) 2)
132 | (if (second l) #t #f)
133 | #f) #f))
134 | ; unit test
135 | (module+ test
136 | (check-equal? (second? '(1)) #f)
137 | (check-equal? (second? '(1 2)) #t)
138 | (check-equal? (second? '(1 2 3)) #t))
139 |
140 | ; Predicate that returns true if the second element of the list is '#true (and nothing else!)
141 | (define (second-true? l)
142 | (if (second? l)
143 | (if (equal? (second l) #t) #t #f)
144 | #f))
145 | ; unit test
146 | (module+ test
147 | (check-equal? (second-true? '(1 anything)) #f)
148 | (check-equal? (second-true? '(1 #t)) #t))
149 |
150 | ; Returns a list of tables which contain the given column name
151 | (define (which-tables-contain? db tables column)
152 | (if (and (list? tables) (non-empty-string? column))
153 | (let* ((results (map (curry table-contains? db column) tables))
154 | (zipped (zip tables results)))
155 | (first-of-each (filter second-true? zipped)))
156 | null))
157 | ; Test
158 | ;(which-tables-contain? db nodixia-tables "produit_num")
159 |
160 | ; same as which-tables-contain? uses stored db schema for best performance
161 | (define (which-tables-contain?* db-schema column)
162 | (if (and (list? db-schema) (non-empty-string? column))
163 | (let* ((tables (first-of-each db-schema)) ; list of strings.
164 | (list-of-column-lists (second-of-each db-schema)) ; list of lists.
165 | (column-in-list? (lambda (c l) (if (member c l) #t #f)))
166 | (results (map (curry column-in-list? column) list-of-column-lists))
167 | (zipped (zip tables results)))
168 | (first-of-each (filter second-true? zipped)))
169 | null))
170 | ; Test
171 | ;(which-tables-contain?* nodixia-schema "produit_num")
172 |
173 | ; Generic query launcher with automatic conversion to list of strings and swap columns and rows for display in a listbox
174 | (define (get-query-results db query wildcard-list)
175 | (if (not (string? query)) #f
176 | (swap-columns-and-rows (sql-ml->sl (apply query-rows db query wildcard-list)))))
177 |
178 | ; Get MySQL table column names for listbox headers - TESTED
179 | (define (get-table-headers db table)
180 | (if (null? table) #f
181 | (map (lambda (l) (car l))
182 | (ml->sl (query-rows db (format "SHOW COLUMNS FROM ~a" table))))))
183 |
184 | ; Get an SQL query's SELECT items as a string (helper for get-query-headers#)
185 | (define (get-query-params query)
186 | (string-join (match (string-split query " ")
187 | [(list "SELECT" params ... "FROM" tables ...) params]) " "))
188 |
189 | ; Build a SELECT query from the name of a table and a list of columns
190 | (define (make-select-query db table columns)
191 | (if (and (non-empty-string? table) (list? columns))
192 | (let* ((first-id (cond [(null? columns) null]
193 | [(equal? columns #f) #f]
194 | [else (car columns)]))
195 | (comma-delimited-ids (cond [(null? columns) "*"]
196 | [(equal? columns #f) null]
197 | [else (string-append (apply string-append (map (curryr string-append ", ") (all-but-last columns))) (last columns))])))
198 | (cond [(equal? columns #f) #f] ; exit
199 | [(null? columns) (string-append "SELECT " comma-delimited-ids " FROM " table " LIMIT 50")] ; Return SELECT * type query
200 | [else (string-append "SELECT " comma-delimited-ids " FROM " table " ORDER BY " first-id " LIMIT 50")])) #f)) ; Return complete query or false if no table provided
201 |
202 | ; Utility function to convert SQL query string to list the proper way
203 | (define (sql-query->list query-params)
204 | (map (curryr string-split " ") (map (curryr string-replace2 "(" " ( " ")" " ) ") (map string-trim (string-split query-params ",")))))
205 |
206 | ; Same as get-query-headers but with support for arbitrary queries mixing 'AS' operators and straight columns without 'AS', as well as subqueries (which are ignored) - TESTED
207 | (define (get-query-headers# query)
208 | (let ((param-list (sql-query->list (get-query-params query))))
209 | (match param-list
210 | [(list (or (list columnname) (list _ "AS" columnname) (list _ ... "AS" columnname)) ...) columnname])))
211 | ; Unit-test
212 | (module+ test
213 | (check-equal? (get-query-headers# "SELECT d.a AS c1, d.b AS c2, d.c AS c3, c4, c5, (SELECT d FROM other-table WHERE e = 9) AS c6 FROM table d LEFT JOING table2 ON (t.column1 = t2.column2) WHERE e = 1 AND f = 2 LIMIT 100") '("c1" "c2" "c3" "c4" "c5" "c6")))
214 |
215 | ; Same as get-query-headers# but with support for parsing column names from nested queries lacking AS
216 | (define (get-query-headers## query)
217 | (let ((param-list (sql-query->list (get-query-params query))))
218 | (match param-list
219 | [(list (or
220 | (list columnname)
221 | (list _ "AS" columnname)
222 | (list _ ... "AS" columnname)
223 | (list "(" "SELECT" columnname ... "FROM" _ ... ")")
224 | (list "(" "IFNULL" columnname _ ... ")") ; IFNULL(d.lig_nodoc, IF(p.produit_palette > '', (SELECT lig_nodoc FROM mw_doclig WHERE lig_ref = p.produit_palette LIMIT 1), ''))
225 | (list "(" "IFNULL" _ ... "AS" columnname ")")
226 | )
227 | ...) columnname])))
228 | ; Unit-test
229 | ;(check-equal? (get-query-headers## "SELECT d.a AS c1, IFNULL(c2, IF(c25 > '', (SELECT c26 FROM more-tables WHERE c27 = 2 LIMIT 1), '')), d.c AS c3, c4, c5, (SELECT d FROM other-table WHERE e = 9) AS c6 FROM table d WHERE e = 1 AND f = 2 LIMIT 100") '("c1" "c2" "c3" "c4" "c5" "c6"))
230 | ;(get-query-headers## "SELECT d.a AS c1, IFNULL(c2, IF(c25 > '', (SELECT c26 FROM more-tables WHERE c27 = 2 LIMIT 1), '')) AS somecolumn, d.c AS c3, c4, c5, (SELECT d FROM other-table WHERE e = 9) AS c6 FROM table d WHERE e = 1 AND f = 2 LIMIT 100")
231 |
232 | ; Returns a list of the SQL 'AS' columns - TESTED
233 | ; Does NOT support nested 'AS' operators!
234 | (define (get-query-headers q)
235 | (let* ((q1 (string-split q " AS ")) ; split string at " AS "
236 | (q2 (map (curryr string-split ",") q1)) ; for each element, split again by ","
237 | (q3 (map car q2)) ; make a list of the first items in each comma-delimited list
238 | (q4 (cdr q3)) ; save the post-AS to another list
239 | (q5 (all-but-last q4)) ;
240 | (q6 (last q4))
241 | (q7 (car (string-split q6 " "))))
242 | (append q5 (list q7))))
243 | ; Unit-test
244 | (module+ test
245 | (check-equal? (get-query-headers "SELECT d.a AS c1, d.b AS c2, d.c AS c3, (SELECT a FROM b WHERE c) AS c4 FROM table d WHERE e = 1 AND f = 2 LIMIT 100") '("c1" "c2" "c3" "c4")))
246 | ;(get-query-headers "SELECT d.a AS c1, IFNULL(c2, IF(c25 > '', (SELECT c26 FROM more-tables WHERE c27 = 2 LIMIT 1), '')) AS somecolumn, d.c AS c3, c4, c5, (SELECT d FROM other-table WHERE e = 9) AS c6 FROM table d WHERE e = 1 AND f = 2 LIMIT 100")
247 |
248 | ; Same as previous but displays the stuff
249 | (define (get-query-headers-parts q)
250 | (let* ((q1 (string-split q " AS ")) ; split string at " AS "
251 | (q2 (map (curryr string-split ",") q1)) ; for each element, split again by ","
252 | (q3 (map car q2)) ; make a list of the first items in each comma-delimited list
253 | (q4 (cdr q3)) ; save the post-AS to another list
254 | (q5 (all-but-last q4)) ;
255 | (q6 (last q4))
256 | (q7 (car (string-split q6 " ")))
257 | (result (append q5 (list q7))))
258 | (begin
259 | (echo "Query: \"" q "\"")
260 | (echo "q1 - split on AS : " q1)
261 | (echo "q2 - map split comma q1 : " q2)
262 | (echo "q3 - map car q2 : " q3)
263 | (echo "q4 - rest q3 : " q4)
264 | (echo "q5 - all-but-last q4 : " q5)
265 | (echo "q6 - last q4 : " q6)
266 | (echo "q7 - car of split q6 on space : " q7)
267 | (echo "result (q5 + q7) column names : " result))))
268 | ; Unit test
269 | ;(get-query-headers-parts "SELECT a AS b, c AS d, e AS f, g AS h FROM table WHERE a = 5")
270 |
271 | ; Same as get-query-headers but with support for '*' statements but limited to somewhat simple queries with mixed columns and AS's - TESTED
272 | (define (get-query-headers* db query)
273 | (if (string-prefix? query "SELECT *")
274 | (let ((table (car (match (string-split query " ") ((list "SELECT" stuff ... "FROM" table ...) table))))) ; Pattern-match * SQL query
275 | (get-table-headers db table))
276 | (get-query-headers## query)))
277 |
278 | ; Convert an sql-date, sql-time or sql-timestamp to human-readable format
279 | (define (sql-date->string date)
280 | (cond [(sql-date? date) (if (equal? (sql-date-month date) 0) "No date"
281 | (date->string (sql-datetime->srfi-date date)))]
282 | [(sql-timestamp? date) (if (equal? (sql-timestamp-month date) 0) "No date"
283 | (date->string (sql-datetime->srfi-date date)))]
284 | [(sql-time? date) (date->string (sql-datetime->srfi-date date))]
285 | [else "Unknown date"]))
286 |
287 | ; Convert a mixed list to a list of strings
288 | ; formerly mixed-list->string-list
289 | (define (ml->sl l)
290 | (cond [(null? l) null]
291 | [(equal? l #f) null]
292 | [(list? (car l)) (cons (ml->sl (car l)) (ml->sl (cdr l)))]
293 | [(vector? (car l)) (cons (ml->sl (vector->list (car l))) (ml->sl (cdr l)))]
294 | [else (cons (~a (car l)) (ml->sl (cdr l)))]))
295 |
296 | ; Convert an sql mixed list to a list of strings
297 | (define (sql-ml->sl l)
298 | (if (null? l) null
299 | (let ((f (car l))
300 | (r (cdr l)))
301 | (cond [(list? f) (cons (sql-ml->sl f) (sql-ml->sl r))]
302 | [(vector? f) (cons (sql-ml->sl (vector->list f)) (sql-ml->sl r))]
303 | [(sql-date? f) (cons (sql-date->string f) (sql-ml->sl r))]
304 | [(sql-time? f) (cons (sql-date->string f) (sql-ml->sl r))]
305 | [(sql-timestamp? f) (cons (sql-date->string f) (sql-ml->sl r))]
306 | [else (cons (~a f) (sql-ml->sl r))]))))
307 |
308 | ;;; Utility functions
309 |
310 | ;; executes an SQL query. Returns #t if successful, #f otherwise.
311 | (define (query-execute db query)
312 | (and (non-empty-string? query)
313 | (query-exec db query)))
314 |
315 | ;; executes an SQL query and returns rows, returns #f if zero row returned
316 | (define (query-record db query)
317 | (and (non-empty-string? query)
318 | (query-rows db query)))
319 |
320 | ;; executes an SQL query and returns the string value, returns #f if zero row returned
321 | (define (query-string db query)
322 | (and (non-empty-string? query)
323 | (query-maybe-value db query)))
324 |
325 |
326 | ; EOF
327 |
--------------------------------------------------------------------------------
/system.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/gui
2 | (provide execute-async ; (execute-async startup-path program-binary-path command-line-parameters)
3 | system->ports) ; (system->ports command)
4 | ;;; defs
5 |
6 | ;; launches a program in a cross-platform way
7 | (define (execute-async startup-path program-binary-path command-line-parameters)
8 | (if (and (non-empty-string? startup-path)
9 | (non-empty-string? program-binary-path)
10 | (file-exists? program-binary-path))
11 | (if (equal? (system-type 'os) 'windows)
12 | (shell-execute #f
13 | program-binary-path
14 | command-line-parameters
15 | startup-path
16 | 'sw_shownormal) ; possible values: 'sw_shownormal 'sw_hide 'sw_minimize
17 | (process program-binary-path))
18 | (show-error-message "This program is not installed.")))
19 |
20 | ;; redirect output and error ports to string, returning both as values
21 | (define (system->ports command)
22 | (let ((out (open-output-string))
23 | (err (open-output-string)))
24 | (parameterize ((current-output-port out)
25 | (current-error-port err))
26 | (system command)
27 | (values (get-output-string out)
28 | (get-output-string err)))))
29 | ; unit test
30 | ;(define-values (output err)
31 | ; (system->ports "notepad.exe"))
32 |
33 | ; EOF
34 |
--------------------------------------------------------------------------------
/xml.rkt:
--------------------------------------------------------------------------------
1 | #lang racket
2 | (provide get-xml-value-from-id) ; (get-xml-value-from-id file pattern)
3 |
4 | ;;; purpose
5 |
6 | ; to provide a useful collection of functions for handling XML and XML files.
7 |
8 | ;;; version history
9 |
10 | ; v1.0 - this version.
11 |
12 | ;;; defs
13 |
14 | ;; returns the value of an XML line given its id (harmony format with value before id)
15 | ;; returns the username given the contents of a localprefs.xml file
16 | ;;
17 | ;; sample use:
18 | ;; (get-xml-value-from-id "C:\\Users\\user\\Desktop\\test.xml" "SOME_XML_VALUE")
19 | (define (get-xml-value-from-id file pattern)
20 | ; read file to lines
21 | (define prefs-lines
22 | (file->lines file))
23 | ; helper func to find value line
24 | (define (login line)
25 | (string-contains? line pattern))
26 | ; helper func to extract value alone
27 | (define (clean line)
28 | (define parts (string-split line "\""))
29 | (second parts))
30 | ; build list of matches and return unique match if found
31 | (define matches (filter login prefs-lines))
32 | (if (= (length matches) 1)
33 | (clean (first matches))
34 | #f))
35 |
36 |
37 | ; EOF
38 |
--------------------------------------------------------------------------------