Rebol[
    Title: "Parseen"
    Date: 18-Mar-2007/9:57:05+1:00
    History: [
        26/Apr/2003/11:30 "working version"
        21/Dec/2004/13:40 "thru-rule added"
        22/Dec/2004/8:05 "lit added"
        18-Mar-2007/1:45:14+1:00 "do-block corrected"
        18-Mar-2007/9:57:05+1:00 "dialect upgraded"
    ]
    File: %parseen.r
    Author: "Ladislav Mecir"
    Purpose: {Parse enhancements}
    Category: [Advanced]
]

#include-check %build.r

alpha: charset [#"a" - #"z" #"A" - #"Z" #"_"]
digit: charset [#"0" - #"9"]
nondigit: complement digit
alnum: union alpha digit
nonalnum: complement alnum
ws: charset [#" " #"^-" #"^/" #"^M" #"^(page)"]
nonws: complement ws

; a rule that always fails, opposite to none
fail: [end skip]

comment [

;   Example # 1

    parseen "ab" [not [any "a" "b"]]
    parseen "b" [not [any "a" "b"]]
    parseen "" [not [any "a" "b"]]

;   Example # 2

    parseen "ab" [not ["aa"] any "a" "b"]
    parseen "aab" [not ["aa"] any "a" "b"]

;   Example # 3

    parseen [1] [any [not [lit [1]] skip]]
    parseen [2] [any [not [lit [1]] skip]]

;   Example # 4

    parseen [1 a] [not [integer!] to end]
    parseen [a 1] [not [integer!] to end]

;   Example # 5

    parseen [a b c 1 d] [any [not [integer!] skip]]
    parseen [a b c d e] [any [not [integer!] skip]]

;   Example # 6

    result: ""
    parseen/all "aa" [to [" " | "<br>"] result: to end]
    probe result
    parseen/all "a a<br>" [to [" " | "<br>"] result: to end]
    probe result
    parseen/all "ab<br> " [to [" " | "<br>"] result: to end]
    probe result

;   Example # 7

    four-digit: [4 digit]
    parseen/all "abcd 1234" [to [four-digit] copy fd four-digit to end]
    probe fd

;   Example # 8

    pm: charset "+-"
    parseen "assdasasasa+" [copy t thru [pm]]
    probe t

;   Example # 9

    parseen ['ahoj] [lit 'ahoj]
    parseen [ahoj] [lit 'ahoj]
]

use [
    enblk
    rule
    rules
    single-rule
    rule-block
    rule-result
    a1 a2
    r1 r2
    stack
    push
    pop
] [
    enblk: func [
        value [any-type!]
    ] [
        either block? get/any 'value [:value] [
            head insert/only copy [] get/any 'value
        ]
    ]

    rules: [
        (
            push [rule-block]
            rule-block: copy []
        )
        any [end break | rule (insert tail rule-block rule-result)]
        (
            rule-result: rule-block
            pop [rule-block]
        )
    ]

    rule: [
        (push [single-rule a1 a2 a3])
        [
            ; repetition-like, "enhanced"
            'to a1: block! :a1 into rules (
                single-rule: build [
                    any [
                        [
                            only rule-result (r1: fail r2: none) |
                            (r1: none r2: fail) skip
                        ]
                        r1
                    ]
                    r2
                ]
            ) |
            'thru a1: block! :a1 into rules (
                single-rule: build [
                    any [only rule-result (r1: none) break | (r1: fail) skip] r1
                ]
            ) |
            ; their "original versions"
            copy single-rule ['to opt skip | 'thru opt skip] |
            ; set
            copy single-rule ['set word!] rule (
                insert/only tail single-rule rule-result
            ) |
            ; copy
            copy single-rule ['copy word!] rule (
                insert/only tail single-rule rule-result
            ) |
            ; repetition-like, "normal"
            [
                copy single-rule 1 2 integer! |
                copy single-rule 'opt |
                copy single-rule 'some |
                copy single-rule 'any |
                copy single-rule 'into |
                (single-rule: copy [])
            ]
            [
                a1: block! :a1 into rules (
                    insert/only tail single-rule rule-result
                ) |
                'lit end | ; invalid LIT use, ignored
                'lit
                [
                    set a1 block! |
                    set a1 paren! (a1: enblk do a1) |
                    copy a1 skip
                ]
                (
                    insert/only tail single-rule build [
                        copy r1 ins length? a1 skip (
                            r1: unless r1 = only a1 [fail]
                        )
                        r1
                    ]
                ) |
                'not end | ; invalid NOT use, ignored
                'not rule (
                    insert/only tail single-rule build [
                        [only rule-result (r1: fail) | (r1: none)] r1
                    ]
                ) |
                'at end | ; invalid AT use, ignored
                'at rule (
                    insert/only tail single-rule build [
                        [only rule-result (r1: none) | (r1: fail)] fail | r1
                    ]
                ) |
                'either
                rule (a1: rule-result)
                rule (a2: rule-result)
                rule (
                    insert/only tail single-rule build [
                        [only a1 (r1: only a2) | (r1: only rule-result)] r1
                    ]
                ) |
                'check set a1 paren! (
                    insert/only tail single-rule build [
                        (r1: unless do only a1 [fail]) r1
                    ]
                ) |
                'check | ; invalid CHECK use, ignored
                'use block! end | ; invalid USE use, ignored
                'use set a1 block! rule (
                    insert/only tail single-rule build [
                        (push only a1) only rule-result (pop only a1)
                    ]
                ) |
                'use | ; invalid USE use, ignored
                copy a1 skip (insert tail single-rule a1) |
                none
            ]
        ]
        (
            rule-result: single-rule
            pop [single-rule a1 a2 a3]
        )
    ]

    stack: copy []
    push: func [block [block!]] [
        foreach variable block [insert/only tail stack get/any variable]
    ]
    pop: func [block [block!]] [
        set/any block stack: skip tail stack negate length? block
        clear stack
    ]

    compile: func [
        {compile an enhanced PARSE rule}
        [catch]
        rule-to-compile [block!]
    ] [
        parse rule-to-compile rules
        return rule-result
    ]
]

parseen: func [
    "Parses a series according to rules."
    input [series!] "Input series to parse"
    rules [block! string! none!] "Rules to parse by"
    /all "Parses all chars including spaces."
    /case "Uses case-sensitive comparison."
    /local call
] [
    call: copy [parse]
    if all [insert tail call 'all]
    if case [insert tail call 'case]
    call: reduce [to path! call :input compile rules]
    do call
]