"{ 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
        Smalltalk isSmalltalkX ifTrue:[
            ^ self char: Character return message: 'carriage return expected'
        ].
        ^ self char: Character 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
        Smalltalk isSmalltalkX ifTrue:[
            ^ self chars: (String with: Character return with: Character lf) message: 'newline expected'
        ].
        ^ self chars: (String with: Character 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: aCollectionOfChars
	^ self
		on: [ :each | (aCollectionOfChars includes: each) not ] message: 'any except ' , aCollectionOfChars printString , ' expected'
		negated: [ :each | aCollectionOfChars includes: each ] message: aCollectionOfChars printString ,  ' not expected'
!

anyOf: anArray
	^ self
		on: [ :each | anArray includes: each ] message: 'any of ' , anArray printString , ' expected'
		negated: [ :each | (anArray includes: each) not ] message: 'none of ' , anArray 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.4 2012-12-01 14:29:54 cg Exp $'
!

version_CVS
    ^ '$Header: /cvs/stx/stx/goodies/petitparser/PPPredicateObjectParser.st,v 1.4 2012-12-01 14:29:54 cg Exp $'
!

version_SVN
    ^ '§Id: PPPredicateObjectParser.st 2 2010-12-17 18:44:23Z vranyj1 §'
! !