SystemOrganization addCategory: #'Cutie-LanguageBoxes'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-Skins'! TestCase subclass: #LBTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! LBTestCase subclass: #LBCrosscuttingTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBCrosscuttingTest class methodsFor: 'accessing' stamp: 'lr 6/23/2009 11:45'! languageBoxes ^ Array with: LBPathBox with: LBRegexpBox! ! !LBCrosscuttingTest methodsFor: 'testing' stamp: 'lr 6/23/2009 11:45'! testModular | input output | input := #(('aaaa') ('aaab' 'aaba' 'abaa' 'baaa') ('aabb' 'abba' 'bbaa' 'abab' 'baba' 'baab') ('abbb' 'babb' 'bbab' 'bbba') ('bbbb')). output := input::yourself[ :each | each =~ /a*b*/ ]. self assert: output = #('aaaa' 'aaab' 'aabb' 'abbb' 'bbbb')! ! LBTestCase subclass: #LBFactoryTest instanceVariableNames: '' classVariableNames: 'LALispFactory' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Skins'! !LBFactoryTest class methodsFor: 'accessing' stamp: 'lr 6/23/2009 12:05'! languageBoxes ^ Array with: LBFactoryBox! ! !LBFactoryTest methodsFor: 'testing-lisp' stamp: 'lr 6/23/2009 12:06'! testLispFactoryMorph | morph | morph := <>. self assert: (morph isKindOf: WatchMorph). self assert: (morph color = Color white). morph submorphs do: [ :each | self assert: each color = Color black ]! ! !LBFactoryTest methodsFor: 'testing-lisp' stamp: 'lr 6/23/2009 12:06'! testLispFactoryOrderedCollection | collection | collection := <>. self assert: collection size = 4. self assert: collection first = 1. self assert: collection second = 2. self assert: collection third size = 1. self assert: collection third first = 3. self assert: collection fourth size = 2. self assert: collection fourth first = 4. self assert: collection fourth second = 5! ! LBTestCase subclass: #LBPathAspectTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBPathAspectTest class methodsFor: 'accessing' stamp: 'lr 6/23/2009 11:45'! languageBoxes ^ Array with: LBPathBox! ! !LBPathAspectTest methodsFor: 'testing' stamp: 'lr 6/23/2009 11:46'! testSimpleFilter | input output | input := #((1 2 3) (4 5) (6)). output := input::yourself[ :each | each odd ]. self assert: output = #(1 3 5)! ! !LBPathAspectTest methodsFor: 'testing' stamp: 'lr 6/23/2009 11:46'! testSimplePath | input output | input := #((1 2 3) (4 5) (6)). output := input::yourself. self assert: output = #(1 2 3 4 5 6)! ! LBTestCase subclass: #LBPositionalAspectTest instanceVariableNames: 'seen' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBPositionalAspectTest class methodsFor: 'accessing' stamp: 'lr 6/23/2009 11:45'! languageBoxes ^ Array with: LBPositionalBox! ! !LBPositionalAspectTest methodsFor: 'running' stamp: 'lr 5/18/2009 11:47'! assertSeen: anArray self assert: seen asArray = anArray description: anArray printString , ' expected, but got ' , seen asArray printString. seen := OrderedCollection new! ! !LBPositionalAspectTest methodsFor: 'utilities' stamp: 'lr 5/18/2009 14:30'! empty! ! !LBPositionalAspectTest methodsFor: 'utilities' stamp: 'lr 5/18/2009 11:47'! foo seen add: #foo! ! !LBPositionalAspectTest methodsFor: 'utilities' stamp: 'lr 5/18/2009 11:48'! foo: aFirstObject seen add: #foo:; add: aFirstObject! ! !LBPositionalAspectTest methodsFor: 'utilities' stamp: 'lr 5/18/2009 11:48'! foo: aFirstObject with: aSecondObject seen add: #foo:with:; add: aFirstObject; add: aSecondObject! ! !LBPositionalAspectTest methodsFor: 'utilities' stamp: 'lr 5/18/2009 11:48'! foo: aFirstObject with: aSecondObject with: aThirdObject seen add: #foo:with:with:; add: aFirstObject; add: aSecondObject; add: aThirdObject! ! !LBPositionalAspectTest methodsFor: 'running' stamp: 'lr 6/23/2009 11:47'! setUp super setUp. seen := OrderedCollection new! ! !LBPositionalAspectTest methodsFor: 'testing-chaining' stamp: 'lr 5/18/2009 14:43'! testChainAtBegin self foo(1) empty. self assertSeen: #(foo: 1). self foo(1, 2) empty empty. self assertSeen: #(foo:with: 1 2)! ! !LBPositionalAspectTest methodsFor: 'testing-chaining' stamp: 'lr 5/18/2009 14:31'! testChainAtEnd self empty foo(1). self assertSeen: #(foo: 1). self empty empty foo(1, 2). self assertSeen: #(foo:with: 1 2)! ! !LBPositionalAspectTest methodsFor: 'testing-chaining' stamp: 'lr 5/18/2009 14:43'! testChainInbetween self empty foo(1) empty. self assertSeen: #(foo: 1). self empty empty foo(1, 2) empty empty. self assertSeen: #(foo:with: 1 2)! ! !LBPositionalAspectTest methodsFor: 'testing-chaining' stamp: 'lr 5/18/2009 14:48'! testMultipleChained self foo() foo(2) foo(3, 4) foo(4, 5, 6). self assertSeen: #(foo foo: 2 foo:with: 3 4 foo:with:with: 4 5 6)! ! !LBPositionalAspectTest methodsFor: 'testing-nested' stamp: 'lr 5/18/2009 14:47'! testNestedCalling self foo(1, (self foo(2, (self foo(3))))). self assertSeen: #(foo: 3 foo:with: 2) , (Array with: self) , #(foo:with: 1) , (Array with: self)! ! !LBPositionalAspectTest methodsFor: 'testing-nested' stamp: 'lr 5/18/2009 14:44'! testNestedExpression self foo(('a' , 'b'), (1 + 2)). self assertSeen: #(foo:with: 'ab' 3)! ! !LBPositionalAspectTest methodsFor: 'testing-arguments' stamp: 'lr 5/18/2009 14:27'! testOneArgument self foo('abc'). self assertSeen: #(foo: 'abc')! ! !LBPositionalAspectTest methodsFor: 'testing-arguments' stamp: 'lr 5/18/2009 14:28'! testTreeArguments self foo(true, false, nil). self assertSeen: #(foo:with:with: true false nil)! ! !LBPositionalAspectTest methodsFor: 'testing-arguments' stamp: 'lr 5/18/2009 14:28'! testTwoArguments self foo($a, 'b'). self assertSeen: #(foo:with: $a 'b')! ! !LBPositionalAspectTest methodsFor: 'testing-arguments' stamp: 'lr 5/18/2009 14:27'! testZeroArguments self foo(). self assertSeen: #(foo)! ! LBTestCase subclass: #LBQuoteAspectTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBQuoteAspectTest class methodsFor: 'accessing' stamp: 'lr 6/23/2009 11:45'! languageBoxes ^ Array with: LBQuoteBox! ! !LBQuoteAspectTest methodsFor: 'testing-splice' stamp: 'lr 5/7/2009 13:04'! testParseSplice1 self assert: `@(10 factorial) = 3628800! ! !LBQuoteAspectTest methodsFor: 'testing-splice' stamp: 'lr 5/7/2009 13:04'! testParseSplice2 self assert: `@(DateAndTime now) < DateAndTime now! ! !LBQuoteAspectTest methodsFor: 'testing-quote' stamp: 'lr 5/7/2009 13:04'! testQuote1 | ast | ast := ``(1 + 2). self assert: (ast isKindOf: RBMessageNode). self assert: ast formattedCode = '1 + 2'! ! !LBQuoteAspectTest methodsFor: 'testing-quote' stamp: 'lr 5/7/2009 13:04'! testQuote2 | ast | ast := ``{ 1 }. self assert: (ast isKindOf: RBArrayNode). self assert: ast formattedCode = '{ 1 }'! ! !LBQuoteAspectTest methodsFor: 'testing-quote' stamp: 'lr 5/7/2009 13:04'! testQuote3 | ast | ast := ``[ ]. self assert: (ast isKindOf: RBBlockNode). self assert: ast formattedCode = '[ ]'! ! !LBQuoteAspectTest methodsFor: 'testing-quote' stamp: 'lr 5/7/2009 13:04'! testQuote4 | ast | ast := ``123. self assert: (ast isKindOf: RBLiteralNode). self assert: ast formattedCode = '123'! ! !LBQuoteAspectTest methodsFor: 'testing-quote' stamp: 'lr 4/3/2009 11:48'! testQuote5 | ast | ast := ``x. self assert: (ast isKindOf: RBVariableNode). self assert: ast formattedCode = 'x'! ! !LBQuoteAspectTest methodsFor: 'testing-unquote' stamp: 'lr 4/3/2009 11:48'! testUnquote1 | one two ast | one := ``1. two := ``2. ast := ``(`,one + `,two). self assert: (ast isKindOf: RBMessageNode). self assert: ast formattedCode = '1 + 2'! ! !LBQuoteAspectTest methodsFor: 'testing-unquote' stamp: 'lr 4/3/2009 11:48'! testUnquote2 | ast | ast := ``b. ast := ``(`,ast := 12). self assert: ast isAssignment. self assert: ast variable isVariable. self assert: ast variable name = 'b'. self assert: ast value isLiteral. self assert: ast value value = 12! ! LBTestCase subclass: #LBRegexpAspectTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBRegexpAspectTest class methodsFor: 'accessing' stamp: 'lr 6/23/2009 11:45'! languageBoxes ^ Array with: LBRegexpBox! ! !LBRegexpAspectTest methodsFor: 'accessing' stamp: 'lr 5/7/2009 12:19'! testPaper self assert: ('Nena - 99 Luftballons' =~ /.*\d+.*/)! ! !LBRegexpAspectTest methodsFor: 'accessing' stamp: 'lr 5/7/2009 12:19'! testRegexp self assert: ('10010100' =~ /[01]+/). self assert: ('aaaaab' =~ /a*b/). self assert: ('abbbbbbc' =~ /ab+c/). self assert: ('abbb' =~ /ab*/)! ! !LBTestCase class methodsFor: 'private' stamp: 'lr 6/23/2009 12:09'! compile: aString classified: aSymbol notifying: anObject trailer: anArray ifFail: aBlock "Before compiling the methods of the receiver make sure that the language boxes are added." self languageBoxes do: [ :box | (box default environments noneSatisfy: [ :env | env includesClass: self ]) ifTrue: [ box default addClass: self ] ]. ^ super compile: aString classified: aSymbol notifying: anObject trailer: anArray ifFail: aBlock! ! !LBTestCase class methodsFor: 'accessing' stamp: 'lr 6/23/2009 11:44'! languageBoxes ^ #()! ! CUCompositeParser subclass: #LBFactoryParser instanceVariableNames: 'primary message' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Skins'! !LBFactoryParser class methodsFor: 'accessing' stamp: 'lr 4/8/2009 15:06'! concern ^ nil! ! !LBFactoryParser class methodsFor: 'accessing' stamp: 'lr 4/8/2009 15:05'! identifier ^ nil! ! !LBFactoryParser class methodsFor: 'instance creation' stamp: 'lr 5/7/2009 13:18'! primary: aPrimaryParser message: aMessageParser ^ self basicNew initializePrimary: aPrimaryParser message: aMessageParser! ! !LBFactoryParser methodsFor: 'initialization' stamp: 'lr 5/7/2009 13:18'! initializePrimary: aPrimaryParser message: aMessageParser primary := aPrimaryParser. message := aMessageParser. self initialize! ! LBFactoryParser subclass: #LBLispFactoryParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Skins'! LBLispFactoryParser subclass: #LBLispFactoryCompiler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Skins'! !LBLispFactoryCompiler class methodsFor: 'accessing' stamp: 'lr 4/8/2009 15:17'! concern ^ #compile:! ! !LBLispFactoryCompiler methodsFor: 'grammar' stamp: 'lr 4/8/2009 15:38'! send super send ==> [ :nodes | | resultNodes messageNode | resultNodes := OrderedCollection new. messageNode := RBMessageNode receiver: ``(stack last) selectorParts: nodes second first arguments: nodes second second. nodes third isEmpty ifTrue: [ resultNodes add: messageNode ] ifFalse: [ resultNodes add: ``(stack addLast: `,messageNode); addAll: nodes third flatten; add: ``(stack removeLast) ]. resultNodes ]! ! !LBLispFactoryCompiler methodsFor: 'grammar' stamp: 'lr 4/8/2009 15:38'! start super start ==> [ :nodes | RBSequenceNode new addTemporaryNamed: 'stack'; addNode: ``(stack := OrderedCollection with: `,(nodes second)); addNodes: (nodes third flatten); addNode: ``(stack last); yourself ]! ! !LBLispFactoryParser class methodsFor: 'accessing' stamp: 'lr 4/8/2009 15:41'! concern ^ #highlight:! ! !LBLispFactoryParser class methodsFor: 'accessing' stamp: 'lr 4/9/2009 10:55'! identifier ^ 'builder-parens:'! ! !LBLispFactoryParser methodsFor: 'token' stamp: 'lr 5/5/2009 14:31'! close $) token! ! !LBLispFactoryParser methodsFor: 'token' stamp: 'lr 5/5/2009 14:31'! open $( token! ! !LBLispFactoryParser methodsFor: 'grammar' stamp: 'lr 4/8/2009 15:06'! send open , message , send star , close! ! !LBLispFactoryParser methodsFor: 'grammar' stamp: 'lr 4/8/2009 15:07'! start open , primary , send star , close! ! LBFactoryParser subclass: #LBPythonFactoryParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Skins'! LBPythonFactoryParser subclass: #LBPythonFactoryCompiler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Skins'! !LBPythonFactoryCompiler class methodsFor: 'accessing' stamp: 'lr 4/8/2009 15:41'! concern ^ #compile:! ! !LBPythonFactoryCompiler methodsFor: 'grammar' stamp: 'lr 4/9/2009 11:00'! send super start ==> [ :nodes | self halt. OrderedCollection new add: nodes first size - nodes second; addAll: nodes flatten; yourself ]! ! !LBPythonFactoryCompiler methodsFor: 'grammar' stamp: 'lr 4/8/2009 15:45'! start super start ==> [ :nodes | self halt ]! ! !LBPythonFactoryParser class methodsFor: 'accessing' stamp: 'lr 5/7/2009 12:07'! concern ^ #highlight:! ! !LBPythonFactoryParser class methodsFor: 'accessing' stamp: 'lr 4/9/2009 10:55'! identifier ^ 'builder-indent:'! ! !LBPythonFactoryParser methodsFor: 'token' stamp: 'lr 5/5/2009 15:19'! indent #tab star! ! !LBPythonFactoryParser methodsFor: 'token' stamp: 'lr 5/5/2009 14:31'! newline #cr token! ! !LBPythonFactoryParser methodsFor: 'grammar' stamp: 'lr 4/8/2009 10:36'! send indent , message , newline optional! ! !LBPythonFactoryParser methodsFor: 'grammar' stamp: 'lr 4/8/2009 10:36'! start indent , primary , send star! ! LBLanguageBox subclass: #LBFactoryBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Skins'! !LBFactoryBox methodsFor: 'hooks' stamp: 'lr 6/23/2009 11:12'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #cascadeExpression); parser: (self factoriesFor: aGrammar)! ! !LBFactoryBox methodsFor: 'hooks' stamp: 'lr 5/7/2009 13:21'! compile: aNode ^ aNode third! ! !LBFactoryBox methodsFor: 'parsing' stamp: 'lr 6/23/2009 12:06'! factoriesFor: aParser ^ (LBFactoryParser withAllSubclasses select: [ :class | aParser class concern = class concern ]) inject: PPChoiceParser new into: [ :parser :class | parser / ('<<' asParser token , class identifier asParser token , (class primary: (aParser productionAt: #cascadeExpression) message: (aParser productionAt: #message)) , '>>' asParser token) ]! ! !LBFactoryBox methodsFor: 'hooks' stamp: 'lr 5/7/2009 13:40'! highlight: aNode ^ CHHighlighter mark: aNode with: Color orange! ! LBLanguageBox subclass: #LBPathBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBPathBox class methodsFor: 'initialization' stamp: 'lr 11/6/2008 12:09'! initialize self default recompile! ! !LBPathBox methodsFor: 'hooks' stamp: 'lr 6/23/2009 11:13'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #cascadeExpression); parser: (aGrammar productionAt: #primary) , ('::' asParser token , (aGrammar productionAt: #unaryToken) , ('()' asParser token / (aGrammar productionAt: #block) optional)) plus! ! !LBPathBox methodsFor: 'hooks' stamp: 'lr 2/6/2009 11:59'! compile: aCollection ^ (aCollection second collect: [ :each | each flatten ]) inject: aCollection first into: [ :receiver :array | | result | result := ``(`,(receiver) gather: `,(array second value asSymbol)). array third isNil ifFalse: [ result := ``(`,result select: `,(array third)) ]. result ]! ! !LBPathBox methodsFor: 'hooks' stamp: 'lr 4/2/2009 15:32'! highlight: aCollection ^ CHHighlighter mark: aCollection with: TextEmphasis italic! ! LBLanguageBox subclass: #LBPositionalBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBPositionalBox class methodsFor: 'initialization' stamp: 'lr 5/18/2009 11:17'! initialize self default recompile! ! !LBPositionalBox methodsFor: 'hooks' stamp: 'lr 6/23/2009 11:13'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #unaryMessage); parser: (aGrammar productionAt: #unary) token , $( asParser token , ((aGrammar productionAt: #primary) separatedBy: $, asParser token) optional , $) asParser token! ! !LBPositionalBox methodsFor: 'hooks' stamp: 'lr 5/18/2009 12:09'! compile: aCollection | selectors arguments | selectors := OrderedCollection with: aCollection first. arguments := OrderedCollection new. aCollection third do: [ :argument | (argument isKindOf: PPToken) ifFalse: [ (selectors size = 1 and: [ selectors last value last ~= $: ]) ifTrue: [ selectors add: (PPToken on: selectors removeFirst value , ':') ] ifFalse: [ selectors add: (PPToken on: 'with:') ]. arguments add: argument ] ]. ^ Array with: selectors asArray with: arguments asArray! ! !LBPositionalBox methodsFor: 'hooks' stamp: 'lr 5/18/2009 12:07'! highlight: aCollection ^ CHHighlighter mark: aCollection with: TextEmphasis underlined! ! !LBPositionalBox methodsFor: 'hooks' stamp: 'lr 5/18/2009 12:06'! transform: aCollection ^ Array with: aCollection first with: aCollection second with: (aCollection third ifNil: [ #() ]) with: aCollection fourth! ! LBLanguageBox subclass: #LBQuoteBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! LBQuoteBox subclass: #LBPrimaryQuoteBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBPrimaryQuoteBox methodsFor: 'hooks' stamp: 'lr 6/23/2009 11:13'! change: aGrammar ^ LBChange new choice; before: (aGrammar productionAt: #primary); parser: self metaParser token , (aGrammar productionAt: #primary)! ! !LBQuoteBox methodsFor: 'hooks' stamp: 'lr 2/3/2009 19:08'! compile: aCollection ^ (self findMetaClass: aCollection first value) value: aCollection second! ! !LBQuoteBox methodsFor: 'private' stamp: 'lr 2/3/2009 19:08'! findMetaClass: aString ^ QQMetaNode subclasses detect: [ :each | aString last = each prefix ] ifNone: [ self error: 'Unknown meta node ' , aString printString ]! ! !LBQuoteBox methodsFor: 'hooks' stamp: 'lr 2/3/2009 19:08'! highlight: aCollection ^ (self findMetaClass: aCollection first value) highlight: aCollection! ! !LBQuoteBox methodsFor: 'testing' stamp: 'lr 6/23/2009 11:44'! includesSelector: aSelector in: aClass "The quoting operators should be available everywhere." ^ self class name ~= #LBQuoteBox! ! !LBQuoteBox methodsFor: 'private' stamp: 'lr 5/7/2009 11:51'! metaParser ^ QQMetaNode subclasses inject: PPChoiceParser new into: [ :parser :class | parser / (String with: $` with: class prefix) asParser ]! ! LBQuoteBox subclass: #LBVariableQuoteBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBVariableQuoteBox methodsFor: 'hooks' stamp: 'lr 6/23/2009 11:13'! change: aGrammar ^ LBChange new choice; before: (aGrammar productionAt: #variable); parser: self metaParser token , (aGrammar productionAt: #variable)! ! LBLanguageBox subclass: #LBRegexpBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBRegexpBox class methodsFor: 'initialization' stamp: 'lr 11/6/2008 12:09'! initialize self default recompile! ! !LBRegexpBox methodsFor: 'hooks' stamp: 'lr 6/23/2009 11:13'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #primary); parser: ($/ asParser , $/ asParser negate star , $/ asParser) token! ! !LBRegexpBox methodsFor: 'hooks' stamp: 'lr 1/19/2009 09:49'! compile: aToken ^ QQObjectNode literalToken: aToken value: (aToken value copyFrom: 2 to: aToken size - 1) asRegex! ! !LBRegexpBox methodsFor: 'hooks' stamp: 'lr 1/19/2009 09:49'! highlight: aToken ^ aToken -> Color orange! ! !String methodsFor: '*cutie-languageboxes' stamp: 'lr 5/7/2009 12:17'! =~ aRegexp ^ aRegexp matches: self! ! !ProtoObject methodsFor: '*cutie-languageboxes' stamp: 'lr 6/23/2009 11:54'! languageBoxesHighlight ^ LBSmalltalkGrammar compileUseLanguageBoxes ifTrue: [ LBHighlightAction new ]! ! !ProtoObject methodsFor: '*cutie-languageboxes' stamp: 'lr 6/23/2009 11:54'! languageBoxesParser ^ LBSmalltalkGrammar compileUseLanguageBoxes ifTrue: [ LBParseAction new ]! ! !QQTestCase class methodsFor: '*cutie-languageboxes' stamp: 'lr 6/23/2009 11:52'! languageBoxesHighlight ^ nil! ! !QQTestCase class methodsFor: '*cutie-languageboxes' stamp: 'lr 6/23/2009 11:53'! languageBoxesParser ^ nil! ! LBPathBox initialize! LBPositionalBox initialize! LBRegexpBox initialize!