View script | License | Download script | History | Other scripts by: luce80 |
28-Mar 15:22 UTC
[0.047] 24.791k
[0.047] 24.791k
Archive version of: parse-aid.r ... version: 9 ... luce80 13-Jul-2013Amendment note: Added saving before every parse || Publicly available? Yes REBOL [ title: "Parse Aid" file: %parse-aid.r author: "Marco Antoniazzi" Copyright: "(C) 2011,2012,2013 Marco Antoniazzi. All Rights reserved" email: [luce80 AT libero DOT it] date: 13-07-2013 version: 0.6.1 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"] 0.5.6 [05-01-2012 "added results auto-scrolling"] 0.5.7 [22-01-2012 "little bug fix in error handling"] 0.5.8 [05-05-2012 "added undo (Ctrl+Z) and redo (Ctrl+R)"] 0.5.9 [14-12-2012 "Fixed undo if no field has focus"] 0.6.0 [19-03-2013 "Integrates Brett Handley's parse-analysis-view"] 0.6.1 [13-07-2013 "Added saving before every parse"] ] comment: {28-Aug-2011 GUI automatically generated by VID_build. Author: Marco Antoniazzi For help on using visualize see comments in %parse-analysis-view.r and documentation at wwww.rebol.org } library: [ level: 'intermediate platform: 'all type: 'tool domain: 'parse tested-under: [View 2.7.8.3.1] support: none license: 'BSD see-also: none ] thumbnail: http://i40.tinypic.com/2s0zo5d.png todo: { - parse blocks - undo - ask to save before exit if something modified - scroll-wheel } ] ; file , undo 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 [alert "Not a valid Parse-Aid file" exit] if not-equal? second temp-list 1 [alert "Not a valid Parse-Aid file" 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 /no-flash /local file-name filt ext response job f1] [ ;if empty? job [return false] if not named [as: true] if as [ filt: "*.r" ext: %.r file-name: request-file/title/keep/only/save/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 ] unless no-flash [f1: 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 unless no-flash [ wait 1.3 unview/only f1 change_title ] saved?: yes ] undo: does [ if all [system/view/focal-face system/view/focal-face/parent-face/style = 'area-scroll] [system/view/focal-face/parent-face/undo] ] redo: does [ if system/view/focal-face/parent-face/style = 'area-scroll [system/view/focal-face/parent-face/redo] ] ; 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 arg1: any [attempt [get in err 'arg1] 'unset] arg2: get in err 'arg2 arg3: get in err 'arg3 message: get err/id if block? message [bind message 'arg1] print ["** ERROR: " form reduce message] none ] 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 system/view/vid/vid-feel/move-drag area-results/vscroll/pane/3 1 ; autoscroll down ][ alert "ERROR. Probable infinite loop." reset-face area-results throw ] ] print: func [value] [prin value prin newline] parse_test: func [/local result] [ if get-face check-clear-res [reset-face area-results] if get-face check-save [save_file/no-flash] 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 %../area-scroll-style.r ;Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004} do decompress ; %area-scroll-style.r Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004} 64#{ eJztWUuP5LYRvutXMJ3D2gvIml4bgSHsZg65+OJbYCwg9BgciWopq5Y6Enu6J0H8 2/NVFUlR3T0vZ4NcYsMekawq1otVH9mJHo1OJ/vYmVzRn/YfRhWJzJbj0HW5ooE6 trbBwqGvhlxVg5lUoceMhhuVjGYxS0PM6qr61Q6/Ek3atZPNVX3oS1CUdsN05wSK V5K6PaVT11ZmTPd61J4tWe2GB6O0kjUQl8NYtf1WWXOyqm5NVynRGZPfrVRia7WS NV0ajCeMhTkTOkhxS6TzqLdqpbtpUG5gG6PO6Im0G0rdKbvbky5WtVMCc5K2Vv3Q m1tl64zUVoU5tWROO+U0N5FnU2WqrUnpmwih4m6fq13bq/VpDUkgcOzZTo9bzM8T w9jKBHmSJKRsG0mBj6Y60ycIgJFZpS1mdvqkbkR2kCFmZLlWmTKIKBwADWj88c8g LmQAc9akeO0dUUCo+xR57SQyaI81FGKmZGqGIxRJKPZjrh58AjX+Y+rqnL0EWp5K j21lm1yt/6SSI6IJV+n93vSV0v2jKnhKlcMe3xtyshOpit4csyDfjgfkxbidsHET UzTXKHwoZW9VwMy2t2ZrxlsmyT4I81JDWdmonnzuJOFcVOnQd9Cu7vQ2pVwCwVHN C45yOFhsSLE/J41WmJadV5ZmmiiCX4ySAWyfjGW29/5AsIwH3R0MuYZGOadzpkeV yAfzZoFTzSyOojamwzn822Gy7sxNQpSUndFyPLL5gMazdMp5llTeXlNuI3+gT0ap unHsVwnP9efjZJXZ7e3jrUxzujuJ55UDyhygdfFuRD5ywswsnem3tomEbDZL/0Ra OeOf9U3Cob8ajhcCEXG9YSM66peBp2m/HRcXKQrIb/4O0ygY33xQ7+VAaToZvMQZ F74ykXZzutl8y77nlXDakniYDXUNM7KTbDj/xU6ya3Rwks0srlmKa5biHp2Y8Pcp cT6lYpsvNF4oLD6ERPlzTaWFRo7+5OyK9nwqUlhL5OhK9Wr71tKRpXo3mQ4leq97 aOtKGSvABfk46v2tKkKhouIoyxyqe/SaL7dg6wbs9EF9CsksU9RHZUdHsv7x5jv3 H6kdSg0rQcMp6EgaKarTVGZScfXelJI077jpw4IHZN30OFmzyx5a1KskaufBmlAK orlnur+z6w8b1zfXN/hHfQy2zce6GA03/XtdflFWt928Rl7qJzPajAttg5IbMbIa tJWrWItiJSCm0ZPHIqSEqzTR3q5/gwQNhEpxVAcvtg4byK7wW1bCh9SqAZ3KBvhk dIvYzhtGXRmTViAMFtF86P8/kFPRmniXK+vfc7Jdy0YqORxQ3j19aKf2vkP8vT6+ S3d1EoDbdU/MFl16Yl57Lgiv88QzRrITXvLU1/HEJaVPWJ50rhFGYCW2VBpSUtoT QzFU0tYKKMPe5bDbDxNa0tS0tVXf1ECW5ltM9xZHPYy/GLht2FEp3yycxSnvFP2P dwB0bMiGjVSpne41YKicA7GSqByyBT5QZbcHrCOXo1Q447kilY0GTiLqP67u/rIi X2DA2EyjfgVNm7ajPW9V4nAmc5No8H1eoZI5NtR+WDBvdS4hHXW/BVq+KChxz2/7 ypxuncZ09iVdglglTeY2solBu9ONkAapBm04RbPK1PrQWbazSKDxTysGihjnat8i MhyeOZfWOEAv63fGRNLXG0Ij2OG38x3eKvwJuT+vnuNuL7nBk62In9l/eSs7Midn AIyvdn8/6LHKs2zuW93eSf78rOSA4xYQTtAbh+5NSolHEuH8X2VcALU1mFUhWSWR lzixuzcu6V5jH4v2trF4idint8p4RdCS8C+1jU5bU8XdvrTt0Ps3ANTUTGYEeDj0 T3/4Eii4PJF7Ko3pSyW4txuHFWgyDAk9jY6Sr9YJYdbc32ADyrklivhGVQicYn1o gjoFqqNIoi+UVsZNMuMw1BLEMWhyHIyfvBY5IzjXfNxlbVGo1T3Heb4mpnXbQbcc LZJcw84LHIjYlNohde2Q6iwl6j/vfrpL7367+/nu890vd3/9F/fsUR8XdwHqpWgF cZ3GNZ2X3jmjHJJkmBewYzIPgze1IPTZpyxmvtF+rz5+Wl6pRBwfLS5c0aRUsmKt 0MtZDtpFhCYRAzSc1N11rrC/xCPpCGX01lx4xDwYRNg1NWAIKvGbUOMdAKmGYy9u Oze5aicNGFAF+DM3i9T8/aA7R0dKvY+0Iu8N5SFc4QRTkS5ZNRwgMcUZI69ca+ss 4KXGTq8Z0tc7U1tBDq+VJbxXRAWIAENhbzIbLLoLf+FrmFjdgElqptSR4up07qgd kkrOiXDYclcv6QRIyWbtZWtZYlcGMw+98NJAsiDa4xXS3J1uRB0LT1IEB/29G5Bz DNb6eEdbvGKH/56vvqapfGs96kdfDYTsB4DE4UGeJhey+FXxdLOcTKPnBsGB8fMD fy/fNOep8Kr51keKWYS/O5OupBqpSGgujV5J2SnnLKCgsvB7fYxDhE5+5usLYy9M jVwVwkBY4+rzz2HvipMPjfNMFMwghENp2x1VIA7etRhBE0zKdd+nR4g0ecMHmL7/ H9dXuO8rR1yQm6sc4rIne7FcxkRP4mNgeQ435nUqoNHVL2JMzrqGtM4trAs4wuG5 62r7TrxcPH8ZhVExDHEokvsllEZLpt9UlktnvwX5XyFYJVD7jaGl7wzqHUFOzPlE dtmKGO91OwYI7LtbeDKM3xmh7c3cAJsnSZKAKB2I8nBSyqzH+xFANWcIVZCse/Y7 UKPml4jw+xSaAmMWRsoh7cPbhqfzrgaJaquTysiVDPGmxQMfPWjSKx+8FHYASzFD ehLt0fyV3xmcCxiGL0IVKlD8vDiDaf5ZUCjpRyp3XZlfmMOPOUvz9SRRiz2v3ONv 9qg+ODnz03LzvBzPelpKXDs57ukrUraYv0OY5tf88DQvgaWxPwz/Bja6BRBaHQAA } resize-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/old-offset/x + event/offset/x ;- face/user-data/x ; We cannot modify face/old-offset but why not use it? 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 [ resize-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 check-save: check-line "before every parse" btn "Visualise" sky [visualise] check-ignore: check-line "and ignore charsets" off space sp btn "Clear (T)est" #"^T" [reset-face area-test] btn "Clear R(e)sults" #"^e" [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" with [append init [deflag-face self/ar 'tabbed ]] text-results: text bold "Results" area-results: area-scroll silver read-only key escape (sp * 0x-1) [ask_close] key #"^Z" (sp * 0x-1) [undo] key #"^R" (sp * 0x-1) [redo] ] main-window/user-data: reduce ['size main-window/size] insert-event-func func [face event /local siz] [ switch event/type [ close [ if event/face = main-window [ask_close] if event/face = vis-win [unview/only vis-win] 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 resize-faces siz button-balance/offset: button-balance/offset + (siz * 1x0) button-balance/size: button-balance/size + (siz * 0x2) show main-window ] ] event ] visualise: func [/local modul ruls] [ modul: all [ any [ attempt [do load %parse-analysis.r] if confirm "File %parse-analysis.r not found in current directory, download it?" [ modul: attempt [do load request-download/to http://www.rebol.org/download-a-script.r?script-name=parse-analysis.r %parse-analysis.r] ] ] any [ attempt [do load %parse-analysis-view.r] if confirm "File %parse-analysis-view.r not found in current directory, download it?" [ modul: attempt [do load request-download/to http://www.rebol.org/download-a-script.r?script-name=parse-analysis-view.r %parse-analysis-view.r] ] ] visualise-parse: func [ {Displays your input and highlights the parse rules.} data [string! block!] {Input to the parse.} rules [block! object!] {Block of words or an object containing rules. Each word must identify a Parse rule to be hooked.} body [block!] {Invoke Parse on your input.} /ignore {Exclude specific terms from result.} exclude-terms [block!] {Block of words representing rules.} /local result block tokens ][ if not ignore [exclude-terms: copy []] view/new center-face layout [title "Visualise Parse" label "Tokenising input..."] err? [ tokens: tokenise-parse/all-events/ignore rules body exclude-terms if block? data [ block: data data: mold block convert-block-to-text-tokens/text block tokens data ] ] unview if block? tokens [view/new vis-win: make-token-stepper data tokens] ] do get-face area-charsets do get-face area-rules ruls: context load join get-face area-charsets get-face area-rules visualise-parse/ignore copy get-face area-test ruls [do pick [parse/all parse] get-face check-spaces copy get-face area-test get in ruls to-word get-face field-main-rule] either get-face check-ignore [load get-face area-charsets][[]] ] ] 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 vis-win: none 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] |