Here is the source:
REBOL [
title: "Parse Aid"
file: %parse-aid.r
author: "Marco Antoniazzi"
Copyright: "(C) 2011 Marco Antoniazzi. All Rights reserved"
email: [luce80 AT libero DOT it]
date: 24-09-2011
version: 0.5.5
Purpose: "Help make and test parse rules"
History: [
0.5.1 [03-09-2011 "First version"]
0.5.2 [04-09-2011 "modified resizing"]
0.5.3 [17-09-2011 "Added balancing, changed save format (using strings to preserve comments)"]
0.5.4 [18-09-2011 "Modified infinite loop exit mode,fixed scrollers"]
0.5.5 [24-09-2011 "added shift-selecting"]
]
comment: "28-Aug-2011 GUI automatically generated by VID_build. Author: Marco Antoniazzi"
license: 'BSD
]
; file
change_title: func [/modified] [
clear find/tail main-window/text "- "
if modified [append main-window/text "*"]
append main-window/text to-string last split-path any [job-name %Untitled]
main-window/changes: [text] show main-window
]
open_file: func [/local file-name temp-list job] [
until [
file-name: request-file/title/keep/only/filter "Load a rules file" "Load" "*.r"
if none? file-name [exit]
exists? file-name
]
job-name: file-name
temp-list: load file-name
if not-equal? first temp-list 'Parse_Aid-block [exit]
job: temp-list
set-face check-clear-res get job/clear-res
set-face check-spaces get job/spaces
set-face field-main-rule job/main-rule
set-face area-charsets job/charsets
set-face area-rules job/rules
set-face area-test job/test
named: yes
change_title
saved?: yes
]
save_file: func [/as /local file-name filt ext response job] [
;if empty? job [return false]
if not named [as: true]
if as [
filt: "*.r"
ext: %.r
file-name: request-file/title/keep/only/filter "Save as Rebol file" "Save" filt
if none? file-name [return false]
if not-equal? suffix? file-name ext [append file-name ext]
response: true
if exists? file-name [response: request rejoin [{File "} last split-path file-name {" already exists, overwrite it?}]]
if response <> true [return false]
job-name: file-name
named: yes
]
flash/with join "Saving to: " job-name main-window
job: reduce [
'Parse_Aid-block 1
'clear-res get-face check-clear-res
'spaces get-face check-spaces
'main-rule get-face field-main-rule
'charsets get-face area-charsets
'rules get-face area-rules
'test get-face area-test
]
save job-name job
wait 1.3
unview
change_title
saved?: yes
]
; rules
charsets-block: copy [
digit: charset [#"0" - #"9"]
upper: charset [#"A" - #"Z"]
lower: charset [#"a" - #"z"]
alpha: union upper lower
alpha_: union alpha charset "_"
alpha_digit: union alpha_ digit
hexdigit: union digit charset "abcdefABCDEF"
bindigit: charset "01"
space: charset " ^-^/"
]
rules-block: copy [
digits: [some digit]
sp*: [any space]
sp+: [some space]
area-code: ["(" 3 digit ")"]
local-code: [3 digit "-" 4 digit]
phone-num: [opt area-code copy var local-code (print ["number:" var])]
]
err?: func [blk /local arg1 arg2 arg3 message err][;11-Feb-2007 Guest2
if not error? err: try blk [return :err]
err: disarm err
set [arg1 arg2 arg3] reduce [err/arg1 err/arg2 err/arg3]
message: get err/id
if block? message [bind message 'arg1]
print ["**ERROR: " form reduce message]
]
prin: func [value] [
either 100000 > length? get-face area-results [ ; avoid fill mem
set-face area-results append get-face area-results form reduce value
][
alert "ERROR. Probable infinite loop."
reset-face area-results
throw
]
]
print: func [value] [prin append form reduce value #"^/"]
parse_test: func [/local result] [
if get-face check-clear-res [reset-face area-results]
result: err? [
do get-face area-charsets
do get-face area-rules
do pick [parse/all parse] get-face check-spaces copy get-face area-test get load get-face field-main-rule
]
text-parsed/color: white
show text-parsed
wait .1 ; to see the activity
either logic? result [
text-parsed/color: 80 + either result [green] [red]
text-parsed/text: uppercase form result
] [text-parsed/text: "ERROR" ]
show text-parsed
]
; gui
do decompress ; %area-scroll-style.r Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004}
64#{
eJztWW2P28YR/uz9FQMVhe8Olni6uGmii3NI3cIpYKdBkQQFCB2wRy7FtSlS5a5O
Ugz3t/eZ2eWL5PNLi/Rb4Zcjl7PzvjPP7P39L3/620tKVWErs6Df69boqcvapqqm
zh8qM2uVt56/Tb7DN9pZX1IgMK0joZkovfVl04Lmzza3pqXnGj+2dKYrqx1h0Tw/
nyiz1rZaUNqa142tKZ3k+JBNyDfTrNQtffmUJt66DLsm9LvJbEKTop0slyrXHgpc
fT19va0O06vLy6fqHtJtUy9oPrucXarNtt00DkRv1U+ldYS/mmqzIzYoaBlUB5Wz
d3gDA28hinSdJ01L0N/+2tQeK715M/VXT7qqmh05U5nMQyI1BXmz99RsvYP+5Esw
s2anmauIA0cq9T3eCK/5tKmrA62b3MzUO/W82Rxauyo9dH3xw8/00jhHL0xtWkj+
cXtX2Yxe2szUztDZyxc/vjynKfWb6Oz5OR07md3xTsFo37QHeFeJR9hbl38UX9Hb
wrYOW6FMdU6bIKOFQdqZ2Tuhn9P8D9PLr0E/nzP9nlwF41rK7b1lR9PdgS6hSbXN
zFeXYdMVXT0dNuk8Nzm50hZ+Gr1Vr0Y7lvijQn5xOBYSFfurgcajrFsEF0qsUqWu
6eLigiSkxbYOAcAz+zxrtrU37Ua3nmMSkxavGsm8nwb95X0he8Hu7bqRqETbdJY1
bc5aSkALa6o88sEiPOMLehs+6cy8Uw6vYWvSpUj8krQmb/UKTqhcQ/GFlTwhB2XV
cNL59Yb18GzMNelnem/dE7w8szUygRz88gSfn/FDl3FqCRNsQXVTmxvyRcK2UWr2
1i+VdQteEvopmXxlpvzMdArCFrTGiZvv5yxw2m1O1rpdYX1YwCEICw75yQymYj+Y
XNP3psUhguPLBkdNzGO1Z0hEpIehHHpxmmTNGrzYrUH7ljY2eyNujlsIIjqXqGvE
xyDcbHYwINnTt/3zgdL5Mr1aKpBhjbcjEAlKAhbWeo+sFNN6EwLjZKEp6fjCAfz+
zbcgTsPLElzZmTFWKVjGx8DNusCBJczhDd6iXMmVoAiJvKD7LmXL7sFVxULio2I6
7mzuSxSpLx89enRNuSn0tvK97SSfuyz/AeVqh4REejfkNiazxYF2GkmeDyXpyclm
KTZcZYirzEwJAxyizcbgg67hvsAzQwmhdMk5FPWmFAUy6Y3w7Zbr18otVTkmKB8g
6HQI9lEKR1rouTLtjVAkV2HvsRfClyXqMlIqMBrqY1pUejXl4yR1e/gQCFFtIY7z
+pRy9CWQIjrX7M/vsgy1tWmd6NbyhgXh8FXhZG7vhAUnLfuQa95wYpWWzZxhbwyF
F3jOGS+CL7qSIizudbU1S/RQkcD/J7pV4afsTPp9NGwIBIUxVaLz11vnY8lyQgMr
Vg8JW6aRf8IHc6kyVPH2IbKPaDPaE2R9SpPWPGj4R4WM9ny2EK43IynBu7waJUlF
CHVJhcd+FSXr7IouQsZzjIOfJC36J6Fc0uX+cnnOh18+9KdBjV+TpihgQLIP4oaf
EBSEjlJbLXtu5TG38pjbIXLpf36AWxfjkb3vqXukbXAe+IUfD+hzpE4k30ebBoEf
ig9HNzTwUFhsbT2fB653aPaF2uiaT1coMorFSzHetXpzQ2lfQ7g2LrkU1k1AXLOh
nmEPlyriPWRqxlOojL60WMuaCn2kwL9jRMWCJNp36KtvbgKdoyt6RpWpV77sllD3
ouqRZP4VUE/4t4QY0ZwLi1Rffd/YHKK1p18A7dDaCPZWgKFI8r76sOFhT6w4z6Gc
N115CUQMZzqvsZOIOwdXlWkIPOp8SODHAnxSnAOWk/fOlM7BHQH4LvLu4bccnYiR
uFDB56YOp06+eae4TEhjkoKhQt/kV35SADpmWlkXSfpXFXATrwmi4tPTt+neAzdM
MC7AqcQ35W38jrwCog5s+EkF34eF8AztRxBdVzt9wFRhvJT2EI8zZzprzp8wAAHQ
eOylM0qIjnNS9kSRsr2zYSEZuey67asm5/4qwjnr2cUMD5MxeutbbWlqgCrLkHYW
GXzHUA+gd0CM/WiwKzFN0QCCAVRtdTQwsNiZYrmxxWR+L1ArYSl0Z2FPCkF31rMz
wHhbyyACLPDGHKIEIJXTAaN/n2KiQ1wW2MigWZKpFwIWboqxy2LKAHzm6YvFTG6/
v53e/uv21e0/bn+5/WkS0/qVrvUqzjbhIA7IuWiyLY+BnPcdFBkdT3Hm7qhb6szz
FLZM+7MLM+TL43g041mW89GfXjW89omoQ6Ed0lHYDCp8Qd8MdWDETpA0g9LxoqBU
gE36Yhn4AC66g/NmnfB4hwQGdpiGZvXQ9k/tCfUTymg+SicOMfc4txSHA6QhQwSW
4jAIZaWQpCpvdpiaVTS+bvzU/HOrq2g2C7wYSWTPSHB6leNGkZXIoNYNFD7uLjFj
VjxnYkbjuSp9cHkRqTNkBCDIKQ3O4oJCw+McE6qgYpAcPolGfUJu67A3zDmqYyp7
P4eZBKKVa4IAvxmpR7/jULe9oZ3LRvw/zZ7+d376De3EiITqSSnaRYmjWJnjyhTm
6pPKxP6ejbk+Vci+MC0eeUAmrf3l8eJ0wF8KCXsMx+T5eMoclvo58z8EbQOHDlGw
pqwYKwgdeHTtx9a+D463gAIm/rfRyJq6QJM89sN7pr5n6OCnIWIPw+DtRiKIbr8Z
xY+zz5jc5D2w43BFfw35QD13Tgdv10aYtWYDYPIZjUoWpVtVdLf1Pty2xKuifCZw
7MT28F17e2+4he7QuaBCyXcFZ+MP4j14gk9jIokqbM5Dvj2UViMw06V/n5tcIruU
5Of/Z+InXPeb5igjEEYnAWIwIHEkVwAPoHMumsGhH2zTDD9uoh3MurBjIBGBzPBd
WhlQ0sizoX2uOB07LKHlsvADBsRmfN1fLuIv3wwAXRVts0YIkQebiofbQMRMAlA7
AeANg7LubgvRQXhOZB5NzKGRjAFOhPvSrWEzmj3fDR5/OrnP7CCqGArqaA/b3jVU
eixTGRa7UxLPAnJooy2PUflWMEIEBf1YOZ5Elylmo0hQfpAAjgwwP4KzDuRLg4oZ
MB4ZzMnMEGYLmRyU2jqsyHjUg2/0UoFCMrj0JwoDacDhP6NaWX8Y7odRbLIwiPVx
Ukccu4iAGdl8Twl7nAGpO5rMeDTm8Qy+7FXBjtGEpvmeyMuvId6/DhpdSB+HsyvP
46HQdW+YwTs6p1yfpHGy7H9p0d+ewr/DBUZ/l3fsQO1CzMeRo3i7kBzoClLGQjCX
n/wihKUMFxvlx6V0jPfH8uYqXAuY9cYfbsZ2psNzlwbDHVJ/JRTyRspTd37/DVw/
MtO8GgAA
}
rezize-faces: func [siz [pair!] /move] [
area-charsets/ar/line-list: none ; to reactivate auto-wrapping
resize-face/no-show area-charsets area-charsets/size + (siz * 1x0)
area-rules/ar/line-list: none ; to reactivate auto-wrapping
resize-face/no-show area-rules area-rules/size + (siz * 1x2)
text-test/offset/x: text-test/offset/x + siz/x
area-test/offset/x: area-test/offset/x + siz/x
text-results/offset: text-results/offset + siz
area-results/offset: area-results/offset + siz
if move [siz: - siz]
resize-face/no-show area-test area-test/size + siz
resize-face/no-show area-results area-results/size + siz
]
feel-move: [
engage-super: :engage
engage: func [face action event /local prev-offset] [
engage-super face action event
if (action = 'down) [
face/user-data: event/offset
]
if find [over away] action [
prev-offset: face/offset
face/offset/x: face/offset/x + event/offset/x - face/user-data/x
face/offset/x: first confine face/offset face/size area-charsets/offset + 100x0 area-test/offset + area-test/size - 100x0
if prev-offset <> face/offset [
rezize-faces/move (face/offset - prev-offset * 1x0)
show main-window
]
]
;show face
]
]
;append system/view/VID/vid-styles area-style ; add to master style-sheet
main-window: center-face layout [
styles area-style
do [sp: 4x4] origin sp space sp
Across
btn "(O)pen..." #"^O" [open_file]
btn "(S)ave" #"^S" [save_file]
pad (sp * -1x0)
btn "as..." [save_file/as]
;check-line "save also test" on
pad 350
btn "Clear (T)est" #"^T" [reset-face area-test]
btn "Clear (R)esults" #"^R" [reset-face area-results]
check-clear-res: check-line "before every parse"
return
btn "(P)arse" #"^P" yellow [parse_test]
check-spaces: check-line "also spaces" on
;check-line "on rules update" on
text "with this rule:" bold
field-main-rule: field "phone-num" 300x22
text bold "Result:"
text-parsed: text bold as-is " NONE " black white center
return
Below
guide
style area-scroll area-scroll 400x200 hscroll vscroll font-name font-fixed para [origin: 2x0 Tabs: 10]
text bold "Charsets"
area-charsets: area-scroll wrap
text-rules: text bold "Rules"
area-rules: area-scroll wrap
return
button-balance: button "|" 6x450 gray feel feel-move edge [size: 1x1]
return
text-test: text bold "Test"
area-test: area-scroll "(707)467-8000"
text-results: text bold "Results"
area-results: area-scroll silver read-only
key (escape) (sp * 0x-1) [ask_close]
]
main-window/user-data: reduce ['size main-window/size]
insert-event-func func [face event /local siz] [
switch event/type [
close [
ask_close
return none
]
resize [
face: main-window
siz: face/size - face/user-data/size / 2 ; compute size difference / 2
face/user-data/size: face/size ; store new size
rezize-faces siz
button-balance/offset: button-balance/offset + (siz * 1x0)
button-balance/size: button-balance/size + (siz * 0x2)
show main-window
]
]
event
]
ask_close: does [
either not saved? [
switch request ["Exit without saving?" "Yes" "Save" "No"] reduce [
yes [quit]
no [if save_file [quit]]
]
][
if confirm "Exit now?" [quit]
;quit
]
]
; main
set-face area-charsets trim mold/only charsets-block
set-face area-rules trim mold/only rules-block
job-name: none
named: no
saved?: yes
main-title: join copy System/script/header/title " - Untitled"
view/title/options main-window main-title reduce ['resize 'min-size main-window/size + system/view/title-size + 8x10 + system/view/resize-border]
No comments:
Post a Comment