Commit3a74d4b0Recorded20 Feb 2026Repositorysigil-peg
feat: Add sigil-peg parsing expression grammar library
Message
Implements a PEG library with S-expression pattern DSL inspired by Janet's PEG module. Features recursive interpreter with backtracking, ordered choice, repetition, lookahead, and comprehensive capture system including tagged captures, grouping, and match-time transforms (cmt).
78 tests covering all pattern types and edge cases.
Changed
package.sgl | 16 +++++
src/sigil/peg.sgl | 578 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
test/test-peg.sgl | 449 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 1043 insertions(+)Diff
package.sgladded
@@ -0,0 +1,16 @@
+1
;;; sigil-peg - Parsing Expression Grammar library+2
;;;+3
;;; Provides a PEG pattern matching and parsing library for Sigil,+4
;;; representing patterns as S-expressions with a capture stack for+5
;;; structured output.+6
+7
(package+8
name: "sigil-peg"+9
version: "0.5.0"+10
description: "PEG parsing expression grammar library"+11
url: "https://codeberg.org/sigil/sigil"+12
license: "BSD-3-Clause"+13
authors: (list "David Wilson <[email protected]>")+14
+15
dependencies: (list+16
(from-workspace name: "sigil-stdlib")))src/sigil/peg.sgladded
@@ -0,0 +1,578 @@
+1
;;; (sigil peg) - Parsing Expression Grammar Library+2
;;;+3
;;; A PEG (Parsing Expression Grammar) library representing patterns as+4
;;; S-expressions with a capture stack for structured output. Inspired+5
;;; by Janet's PEG module.+6
;;;+7
;;; ## Basic Usage+8
;;;+9
;;; ```scheme+10
;;; (import (sigil peg))+11
;;;+12
;;; ;; Match a literal string+13
;;; (peg/match '(seq "hello" " " "world") "hello world")+14
;;; ; => #<peg-match 0..11 ()>+15
;;;+16
;;; ;; Capture matched text+17
;;; (peg-match-captures (peg/match '(<- (* (char-set char-alphabetic?))) "hello"))+18
;;; ; => ("hello")+19
;;;+20
;;; ;; Define a grammar with named rules+21
;;; (define-grammar csv+22
;;; (main (* (seq 'field (? (seq "," 'field)) 'newline))+23
;;; (field (<- (+ (! ",") (! "\n") any-char)))+24
;;; (newline (/ "\n" (input-end))))+25
;;; ```+26
;;;+27
;;; ## Pattern Language+28
;;;+29
;;; **Atomic:** `"literal"`, `#\char`, `'rule-ref`, `any-char`,+30
;;; `(char-range #\a #\z)`, `(char-set char-alphabetic?)`+31
;;;+32
;;; **Combinators:** `(seq p ...)`, `(/ p ...)`, `(* p)`, `(+ p)`,+33
;;; `(? p)`, `(! p)`, `(& p)`, `(to p)`, `(thru p)`, `(between min max p)`+34
;;;+35
;;; **Captures:** `(<- p)`, `(<- p tag)`, `(group p)`, `(position)`,+36
;;; `(constant val)`, `(cmt p fn)`, `(drop p)`, `(backref tag)`,+37
;;; `(replace p val)`+38
;;;+39
;;; **Anchors:** `(line-start)`, `(line-end)`, `(input-start)`, `(input-end)`+40
+41
(define-library (sigil peg)+42
(import (sigil string)+43
(sigil struct)+44
(sigil io))+45
(export+46
;; Core API+47
peg/match+48
peg/find+49
peg/find-all+50
peg/replace+51
peg/replace-all+52
+53
;; Match accessors+54
peg-match?+55
peg-match-start+56
peg-match-end+57
peg-match-captures+58
peg-match-text+59
+60
;; Grammar definition+61
define-grammar+62
+63
;; Pre-built patterns+64
peg/alpha+65
peg/digit+66
peg/space+67
peg/alnum+68
peg/newline+69
peg/any)+70
+71
(begin+72
+73
;; ============================================================+74
;; Data Types+75
;; ============================================================+76
+77
(define-struct peg-match+78
(start)+79
(end)+80
(captures))+81
+82
;; ============================================================+83
;; Predicate Resolution+84
;; ============================================================+85
+86
;; Resolve a symbol naming a character predicate to the actual procedure.+87
;; Known predicates are looked up; unknown symbols raise an error.+88
(define (resolve-char-predicate sym)+89
(cond+90
((eq? sym 'char-alphabetic?) char-alphabetic?)+91
((eq? sym 'char-numeric?) char-numeric?)+92
((eq? sym 'char-whitespace?) char-whitespace?)+93
((eq? sym 'char-upper-case?)+94
(lambda (c) (and (char-alphabetic? c)+95
(char=? c (char-upcase c)))))+96
((eq? sym 'char-lower-case?)+97
(lambda (c) (and (char-alphabetic? c)+98
(char=? c (char-downcase c)))))+99
(else (error (string-append "peg: unknown char predicate: "+100
(symbol->string sym))))))+101
+102
;; Resolve a symbol binding from the grammar's __bindings entry.+103
(define (peg--resolve-binding sym grammar)+104
(let ((bindings (assq '__bindings grammar)))+105
(if bindings+106
(let ((entry (assq sym (cdr bindings))))+107
(if entry+108
(cdr entry)+109
(error (string-append "peg: unresolved binding: "+110
(symbol->string sym)))))+111
(error (string-append "peg: unresolved binding: "+112
(symbol->string sym))))))+113
+114
;; ============================================================+115
;; Pre-built Patterns+116
;; ============================================================+117
+118
(define peg/alpha '(char-set char-alphabetic?))+119
(define peg/digit '(char-set char-numeric?))+120
(define peg/space '(char-set char-whitespace?))+121
(define peg/alnum '(/ (char-set char-alphabetic?) (char-set char-numeric?)))+122
(define peg/newline '(/ "\r\n" "\n" "\r"))+123
(define peg/any 'any-char)+124
+125
;; ============================================================+126
;; Grammar Definition Macro+127
;; ============================================================+128
+129
(define-syntax define-grammar+130
(syntax-rules (with-bindings)+131
;; With bindings: (define-grammar name (with-bindings (sym val) ...) (rule pat) ...)+132
((_ name+133
(with-bindings (bname bval) ...)+134
(rule-name pattern) ...)+135
(define name+136
(cons (cons '__bindings (list (cons 'bname bval) ...))+137
(list (cons 'rule-name 'pattern) ...))))+138
;; Without bindings+139
((_ name (rule-name pattern) ...)+140
(define name (list (cons 'rule-name 'pattern) ...)))))+141
+142
;; ============================================================+143
;; Core PEG Interpreter+144
;; ============================================================+145
+146
;; Parse the input string starting at pos using the given pattern+147
;; and grammar. Returns (new-pos . captures) on success, or #f on failure.+148
;; captures is a list of captured values (in order).+149
;;+150
;; The grammar is an alist of (rule-name . pattern) pairs.+151
;; tags-box is a mutable pair: (car tags-box) is the tags alist.+152
(define (peg--parse pattern input pos captures tags-box grammar)+153
(let ((len (string-length input)))+154
(cond+155
;; --- Literal string ---+156
((string? pattern)+157
(let ((plen (string-length pattern)))+158
(if (> (+ pos plen) len)+159
#f+160
(let loop ((i 0))+161
(cond+162
((= i plen)+163
(cons (+ pos plen) captures))+164
((char=? (string-ref input (+ pos i))+165
(string-ref pattern i))+166
(loop (+ i 1)))+167
(else #f))))))+168
+169
;; --- Literal character ---+170
((char? pattern)+171
(if (and (< pos len)+172
(char=? (string-ref input pos) pattern))+173
(cons (+ pos 1) captures)+174
#f))+175
+176
;; --- any-char symbol ---+177
((eq? pattern 'any-char)+178
(if (< pos len)+179
(cons (+ pos 1) captures)+180
#f))+181
+182
;; --- Rule reference (other symbol) ---+183
((symbol? pattern)+184
(let ((rule (assq pattern grammar)))+185
(if rule+186
(peg--parse (cdr rule) input pos captures tags-box grammar)+187
(error (string-append "peg: undefined rule: "+188
(symbol->string pattern))))))+189
+190
;; --- Compound patterns ---+191
((pair? pattern)+192
(let ((op (car pattern)))+193
(cond+194
+195
;; (seq p1 p2 ...)+196
((eq? op 'seq)+197
(let loop ((pats (cdr pattern))+198
(cur-pos pos)+199
(cur-caps captures))+200
(if (null? pats)+201
(cons cur-pos cur-caps)+202
(let ((result (peg--parse (car pats) input cur-pos+203
cur-caps tags-box grammar)))+204
(if result+205
(loop (cdr pats) (car result) (cdr result))+206
#f)))))+207
+208
;; (/ p1 p2 ...) - ordered choice+209
((eq? op '/)+210
(let loop ((pats (cdr pattern)))+211
(if (null? pats)+212
#f+213
(let ((result (peg--parse (car pats) input pos+214
captures tags-box grammar)))+215
(if result+216
result+217
(loop (cdr pats)))))))+218
+219
;; (* p) - zero or more+220
((eq? op '*)+221
(let ((sub (cadr pattern)))+222
(let loop ((cur-pos pos) (cur-caps captures))+223
(let ((result (peg--parse sub input cur-pos+224
cur-caps tags-box grammar)))+225
(if (or (not result) (= (car result) cur-pos))+226
;; Failed or zero-width match: stop to prevent infinite loop+227
(cons cur-pos cur-caps)+228
(loop (car result) (cdr result)))))))+229
+230
;; (+ p) - one or more+231
((eq? op '+)+232
(let ((sub (cadr pattern)))+233
(let ((first (peg--parse sub input pos captures tags-box grammar)))+234
(if (not first)+235
#f+236
(let loop ((cur-pos (car first))+237
(cur-caps (cdr first)))+238
(let ((result (peg--parse sub input cur-pos+239
cur-caps tags-box grammar)))+240
(if (or (not result) (= (car result) cur-pos))+241
(cons cur-pos cur-caps)+242
(loop (car result) (cdr result)))))))))+243
+244
;; (? p) - optional+245
((eq? op '?)+246
(let ((result (peg--parse (cadr pattern) input pos+247
captures tags-box grammar)))+248
(if result result (cons pos captures))))+249
+250
;; (! p) - negative lookahead+251
((eq? op '!)+252
(let ((result (peg--parse (cadr pattern) input pos+253
captures tags-box grammar)))+254
(if result #f (cons pos captures))))+255
+256
;; (& p) - positive lookahead+257
((eq? op '&)+258
(let ((result (peg--parse (cadr pattern) input pos+259
captures tags-box grammar)))+260
(if result (cons pos captures) #f)))+261
+262
;; (to p) - match anything until p (don't consume p)+263
((eq? op 'to)+264
(let ((sub (cadr pattern)))+265
(let loop ((cur-pos pos))+266
(if (> cur-pos len)+267
#f+268
(let ((result (peg--parse sub input cur-pos+269
captures tags-box grammar)))+270
(if result+271
(cons cur-pos captures)+272
(loop (+ cur-pos 1))))))))+273
+274
;; (thru p) - match anything through p (consume p)+275
((eq? op 'thru)+276
(let ((sub (cadr pattern)))+277
(let loop ((cur-pos pos))+278
(if (> cur-pos len)+279
#f+280
(let ((result (peg--parse sub input cur-pos+281
captures tags-box grammar)))+282
(if result+283
(cons (car result) (cdr result))+284
(loop (+ cur-pos 1))))))))+285
+286
;; (between min max p)+287
((eq? op 'between)+288
(let ((mn (cadr pattern))+289
(mx (caddr pattern))+290
(sub (cadddr pattern)))+291
(let loop ((count 0) (cur-pos pos) (cur-caps captures))+292
(if (= count mx)+293
(cons cur-pos cur-caps)+294
(let ((result (peg--parse sub input cur-pos+295
cur-caps tags-box grammar)))+296
(if (or (not result) (= (car result) cur-pos))+297
(if (>= count mn)+298
(cons cur-pos cur-caps)+299
#f)+300
(loop (+ count 1) (car result) (cdr result))))))))+301
+302
;; (char-range lo hi)+303
((eq? op 'char-range)+304
(let ((lo (cadr pattern))+305
(hi (caddr pattern)))+306
(if (and (< pos len)+307
(let ((c (string-ref input pos)))+308
(and (char>=? c lo) (char<=? c hi))))+309
(cons (+ pos 1) captures)+310
#f)))+311
+312
;; (char-set pred-symbol)+313
((eq? op 'char-set)+314
(let ((pred (let ((p (cadr pattern)))+315
(if (procedure? p)+316
p+317
(resolve-char-predicate p)))))+318
(if (and (< pos len) (pred (string-ref input pos)))+319
(cons (+ pos 1) captures)+320
#f)))+321
+322
;; (<- p) or (<- p tag)+323
((eq? op '<-)+324
(let ((sub (cadr pattern))+325
(tag (if (> (length pattern) 2) (caddr pattern) #f)))+326
(let ((result (peg--parse sub input pos captures tags-box grammar)))+327
(if result+328
(let* ((end-pos (car result))+329
(text (substring input pos end-pos))+330
(new-caps (cons text (cdr result))))+331
(if tag+332
(begin+333
(set-car! tags-box (cons (cons tag text) (car tags-box)))+334
(cons end-pos new-caps))+335
(cons end-pos new-caps)))+336
#f))))+337
+338
;; (group p) - collect sub-captures into a list+339
((eq? op 'group)+340
(let ((sub (cadr pattern)))+341
(let ((result (peg--parse sub input pos '() tags-box grammar)))+342
(if result+343
(let ((sub-caps (reverse (cdr result))))+344
(cons (car result) (cons sub-caps captures)))+345
#f))))+346
+347
;; (position) - capture current position+348
((eq? op 'position)+349
(cons pos (cons pos captures)))+350
+351
;; (constant val) - capture a constant value+352
((eq? op 'constant)+353
(cons pos (cons (cadr pattern) captures)))+354
+355
;; (cmt p fn) - match p, transform captures through fn+356
;; fn can be a procedure or a symbol (resolved from grammar bindings)+357
((eq? op 'cmt)+358
(let* ((sub (cadr pattern))+359
(fn-val (caddr pattern))+360
(fn (if (procedure? fn-val)+361
fn-val+362
(peg--resolve-binding fn-val grammar))))+363
(let ((result (peg--parse sub input pos '() tags-box grammar)))+364
(if result+365
(let* ((sub-caps (reverse (cdr result)))+366
(transformed (apply fn sub-caps)))+367
(cons (car result) (cons transformed captures)))+368
#f))))+369
+370
;; (drop p) - match p, discard captures+371
((eq? op 'drop)+372
(let ((result (peg--parse (cadr pattern) input pos+373
captures tags-box grammar)))+374
(if result+375
(cons (car result) captures)+376
#f)))+377
+378
;; (backref tag) - match previously tagged capture text+379
((eq? op 'backref)+380
(let* ((tag-name (cadr pattern))+381
(entry (assq tag-name (car tags-box))))+382
(if entry+383
(peg--parse (cdr entry) input pos captures tags-box grammar)+384
#f)))+385
+386
;; (replace p val) - match p, capture val instead+387
((eq? op 'replace)+388
(let ((sub (cadr pattern))+389
(val (caddr pattern)))+390
(let ((result (peg--parse sub input pos captures tags-box grammar)))+391
(if result+392
(cons (car result) (cons val captures))+393
#f))))+394
+395
;; (line-start)+396
((eq? op 'line-start)+397
(if (or (= pos 0)+398
(and (> pos 0)+399
(char=? (string-ref input (- pos 1)) #\newline)))+400
(cons pos captures)+401
#f))+402
+403
;; (line-end)+404
((eq? op 'line-end)+405
(if (or (= pos len)+406
(char=? (string-ref input pos) #\newline))+407
(cons pos captures)+408
#f))+409
+410
;; (input-start)+411
((eq? op 'input-start)+412
(if (= pos 0)+413
(cons pos captures)+414
#f))+415
+416
;; (input-end)+417
((eq? op 'input-end)+418
(if (= pos len)+419
(cons pos captures)+420
#f))+421
+422
(else+423
(error (string-append "peg: unknown pattern operator: "+424
(symbol->string op)))))))+425
+426
(else+427
(error "peg: invalid pattern")))))+428
+429
;; ============================================================+430
;; Grammar Normalization+431
;; ============================================================+432
+433
;; Normalize a grammar: if it's a bare pattern (not an alist),+434
;; wrap it as ((main . pattern)). If it's an alist, normalize+435
;; entries to dotted pairs: (name pattern) -> (name . pattern).+436
(define (normalize-grammar pat)+437
(if (and (pair? pat)+438
(pair? (car pat))+439
(symbol? (caar pat)))+440
;; Looks like an alist of rules — normalize entry format+441
(map (lambda (entry)+442
(if (and (not (eq? (car entry) '__bindings))+443
(pair? (cdr entry))+444
(null? (cddr entry)))+445
;; (name pattern) list format -> (name . pattern)+446
(cons (car entry) (cadr entry))+447
;; Already (name . pattern) dotted pair or __bindings+448
entry))+449
pat)+450
;; Bare pattern — wrap as main rule+451
(list (cons 'main pat))))+452
+453
;; ============================================================+454
;; Public API+455
;; ============================================================+456
+457
;;; Match a PEG grammar against the input string.+458
;;;+459
;;; Returns a peg-match on success, or #f on failure. The grammar+460
;;; can be a bare pattern or a list of named rules (entry point is 'main).+461
;;;+462
;;; ```scheme+463
;;; (peg/match "hello" "hello world")+464
;;; ; => #<peg-match 0..5 ()>+465
;;;+466
;;; (peg/match '(<- (* (char-set char-alphabetic?))) "hello world")+467
;;; ; => #<peg-match 0..5 ("hello")>+468
;;; ```+469
(define (peg/match grammar input . rest)+470
(let* ((start (if (null? rest) 0 (car rest)))+471
(gram (normalize-grammar grammar))+472
(result (peg--parse 'main input start '() (list '()) gram)))+473
(if result+474
(peg-match start: start+475
end: (car result)+476
captures: (reverse (cdr result)))+477
#f)))+478
+479
;;; Find the first match of grammar anywhere in input.+480
;;;+481
;;; Tries matching at each position from left to right, returning the+482
;;; first successful match, or #f if no match is found.+483
;;;+484
;;; ```scheme+485
;;; (peg/find '(<- "world") "hello world")+486
;;; ; => #<peg-match 6..11 ("world")>+487
;;; ```+488
(define (peg/find grammar input)+489
(let ((len (string-length input))+490
(gram (normalize-grammar grammar)))+491
(let loop ((pos 0))+492
(if (> pos len)+493
#f+494
(let ((result (peg--parse 'main input pos '() (list '()) gram)))+495
(if result+496
(peg-match start: pos+497
end: (car result)+498
captures: (reverse (cdr result)))+499
(loop (+ pos 1))))))))Showing the first 500 of 579 diff lines for this file. This diff is INCOMPLETE; read the file or clone the repository for the rest.
test/test-peg.sgladded
@@ -0,0 +1,449 @@
+1
(import (sigil test)+2
(sigil peg))+3
+4
;; ============================================================+5
;; Atomic Patterns+6
;; ============================================================+7
+8
(test-group "literal strings"+9
(test "match exact string"+10
(let ((m (peg/match "hello" "hello world")))+11
(assert-true (peg-match? m))+12
(assert-equal 0 (peg-match-start m))+13
(assert-equal 5 (peg-match-end m))))+14
+15
(test "fail on mismatch"+16
(assert-false (peg/match "xyz" "hello")))+17
+18
(test "fail on too short"+19
(assert-false (peg/match "hello world!" "hello")))+20
+21
(test "empty string always matches"+22
(let ((m (peg/match "" "hello")))+23
(assert-true (peg-match? m))+24
(assert-equal 0 (peg-match-end m)))))+25
+26
(test-group "literal characters"+27
(test "match character"+28
(let ((m (peg/match #\h "hello")))+29
(assert-true (peg-match? m))+30
(assert-equal 1 (peg-match-end m))))+31
+32
(test "fail on wrong character"+33
(assert-false (peg/match #\x "hello"))))+34
+35
(test-group "any-char"+36
(test "matches any character"+37
(let ((m (peg/match 'any-char "x")))+38
(assert-true (peg-match? m))+39
(assert-equal 1 (peg-match-end m))))+40
+41
(test "fails on empty input"+42
(assert-false (peg/match 'any-char ""))))+43
+44
(test-group "char-range"+45
(test "match character in range"+46
(assert-true (peg-match? (peg/match '(char-range #\a #\z) "hello"))))+47
+48
(test "fail on character outside range"+49
(assert-false (peg/match '(char-range #\a #\z) "Hello")))+50
+51
(test "match boundary characters"+52
(assert-true (peg-match? (peg/match '(char-range #\a #\z) "a")))+53
(assert-true (peg-match? (peg/match '(char-range #\a #\z) "z")))))+54
+55
(test-group "char-set"+56
(test "match alphabetic"+57
(assert-true (peg-match? (peg/match '(char-set char-alphabetic?) "a"))))+58
+59
(test "fail alphabetic on digit"+60
(assert-false (peg/match '(char-set char-alphabetic?) "1")))+61
+62
(test "match numeric"+63
(assert-true (peg-match? (peg/match '(char-set char-numeric?) "5"))))+64
+65
(test "match whitespace"+66
(assert-true (peg-match? (peg/match '(char-set char-whitespace?) " ")))))+67
+68
;; ============================================================+69
;; Combinators+70
;; ============================================================+71
+72
(test-group "seq"+73
(test "sequence of literals"+74
(let ((m (peg/match '(seq "hello" " " "world") "hello world")))+75
(assert-true (peg-match? m))+76
(assert-equal 11 (peg-match-end m))))+77
+78
(test "fail if any part fails"+79
(assert-false (peg/match '(seq "hello" " " "earth") "hello world"))))+80
+81
(test-group "ordered choice"+82
(test "first alternative matches"+83
(let ((m (peg/match '(/ "hello" "world") "hello")))+84
(assert-true (peg-match? m))+85
(assert-equal 5 (peg-match-end m))))+86
+87
(test "second alternative matches"+88
(let ((m (peg/match '(/ "hello" "world") "world")))+89
(assert-true (peg-match? m))+90
(assert-equal 5 (peg-match-end m))))+91
+92
(test "fail if none match"+93
(assert-false (peg/match '(/ "hello" "world") "foo"))))+94
+95
(test-group "zero or more"+96
(test "matches multiple"+97
(let ((m (peg/match '(* #\a) "aaa")))+98
(assert-true (peg-match? m))+99
(assert-equal 3 (peg-match-end m))))+100
+101
(test "matches zero"+102
(let ((m (peg/match '(* #\a) "bbb")))+103
(assert-true (peg-match? m))+104
(assert-equal 0 (peg-match-end m))))+105
+106
(test "greedy matching"+107
(let ((m (peg/match '(* (char-set char-alphabetic?)) "hello123")))+108
(assert-true (peg-match? m))+109
(assert-equal 5 (peg-match-end m)))))+110
+111
(test-group "one or more"+112
(test "matches multiple"+113
(let ((m (peg/match '(+ #\a) "aaa")))+114
(assert-true (peg-match? m))+115
(assert-equal 3 (peg-match-end m))))+116
+117
(test "fails on zero"+118
(assert-false (peg/match '(+ #\a) "bbb"))))+119
+120
(test-group "optional"+121
(test "matches when present"+122
(let ((m (peg/match '(seq (? "-") (+ (char-set char-numeric?))) "-42")))+123
(assert-true (peg-match? m))+124
(assert-equal 3 (peg-match-end m))))+125
+126
(test "succeeds when absent"+127
(let ((m (peg/match '(seq (? "-") (+ (char-set char-numeric?))) "42")))+128
(assert-true (peg-match? m))+129
(assert-equal 2 (peg-match-end m)))))+130
+131
(test-group "negative lookahead"+132
(test "succeeds when pattern does not match"+133
(let ((m (peg/match '(seq (! "x") any-char) "abc")))+134
(assert-true (peg-match? m))+135
(assert-equal 1 (peg-match-end m))))+136
+137
(test "fails when pattern matches"+138
(assert-false (peg/match '(seq (! "a") any-char) "abc"))))+139
+140
(test-group "positive lookahead"+141
(test "succeeds without consuming"+142
(let ((m (peg/match '(seq (& "hello") "hello") "hello")))+143
(assert-true (peg-match? m))+144
(assert-equal 5 (peg-match-end m))))+145
+146
(test "fails when pattern does not match"+147
(assert-false (peg/match '(& "world") "hello"))))+148
+149
(test-group "to"+150
(test "match up to target"+151
(let ((m (peg/match '(seq (to ".") ".") "hello.world")))+152
(assert-true (peg-match? m))+153
(assert-equal 6 (peg-match-end m))))+154
+155
(test "fail if target not found"+156
(assert-false (peg/match '(seq (to ".") ".") "hello"))))+157
+158
(test-group "thru"+159
(test "match through target"+160
(let ((m (peg/match '(thru ".") "hello.world")))+161
(assert-true (peg-match? m))+162
(assert-equal 6 (peg-match-end m)))))+163
+164
(test-group "between"+165
(test "match exactly min"+166
(let ((m (peg/match '(between 2 4 #\a) "aa")))+167
(assert-true (peg-match? m))+168
(assert-equal 2 (peg-match-end m))))+169
+170
(test "match up to max"+171
(let ((m (peg/match '(between 2 4 #\a) "aaaaa")))+172
(assert-true (peg-match? m))+173
(assert-equal 4 (peg-match-end m))))+174
+175
(test "fail below min"+176
(assert-false (peg/match '(between 2 4 #\a) "a"))))+177
+178
;; ============================================================+179
;; Captures+180
;; ============================================================+181
+182
(test-group "basic capture"+183
(test "capture matched text"+184
(let ((m (peg/match '(<- (+ (char-set char-alphabetic?))) "hello world")))+185
(assert-true (peg-match? m))+186
(assert-equal '("hello") (peg-match-captures m))))+187
+188
(test "multiple captures"+189
(let ((m (peg/match '(seq (<- (+ (char-set char-alphabetic?)))+190
" "+191
(<- (+ (char-set char-alphabetic?))))+192
"hello world")))+193
(assert-equal '("hello" "world") (peg-match-captures m)))))+194
+195
(test-group "tagged capture"+196
(test "capture with tag"+197
(let ((m (peg/match '(<- (+ (char-set char-alphabetic?)) word) "hello")))+198
(assert-equal '("hello") (peg-match-captures m)))))+199
+200
(test-group "group capture"+201
(test "group sub-captures into list"+202
(let ((m (peg/match '(group (seq (<- "a") (<- "b") (<- "c"))) "abc")))+203
(assert-equal '(("a" "b" "c")) (peg-match-captures m))))+204
+205
(test "nested groups"+206
(let ((m (peg/match '(group (seq (<- "a") (group (seq (<- "b") (<- "c"))))) "abc")))+207
(assert-equal '(("a" ("b" "c"))) (peg-match-captures m)))))+208
+209
(test-group "position capture"+210
(test "capture current position"+211
(let ((m (peg/match '(seq "hello" (position)) "hello world")))+212
(assert-equal '(5) (peg-match-captures m)))))+213
+214
(test-group "constant capture"+215
(test "capture constant value"+216
(let ((m (peg/match '(seq "hello" (constant found-it)) "hello")))+217
(assert-equal '(found-it) (peg-match-captures m)))))+218
+219
(test-group "cmt capture"+220
(test "transform captures"+221
(let ((m (peg/match `(cmt (<- (+ (char-set char-numeric?)))+222
,string->number)+223
"42")))+224
(assert-equal '(42) (peg-match-captures m))))+225
+226
(test "transform multiple captures"+227
(let ((m (peg/match `(cmt (seq (<- (+ (char-set char-numeric?)))+228
"+"+229
(<- (+ (char-set char-numeric?))))+230
,(lambda (a b) (+ (string->number a) (string->number b))))+231
"3+4")))+232
(assert-equal '(7) (peg-match-captures m)))))+233
+234
(test-group "drop capture"+235
(test "match without capturing"+236
(let ((m (peg/match '(seq (drop (+ (char-set char-whitespace?)))+237
(<- (+ (char-set char-alphabetic?))))+238
" hello")))+239
(assert-equal '("hello") (peg-match-captures m)))))+240
+241
(test-group "backref"+242
(test "match previously captured text"+243
(let ((m (peg/match '(seq (<- (+ (char-set char-alphabetic?)) word)+244
" "+245
(backref word))+246
"hello hello")))+247
(assert-true (peg-match? m))))+248
+249
(test "fail when backref doesn't match"+250
(assert-false (peg/match '(seq (<- (+ (char-set char-alphabetic?)) word)+251
" "+252
(backref word))+253
"hello world"))))+254
+255
(test-group "replace"+256
(test "capture replacement value"+257
(let ((m (peg/match '(replace "hello" greeting) "hello")))+258
(assert-equal '(greeting) (peg-match-captures m)))))+259
+260
;; ============================================================+261
;; Anchors+262
;; ============================================================+263
+264
(test-group "input anchors"+265
(test "input-start at beginning"+266
(assert-true (peg-match? (peg/match '(seq (input-start) "hello") "hello"))))+267
+268
(test "input-end at end"+269
(assert-true (peg-match? (peg/match '(seq "hello" (input-end)) "hello"))))+270
+271
(test "input-start fails in middle"+272
(assert-false (peg/match '(seq "he" (input-start) "llo") "hello"))))+273
+274
(test-group "line anchors"+275
(test "line-start at beginning"+276
(assert-true (peg-match? (peg/match '(seq (line-start) "hello") "hello"))))+277
+278
(test "line-start after newline"+279
(assert-true+280
(peg-match?+281
(peg/match '(seq "line1\n" (line-start) "line2") "line1\nline2"))))+282
+283
(test "line-end before newline"+284
(assert-true+285
(peg-match?+286
(peg/match '(seq "hello" (line-end)) "hello\nworld"))))+287
+288
(test "line-end at input end"+289
(assert-true+290
(peg-match?+291
(peg/match '(seq "hello" (line-end)) "hello")))))+292
+293
;; ============================================================+294
;; Grammar Rules (define at top level to avoid closure issues)+295
;; ============================================================+296
+297
(define-grammar word-pair+298
(main (seq word " " word))+299
(word (+ (char-set char-alphabetic?))))+300
+301
(define-grammar nested-parens+302
(main (seq "(" inner ")"))+303
(inner (/ main (* (seq (! "(") (! ")") any-char)))))+304
+305
(define-grammar int-parser+306
(with-bindings (to-num string->number))+307
(main (cmt (<- (+ (char-set char-numeric?))) to-num)))+308
+309
(test-group "grammars"+310
(test "define-grammar with rule references"+311
(let ((m (peg/match word-pair "hello world")))+312
(assert-true (peg-match? m))+313
(assert-equal 11 (peg-match-end m))))+314
+315
(test "recursive grammar"+316
(assert-true (peg-match? (peg/match nested-parens "()")))+317
(assert-true (peg-match? (peg/match nested-parens "(abc)")))+318
(assert-true (peg-match? (peg/match nested-parens "(())")))+319
(assert-true (peg-match? (peg/match nested-parens "((abc))")))+320
(assert-false (peg/match nested-parens "((")))+321
+322
(test "grammar with bindings for cmt"+323
(let ((m (peg/match int-parser "42")))+324
(assert-equal '(42) (peg-match-captures m)))))+325
+326
;; ============================================================+327
;; Public API+328
;; ============================================================+329
+330
(test-group "peg/find"+331
(test "find first match anywhere"+332
(let ((m (peg/find '(<- (+ (char-set char-numeric?))) "abc123def")))+333
(assert-true (peg-match? m))+334
(assert-equal 3 (peg-match-start m))+335
(assert-equal 6 (peg-match-end m))+336
(assert-equal '("123") (peg-match-captures m))))+337
+338
(test "return #f when no match"+339
(assert-false (peg/find '(+ (char-set char-numeric?)) "abcdef"))))+340
+341
(test-group "peg/find-all"+342
(test "find all matches"+343
(let ((ms (peg/find-all '(<- (+ (char-set char-alphabetic?))) "hello world foo")))+344
(assert-equal 3 (length ms))+345
(assert-equal '("hello") (peg-match-captures (car ms)))+346
(assert-equal '("world") (peg-match-captures (cadr ms)))+347
(assert-equal '("foo") (peg-match-captures (caddr ms)))))+348
+349
(test "empty list when no matches"+350
(assert-equal '() (peg/find-all '(+ (char-set char-numeric?)) "abcdef"))))+351
+352
(test-group "peg/replace"+353
(test "replace first match"+354
(assert-equal "abcXdef"+355
(peg/replace '(+ (char-set char-numeric?)) "X" "abc123def")))+356
+357
(test "no match returns original"+358
(assert-equal "abcdef"+359
(peg/replace '(+ (char-set char-numeric?)) "X" "abcdef")))+360
+361
(test "replace with procedure"+362
(assert-equal "abc456def"+363
(peg/replace '(<- (+ (char-set char-numeric?)))+364
(lambda (m)+365
(number->string (* 2 (string->number+366
(car (peg-match-captures m))))))+367
"abc228def"))))+368
+369
(test-group "peg/replace-all"+370
(test "replace all matches"+371
(assert-equal "aNbNcN"+372
(peg/replace-all '(+ (char-set char-numeric?)) "N" "a1b23c456")))+373
+374
(test "no matches returns original"+375
(assert-equal "abc"+376
(peg/replace-all '(+ (char-set char-numeric?)) "N" "abc"))))+377
+378
(test-group "peg-match-text"+379
(test "extract matched text"+380
(let ((m (peg/find '(+ (char-set char-alphabetic?)) "123hello456")))+381
(assert-equal "hello" (peg-match-text m "123hello456")))))+382
+383
;; ============================================================+384
;; Pre-built Patterns+385
;; ============================================================+386
+387
(test-group "pre-built patterns"+388
(test "peg/alpha matches letter"+389
(assert-true (peg-match? (peg/match peg/alpha "a")))+390
(assert-false (peg/match peg/alpha "1")))+391
+392
(test "peg/digit matches digit"+393
(assert-true (peg-match? (peg/match peg/digit "5")))+394
(assert-false (peg/match peg/digit "a")))+395
+396
(test "peg/space matches whitespace"+397
(assert-true (peg-match? (peg/match peg/space " ")))+398
(assert-false (peg/match peg/space "a")))+399
+400
(test "peg/newline matches newline"+401
(assert-true (peg-match? (peg/match peg/newline "\n")))+402
(assert-true (peg-match? (peg/match peg/newline "\r\n")))))+403
+404
;; ============================================================+405
;; Practical Grammars (defined at top level)+406
;; ============================================================+407
+408
(define-grammar csv-line+409
(main (seq field (* (seq "," field))))+410
(field (/ quoted-field plain-field))+411
(quoted-field (seq "\"" (<- (* (/ "\"\"" (seq (! "\"") any-char)))) "\""))+412
(plain-field (<- (* (seq (! ",") (! "\n") any-char)))))+413
+414
(define-grammar key-value+415
(main (seq ws pair (* (seq ws "," ws pair)) ws))+416
(pair (group (seq (<- ident) ws "=" ws value)))+417
(ident (+ (/ (char-set char-alphabetic?) #\_)))+418
(value (/ quoted bare))+419
(quoted (seq "\"" (<- (* (seq (! "\"") any-char))) "\""))+420
(bare (<- (+ (seq (! ",") (! (char-set char-whitespace?)) any-char))))+421
(ws (* (char-set char-whitespace?))))+422
+423
(test-group "practical: CSV field parsing"+424
(test "parse simple CSV"+425
(let ((m (peg/match csv-line "hello,world,foo")))+426
(assert-true (peg-match? m))+427
(assert-equal '("hello" "world" "foo") (peg-match-captures m))))+428
+429
(test "parse CSV with empty fields"+430
(let ((m (peg/match csv-line "a,,c")))+431
(assert-true (peg-match? m))+432
(assert-equal '("a" "" "c") (peg-match-captures m)))))+433
+434
(test-group "practical: integer parsing"+435
(test "parse integer with sign"+436
(let ((m (peg/match `(cmt (seq (<- (? (/ "-" "+")))+437
(<- (+ (char-set char-numeric?))))+438
,(lambda (sign digits)+439
(string->number (string-append sign digits))))+440
"-42")))+441
(assert-equal '(-42) (peg-match-captures m)))))+442
+443
(test-group "practical: key-value pairs"+444
(test "parse key-value pairs"+445
(let ((m (peg/match key-value "name=hello, age=42")))+446
(assert-true (peg-match? m))+447
(assert-equal '(("name" "hello") ("age" "42")) (peg-match-captures m)))))+448
+449
(run-tests)