SystemOrganization addCategory: #'PetitGui-Core'!

!PPChoiceParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/11/2009 20:54'!
exampleOn: aStream
	"If there is already a lot written, try to pick an empty possiblity."
	
	aStream position > 512 ifTrue: [
		parsers
			detect: [ :each | each isNullable ]
			ifNone: [ ^ self ] ].
	parsers atRandom exampleOn: aStream! !

!PPChoiceParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/17/2009 22:52'!
morphicShapeSeen: aSet depth: anInteger
	^ self morphicShapeSeen: aSet depth: anInteger do: [ :cc |
		| morph |
		morph := self newColumnMorph 
			cellInset: 5;
			yourself.
		self children do: [ :each | 
			morph addMorphBack: (self newRowMorph
				hResizing: #spaceFill;
				addMorphBack: (each class = PPEpsilonParser 
					ifTrue: [ self newSpacerMorph extent: 0 @ 0 ]
					ifFalse: [ cc value: each ]);
				addMorphBack: (self newColumnMorph
					hResizing: #spaceFill;
					addMorphBack: (self newSpacerMorph height: 10);
					addMorphBack: ((LineMorph from: 0 @ 0 to: 20 @ 0 color: Color black width: 1)
						hResizing: #spaceFill;
						minWidth: 20;
						yourself);
					yourself);
				yourself) ].
		morph fullBounds.
		self newRowMorph
			addMorphBack: (self newColumnMorph
				addMorphBack: (self newSpacerMorph height: 10);
				addMorphBack: (LineMorph from: 0 @ 0 to: 20 @ 0 color: Color black width: 1);
				yourself);
			addMorphBack: (self newColumnMorph
				addMorphBack: (self newSpacerMorph width: 1; height: 10);
				addMorphBack: (LineMorph from: 0 @ 0 to: 0 @ (morph height - 23) color: Color black width: 1);
				yourself);
			addMorphBack: morph;
			addMorphBack: (self newColumnMorph
				addMorphBack: (self newSpacerMorph width: 1; height: 10);
				addMorphBack: (LineMorph from: 0 @ (morph height - 23) to: 0 @ 0 color: Color black width: 1)
					makeForwardArrow;
					width: 1;
				yourself);
			yourself ]! !

!PPPluggableParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/13/2009 14:41'!
displayName
	^ String streamContents: [ :stream | block decompile shortPrintOn: stream ]! !

!PPAndParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/13/2009 14:17'!
displayDescription
	^ 'and'! !

!PPEpsilonParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/6/2009 18:42'!
displayName
	^ 'epsilon'! !

!PPLiteralParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/13/2009 14:19'!
displayName
	^ literal printString! !

!PPEndOfInputParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/13/2009 14:18'!
displayDescription
	^ 'end of input'! !

!PPSequenceParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/9/2009 14:24'!
exampleOn: aStream
	parsers do: [ :each | each exampleOn: aStream ]! !

!PPSequenceParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/17/2009 21:54'!
morphicShapeSeen: aSet depth: anInteger
	^ self morphicShapeSeen: aSet depth: anInteger do: [ :cc |
		self children
			inject: self newRowMorph
			into: [ :result :each | 
				result 
					addMorphBack: (cc value: each);
					yourself ] ]! !

Object subclass: #PPBrowser
	instanceVariableNames: 'browser'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitGui-Core'!

!PPBrowser class methodsFor: 'instance-creation' stamp: 'lr 11/6/2009 16:32'!
open
	^ self new open! !

!PPBrowser methodsFor: 'browse-parts' stamp: 'lr 11/11/2009 20:48'!
browseClassesOn: aBrowser
	aBrowser tree
		title: 'Classes';
		format: [ :class | class name ];
		children: [ :class | self subclassesOf: class ];
		act: [
			self selectedClass removeFromSystem.
			aBrowser entity: self rootClass ]
			on: $r entitled: 'remove (x)';
		act: [
			StandardToolSet browse: self selectedClass selector: nil ] 
			on: $b entitled: 'browse (b)'! !

