--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/PPPredicateObjectParser.st	Thu Aug 18 20:56:17 2011 +0200
@@ -0,0 +1,162 @@
+"{ Package: 'squeak:petitparser' }"
+
+PPPredicateParser subclass:#PPPredicateObjectParser
+	instanceVariableNames:''
+	classVariableNames:''
+	poolDictionaries:''
+	category:'PetitParser-Parsers'
+!
+
+PPPredicateObjectParser comment:'A parser that accepts if a given predicate on one element of the input sequence holds.'
+!
+
+
+!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
+	^ 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
+	^ 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_SVN
+    ^ '$Id: PPPredicateObjectParser.st,v 1.1 2011-08-18 18:56:17 cg Exp $'
+! !