"{ Package: 'stx:goodies/petitparser' }"

PPPredicateParser subclass:#PPPredicateObjectParser

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	category:'PetitParser-Parsers'

!

!PPPredicateObjectParser class methodsFor:'instance creation'!

on: aBlock message: aString

	^ self on: aBlock message: aString negated: [ :each | (aBlock value: each) not ] message: 'no ' , aString

!

on: aBlock message: aString negated: aNegatedBlock message: aNegatedString

	^ self new initializeOn: aBlock message: aString negated: aNegatedBlock message: aNegatedString

! !

!PPPredicateObjectParser class methodsFor:'factory-chars'!

blank

	^ self chars: (String with: Character space with: Character tab) message: 'blank expected'

!

char: aCharacter

	^ self expect: aCharacter message: (String with: $" with: aCharacter with: $") , ' expected'

!

char: aCharacter message: aString

	^ self expect: aCharacter message: aString

!

chars: aCollection message: aString

	^ self on: (PPCharSetPredicate on: [ :char | aCollection includes: char ]) message: aString

!

cr

    |cr|

    cr := Smalltalk isSmalltalkX 

            ifTrue:[Character return] 

            ifFalse:[Character cr].

    ^ self char: cr message: 'carriage return expected'

!

digit

	^ self on: (PPCharSetPredicate on: [ :char | char isDigit ]) message: 'digit expected'

!

hex

	^ self 

		on: (PPCharSetPredicate on: [ :char | 

			(char between: $0 and: $9) 

				or: [ (char between: $a and: $f) 

				or: [ (char between: $A and: $F) ] ] ])

		message: 'hex digit expected'

!

letter

	^ self on: (PPCharSetPredicate on: [ :char | char isLetter ]) message: 'letter expected'

!

lf

	^ self char: Character lf

!

lowercase

	^ self on: (PPCharSetPredicate on: [ :char | char isLowercase ]) message: 'lowercase letter expected'

!

newline

    |cr|

    cr := Smalltalk isSmalltalkX 

            ifTrue:[Character return] 

            ifFalse:[Character cr].

    ^ self chars: (String with: cr with: Character lf) message: 'newline expected'

!

punctuation

	^ self chars: '.,"''?!!;:#$%&()*+-/<>=@[]\^_{}|~' message: 'punctuation expected'

!

space

	^ self on: (PPCharSetPredicate on: [ :char | char isSeparator ]) message: 'separator expected'

!

tab

	^ self char: Character tab message: 'tab expected'

!

uppercase

	^ self on: (PPCharSetPredicate on: [ :char | char isUppercase ]) message: 'uppercase letter expected'

!

word

	^ self on: (PPCharSetPredicate on: [ :char | char isAlphaNumeric ]) message: 'letter or digit expected'

! !

!PPPredicateObjectParser class methodsFor:'factory-objects'!

any

	^ self

		on: [ :each | true ] message: 'input expected'

		negated: [ :each | false ] message: 'no input expected'

!

anyExceptAnyOf: aCollection

	^ self

		on: [ :each | (aCollection includes: each) not ] message: 'any except ' , aCollection printString , ' expected'

		negated: [ :each | aCollection includes: each ] message: aCollection printString ,  ' not expected'

!

anyOf: aCollection

	^ self

		on: [ :each | aCollection includes: each ] message: 'any of ' , aCollection printString , ' expected'

		negated: [ :each | (aCollection includes: each) not ] message: 'none of ' , aCollection printString ,  'expected'

!

between: min and: max

	^ self

		on: [ :each | each >= min and: [ each <= max ] ] message: min printString , '..' , max printString , ' expected'

		negated: [ :each | each < min or: [ each > max ] ] message: min printString , '..' , max printString , ' not expected'

!

expect: anObject

	^ self expect: anObject message: anObject printString , ' expected'

!

expect: anObject message: aString

	^ self 

		on: [ :each | each = anObject ] message: aString

		negated: [ :each | each ~= anObject ] message: 'no ' , aString

! !

!PPPredicateObjectParser methodsFor:'initialization'!

initializeOn: aBlock message: aString negated: aNegatedBlock message: aNegatedString

	predicate := aBlock.

	predicateMessage := aString.

	negated := aNegatedBlock.

	negatedMessage := aNegatedString

! !

!PPPredicateObjectParser methodsFor:'operators'!

negate

	"Answer a parser that is the negation of the receiving predicate parser."

	^ self class 

		on: negated message: negatedMessage 

		negated: predicate message: predicateMessage

! !

!PPPredicateObjectParser methodsFor:'parsing'!

parseOn: aStream

	^ (aStream atEnd not and: [ predicate value: aStream uncheckedPeek ])

		ifFalse: [ PPFailure message: predicateMessage at: aStream position ]

		ifTrue: [ aStream next ]

! !

!PPPredicateObjectParser class methodsFor:'documentation'!

version

    ^ '$Header: /cvs/stx/stx/goodies/petitparser/PPPredicateObjectParser.st,v 1.5 2014-03-04 14:33:20 cg Exp $'

!

version_CVS

    ^ '$Header: /cvs/stx/stx/goodies/petitparser/PPPredicateObjectParser.st,v 1.5 2014-03-04 14:33:20 cg Exp $'

!

version_SVN

    ^ '$Id: PPPredicateObjectParser.st,v 1.5 2014-03-04 14:33:20 cg Exp $'

! !