Commited a Smalltalk parser (MC package PetitSmalltalk)
Name: PetitSmalltalk-JanKurs.71
Author: JanKurs
Time: 19-08-2014, 02:18:05 AM
UUID: d1d11836-f3e2-4709-abd3-e2ff3b72d7c4
Repository: http://smalltalkhub.com/mc/Moose/PetitParser/main
Ancestors:
Fixes to be compatible with PPContext
"{ 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 ]
! !