[MathNotation] Implement Sectioning

src/MathNotation-Pharo/RBHoleToken.class.st

@@ -0,0 +1,76 @@
+"
+RBHoleToken is a lexical-level representation of a hole, i.e. an empty space
+in an incomplete term.  For example, in category theory it is standard to write
+𝒞(A,–) meaning 'that thing which takes B to answer 𝒞(A,B)'. In the 'sectioning'
+notation (standard in BMF formalism), the function ⊕y takes x to x⊕y (here
+⊕::A×B→C is an arbitrary binary operator).  In term rewriting, it is customary
+to allow terms to contain occurrences of a special constant symbol □.
+
+Although this construct can, in principle, be spelled out in coordinates,
+in the above-mentioned applications this notational abstraction becomes
+essential, as opposed to merely convenient.
+
+Implementation Notes:
+
+At the lexical level, the Hole is represented by a dedicated single character;
+which character it is, is specified by RBHoleToken class>>codePoint.
+The scanner isolates the rest of the parser from knowledge of this concrete
+syntax.
+
+In the present notation, the scope of an incomplete term is always the message
+send.  For example, you can write
+
+  a := 3+□
+
+but not
+
+  a := □
+
+or
+
+  ^□.
+
+Because this notation is an extension to our substrate language, which is
+Smalltalk-80, the meaning of these incomplete terms is given by BlockClosures.
+For example,
+
+  3+□
+
+stands for
+
+  [ :x | 3+x ]
+
+where x is some image-unique variable name.
+
+A message send may contain zero or more hole arguments (including self).
+If there are more than one hole, each hole becomes a separate block argument;
+the order of currying is
+
+  self → arg₁ → … → argₙ.
+
+"
+Class {
+	#name : #RBHoleToken,
+	#superclass : #RBToken,
+	#category : #'MathNotation-Pharo'
+}
+
+{ #category : #'concrete syntax' }
+RBHoleToken class >> codePoint [
+	"In the current implementation, we use $□ ('WHITE SQUARE', U+25A1)
+	 to denote 'Hole' in concrete syntax, but any suitable character,
+	 such as $– ('EN DASH' (U+2013), $☐ ('BALLOT BOX', U+2610), etc
+	 should work, by changing ONLY this method."
+
+	^16r25A1
+]
+
+{ #category : #testing }
+RBHoleToken >> isHole [
+	^true
+]
+
+{ #category : #accessing }
+RBHoleToken >> length [
+	^1
+]

src/MathNotation-Pharo/RBMessageNode.extension.st

@@ -0,0 +1,35 @@
+Extension { #name : #RBMessageNode }
+
+{ #category : #'*MathNotation-Pharo' }
+RBMessageNode class >> receiver: aValueNode selector: aSelector keywordsPositions: positionList arguments: valueNodes [
+	^(self new)
+		receiver: aValueNode
+			selector: aSelector
+			keywordsPositions: positionList 
+			arguments: valueNodes;
+		wrapSectionedSend
+]
+
+{ #category : #'*MathNotation-Pharo' }
+RBMessageNode >> wrapSectionedSend [
+	| allArgs holes block blockArgs |
+	allArgs := {receiver}, arguments.
+	(allArgs noneSatisfy: #isSectionArgument) ifTrue: [
+		^self  "ordinary MessageNode"
+	].
+
+	"sectioned message send"
+	holes := allArgs select: #isSectionArgument.
+	blockArgs := holes collect: #holePlug.
+
+	receiver := receiver holePlug.
+	receiver parent: self.
+	arguments := arguments collect: #holePlug.
+	arguments do: [ :eachArgument | eachArgument parent: self ].
+
+	block := RBBlockNode
+		arguments: blockArgs
+		body: (RBSequenceNode statements: (OrderedCollection with: self)).
+	blockArgs do: [ :eachBlockArg | eachBlockArg parent: block ].
+	^block
+]

src/MathNotation-Pharo/RBNode.extension.st

@@ -0,0 +1,21 @@
+Extension { #name : #RBNode }
+
+{ #category : #'*MathNotation-Pharo' }
+RBNode >> holePlug [
+	^self
+]
+
+{ #category : #'*MathNotation-Pharo' }
+RBNode >> isSectionArgument [
+	^false
+]
+
+{ #category : #'*MathNotation-Pharo' }
+RBNode >> parserError: aString [
+	self parserError: aString in: RBParser findContextReceivingMe
+]
+
+{ #category : #'*MathNotation-Pharo' }
+RBNode >> parserError: aString in: parsersContext [
+	parsersContext return: (parsersContext receiver parserError: aString)
+]

src/MathNotation-Pharo/RBParser.extension.st

@@ -0,0 +1,31 @@
+Extension { #name : #RBParser }
+
+{ #category : #'*MathNotation-Pharo' }
+RBParser >> parseHole [
+	| token node |
+	token := currentToken.
+	self step.
+	node := SectionArgumentNode newAt: token start.
+	self addCommentsTo: node.
+	^node
+
+]
+
+{ #category : #'*MathNotation-Pharo' }
+RBParser >> parsePrimitiveObject [
+	currentToken isHole ifTrue: [^self parseHole].
+	currentToken isIdentifier ifTrue: [^self parsePrimitiveIdentifier].
+	(currentToken isLiteralToken and: [currentToken isMultiKeyword not]) 
+		ifTrue: [^self parsePrimitiveLiteral].
+	currentToken isLiteralArrayToken
+		ifTrue: 
+			[^currentToken isForByteArray 
+				ifTrue: [self parseLiteralByteArray]
+				ifFalse: [self parseLiteralArray]].
+	currentToken isSpecial
+		ifTrue: 
+			[currentToken value = $[ ifTrue: [^self saveCommentsDuring:[self parseBlock]].
+			currentToken value = $( ifTrue: [^self parseParenthesizedExpression].
+			currentToken value = ${ ifTrue: [^self parseArray]].
+	^ self parserError: 'Variable or expression expected'
+]

src/MathNotation-Pharo/RBScanner.extension.st

@@ -102,3 +102,27 @@ RBScanner >> isUnicodeMathOperator: aCharacter [
 
 	)	includes: aCharacter asInteger
 ]
+
+{ #category : #'*MathNotation-Pharo' }
+RBScanner >> scanHole [
+	self step.
+	^RBHoleToken start: tokenStart
+]
+
+{ #category : #'*MathNotation-Pharo' }
+RBScanner >> scanToken [
+	"fast-n-ugly. Don't write stuff like this. Has been found to cause cancer in laboratory rats. Basically a 
+	case statement. Didn't use Dictionary because lookup is pretty slow."
+
+	characterType = #alphabetic ifTrue: [^self scanIdentifierOrKeyword].
+	(characterType = #digit 
+		or: [currentCharacter = $- and: [(self classify: stream peek) = #digit]]) 
+			ifTrue: [^self scanNumber].
+	characterType = #binary ifTrue: [^self scanBinary: RBBinarySelectorToken].
+	characterType = #special ifTrue: [^self scanSpecialCharacter].
+	currentCharacter = $' ifTrue: [^self scanLiteralString].
+	currentCharacter = $# ifTrue: [^self scanLiteral].
+	currentCharacter = $$ ifTrue: [^self scanLiteralCharacter].
+	currentCharacter codePoint = RBHoleToken codePoint ifTrue: [^self scanHole].
+	^self scanUnknownCharacter
+]

src/MathNotation-Pharo/RBToken.extension.st

@@ -0,0 +1,6 @@
+Extension { #name : #RBToken }
+
+{ #category : #'*MathNotation-Pharo' }
+RBToken >> isHole [
+	^false
+]

src/MathNotation-Pharo/SectionArgumentNode.class.st

@@ -0,0 +1,45 @@
+Class {
+	#name : #SectionArgumentNode,
+	#superclass : #RBVariableNode,
+	#classVars : [
+		'N'
+	],
+	#category : #'MathNotation-Pharo'
+}
+
+{ #category : #naming }
+SectionArgumentNode class >> freshName [
+	^'_ß', self nextN printString
+]
+
+{ #category : #'instance creation' }
+SectionArgumentNode class >> newAt: aPosition [
+	^self
+		identifierNamed: self freshName
+		at: aPosition
+]
+
+{ #category : #naming }
+SectionArgumentNode class >> nextN [
+	N isNil ifTrue: [ N :=0 ].
+	N := N+1.
+	^N
+]
+
+{ #category : #substitution }
+SectionArgumentNode >> holePlug [
+	^RBVariableNode named: name start: start
+]
+
+{ #category : #testing }
+SectionArgumentNode >> isSectionArgument [
+	^true
+]
+
+{ #category : #accessing }
+SectionArgumentNode >> parent: p [
+	(p isKindOf: RBMessageNode) ifFalse: [
+		self parserError: '□ can only be a message''s arg or receiver'
+	].
+	^super parent: p
+]

src/MathNotation-Tests/RBParserTest.extension.st

@@ -0,0 +1,29 @@
+Extension { #name : #RBParserTest }
+
+{ #category : #'*MathNotation-Tests' }
+RBParserTest >> testSectioningCollect [
+	self
+		assert: (#(1 2 3) collect: 100+□)
+		equals: #(101 102 103)
+]
+
+{ #category : #'*MathNotation-Tests' }
+RBParserTest >> testSectioningL [
+	self
+		assert: (□+4 value: 3)
+		equals: 7
+]
+
+{ #category : #'*MathNotation-Tests' }
+RBParserTest >> testSectioningLR [
+	self
+		assert: (□+□ value: 3 value: 4)
+		equals: 7
+]
+
+{ #category : #'*MathNotation-Tests' }
+RBParserTest >> testSectioningR [
+	self
+		assert: (3+□ value: 4)
+		equals: 7
+]

src/PreSmalltalks/Behavior.extension.st

@@ -0,0 +1,6 @@
+Extension { #name : #Behavior }
+
+{ #category : #'*PreSmalltalks' }
+Behavior >> findContextReceivingMe [
+	^thisContext findContextSuchThat: [ :c | c receiver isKindOf: self ]
+]