!PPBrowser methodsFor: 'browse-parts' stamp: 'lr 11/11/2009 20:45'!
browseExampleOn: aBrowser
	aBrowser text
		title: 'Example';
		useExplicitNotNil;
		display: [ :parsers | self production example ]! !

!PPBrowser methodsFor: 'browse-parts' stamp: 'lr 11/11/2009 20:44'!
browseFirstOn: aBrowser
	aBrowser list
		title: 'First';
		useExplicitNotNil;
		format: [ :parser | parser displayName ];
		display: [ :parsers | self production firstSet ]! !

!PPBrowser methodsFor: 'browse-parts' stamp: 'lr 11/11/2009 20:44'!
browseFollowOn: aBrowser
	aBrowser list
		title: 'Follow';
		useExplicitNotNil;
		format: [ :parser | parser displayName ];
		display: [ :parsers | self production followSet ]! !

!PPBrowser methodsFor: 'browse-parts' stamp: 'lr 11/17/2009 20:22'!
browseGraphOn: aBrowser
	aBrowser morph
		title: 'Graph';
		useExplicitNotNil;
		display: [ :parsers |
			| morph |
			morph := ScrollPane new.
			morph color: Color white.
			morph scroller addMorph: self production morphicProduction.
			morph ]! !

!PPBrowser methodsFor: 'browse' stamp: 'lr 11/11/2009 20:46'!
browseOn: aBrowser
	aBrowser title: 'PetitParser Browser'; color: Color yellow muchDarker.
	aBrowser row: [ :row | row column: #classes; column: #selectors ].
	aBrowser row: [ :row | row column: #actions span: 2 ] span: 2.
	
	aBrowser showOn: #classes; using: [ 
		self browseClassesOn: aBrowser ].
	aBrowser showOn: #selectors; from: #classes; using: [
		self browseSelectorsOn: aBrowser ].

	aBrowser showOn: #actions; from: #classes; from: #selectors; using: [
		self browseSourceOn: aBrowser.
		self browseTestOn: aBrowser.
		self browseGraphOn: aBrowser.
		self browseExampleOn: aBrowser.
		self browseFirstOn: aBrowser.
		self browseFollowOn: aBrowser ]! !

!PPBrowser methodsFor: 'browse-parts' stamp: 'lr 11/11/2009 09:16'!
browseSelectorsOn: aBrowser
	aBrowser list
		title: 'Selectors';
		format: [ :class | class asString ];
		display: [ :class | 
			(((class allInstVarNames
				copyWithoutAll: self rootClass allInstVarNames)
				collect: [ :each | each asSymbol ])
				select: [ :each | class includesSelector: each ])
				asSortedCollection ];
		act: [
			StandardToolSet 
				browse: self selectedClass 
				selector: self selectedSelector ] 
			on: $b entitled: 'browse (b)';
		act: [
			| class selector |
			class := self selectedClass.
			selector := self selectedSelector.
			(class instVarNames includes: selector)
				ifTrue: [ class removeInstVarName: selector ].
			class removeSelector: selector.
			aBrowser entity: self rootModel.
			self selectedClass: class ]
			on: $r entitled: 'remove (x)'! !

!PPBrowser methodsFor: 'browse-parts' stamp: 'lr 11/13/2009 08:54'!
browseSourceOn: aBrowser
	aBrowser text
		title: 'Source';
		useExplicitNotNil;
		display: [ self sourceCode ];
		forSmalltalk: [ self selectedClass ];
		act: [ :node | 
			| class selector |
			class := self selectedClass.
			selector := self sourceCode: node text asString in: class.
			aBrowser entity: self rootModel.
			self selectedClass: class.
			self selectedSelector: selector ]
		on: $s entitled: 'accept (s)'! !

