Archive version of: parse-analysis.r ... version: 5 ... brett 16-Dec-2004

Amendment note: Bug fix - count-parse || Publicly available? Yes

REBOL [
    Title: "Parse Analysis Toolset"
    Date: 17-Dec-2004
    File: %parse-analysis.r
    Purpose: "Some tools to help learn/analyse parse rules."
    Version: 1.1.0
    Author: "Brett Handley"
    Web: http://www.codeconscious.com
    Library: [
        level: 'intermediate
        platform: 'all
        type: 'tool
        domain: [dialects parse text-processing]
        tested-under: [
            core 2.5.6.31 on [WinNT4] {Basic tests.} "Brett"
        ]
        support: none
        license: none
        comment: {
Copyright (C) 2004 Brett Handley All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

May not be executed within web CGI or other server processes.

Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.  Redistributions
in binary form must reproduce the above copyright notice, this list of
conditions and the following disclaimer in the documentation and/or
other materials provided with the distribution.  Neither the name of
the author nor the names of its contributors may be used to
endorse or promote products derived from this software without specific
prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.  
}
        see-also: none
    ]
]

hook-parse: func [
    "Hook parse rules for events: test a rule (Test), rule succeeds (Pass), rule fails (Fail). Returns hook context."
    rules [block!] "Block of words. Each word must identify a Parse rule to be hooked."
    /local hook-context spec
] [

    ; Check the input

    if not parse rules [some any-word!] [make error! "Expecting a block of words."]

    ; Create the hook context.

    hook-context: context [
        step: level: status: current: ; State tracking variables.
        rule-words: ; The original rules (maintaining their bindings).
        rule-def: ; The original rule values.
        last-begin: ; A variable to track the input position when the rule starts.
        last-end: ; A variable to track the input position when the rule ends.
        pass: fail: test: ; Functions called when the corresponding parse event occurs.
        none
        reset: does [step: level: 0 last-begin: last-end: current: none]
    ]
    hook-context/rule-words: rules

    ; Create a context to store the original rule definitions.

    spec: make block! multiply 2 length? rules
    repeat rule rules [insert tail spec to set-word! rule]
    hook-context/rule-def: context append spec [none]

    ; Modify the given rules to point to the
    ; hook-context's tracking rules and save
    ; the original rules.

    repeat rule rules [

        set in hook-context/rule-def rule reduce [get rule]

        set rule bind reduce [

            ; Rule invocation

            to set-word! 'last-begin
            to paren! compose [
                step: step + 1 level: level + 1
                current: (to lit-word! rule) status: 'test
                test
            ]

            ; Call the original rule.

            in hook-context/rule-def rule

            ; Rule Success

            to set-word! 'last-end
            to paren! compose [
                step: step + 1 level: level - 1
                current: (to lit-word! rule) status: 'pass
                pass
            ]

            '|

            ; Rule failure

            to set-word! 'last-end
            to paren! compose [
                step: step + 1 level: level - 1
                current: (to lit-word! rule) status: 'fail
                fail
            ]
            'end 'skip ; Ensure the failure result is maintained.

        ] in hook-context 'self

    ]

    ; Return the hook-context.
    hook-context

]

unhook-parse: func [
    "Unhooks parse rules hooked by the Hook-Parse function."
    hook-context [object!] "Hook context returned by the Hook-Parse function."
] [
    repeat rule hook-context/rule-words [set rule first get in hook-context/rule-def rule]
    hook-context/rule-def: none ; Clear references to original rules.
    hook-context/reset
    return ; return unset
]

count-parse: func [
    "Returns counts of calls, successes, fails of Parse rules."
    body [block!] "Expression to invoke Parse on your input."
    hook-context [object!] "Hook context returned by the Hook-Parse function."
    /local ctr-t ctr-p ctr-f increment
] [

    ; Initialise counters
    foreach w [ctr-t ctr-p ctr-f] [set w array/initial length? hook-context/rule-words 0]

    ; Helper function
    increment: func [ctr /local idx] [
        idx: index? find hook-context/rule-words hook-context/current
        poke ctr idx add 1 pick ctr idx
    ]

    ; Bind to the hook-context. Note that the event functions *must* be bound to the same context.
    do bind [
        test: does [increment ctr-t]
        pass: does [increment ctr-p]
        fail: does [increment ctr-f]
    ] in hook-context 'self

    ; Invoke the parse as specified by user.
    hook-context/reset
    do body

    ; Return result
    reduce [copy hook-context/rule-words ctr-t ctr-p ctr-f]
]

explain-parse: func [
    "Emits numbered parse steps."
    body [block!] "Invoke Parse on your input."
    hook-context [object!] "Hook context returned by the Hook-Parse function."
    /begin begin-fn [any-function!] "Function called when rule begins. Spec: [context-stack [block!] begin-context-clone [object!]]"
    /end end-fn [any-function!] "Function called when rule ends.  Spec: [context-stack [block!] begin-context-clone [object!] end-context-clone [object!]]."
] [
    ; Initialise

    if not begin [
        begin-fn: func [context-stack begin-context] [
            print rejoin bind/copy [
                head insert/dup copy "" "  " subtract level 1
                step " begin '" current " at " index? last-begin
            ] in begin-context 'self
        ]
    ]
    if not end [
        end-fn: func [context-stack begin-context end-context] [
            print rejoin bind/copy [
                head insert/dup copy "" "  " (subtract begin-context/level 1)
                step " end '" current " at " index? last-end
                " started-on " begin-context/step " " end-context/status "ed"
            ] in end-context 'self
        ]
    ]

    use [stack] [

        stack: make block! 20

        ; Make the hook-context. Note that the event functions *must* be
        ; bound to the same context.
        do bind [
            test: has [] [
                begin-fn stack hook-context
                insert tail stack make hook-context []
            ]
            pass: has [ctx] [
                ctx: last stack
                remove back tail stack
                end-fn stack ctx hook-context
            ]
            fail: has [ctx] compose [
                ctx: last stack
                remove back tail stack
                end-fn stack ctx hook-context
            ]
        ] in hook-context 'self

        ; Invoke the hook-context
        hook-context/reset
        do body
    ]

    ; Return unset
    return
]

tokenise-parse: func [
    "Tokenises the input using the rule names."
    body [block!] "Invoke Parse on your input. The block must return True in order to return the result."
    hook-context [object!] "Hook context returned by the Hook-Parse function."
] [
    use [stack result fn-b fn-e] [
        stack: make block! 20
        result: make block! 10000
        fn-b: does [insert/only tail stack tail result]
        fn-e: func [context-stack begin-context end-context /local bookmark] [
            bookmark: last stack
            remove back tail stack
            either 'pass = end-context/status [
                insert tail result reduce [
                    end-context/current
                    subtract index? end-context/last-end index? begin-context/last-begin ; Length
                    index? begin-context/last-begin ; Input position
                ]
            ] [clear bookmark]
        ]
        explain-parse/begin/end body hook-context :fn-b :fn-e
        result
    ]
]