--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/parsers/smalltalk/PPSmalltalkParser.st Tue Oct 07 09:42:03 2014 +0100
@@ -0,0 +1,304 @@
+"{ Package: 'stx:goodies/petitparser/parsers/smalltalk' }"
+
+PPSmalltalkGrammar subclass:#PPSmalltalkParser
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitSmalltalk-Core'
+!
+
+PPSmalltalkParser comment:'Enhances the Smalltalk grammar with production actions to build parse-tree nodes of the refactoring browser.'
+!
+
+!PPSmalltalkParser methodsFor:'accessing'!
+
+startExpression
+ "Make the sequence node has a method node as its parent and that the source is set."
+
+ ^ ([ :stream | stream collection ] asParser and , super startExpression) map: [ :source :node |
+ (RBMethodNode selector: #doIt body: node)
+ source: source.
+ (node statements size = 1 and: [ node temporaries isEmpty ])
+ ifTrue: [ node statements first ]
+ ifFalse: [ node ] ]
+!
+
+startMethod
+ "Make sure the method node has the source code properly set."
+
+ ^ ([ :stream | stream collection ] asParser and , super startMethod)
+ map: [ :source :node | node source: source ]
+! !
+
+!PPSmalltalkParser methodsFor:'grammar'!
+
+array
+ ^ super array map: [ :openNode :statementNodes :closeNode |
+ (self buildArray: statementNodes)
+ left: openNode start;
+ right: closeNode start;
+ yourself ]
+!
+
+expression
+ ^ super expression map: [ :variableNodes :expressionNodes | self build: expressionNodes assignment: variableNodes ]
+!
+
+method
+ ^ super method map: [ :methodNode :bodyNode |
+ methodNode pragmas: bodyNode first.
+ methodNode body: bodyNode second.
+ self buildMethod: methodNode ]
+!
+
+methodDeclaration
+ ^ super methodDeclaration ==> [ :nodes |
+ RBMethodNode
+ selectorParts: nodes first
+ arguments: nodes second ]
+!
+
+methodSequence
+ ^ super methodSequence map: [ :periodNodes1 :pragmaNodes1 :periodNodes2 :tempNodes :periodNodes3 :pragmaNodes2 :periodNodes4 :statementNodes |
+ Array
+ with: pragmaNodes1 , pragmaNodes2
+ with: (self build: tempNodes sequence: periodNodes1 , periodNodes2 , periodNodes3 , periodNodes4 , statementNodes) ]
+!
+
+parens
+ ^ super parens map: [ :openToken :expressionNode :closeToken | expressionNode addParenthesis: (openToken start to: closeToken start) ]
+!
+
+pragma
+ ^ super pragma ==> [ :nodes |
+ (RBPragmaNode selectorParts: nodes second first arguments: nodes second second)
+ addComments: nodes first comments;
+ addComments: nodes last comments;
+ left: nodes first start;
+ right: nodes last start;
+ yourself ]
+!
+
+return
+ ^ super return map: [ :token :expressionNode | RBReturnNode return: token start value: expressionNode ]
+!
+
+sequence
+ ^ super sequence map: [ :tempNodes :periodNodes :statementNodes | self build: tempNodes sequence: periodNodes , statementNodes ]
+!
+
+variable
+ ^ super variable ==> [ :token | RBVariableNode identifierToken: token ]
+! !
+
+!PPSmalltalkParser methodsFor:'grammar-blocks'!
+
+block
+ ^ super block map: [ :leftToken :blockNode :rightToken | blockNode left: leftToken start; right: rightToken start ]
+!
+
+blockArgument
+ ^ super blockArgument ==> #second
+!
+
+blockBody
+ ^ super blockBody
+ ==> [ :nodes |
+ | result |
+ result := RBBlockNode arguments: nodes first first body: nodes last.
+ nodes first last ifNotNil: [ result bar: nodes first last start ].
+ result ]
+! !
+
+!PPSmalltalkParser methodsFor:'grammar-literals'!
+
+arrayLiteral
+ ^ super arrayLiteral ==> [ :nodes | RBLiteralArrayNode startPosition: nodes first start contents: nodes second stopPosition: nodes last start isByteArray: false ]
+!
+
+arrayLiteralArray
+ ^ super arrayLiteralArray ==> [ :nodes | RBLiteralArrayNode startPosition: nodes first start contents: nodes second stopPosition: nodes last start isByteArray: false ]
+!
+
+byteLiteral
+ ^ super byteLiteral ==> [ :nodes | RBLiteralArrayNode startPosition: nodes first start contents: nodes second stopPosition: nodes last start isByteArray: true ]
+!
+
+byteLiteralArray
+ ^ super byteLiteralArray ==> [ :nodes | RBLiteralArrayNode startPosition: nodes first start contents: nodes second stopPosition: nodes last start isByteArray: true ]
+!
+
+charLiteral
+ ^ super charLiteral ==> [ :token | RBLiteralValueNode literalToken: ((RBLiteralToken value: token inputValue second start: token start stop: token stop) comments: token comments; yourself) ]
+!
+
+falseLiteral
+ ^ super falseLiteral ==> [ :token | RBLiteralValueNode literalToken: ((RBLiteralToken value: false start: token start stop: token stop) comments: token comments; yourself) ]
+!
+
+nilLiteral
+ ^ super nilLiteral ==> [ :token | RBLiteralValueNode literalToken: ((RBLiteralToken value: nil start: token start stop: token stop) comments: token comments; yourself) ]
+!
+
+numberLiteral
+ ^ super numberLiteral ==> [ :token | RBLiteralValueNode literalToken: ((RBNumberLiteralToken value: (Number readFrom: token inputValue) start: token start stop: token stop source: token inputValue) comments: token comments; yourself) ]
+!
+
+stringLiteral
+ ^ super stringLiteral ==> [ :token | RBLiteralValueNode literalToken: ((RBLiteralToken value: (self buildString: token inputValue) start: token start stop: token stop) comments: token comments; yourself) ]
+!
+
+symbolLiteral
+ ^ super symbolLiteral ==> [ :tokens | RBLiteralValueNode literalToken: ((RBLiteralToken value: (self buildString: tokens last inputValue) asSymbol start: tokens first start stop: tokens last stop) comments: tokens last comments; yourself) ]
+!
+
+symbolLiteralArray
+ ^ super symbolLiteralArray ==> [ :token | RBLiteralValueNode literalToken: ((RBLiteralToken value: (self buildString: token inputValue) asSymbol start: token start stop: token stop) comments: token comments; yourself) ]
+!
+
+trueLiteral
+ ^ super trueLiteral ==> [ :token | RBLiteralValueNode literalToken: ((RBLiteralToken value: true start: token start stop: token stop) comments: token comments; yourself) ]
+! !
+
+!PPSmalltalkParser methodsFor:'grammar-messages'!
+
+binaryExpression
+ ^ super binaryExpression map: [ :receiverNode :messageNodes | self build: receiverNode messages: messageNodes ]
+!
+
+cascadeExpression
+ ^ super cascadeExpression map: [ :receiverNode :messageNodes | self build: receiverNode cascade: messageNodes ]
+!
+
+keywordExpression
+ ^ super keywordExpression map: [ :receiveNode :messageNode | self build: receiveNode messages: (Array with: messageNode) ]
+!
+
+unaryExpression
+ ^ super unaryExpression map: [ :receiverNode :messageNodes | self build: receiverNode messages: messageNodes ]
+! !
+
+!PPSmalltalkParser methodsFor:'private'!
+
+addStatements: aCollection into: aNode
+ aCollection isNil
+ ifTrue: [ ^ aNode ].
+ aCollection do: [ :each |
+ each class == PPSmalltalkToken
+ ifFalse: [ aNode addNode: each ]
+ ifTrue: [
+ aNode statements isEmpty
+ ifTrue: [ aNode addComments: each comments ]
+ ifFalse: [ aNode statements last addComments: each comments ].
+ aNode periods: (aNode periods asOrderedCollection
+ addLast: each start;
+ yourself) ] ].
+ ^ aNode
+!
+
+build: aNode assignment: anArray
+ ^ anArray isEmpty
+ ifTrue: [ aNode ]
+ ifFalse: [
+ anArray reverse
+ inject: aNode
+ into: [ :result :each |
+ RBAssignmentNode
+ variable: each first
+ value: result
+ position: each second start ] ]
+!
+
+build: aNode cascade: anArray
+ | messages semicolons |
+ ^ (anArray isNil or: [ anArray isEmpty ])
+ ifTrue: [ aNode ]
+ ifFalse: [
+ messages := OrderedCollection new: anArray size + 1.
+ messages addLast: aNode.
+ semicolons := OrderedCollection new.
+ anArray do: [ :each |
+ messages addLast: (self
+ build: aNode receiver
+ messages: (Array with: each second)).
+ semicolons addLast: each first start ].
+ RBCascadeNode messages: messages semicolons: semicolons ]
+!
+
+build: aNode messages: anArray
+ ^ (anArray isNil or: [ anArray isEmpty ])
+ ifTrue: [ aNode ]
+ ifFalse: [
+ anArray
+ inject: aNode
+ into: [ :rec :msg |
+ msg isNil
+ ifTrue: [ rec ]
+ ifFalse: [
+ RBMessageNode
+ receiver: rec
+ selectorParts: msg first
+ arguments: msg second ] ] ]
+!
+
+build: aTempCollection sequence: aStatementCollection
+ | result |
+ result := self
+ addStatements: aStatementCollection
+ into: RBSequenceNode new.
+ aTempCollection isEmpty ifFalse: [
+ result
+ leftBar: aTempCollection first start
+ temporaries: aTempCollection second
+ rightBar: aTempCollection last start ].
+ ^ result
+!
+
+buildArray: aStatementCollection
+ ^ self addStatements: aStatementCollection into: RBArrayNode new
+!
+
+buildMethod: aMethodNode
+ aMethodNode selectorParts
+ do: [ :each | aMethodNode addComments: each comments ].
+ aMethodNode arguments
+ do: [ :each | aMethodNode addComments: each token comments ].
+ aMethodNode pragmas do: [ :pragma |
+ aMethodNode addComments: pragma comments.
+ pragma selectorParts
+ do: [ :each | aMethodNode addComments: each comments ].
+ pragma arguments do: [ :each |
+ each isLiteralArray
+ ifFalse: [ aMethodNode addComments: each token comments ] ].
+ pragma comments: nil ].
+ ^ aMethodNode
+!
+
+buildString: aString
+ (aString isEmpty or: [ aString first ~= $' or: [ aString last ~= $' ] ])
+ ifTrue: [ ^ aString ].
+ ^ (aString
+ copyFrom: 2
+ to: aString size - 1)
+ copyReplaceAll: ''''''
+ with: ''''
+! !
+
+!PPSmalltalkParser methodsFor:'token'!
+
+binaryToken
+ ^ super binaryToken ==> [ :token | (RBBinarySelectorToken value: token inputValue start: token start) comments: token comments; yourself ]
+!
+
+identifierToken
+ ^ super identifierToken ==> [ :token | (RBIdentifierToken value: token inputValue start: token start) comments: token comments; yourself ]
+!
+
+keywordToken
+ ^ super keywordToken ==> [ :token | (RBKeywordToken value: token inputValue start: token start) comments: token comments; yourself ]
+!
+
+unaryToken
+ ^ super unaryToken ==> [ :token | (RBIdentifierToken value: token inputValue start: token start) comments: token comments; yourself ]
+! !
+