CombinatorialParsing.ns

Newspeak3
'Root'
class CombinatorialParsing usingPlatform: platform = (
(* The Newspeak parser combinator library.

Copyright 2008 Cadence Design Systems, Inc.
Copyright 2012 Cadence Design Systems, Inc.
Copyright 2013 Ryan Macnak

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 *)
|

private List = platform collections List.
private Map = platform collections Map.
private ObjectMirror = platform mirrors ObjectMirror.
|) (
class AlternatingParser either: p_ or: q_ = CombinatorialParser (
(* A parser that parses either P or Q. *)
|
p <CombinatorialParser> = p_.
q <CombinatorialParser> = q_.
|) (
combineErrors: e1 <String> and: e2 <String> at: pos <Integer> with: blk <[:String :Integer]> = (
	| or <String> msg <String> |
	or:: (e1 = '' or: [e2 = '']) ifTrue: [''] ifFalse: [' or '].
	msg:: e1 = e2 ifTrue: [e1] ifFalse: [e1, or , e2].
	^blk value: msg value: pos
)
public parse: input <ReadStream> inContext: context <ParserContext> ifError: blk <[:String :Integer]> = (
	| rewindPosition |
	rewindPosition:: input position.
  	^p parse: input inContext: context ifError:
		[:msg1 :pos1 |
		input position: rewindPosition.
		context recordFailure: {msg1. pos1}.
		^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]]
)
) : (
)
class CharacterRangeParser from: startChar <Character> to: endChar <Character> = CombinatorialParser (|
startRune <Integer> = startChar runeAt: 1.
endRune <Integer> = endChar runeAt: 1.
message <String> = startChar asString, '-', endChar asString, ' expected'.
|) (
public parse: input inContext: context ifError: blk = (
	| rune |
	input atEnd ifTrue: [^blk value: message value: input position].
	rune:: input next.
	rune < startRune ifTrue: [^blk value: message value: input position].
	rune > endRune ifTrue: [^blk value: message value: input position].
	^rune
)
) : (
)
public 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. *)
) (
public parse: input inContext: context ifError: blk = (
	| comment char onFail |
	onFail:: [blk value: 'Premature end of input' value: input position - 1].
	comment: List new.
	[termBlock value: input] whileFalse:
		[input atEnd ifTrue: [^onFail].
		comment add: input next].
	^comment
)
) : (
)
public 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. *)
| public name |) (
public & p <CombinatorialParser> ^<SequentialParser> = (
	(* The sequencing combinator (implicit in BNF). *)
	^SequentialParser withSubparsers: {self. p}
)
public , p <CombinatorialParser> ^<SequentialParser> = (
	(* The flattening 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
)
public isKindOfCombinatorialParser = (
	(* should be auto-generated *)
	^true
)
public not ^<CombinatorialParser> = (
	^NegatingParser withSubparser: self
)
public opt ^ <CombinatorialParser> = (
	(* [P] = P | e *)
	^self | empty
)
public parse: input <ReadStream> ^ <T | ParserError> = (
	^self
		parse: input
		ifErrorNoContext: [:msg :pos | ^(ParserError message: msg position: pos) signal]
)
public parse: input <ReadStream> ifError: blk <[:String :Integer | X def]> ^ <T|X> = (
	#FLAG.
	^self parse: input ifErrorNoContext: blk
(* | 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.
	  ] *)
)
public parse: input <ReadStream> ifErrorNoContext: blk <[:String :Integer | X def]> ^ <T|X> = (
	(* YK - a context-less protocol for speeding up parsing *)
	(* Turns out maintaining a context is expensive in runtime and doesn't
	do much for locating errors. Experimenting with other error localization
	mechanism. To minimize impact, the parse:inContext:ifError: protocol
	is maintained, and a bogus reportFailure is implemented on self *)
	^self parse: input inContext: self ifError: blk
)
public parse: input <ReadStream> inContext: context ifError: blk = (
	subclassResponsibility
)
public parseString: input <String> ^ <T | ParserError> = (
	^self parse: (ParserStream over: input)
)
public parseString: input <String> ifError: blk <[:String :Integer | X def]> ^ <T|X> = (
	^self parse: (ParserStream over: input) ifError: blk
)
public plus ^<CombinatorialParser> = (
	(* Return a parser that accepts one or more repetitions of what the receiver accepts. Denoted by the postfix + in BNF *)
	^PlusParser withSubparser: self.
)
public 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 |
	                    List new  addFirst: fst; addAll: rst; yourself (* could be optimized to reuse rst *)
	       ]
)
public 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]
)
public printOn: stream = (
	name isNil
		ifTrue: [super printOn: stream]
		ifFalse: [stream nextPutAll: name]
)
public recordFailure: f = (
	(* YK- do nothing, save time *)
)
public 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. *)
	^StarParser withSubparser: self.
)
public 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: [List new] ifFalse: [rs]]
)
public 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: [List new] ifFalse: [rs]]
)
public ultimateParser = (
	(* Used to bypass 0 .. n ForwardReferenceParsers to get to the real parser. Usually, this is self. Only ForwardReferenceParsers forward the request to their forwardee. *)
	^self
)
public value = (
	^self
)
public wrap: blk = (
	^WrappingParser new wrapParser: self withWrapper: blk
)
public wrap: blk name: msg = (
	^(NamedWrappingParser new wrapParser: self withWrapper: blk) name: msg
)
public wrapper: blk = (
	^wrap: [:result | blk valueWithArguments: result asArray]
)
public wrapper: blk name: msg = (
	^wrap: [:result | blk valueWithArguments: result asArray]
	name: msg
)
public | p <CombinatorialParser> ^<CombinatorialParser> = (
	(* The alternation combinator - denoted by | in BNF *)
	^AlternatingParser either: self or: p
)
public char: c <Character> ^<CombinatorialParser> = (
	^CharacterRangeParser from: c to: c
)
public charBetween: c1 <Character> and: c2 <Character> ^<CombinatorialParser> = (
	^CharacterRangeParser from: c1 to: c2
)
public empty ^<CombinatorialParser> = (
	^EmptyParser new
)
public eoi ^<CombinatorialParser> = (
	^tokenFor: EOIParser new
)
public fail ^<CombinatorialParser> = (
	^FailingParser new
)
) : (
)
public class CommentParser = CombinatorialParser (|
	public termBlock
|) (
public 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. *)
) (
public 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. *)
) (
public parse: input inContext: context ifError: blk = (
	^nil
)
) : (
)
public class ExecutableGrammar = CombinatorialParser (
(* This class is intended to implement Parser
Combinators. A ExecutableGrammar[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. *)
|
	forwardReferenceTable ::= Map new.
	protected selfMirror <ObjectMirror> = ObjectMirror reflecting: self.
|self setupForwardReferences.
  self bindForwardReferences) (
bindForwardReferences = (
	forwardReferenceTable keysAndValuesDo:
		[:k :v | v bindingRoutine: [finalBindForwardReferences]].
)
comment ^<CombinatorialParser> = (
	^fail
)
finalBindForwardReferences = (
	forwardReferenceTable keysAndValuesDo:
		[:k :v | | p |
		p:: (selfMirror getSlot: k asSymbol) reflectee.
		(p isKindOfCombinatorialParser) ifTrue: [
			v bind: p.
			p name: k (* a good place to name the productions *)]]
)
public nameProductions = (
	selfMirror getClass slots do:
		[:slot <SlotMirror> |
		| parser |
		parser:: (selfMirror getSlot: slot simpleName) reflectee.
		parser isKindOfCombinatorialParser ifTrue: [parser name: slot name]].
)
setupForwardReferences = (
	(* Go through all non-nil instance variables and set them to a fresh forward reference. If these do not correspond to productions, they will be overridden by the subclass. *)
	selfMirror getClass slots do:
		[:slot <SlotMirror> |
		| fref iv |
		iv:: slot name.
		fref:: ForwardReferenceParser new.
		(selfMirror getSlot: iv) reflectee isNil ifTrue:
			[forwardReferenceTable at: iv put: fref.
			selfMirror setSlot: iv to: fref]]
)
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. *)

^(whitespace | comment) star, (TokenizingParser withSubparser: p)
	wrapper: [:discardWhitespace :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: string <Symbol> ^<CombinatorialParser> = (
	^tokenFor: (StringParser for: string)
)
public 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
)
) : (
)
class FailingParser = CombinatorialParser (
(* The parser that always fails. It never parses anything. *)
) (
public parse: input inContext: context ifError: blk = (
	^blk value: 'Failing Parser invoked' value: input position
)
) : (
)
class ForwardReferenceParser = CombinatorialParser (|
	forwardee
	public bindingRoutine
|) (
public & p <CombinatorialParser> ^ <CombinatorialParser> = (
	^forwardee isNil
		ifTrue: [super & p]
		ifFalse: [forwardee & p]
)
public bind: p <CombinatorialParser> = (
	(* as a precaution, only bind if p is a parser *)
	(p isKindOfCombinatorialParser) ifTrue: [forwardee: p]
)
public opt = (
	^forwardee isNil
		ifTrue: [super opt]
		ifFalse: [forwardee opt]
)
public parse: input inContext: context  ifError: blk = (
	^parserToForwardTo parse: input inContext: context  ifError: blk.
)
public parserToForwardTo ^<CombinatorialParser> = (
	forwardee isNil ifTrue: [bindingRoutine value].
	^forwardee
)
public ultimateParser ^<CombinatorialParser> = (
	^parserToForwardTo ultimateParser
)
public wrapper: blk ^<CombinatorialParser> = (
	(* see comments in ForwardingWrappingParser *)
	^ForwardingWrappingParser new wrapParser: self withWrapper: blk
)
public | p = (
	^forwardee isNil
		ifTrue: [super | p]
		ifFalse: [forwardee | p]
)
) : (
)
class ForwardingWrappingParser = WrappingParser (
(* When a ForwardingReferenceParser is wrapped using the wrapper: combinator, we don't know what the  arity the wrapping block should have - it will depend on the arity of the parser we forward to.  We cannot determine whether to use the implementation of wrapper: given in ordinary parsers, which forwards to the wrap: combinator (designed for block with arity 1) or the implementation used in SequentialParsers, (designed for n-ary blocks, where n is the length of the list of parsers the SequentialParser sequences). Instead, we must defer the decision on how to handle the situation until the parser tree is complete. This is accomplished by using this class as the result of the wrapper: combinator for ForwardReferenceParser.

Instances of this class determiine how to act when asked to parse. At that time, the parse tree must be complete, and they can ask the ultimate parser for a wrappin parser that is suitable configured, and forward requests to it. *)
|
	wrappingParser
|) (
public parse: input inContext: context ifError: blk = (
	^trueWrappingParser parse: input inContext: context ifError: blk
)
trueWrappingParser ^<WrappingParser> = (
	wrappingParser isNil ifTrue:
		[wrappingParser:: parser ultimateParser wrapper: wrapperBlock].
	^wrappingParser
)
) : (
)
class NamedWrappingParser = WrappingParser (
(* This is exactly the same as a WrappingParser, but it passes itself down
in the context parameter, to provide more meaningful error messages. *)
) (
public parse: input inContext: context ifError: blk = (
	^wrapperBlock value: (parser parse: input inContext: self ifError: blk )
)
) : (
)
class NegatingParser withSubparser: p = 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. *)
| subparser <CombinatorialParser> = p. |) (
public parse: input inContext: ctxt ifError: blk = (
	| rewindPosition |
	rewindPosition:: input position.
	subparser parse: input inContext: ctxt ifError: [:msg :pos | input position: rewindPosition. ^true].
	blk value: 'not combinator failed' value: rewindPosition.
)
) : (
)
class ParserContext = (
(* 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 ::= List new. |) (
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]
)
) : (
)
public class ParserError message: m position: p = Error (|
	public message <String> = m.
	public position <Integer> = p.
|) (
public description = (
	^'ParserError: ', message
)
public printString = (
	^'ParserError: ', message, ' (', position printString, ')'
)
) : (
)
class ParserStream over: string = (|
public contents = string.
public position ::= 0.
|) (
public atEnd = (
	^position >= contents size
)
public next = (
	position >= contents size ifTrue: [^nil].
	position:: 1 + position.
	^contents runeAt: position
)
public peek = (
	position >= contents size ifTrue: [^nil].
	^contents runeAt: 1 + position
)
) : (
)
class PlusParser withSubparser: p = CombinatorialParser (
(* An attempt to optimize the + operator by having a dedicated parser for it. *)
| subparser = p. |) (
public parse: input inContext: context ifError: blk = (
	| rewindPosition results nextResult |
	results:: List new.
	results add: (subparser parse: input inContext: context ifError: blk).
	[
		rewindPosition: input position.
		nextResult:: subparser
			parse: input
			inContext: context
			ifError: [:msg :pos |
				input position: rewindPosition.
				^results].
		results add: nextResult.
	] repeat.
)
) : (
)
class SequentialParser withSubparsers: s = 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 *)
| subparsers <Array[CombinatorialParser]> = s. |) (
public , p <CombinatorialParser> ^<SequentialParser> = (
	^SequentialParser withSubparsers: (subparsers copyWith: p)
)
public parse: input inContext: context ifError: blk = (
	^subparsers
		collect: [:p | p parse: input inContext: context ifError: blk]
)
public wrapper: block = (
	(* 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. *)
	assert: [block numArgs = subparsers size]
		message: 'Block arity does not match production arity'.
	^self wrap: [:results | block valueWithArguments: results asArray]
)
) : (
)
class StarParser withSubparser: p = CombinatorialParser (
(* An attempt to optimize the * operator by having a dedicated parser for it. *)
| subparser = p. |) (
public parse: input inContext: context ifError: blk = (
	| rewindPosition results nextResult |
	results:: List new.
	[
		rewindPosition: input position.
		nextResult:: subparser
			parse: input
			inContext: context
			ifError: [:msg :pos |
				input position: rewindPosition.
				^results].
		results add: nextResult.
	] repeat.
)
) : (
)
class StringParser for: s <String> = 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? *)
| string = s. |) (
public parse: input inContext: context ifError: blk = (
	| pos |
	pos:: input position.
	1 to: string size do: [:index |
		input atEnd ifTrue:
			[^blk value: (string, ' expected') value: pos].
		(string runeAt: index) = input next ifFalse:
			[^blk value: (string, ' expected') value: pos]].
	^string
)
) : (
)
public class Token value: v start: s end: e = (
(* 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. *)
|
	public value = v.
	public start = s.
	public end = e.
|) (
) : (
)
public class TokenizingParser withSubparser: p = CombinatorialParser (| subparser = p. |) (
public parse: input inContext: context ifError: blk = (
	| pos res |
	pos:: input position + 1.
	res:: subparser parse: input inContext: context ifError: blk.
	^Token value: 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. *)
) (
public parse: input inContext: context ifError: blk = (
	| rewindPosition |
	rewindPosition:: input position.
	[input atEnd ifTrue: [false] ifFalse: [input peek <= 32]] whileTrue: [input next].
	input position = rewindPosition ifTrue:
		[input position: rewindPosition.
		blk value: 'Whitespace expected' value: rewindPosition].
	^Token value: #whitespace start: rewindPosition + 1 end: input position
)
) : (
)
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 |) (
public parse: input inContext: context ifError: blk = (
	^wrapperBlock value: (parser parse: input inContext: context ifError: blk )
)
public wrapParser: p withWrapper: blk = (
	parser:: p.
	wrapperBlock:: blk
)
) : (
)
) : (
)