!PPBrowser methodsFor: 'browse-parts' stamp: 'tg 11/16/2009 15:21'!
browseTestOn: aBrowser
	| table input output |
	table := aBrowser tabulator.
	table title: 'Test'; useExplicitNotNil.
	table row: #input; row: #output.
	
	input := String new.
	output := String new.
	table showOn: #input; using: [
		table text
			useExplicitNotNil;
			display: [ :parsers | input ];
			update: #selection on: $s entitled: 'parse (s)' with: [ :presentation |
				input := presentation text copy.
				output := self production end 
					parse: input asParserStream ];
			update: #selection on: $s entitled: 'inspect (i)' with: [ :presentation |
				input := presentation text copy.
				output := self production end
					parse: input asParserStream.
				output explore ] ].
	table showOn: #output; from: #input; using: [ 
		table text 
			display: [ output ] ]! !

!PPBrowser methodsFor: 'public' stamp: 'tg 11/16/2009 15:21'!
open
	browser := GLMTabulator new.
	self browseOn: browser.
	browser openOn: self rootModel! !

!PPBrowser methodsFor: 'accessing-view' stamp: 'lr 11/11/2009 09:06'!
production
	| parser selector |
	parser := self selectedClass new.
	selector := self selectedSelector ifNil: [ ^ parser ].
	^ parser instVarNamed: selector asString! !

!PPBrowser methodsFor: 'accessing' stamp: 'lr 11/11/2009 08:23'!
rootClass
	^ PPCompositeParser! !

!PPBrowser methodsFor: 'accessing' stamp: 'lr 11/11/2009 08:45'!
rootModel
	^ self subclassesOf: self rootClass! !

