Parse aid

The following script is a must have! It helps you to create parsing rules and test them. If you need to learn more about parse, testing your ideas, you have to use it! Marco Antoniazzi wrote it, congratulation Marco!

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 * 1×0)
        area-rules/ar/line-list: none ; to reactivate auto-wrapping
        resize-face/no-show area-rules area-rules/size + (siz * 1×2)
        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 + 100×0 area-test/offset + area-test/size - 100×0
                if prev-offset <> face/offset [
                    rezize-faces/move (face/offset - prev-offset * 1×0)
                    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: 4×4] origin sp space sp
        Across
        btn “(O)pen…” #”^O” [open_file]
        btn “(S)ave” #”^S” [save_file]
        pad (sp * -1×0)
        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” 300×22
        text bold “Result:”
        text-parsed: text bold as-is ”   NONE   “ black white center
        return
        Below
        guide
        style area-scroll area-scroll 400×200 hscroll vscroll font-name font-fixed para [origin: 2×0 Tabs: 10]
        text bold “Charsets”
        area-charsets: area-scroll wrap
        text-rules: text bold “Rules”
        area-rules: area-scroll wrap
        return
        button-balance: button “|” 6×450 gray feel feel-move edge [size: 1×1]
        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 * 1×0)
                button-balance/size: button-balance/size + (siz * 0×2)
                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 + 8×10 + system/view/resize-border]

Tags: ,

Print This Post Print This Post
246 views
1 Star2 Stars3 Stars4 Stars5 Stars (No Ratings Yet)
Loading ... Loading ...

Leave a Reply

You must be logged in to post a comment.