blob: 40469e2757dbda829ecf2d3154fd632a1b492dbc (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
(define-module (language python module re parser)
#:use-module (parser stis-parser)
#:export(parse-reg e-matcher pretty))
(define-syntax-rule (mk n tag str) (define n (f-seq tag (f-tag str))))
(mk f-. #:dot ".")
(mk f-^ #:^ "^")
(mk f-$ #:$ "$")
(mk q* #:* "*")
(mk q? #:? "?")
(mk q+ #:+ "+")
(mk q*? #:*? "*?")
(mk q?? #:?? "??")
(mk q+? #:+? "+?")
(define subexpr (f-list #:sub
(f-seq (f-tag "(") (Ds ee) (f-tag ")"))))
(define f-back
(f-or (f-list #:class (mk-token (f-reg! "[AZbBdDsSwntr]")))
(mk-token (f-seq (f-reg! "[0-7]") (f-reg! "[0-7]") (f-reg! "[0-7]"))
(lambda (x)
(list->string
(list (integer->char (string->number x 8))))))
(mk-token (f-reg! "."))))
(define anongroup (f-list #:?: "(?:" (Ds ee) ")"))
(define namegroup (f-list #:?P< "(?P<" (mk-token (f+ (f-not! (f-reg "[> ]")))) ">" (Ds ee) ")"))
(define (ch not)
(f-list #:ch
(f-or! (f-seq (f-char #\\) f-back)
(mk-token (f-not! not)))))
(define number (mk-token (f+ (f-reg! "[0-9]")) string->number))
(define incant (f-list #:?P= "(?P=" (f-or! number
(mk-token (f+ (f-not! (f-reg "[) ]"))))) ")"))
(define coment (f-and
(f-seq "(?#" (f* (f-not (f-tag ")"))) ")")
f-true))
(define repn? (f-list #:rep? "{" number "}" "?"))
(define repnm? (f-list #:rep? "{" number "," number "}" "?"))
(define repn (f-list #:rep "{" number "}"))
(define repnm (f-list #:rep "{" number "," number "}"))
(define lookh (f-list #:?= "(?=" (Ds ee) ")"))
(define lookh! (f-list #:?! "(?!" (Ds ee) ")"))
(define rev (f-list #:?<= "(?<=" (Ds ee) ")"))
(define rev! (f-list #:?<! "(?<!" (Ds ee) ")"))
(define flags (f-list #:flags "(?"
(mk-token (f* (f-reg! "[aiLmsux]")))
(f-or!
(f-seq "-" (mk-token (f+ (f-reg! "[imsx]"))))
(f-out ""))
":"
(Ds ee) ")"))
(define flags2 (f-list #:flags2 "(?"
(mk-token (f* (f-reg! "[aiLmsux]")))
")"))
(define (bch f) (f-or! (f-seq (f-or! (f-tag "\\n") f-nl)
(f-out (list->string (list #\newline))))
f))
(define bbody (f-cons (f-or!
(f-list #:range (bch (mk-token (f-reg! ".")))
"-" (bch (mk-token (f-reg! "."))))
(f-list #:ch (bch (mk-token (f-reg! ".")))))
(ff*
(f-or!
(f-list #:range (bch (mk-token (f-not! (f-tag "]"))))
"-"
(bch (mk-token (f-not! (f-tag "]")))))
(f-seq (f-tag " ") (f-out (list #:ch " ")))
(f-list #:ch (bch (mk-token (f-not! (f-tag "]")))))))))
(define (f-if a b c) (f-or! (f-seq a b) c))
(define choice
(f-cons #:bracket
(f-or!
(f-seq "[^]" (f-out (list (list #:ch (f-out #f) (f-out "^")))))
(f-cons*
(f-tag "[")
(f-if (f-tag "^") (f-out #t) (f-out #f))
(f-seq bbody "]")))))
(define f-bar (f-tag "|"))
(define qq (ch (f-reg "[][?+|*.$^()\\]")))
(define atom (f-or qq f-. flags2 choice subexpr anongroup namegroup incant coment
lookh lookh! rev rev! f-^ f-$ flags))
(define spec (f-list #:op atom (f-or! q+? q?? q*? q* q? q+ repn? repnm? repn repnm)))
(define aatom (f-or! spec atom))
(define f-com (f-seq (f-tag "#") (f* (f-not (f-or! f-eof f-nl)))))
(define ws (Ds (if (fluid-ref pretty)
(f* (f-or! f-com f-nl (f-reg "[ \t\r]")))
f-true)))
(define line (f-cons* #:seq ws aatom ws (ff* (f-seq ws aatom ws) )))
(define ee (f-cons* #:or line (ff* (f-seq f-bar line))))
(define pretty (make-fluid #f))
(define (parse-reg str)
(with-fluids ((*whitespace* ws))
(parse str (f-seq ee f-eof))))
(define e-matcher ee)
|