!PPBrowser methodsFor: 'accessing-view' stamp: 'lr 11/11/2009 09:14'!
selectedClass
	^ ((browser paneNamed: #classes) port: #selection) value! !

!PPBrowser methodsFor: 'accessing-view' stamp: 'lr 11/11/2009 09:06'!
selectedClass: aClass
	((browser paneNamed: #classes) port: #selection) value: aClass! !

!PPBrowser methodsFor: 'accessing-view' stamp: 'lr 11/11/2009 09:07'!
selectedSelector
	^ ((browser paneNamed: #selectors) port: #selection) value! !

!PPBrowser methodsFor: 'accessing-view' stamp: 'lr 11/11/2009 09:07'!
selectedSelector: aSelector
	((browser paneNamed: #selectors) port: #selection) value: aSelector! !

!PPBrowser methodsFor: 'accessing-view' stamp: 'lr 11/11/2009 20:42'!
sourceCode
	^ (self selectedClass ifNil: [ ^ String new ]) 
		sourceCodeAt: (self selectedSelector ifNil: [ #start ])
		ifAbsent: [ String new ]! !

!PPBrowser methodsFor: 'accessing-view' stamp: 'lr 11/13/2009 10:59'!
sourceCode: aString in: aClass
	| tree source selector |
	tree := RBParser parseMethod: aString onError: [ :msg :pos | nil ].
	source := tree isNil
		ifTrue: [ aString ]
		ifFalse: [ 
			| rewriter |
			rewriter := RBParseTreeRewriter new.
			rewriter
				replace: '`#literal' with: '`#literal asParser' when: [ :node |
					(node isLiteralNode and: [ node value isString or: [ node value isCharacter ] ])
						and: [ (node parent isNil or: [ node parent isMessage not or: [ node parent selector ~= #asParser ] ])
						and: [ (node parents noneSatisfy: [ :each | each isBlock ]) ] ] ];
				replaceMethod: '`@method: `@args | `@temps | ``@.statements. ``.statement `{ :node | node isReturn not }' 
					with: '`@method: `@args | `@temps | ``@.statements. ^ ``.statement'.
			(rewriter executeTree: tree)
				ifTrue: [ rewriter tree newSource ]
				ifFalse: [ aString ] ].
	selector := aClass compile: source.
	(aString numArgs = 0 and: [ (aClass allInstVarNames includes: selector) not ])
		ifTrue: [ aClass addInstVarName: selector asString ].
	^ selector! !

!PPBrowser methodsFor: 'querying' stamp: 'lr 11/11/2009 08:44'!
subclassesOf: aBehavior
	^ aBehavior subclasses asSortedCollection: [ :a :b | a name < b name ]! !

!PPFlattenParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/9/2009 14:28'!
exampleOn: aStream
	super exampleOn: aStream.
	aStream space! !

!PPFailingParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/13/2009 14:16'!
displayColor
	^ Color red! !

!PPFailingParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/6/2009 18:43'!
displayName
	^ message! !

!PPDelegateParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/13/2009 14:20'!
displayDescription
	^ nil! !

!PPDelegateParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/9/2009 14:27'!
exampleOn: aStream
	parser exampleOn: aStream! !

!PPDelegateParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/17/2009 22:41'!
morphicShapeSeen: aSet depth: anInteger
	^ self morphicShapeSeen: aSet depth: anInteger do: [ :cc |
		self displayDescription isNil
			ifTrue: [ cc value: parser ]
			ifFalse: [
				self newRowMorph
					color: (self backgroundForDepth: anInteger);
					addMorphBack: (self newColumnMorph
						addMorphBack: (cc value: parser);
						addMorphBack: (self newRowMorph
							hResizing: #spaceFill;
							listCentering: #center;
							addMorphBack: (StringMorph new
								contents: self displayDescription;
								yourself);
							yourself);
						yourself);		
					addMorphBack: (self newColumnMorph
						addMorphBack: (self newSpacerMorph height: 10);
						addMorphBack: (LineMorph from: 0 @ 0 to: 20 @ 0 color: Color black width: 1);
						yourself);
					yourself ] ]! !

!PPLiteralObjectParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/9/2009 14:25'!
exampleOn: aStream
	aStream nextPut: literal! !

!PPUnresolvedParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/13/2009 14:15'!
displayColor
	^ Color red! !

!PPLiteralSequenceParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/9/2009 14:25'!
exampleOn: aStream
	aStream nextPutAll: literal! !

!PPParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/13/2009 14:11'!
backgroundForDepth: anInteger
	^ Color gray: 1.0 - (anInteger / 20.0)! !

!PPParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/17/2009 20:34'!
displayColor
	^ self isLeaf
		ifTrue: [ Color purple ]
		ifFalse: [ Color blue ]! !

!PPParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/6/2009 18:31'!
displayName
	^ self name isNil
		ifFalse: [ self name asString ]
		ifTrue: [ self class name asString ]! !

!PPParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/9/2009 14:37'!
example
	^ String streamContents: [ :stream | self exampleOn: stream ] limitedTo: 1024! !

!PPParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/9/2009 14:20'!
exampleOn: aStream! !

!PPParser methodsFor: '*petitgui-morphic' stamp: 'lr 11/17/2009 22:03'!
morphicProduction
	^ self newRowMorph
		addMorphBack: (self newRowMorph
			layoutInset: 4;
			addMorphBack: (StringMorph new
				contents: self displayName;
				emphasis: TextEmphasis bold emphasisCode;
				yourself);
			yourself);
		addMorphBack: (self morphicShapeSeen: IdentitySet new depth: 0);
		addMorphBack: (self newColumnMorph
			addMorphBack: (self newSpacerMorph);
			addMorphBack: (LineMorph from: 0 @ 0 to: 20 @ 0 color: Color black width: 1)	
				makeForwardArrow;
			yourself);
		yourself! !

!PPParser methodsFor: '*petitgui-morphic' stamp: 'lr 11/17/2009 22:03'!
morphicShapeDefault
	^ self newRowMorph
		addMorphBack: (self newColumnMorph
			addMorphBack: (self newSpacerMorph);
			addMorphBack: (LineMorph from: 0 @ 0 to: 20 @ 0 color: Color black width: 1)	
				makeForwardArrow;
			yourself);
		addMorphBack: (self newRowMorph
			borderWidth: 1;
			layoutInset: 3;
			color: Color white;
			on: #click send: #value to: [ Transcript show: self; cr ];
			addMorphBack: (StringMorph new
				contents: self displayName;
				color: self displayColor;
				yourself);
			yourself);
		yourself! !

!PPParser methodsFor: '*petitgui-morphic' stamp: 'lr 11/13/2009 13:24'!
morphicShapeSeen: aSet depth: anInteger
	^ self morphicShapeDefault! !

!PPParser methodsFor: '*petitgui-morphic' stamp: 'lr 11/13/2009 13:43'!
morphicShapeSeen: aSet depth: anInteger do: aBlock
	" avoid recursion "
	(aSet includes: self)
		ifTrue: [ ^ self morphicShapeDefault ].
	" display nice name when possible "
	(anInteger > 0 and: [ self name notNil ]) 
		ifTrue: [ ^ self morphicShapeDefault ].
	" don't do it too deep "
	(anInteger > 10)
		ifTrue: [ ^ self morphicShapeDefault ].
	aSet add: self. 
	^ aBlock value: [ :parser |
		parser 
			morphicShapeSeen: aSet 
			depth: anInteger + 1 ]! !

!PPParser methodsFor: '*petitgui-morphic-creational' stamp: 'lr 11/17/2009 21:58'!
newColumnMorph
	^ AlignmentMorph newColumn
		cellPositioning: #topLeft;
		color: Color transparent;
		listCentering: #topLeft;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		layoutInset: 0;
		yourself! !

!PPParser methodsFor: '*petitgui-morphic-creational' stamp: 'lr 11/17/2009 21:57'!
newRowMorph
	^ AlignmentMorph newRow
		cellPositioning: #topLeft;
		color: Color transparent;
		listCentering: #topLeft;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		layoutInset: 0;
		yourself! !

!PPParser methodsFor: '*petitgui-morphic-creational' stamp: 'lr 11/17/2009 22:03'!
newSpacerMorph
	^ Morph new
		color: Color transparent;
		borderWidth: 0;
		extent: 7 @ 7;
		yourself! !

!PPNotParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/13/2009 14:17'!
displayDescription
	^ 'not'! !

!PPNotParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/11/2009 21:09'!
exampleOn: aStream! !

!PPPredicateParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/7/2009 14:21'!
displayName
	^ predicateMessage! !

!PPPredicateParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/11/2009 20:58'!
exampleOn: aStream
	"Produce a random character that is valid. If there are characters in the alpha-numeric range prefer those over all others."

	| valid normal |
	valid := Character allCharacters
		select: [ :char | predicate value: char ].
	normal := valid
		select: [ :char | char asInteger < 127 and: [ char isAlphaNumeric ] ].
	aStream nextPut: (normal isEmpty
		ifTrue: [ valid atRandom ]
		ifFalse: [ normal atRandom ])! !

!PPRepeatingParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/13/2009 14:18'!
displayDescription
	^ String streamContents: [ :stream |
		min = 0 
			ifFalse: [ stream print: min; nextPutAll: '..' ].
		max = SmallInteger maxVal
			ifTrue: [ stream nextPut: $* ]
			ifFalse: [ stream print: max ] ]! !

!PPRepeatingParser methodsFor: '*petitgui-accessing' stamp: 'lr 11/11/2009 20:57'!
exampleOn: aStream
	"Perform the minimal repeatitions required, and a random amount of more if possible and if not that much output has been produced yet."
	
	min timesRepeat: [ 
		super exampleOn: aStream ].
	(max - min min: 5) atRandom timesRepeat: [
		aStream position > 512
			ifTrue: [ ^ self ].
		super exampleOn: aStream ]! !