Source

newspeak / CombinatorialParsing.ns3

The default branch has multiple heads

  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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
Newspeak3
'NS2 Combinatorial Parsing'
class CombinatorialParsing usingLib: platform = NewspeakObject ("
The Newspeak version of the original parser combinator library. 

   Copyright 2008 Cadence Design Systems, Inc.
   
   Licensed under the Apache License, Version 2.0 (the ''License''); you may not use this file except in compliance with the License.  You may obtain a copy of the License at  http://www.apache.org/licenses/LICENSE-2.0
"| 

 
OrderedCollection = platform collections OrderedCollection.
Error = platform exceptions Error.
|)
(
class AlternatingParser = CombinatorialParser (
"A parser that parses either P or Q."| p0 <CombinatorialParser> q0 <CombinatorialParser> pfun <[^CombinatorialParser]> qfun <[^CombinatorialParser]> |)
('accessors'
p ^ <CombinatorialParser> = (

p0 isNil ifTrue:[p0:: pfun value].
^p0
)
q ^ <CombinatorialParser> = (

q0 isNil ifTrue:[q0:: qfun value].
^q0
)'initialization'
either: pf1 <[^CombinatorialParser]> or: pf2  <[^CombinatorialParser]> = (
 
 self assert:[(pf1 isBlock) and: [pf2 isBlock]].
  pfun:: pf1.
  qfun:: pf2
)'parsing'
parse: input <ReadStream> inContext: context  <ParserContext> ifError: blk <[String, Integer]> = (
	| pos  |

	pos:: input position.
  	^ p parse: input inContext: context ifError:
		[:msg1   :pos1  |
		| result |
		input position: pos.
		context recordFailure: {msg1.pos1}.
		result::  q parse: input inContext: context ifError:
			[:msg2  :pos2  |
			context recordFailure: {msg2. pos2}.
			pos1 > pos2 ifTrue:[ ^blk value: msg1 value: pos1].
			pos2 > pos1 ifTrue:[ ^blk value: msg2 value: pos2].
			^combineErrors: msg1 and: msg2 at: pos1 with: blk].
		^result.]
)'private'
combineErrors: e1 <String> and: e2  <String> at: pos <Integer> with: blk<[String, Integer]> = (
 
| or  <String> msg <String> |

or:: (e1 = '' or:[e2 = '']) ifTrue:[''] ifFalse:[' or '].
e1 = e2 ifTrue:[msg:: e1] ifFalse:[msg:: e1,  or  , e2].
^blk value: msg value: pos
))
class CharParser = PredicateTokenParser ()
('initialization'
for: token = (
 
"This method leverages the assumption that characters are immutable values. Hence, if an input
equals the specified token, it is indistiguishable from it, and we can just return token as the result of the
parse. Consequently, the wrapper function we pass to the superclass constructor ignores its input
and returns token."
self assert:[token isKindOfCharacter] message: 'Character token expected'.
^self accept:[:t  | t = token]
           errorMsg: token printString, ' expected'
))
class CollectingCommentParser = CommentParser (
"A special parser used for inputs that need to be rapidly scanned over. It differs from its superclass in that it actually collects the characters it scans, in case they are needed (e.g., for pretty printers). 

Ideally,we should not have to do this, but until we do proper optimization by compiling combinators, this will have to suffice. It provides a marked improvement in performance, By using such parsers for comments, whitespace and strings, the overall performance of the Newqueak parser improved by a factor of 2 or so."| comment |)
('parsing'
parse: input inContext: context ifError: blk = (

| c  |

 comment: OrderedCollection new.
	[termBlock value: input] whileFalse: [ 
		c:: input nextIfAbsent: [blk value:'Premature end of input' value: input position-1].
           comment add: c.
	]. 
^ comment
))
class CombinatorialParser = (
"This class is intended to implement Parser
Combinators. A CombinatorialParser[T]
returns a value of type T after successful
parsing.

The class is abstract. It does not implement
 the parsing routine parse:ifError: .
 
If parsing fails, parse:ifError: should call the error handling block
passed to it.

Concrete subclasses should implement specific grammars.

Parsing is initiated by calling parse:ifError:. This routine takes a ReadStream[Object] as input.
If parsing fails, it is the caller''s responsibility to set the input stream back to its original position
(Q: is this a good idea?).
If an error occurs, the error block passed in is called.")
('as yet unclassified'
assert: b = (
	^self assert: b message: 'Assertion failed'
)
isKindOfCombinatorialParser = (

	"should be auto-generated"
	^ true
)
value = (
	^self
)'combinators'
& p  <CombinatorialParser> ^ <SequentialParser> = (
 
"The sequencing combinator (implicit in BNF). "
| o  |
 
self assert:[p isBlock].

o:: OrderedCollection new add: [self]; add: p; yourself.
^SequentialParser new on: o
)
, p <CombinatorialParser> ^ <SequentialParser> = (
 
"The flattenning sequencing combinator. 
This is what one should typically use in a grammar.
 It differs from '&' in its specification.  '&' is not intended to
flatten the resulting parser tree, while ',' is; this achieved by overriding ',' in SequentialParser to do the flattening.

Why would one want to flatten the tree? Because, given a production

Foo -> Bam Ban Bar Bat

one doesn't want to build the AST by writing

Foo:: Bam & Ban & Bar & Bat
   wrapper:[:start :end | 
	            FooNode b1:start first b2: (start at: 2)  b3: (start at: 3) b4: end
	]

It is much more convenient to flatten the tree and have a flat list of the correct arity.
"

^self & p
)
empty ^ <CombinatorialParser> = (
 
^EmptyParser new
)
eoi ^ <CombinatorialParser> = (

^ tokenFor: EOIParser new
)
fail ^ <CombinatorialParser> = (

^FailingParser new
)
not ^ <CombinatorialParser> = (
 ^NegatingParser for: self
)
opt ^ <CombinatorialParser>= (
 
"[P] = P | e"
^self | [self  empty]
)
plus ^ <CombinatorialParser> = (
 
"Return a parser that accepts one or more repetitions of what the receiver accepts. Denoted by the postfix + in BNF"
"P+ = P & P* ; However, we must flatten the list one level"
^PlusParser new p: self.
"^ self & [ star] 
         wrapper:[:hd : tl  | 
                        |   r   |
                        self assert:[tl isNil not].
                        OrderedCollection new add: hd; addAll: tl; yourself. 
                        ]"
)
plusSeparatedBy: separator <CombinatorialParser> ^ <CombinatorialParser> = (

"Utility for the common case of a list with separators. The separators are discarded, as they are usually only used to guide parsing and
have no semantic value.  If one needs them, one can always build the rule directly"

^self &  [(separator value &  [self] wrapper:[:s  :v |  v]) star] 
        wrapper:[:fst :rst  |
                            | results  |
                              OrderedCollection new  addFirst: fst; addAll: rst; yourself "could be optimized to reuse rst"
                           ]
)
plusSeparatedOrTerminatedBy: separator  <CombinatorialParser> ^ <CombinatorialParser>  = (
 
"Utility for the common case of a list with separators, allowing for an optional appearance of the separator at the end. The separators are discarded, as they are usually only used to guide parsing and
have no semantic value.  If one needs them, one can always build the rule directly"

^( plusSeparatedBy: separator),  [separator value opt]
         wrapper:[:lst  :end | lst]
)
star ^ <CombinatorialParser> = (
 
"Return a parser that accepts zero or more repetitions of what the receiver accepts. Denoted by the postfix * in BNF"
"P* = [P+]"
"We tweak the classic formulation by wrapping it in a parser that takes care to avoid returning nil.
In the ordinary case, if the input is empty, the empty parser will return nil as the result. 
However, we'd rather not  have to check for nil every time we get a result from a starred
production; it is verbose and error prone. In the case of star, it is better to return an empty list
for empty input. The call to wrap: below accomplishes that."
"would be good to cache this, as well as plus and opt"
"^( plus opt) 
           wrap:[:rs  | rs isNil ifTrue:[OrderedCollection new] ifFalse:[rs]]"
^StarParser new p: self.
)
starSeparatedBy: separator  <CombinatorialParser> ^ <CombinatorialParser> = (

"See analogous plus methods. Must wrap to prevent returning nil in empty case"

^( plusSeparatedBy: separator) opt
           wrap:[:rs  | rs isNil ifTrue:[OrderedCollection new] ifFalse:[rs]]
)
starSeparatedOrTerminatedBy: separator  <CombinatorialParser> ^ <CombinatorialParser> = (
 
"See analogous plus methods. Must wrap to prevent returning nil in empty case"
^( plusSeparatedOrTerminatedBy: separator) opt
        wrap:[:rs  | rs isNil ifTrue:[OrderedCollection new] ifFalse:[rs]]
)
| p <CombinatorialParser> ^ <CombinatorialParser> = (
 
" The alternation combinator - denoted by | in BNF"

^AlternatingParser new either: [self] or: p 
)'parsing'
parse: input <ReadStream> ^ <T | ParserError> = (
	^self
		parse: input
		ifError:
			[ :msg :pos | ^ParserError new message: msg; position: pos; signal ]
)
parse: input <ReadStream> ifError: blk <[String, Integer, ^X def]> ^ <T|X>= (
 
| context |

  context:: ParserContext new.
   ^parse: input 
        inContext: context
        ifError:[:msg :pos |
	               context errorPosition = pos 
	                  ifTrue:[
		                      context recordFailure: ( combineErrors: context errorMessage 
		                                                                 and: msg 
		                                                                 at: pos
		                                                          )
		                      ]
	                  ifFalse:[context recordFailure:{msg. pos.}]. 
	               blk value: context errorMessage value: context errorPosition.
	            ]
)
parse: input <ReadStream> inContext: context  ifError: blk = (
 
  self subclassResponsibility
)'private'
combineErrors: e1 and: e2  at: pos = (
 
| or  msg |

or:: (e1 = '' or:[e2 = '']) ifTrue:[''] ifFalse:[' or '].
e1 = e2 ifTrue:[msg:: e1] ifFalse:[msg:: e1,  or  , e2].
^{msg. pos}
)'utilities'
aWhitespaceChar ^ <CombinatorialParser> = (
 
^PredicateTokenParser new accept:[:c   | c asciiValue <=  $  asciiValue]
                                 errorMsg: 'whitespace expected'.
  
)
char: c <Character> ^ <CombinatorialParser>  = (
 

^CharParser new for: c
)
charBetween: c1 <Character>and: c2 <Character>  ^ <CombinatorialParser> = (
 
^PredicateTokenParser new accept:[:c | c between: c1 and: c2]
                                             errorMsg: 'character between ', c1 asString, 
                                                             'and ', c2 asString, 'expected'
)
comment ^ <CombinatorialParser> = (
 
^ fail
)
tokenFor: p <CombinatorialParser> ^ <CombinatorialParser> = (

"Tokenizing involves throwing away leading whitespace and comments.
In addition, it involves associating the token with a starting position within the input stream;
We do the latter first by wrapping p in a TokenizingParser; then we prefix it with a parser
that deals with whitespace and comments, and return the result. "

| posParser | 

posParser:: TokenizingParser new parser: p.

^ ( whitespace | [ comment]) star,  [posParser] 
          wrapper:[:dontCare  :t   | t].
          "type safety note: wrapper is only defined on SequentialParser. The call is always
           statically unsafe but checked dynamically   (see its definition). One could use
           guaranteed to cast to a SequentialParser, but that would not be enough to silence
           the typechecker anyway"
"Design note: It seems tempting to define a combinator, 'token', that returns a tokenized version of its receiver.  Alas, this doesn't work out, since tokenization relies on concepts of whitespace and comment, which are often specific to a given grammar. Hence, the combinator needs to be aan operation of the grammar, not of a specific production."
)
tokenFromChar: c <Character> ^ <CombinatorialParser> = (
 

^ tokenFor: ( char: c)
)
tokenFromSymbol: s <Symbol> ^ <CombinatorialParser> = (
  

^ tokenFor: (SymbolicTokenParser new forSymbol: s)
)
whitespace ^ <CombinatorialParser> = (
 
"It's rare that anyone will need to change this definition"

 "^ aWhitespaceChar plus."

"As an optimization, we process whitespace with a dedicated scanning parser. Of course, this regrettable, and Perhaps Squeak specific, but it is a significant win."

^WhitespaceParser new 
            
           
)
wrap: blk = (
 

^WrappingParser new wrapParser: self withWrapper: blk
)
wrapper: blk = (


^ wrap: [:rs | blk
			valueWithArguments: (rs isKindOfCollection
						ifTrue: [rs asArray]
						ifFalse: [Array with: rs])
			"^wrap: blk"]
))
class CommentParser = CombinatorialParser (| termBlock |)
('parsing'
parse: input inContext: context ifError: blk = (


	[termBlock value: input] whileFalse: [
		input nextIfAbsent: [blk value:'Premature end of input' value: input position-1]
	]. 
))
class EOIParser = CombinatorialParser (
"A parser that only succeeds at the end of the input. This addresses a common problem with combinator parsers. If there is garbage at the end of the input, no production matches it. Consequently, the parsers backtrack to the point where the legal input was consumed, without giving an error message about the junk at the end.")
('parsing'
parse: input inContext: context ifError: blk = (


  input atEnd 
      ifTrue:[^true]
      ifFalse:[blk value: 'Unexpected input' value: input position+1]
))
class EmptyParser = CombinatorialParser (
"The parser that parses the empty input. It always succeeds. This class is a singleton.")
('parsing'
parse: input inContext: context ifError: blk = (
 
  ^nil
))
class FailingParser = CombinatorialParser (
"The parser that always fails. It never parses anything. This class is a singleton.")
('parsing'
parse: input inContext: context ifError: blk = (

  ^blk value: 'Failing Parser invoked' value: input position
))
class NegatingParser for: aParser = CombinatorialParser (
"A parser that implements the  'not' combinator, as in Ford's PEGs. It contains a parser p, and succeeds if p fails and vice versa. It does not move the input forward if it succeeds."| p <CombinatorialParser> = aParser. |)
('parsing'
parse: input inContext: ctxt  ifError: blk = (


| position |

position:: input position.
p parse: input inContext: ctxt ifError:[:msg :pos |  input position: position. ^true].
blk value: 'not combinator failed' value: position.
))
class ParserContext = Object (
"This class defines a context that is shared among a set of combinatorial parsers during a parse. The context can be used to manage information on parsing errors: rather than always report the latest failure that occurred, we can report the one that occurred deepest in the input stream, or implement some other policy - as long as we can record what failures took place.

In addition, this class could be used to support context-sensitive parsing. 
"| failures ::= OrderedCollection new. |)
('error handling'
errorMessage = (


failures isEmpty ifTrue:[^''].
^failures last first
)
errorPosition = (


failures isEmpty ifTrue:[^-1].
^failures last last
)
recordFailure: f = (

(failures isEmpty or: [ failures last last <= f last ])
		ifTrue: [ failures addLast: f]
))
class ParserError = Error (| message <String> position <Integer> |)
()
class PlusParser = CombinatorialParser (
"An attempt to optimize the + operator by having a dedicated parser for it."| p |)
('parsing'
parse: input inContext: context ifError:blk = (


| currentPos results nextResult |

results:: OrderedCollection new.
results add: ( p parse: input inContext: context ifError: blk).
[true] whileTrue:[ 
	                      currentPos:: input position.
	                      nextResult::  p parse: input inContext: context
	                                                     ifError:[:msg :pos | 
		                                                           input position: currentPos.
		                                                           ^results
		                                                           ].
	                     results add: nextResult.
		             ]
))
class PredicateTokenParser = CombinatorialParser (
"Parses a single token matching a given
predicate."| predicate errMsg |)
('initialization'
accept: pred   errorMsg: err = (
 
 predicate: pred.
 errMsg: err.
)'parsing'
parse: input inContext: context  ifError: blk = (
 
| token  |
token:: input nextIfAbsent:[blk value:errMsg value: input position-1].
(predicate value: token) 
  ifFalse:[blk value: errMsg value: input position-1 ].
 ^token.
))
class SequentialParser = CombinatorialParser (
"A parser that activates a sequence of subparsers (P1, ,Pn).

One might think that it would be sufficient to define a class that
combined two parsers in sequence, corresponding to the &
operator, just like AlternatingParser corresponds to the | operator.
However, grammar productions typically involve several elements, so
the typical sequencing operation is n-ary "| parserFuns subparsers |)
('accessing - private'
parsers = (

	"accessor for parsers that caches value of all blocks"
	subparsers isNil
		ifTrue: [subparsers:: parserFuns
						collect: [:pf | 
							self
								assert: [pf isBlock].
							pf value]].
	^ subparsers
)'combinators'
, p = (
 

| o  |

self assert:[p isBlock].

o:: OrderedCollection new addAll:  parserFuns; add: p; yourself.
^SequentialParser new on: o
)'initialization'
on: t = (
 

  parserFuns:: t.
)'parsing'
parse: input inContext: context ifError: blk = (
 
	^  parsers
		collect: [:p | p parse: input inContext: context ifError: blk]
)'wrapping'
wrapper: blk = (
  
"untypesafe, but convenient. We can dynamically ensure
that the arity of the incoming block matches that of this parser.
Given that this routine is only called during parser construction,
dynamic failure of the asserts is sufficient.

We cannot ensure type correctness of the arguments to the block using
this interface. One can use the more verbose followedBy: combinators
if that is deemed essential.
"

self assert:[blk numArgs =  parserFuns size].
^self wrap:[:rs | blk valueWithArguments: rs asArray]
      
))
class StarParser = CombinatorialParser (
"An attempt to optimize the * operator by having a dedicated parser for it."| p |)
('parsing'
parse: input inContext: context ifError:blk = (


| currentPos results nextResult |

results:: OrderedCollection new.

[true] whileTrue:[ 
	                      currentPos:: input position.
	                      nextResult::  p parse: input inContext: context 
	                                                     ifError:[:msg :pos | 
		                                                           input position: currentPos.
		                                                           ^results
		                                                           ].
	                     results add: nextResult.
		             ]
))
class SymbolicTokenParser = CombinatorialParser (
"Parses a given symbol.  One could derive this as an alternation of character parsers, but the derivation is more verbose than defining it directly, and less efficient, so why bother?"| symbol |)
('initialization'
forSymbol: s = (
 

 symbol: s
)'parsing'
parse: input inContext: context ifError: blk = (
 
	| errMsg pos |
	errMsg::  symbol , ' expected'.
	pos:: input position.
	 symbol
		do: [:c | c = (input nextIfAbsent: [blk value: errMsg value: pos])
				ifFalse: [blk value: errMsg value: pos]].
	^  symbol
))
class Token = Object (
"Represents a token of input. Basically, it attaches a start position
to the token's value. Indeally, we'd use a tuple for this, which is why this class
implements the tuple protocol. We could use an array, but that would not be 
typesafe. Until we have tuples, we'll use this class.

It's not yet clear if we should bother adding token codes or values here."| token start end |)
('access'
at1 = (
 
^ token
)
at2 = (

^ start
)
at: n = (
 

self assert:[ n <= 2].
n = 1 ifTrue:[^ token].
^ start
)
fst = (

^ start
)
snd = (

^ token
)'as yet unclassified'
concreteEnd ^ <Integer> = (
	^end
)
concreteStart ^ <Integer> = (
	^start
)'initialization'
for: t start: p = (


 token: t.
 start: p.
)
for: t start: p end: e = (


 token: t.
 start: p.
 end: e.
))
class TokenParser = PredicateTokenParser (
"A parser that accepts a single, specified token.
")
('initialization'
for: token = (
 
^self accept:[:t  | t = token]
      errorMsg: token printString, ' expected'
))
class TokenizingParser = CombinatorialParser (| parser |)
('parsing'
parse: input inContext: context ifError: blk = (

| pos  res  |

pos:: input position + 1.
res::  parser parse: input inContext: context ifError: blk.
^Token new for: res start: pos end: input position
))
class WhitespaceParser = CombinatorialParser (
"A simple scanner to optimize the handling of whitespace. Should be equivalent to'
 aWhitespaceChar plus
Eventually, the framework should optimize well enough that this will be unnecessary."| comment |)
('parsing'
parse: input inContext: context ifError: blk = (

| pos |

pos:: input position.
comment::  OrderedCollection new.
[| c | c:: input peekIfAbsent:[]. c isNil ifTrue:[false] ifFalse:[c isSeparator] ]
 whileTrue:[ comment add: input next].
comment isEmpty ifTrue:[blk value: 'Whitespace expected' value: pos].
^comment
))
class WrappingParser = CombinatorialParser (
"Used to transform the output of another parser. A wrapping parser accepts exactly the same input as the wrapped
parser does, and performs the same error handling. The only differenceis that it takes the output of the wrapped
parser and passes it on to a wrapper block which uses it to produce a new result, which is the output of the wrapping
parser. A typical use is to build nodes of an abstract syntax tree.

The output type of the wrapped parser, S, is also the input to the wrapper. The output type of the wrapper is the output of this 
(the wrapping) parser."| parser wrapperBlock |)
('initialization'
wrapParser: p withWrapper: blk = (
 

parser:: p.
wrapperBlock:: blk
)'parsing'
parse: input inContext: context ifError: blk = (
 

^wrapperBlock value: (parser parse: input inContext: context ifError: blk )
)))