SystemOrganization addCategory: #'Cutie-LanguageBoxes'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-Skins'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-Schematic'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-SQL'! !String methodsFor: '*cutie-languageboxes' stamp: 'lr 5/7/2009 12:17'! =~ aRegexp ^ aRegexp matches: self! ! !String methodsFor: '*cutie-languageboxes' stamp: 'lr 10/2/2009 11:33'! romanToArabic ^ CURomanExample romanToArabic: self! ! 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: #LBPathBoxTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBPathBoxTest class methodsFor: 'accessing' stamp: 'lr 6/23/2009 11:45'! languageBoxes ^ Array with: LBPathBox! ! !LBPathBoxTest methodsFor: 'testing' stamp: 'lr 6/30/2009 13:58'! testSimpleFilter | input output | input := #((1 2 3) (4 5) (6)). output := input::yourself[ :each | each odd ]. self assert: output = #(1 3 5)! ! !LBPathBoxTest 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: #LBPositionalBoxTest instanceVariableNames: 'seen' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBPositionalBoxTest class methodsFor: 'accessing' stamp: 'lr 6/23/2009 11:45'! languageBoxes ^ Array with: LBPositionalBox! ! !LBPositionalBoxTest 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! ! !LBPositionalBoxTest methodsFor: 'utilities' stamp: 'lr 5/18/2009 14:30'! empty! ! !LBPositionalBoxTest methodsFor: 'utilities' stamp: 'lr 5/18/2009 11:47'! foo seen add: #foo! ! !LBPositionalBoxTest methodsFor: 'utilities' stamp: 'lr 5/18/2009 11:48'! foo: aFirstObject seen add: #foo:; add: aFirstObject! ! !LBPositionalBoxTest methodsFor: 'utilities' stamp: 'lr 5/18/2009 11:48'! foo: aFirstObject with: aSecondObject seen add: #foo:with:; add: aFirstObject; add: aSecondObject! ! !LBPositionalBoxTest 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! ! !LBPositionalBoxTest methodsFor: 'running' stamp: 'lr 6/23/2009 11:47'! setUp super setUp. seen := OrderedCollection new! ! !LBPositionalBoxTest 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)! ! !LBPositionalBoxTest 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)! ! !LBPositionalBoxTest 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)! ! !LBPositionalBoxTest methodsFor: 'testing-chaining' stamp: 'lr 6/30/2009 13:58'! 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)! ! !LBPositionalBoxTest 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)! ! !LBPositionalBoxTest methodsFor: 'testing-nested' stamp: 'lr 5/18/2009 14:44'! testNestedExpression self foo(('a' , 'b'), (1 + 2)). self assertSeen: #(foo:with: 'ab' 3)! ! !LBPositionalBoxTest methodsFor: 'testing-arguments' stamp: 'lr 5/18/2009 14:27'! testOneArgument self foo('abc'). self assertSeen: #(foo: 'abc')! ! !LBPositionalBoxTest methodsFor: 'testing-arguments' stamp: 'lr 5/18/2009 14:28'! testTreeArguments self foo(true, false, nil). self assertSeen: #(foo:with:with: true false nil)! ! !LBPositionalBoxTest methodsFor: 'testing-arguments' stamp: 'lr 5/18/2009 14:28'! testTwoArguments self foo($a, 'b'). self assertSeen: #(foo:with: $a 'b')! ! !LBPositionalBoxTest methodsFor: 'testing-arguments' stamp: 'lr 5/18/2009 14:27'! testZeroArguments self foo(). self assertSeen: #(foo)! ! LBTestCase subclass: #LBQuoteBoxTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBQuoteBoxTest class methodsFor: 'accessing' stamp: 'lr 6/23/2009 11:45'! languageBoxes ^ Array with: LBQuoteBox! ! !LBQuoteBoxTest methodsFor: 'testing-splice' stamp: 'lr 5/7/2009 13:04'! testParseSplice1 self assert: `@(10 factorial) = 3628800! ! !LBQuoteBoxTest methodsFor: 'testing-splice' stamp: 'lr 5/7/2009 13:04'! testParseSplice2 self assert: `@(DateAndTime now) < DateAndTime now! ! !LBQuoteBoxTest 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'! ! !LBQuoteBoxTest methodsFor: 'testing-quote' stamp: 'lr 5/7/2009 13:04'! testQuote2 | ast | ast := ``{ 1 }. self assert: (ast isKindOf: RBArrayNode). self assert: ast formattedCode = '{ 1 }'! ! !LBQuoteBoxTest methodsFor: 'testing-quote' stamp: 'lr 6/30/2009 13:58'! testQuote3 | ast | ast := ``[ ]. self assert: (ast isKindOf: RBBlockNode). self assert: ast formattedCode = '[ ]'! ! !LBQuoteBoxTest methodsFor: 'testing-quote' stamp: 'lr 5/7/2009 13:04'! testQuote4 | ast | ast := ``123. self assert: (ast isKindOf: RBLiteralNode). self assert: ast formattedCode = '123'! ! !LBQuoteBoxTest methodsFor: 'testing-quote' stamp: 'lr 4/3/2009 11:48'! testQuote5 | ast | ast := ``x. self assert: (ast isKindOf: RBVariableNode). self assert: ast formattedCode = 'x'! ! !LBQuoteBoxTest 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'! ! !LBQuoteBoxTest 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: #LBRegexpBoxTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBRegexpBoxTest class methodsFor: 'accessing' stamp: 'lr 8/27/2009 16:05'! languageBoxes ^ Array with: LBRegexpBox! ! !LBRegexpBoxTest methodsFor: 'accessing' stamp: 'lr 8/27/2009 16:05'! testPaper self assert: ('Nena - 99 Luftballons' =~ /.*\d+.*/)! ! !LBRegexpBoxTest methodsFor: 'accessing' stamp: 'lr 8/27/2009 16:05'! testRegexp self assert: ('10010100' =~ /[01]+/). self assert: ('aaaaab' =~ /a*b/). self assert: ('abbbbbbc' =~ /ab+c/). self assert: ('abbb' =~ /ab*/)! ! LBTestCase subclass: #LBRomanBoxTest instanceVariableNames: '' classVariableNames: 'III II' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBRomanBoxTest class methodsFor: 'accessing' stamp: 'lr 9/29/2009 11:25'! languageBoxes ^ Array with: LBRomanBox! ! !LBRomanBoxTest methodsFor: 'testing' stamp: 'lr 10/2/2009 14:49'! testRomanNumbers self assert: IV + VII = XI! ! LBTestCase subclass: #LBSchematicBoxTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Schematic'! !LBSchematicBoxTest class methodsFor: 'accessing' stamp: 'lr 10/22/2009 10:37'! languageBoxes ^ Array with: LBSchematicBox! ! !LBSchematicBoxTest methodsFor: 'testing' stamp: 'lr 10/22/2009 14:30'! testSubtextExample | a b c x | #((true true true 1) (true true false 1) (true false true 1) (false true true 2) (true false false 1) (false true false 2) (false false true 2) (false false false 3)) do: [ :spec | a := spec first. b := spec second. c := spec third. x := {| a | = true | = false | = false | = false |} {| b | -- | = true | -- | = false |} {| c | -- | -- | = true | = false |} {| | 1 | 2 | 2 | 3 |}. self assert: x = spec fourth ]! ! LBTestCase subclass: #LBSqlBoxTest instanceVariableNames: '' classVariableNames: 'SELECT FROM SQLSession' poolDictionaries: '' category: 'Cutie-LanguageBoxes-SQL'! !LBSqlBoxTest class methodsFor: 'accessing' stamp: 'lr 7/8/2009 15:51'! languageBoxes ^ Array with: LBSqlBox with: LBRegexpBox ! ! !LBSqlBoxTest methodsFor: 'querying' stamp: 'lr 10/2/2009 12:02'! findEmail: aString "Retrieve the e-mail for the given username aString." | rows | rows := SELECT email FROM users WHERE username = @(/\s*(\w+)\s*/ matches: aString at: 2). rows isEmpty ifTrue: [ self error: 'User not found' ]. ^ rows first first! ! !LBSqlBoxTest methodsFor: 'testing' stamp: 'lr 10/2/2009 11:14'! testUser | email | self halt. email := self findEmail: 'sle'. self assert: email = 'info@planet-sl.org'! ! !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: 'testing' stamp: 'lr 10/2/2009 11:09'! isAbstract ^ self name = #LBTestCase! ! !LBTestCase class methodsFor: 'accessing' stamp: 'lr 6/23/2009 11:44'! languageBoxes ^ #()! ! LBLanguageBox subclass: #LBFactoryBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Skins'! !LBFactoryBox methodsFor: 'hooks' stamp: 'lr 6/30/2009 14:43'! change: aGrammar ^ LBChange new fragment: (self factoriesFor: aGrammar); before: (aGrammar productionAt: #cascadeExpression)! ! !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/30/2009 14:43'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #cascadeExpression); fragment: (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/30/2009 14:43'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #unaryMessage); fragment: (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/30/2009 14:44'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #primary); fragment: 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/30/2009 14:44'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #variable); fragment: 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/30/2009 14:44'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #primary); fragment: ($/ asParser , $/ asParser negate star , $/ asParser) token! ! !LBRegexpBox methodsFor: 'hooks' stamp: 'lr 8/27/2009 16:04'! compile: aToken ^ ``(`,(aToken value copyFrom: 2 to: aToken size - 1) asRegex)! ! !LBRegexpBox methodsFor: 'hooks' stamp: 'lr 1/19/2009 09:49'! highlight: aToken ^ aToken -> Color orange! ! LBLanguageBox subclass: #LBRomanBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBRomanBox methodsFor: 'hooks' stamp: 'lr 10/2/2009 11:32'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #numberLiteral); fragment: LBRomanGrammar new! ! !LBRomanBox methodsFor: 'hooks' stamp: 'lr 10/2/2009 11:33'! compile: aToken ^ aToken value romanToArabic lift: aToken! ! !LBRomanBox methodsFor: 'hooks' stamp: 'lr 9/29/2009 11:24'! highlight: aToken ^ aToken -> Color darkGray! ! LBLanguageBox subclass: #LBSchematicBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Schematic'! !LBSchematicBox methodsFor: 'hooks' stamp: 'lr 10/22/2009 14:15'! change: aGrammar | grammarClass grammar | grammarClass := LBSchematicGrammar allSubclasses detect: [ :each | each concern = aGrammar class concern ] ifNone: [ self error: 'Unsupported language concern: ' , aGrammar class concern ]. grammar := grammarClass variable: (aGrammar productionAt: #variable) condition: (aGrammar productionAt: #binaryMessage) action: (aGrammar productionAt: #primary). ^ LBChange new before: (aGrammar productionAt: #cascadeExpression); fragment: grammar! ! LBLanguageBox subclass: #LBSchematicRow instanceVariableNames: 'nodes' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Schematic'! LBSchematicRow subclass: #LBSchematicActionRow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Schematic'! !LBSchematicActionRow methodsFor: 'building' stamp: 'lr 10/22/2009 14:26'! add: anInteger to: aNode | node | node := (nodes at: anInteger ifAbsent: [ ^ self ]) ifNil: [ ^ self ]. aNode arguments first body addNode: node! ! LBSchematicRow subclass: #LBSchematicConditionRow instanceVariableNames: 'variable' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Schematic'! !LBSchematicConditionRow methodsFor: 'building' stamp: 'lr 10/22/2009 14:28'! add: anInteger to: aNode | array node | array := (nodes at: anInteger ifAbsent: [ ^ self ]) ifNil: [ ^ self ]. node := RBMessageNode receiver: variable selectorParts: array first arguments: array last. aNode receiver: (aNode receiver isLiteral ifTrue: [ node ] ifFalse: [ ``(`,(aNode receiver) and: [ `,node ]) ]) ! ! !LBSchematicConditionRow methodsFor: 'accessing' stamp: 'lr 10/22/2009 13:52'! variable ^ variable! ! !LBSchematicConditionRow methodsFor: 'accessing' stamp: 'lr 10/22/2009 13:52'! variable: aNode variable := aNode! ! !LBSchematicRow methodsFor: 'building' stamp: 'lr 10/22/2009 13:53'! add: anInteger to: aNode self subclassResponsability! ! !LBSchematicRow methodsFor: 'accessing' stamp: 'lr 10/22/2009 13:46'! nodes ^ nodes! ! !LBSchematicRow methodsFor: 'accessing' stamp: 'lr 10/22/2009 13:46'! nodes: anArray nodes := anArray! ! LBLanguageBox subclass: #LBSqlBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-SQL'! !LBSqlBox class methodsFor: 'executing' stamp: 'lr 10/2/2009 11:15'! execute: aString "This is a fake database connection, it always responds a single row with a single column containing the same string. The SQL query doesn't actually matter." ^ #( #('info@planet-sl.org') )! ! !LBSqlBox methodsFor: 'hooks' stamp: 'lr 6/30/2009 15:09'! change: aSmalltalkGrammar ^ LBChange new fragment: (self sqlGrammarFor: aSmalltalkGrammar); before: (aSmalltalkGrammar productionAt: #cascadeExpression)! ! !LBSqlBox methodsFor: 'hooks' stamp: 'lr 10/2/2009 12:02'! compile: aCollection | expressions | expressions := OrderedCollection new. aCollection flatten do: [ :each | each class = PPToken ifTrue: [ (each value = '@(' or: [ each value = ')' ]) ifFalse: [ (expressions notEmpty and: [ expressions last class = RBLiteralNode ]) ifTrue: [ expressions last token instVarNamed: 'stop' put: each stop. expressions last value: expressions last token value ] ifFalse: [ expressions addLast: (RBLiteralNode literalToken: each value: each value) ] ] ] ifFalse: [ each isNil ifFalse: [ expressions addLast: ``(`,each asString) ] ] ]. ^ ``(LBSqlBox execute: `,(expressions fold: [ :a :b | ``(`,a , `,b) ]))! ! !LBSqlBox methodsFor: 'private' stamp: 'lr 8/31/2009 00:29'! sqlGrammarFor: aSmalltalkGrammar | grammarClass grammar | grammarClass := LBSqlGrammar allSubclasses detect: [ :each | each concern = aSmalltalkGrammar class concern ] ifNone: [ self error: 'Unsupported language concern: ' , aSmalltalkGrammar class concern ]. grammar := grammarClass new. LBChange new after: (grammar productionAt: #expression); fragment: ('@(' asParser token , (aSmalltalkGrammar productionAt: #cascadeExpression) , $) asParser token); modify: grammar with: nil. ^ grammar! ! 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! ! CUCompositeParser subclass: #LBRomanGrammar instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! !LBRomanGrammar methodsFor: 'productions' stamp: 'lr 10/2/2009 11:27'! romanCharacter $I / $V / $X / $L / $C / $D / $M! ! !LBRomanGrammar methodsFor: 'productions' stamp: 'lr 10/2/2009 14:49'! romanNumber (romanCharacter plus , #word not) token ==> [ :token | token value romanToArabic isNil ifTrue: [ PPFailure reason: 'Roman number expected' ] ifFalse: [ token ] ]! ! !LBRomanGrammar methodsFor: 'accessing' stamp: 'lr 10/2/2009 11:25'! start romanNumber! ! CUCompositeParser subclass: #LBSchematicGrammar instanceVariableNames: 'variable condition action' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Schematic'! LBSchematicGrammar subclass: #LBSchematicCompiler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Schematic'! !LBSchematicCompiler class methodsFor: 'accessing' stamp: 'lr 10/22/2009 11:39'! concern ^ #compile:! ! !LBSchematicCompiler methodsFor: 'productions' stamp: 'lr 10/22/2009 14:05'! actionCell super actionCell ==> #second! ! !LBSchematicCompiler methodsFor: 'productions' stamp: 'lr 10/22/2009 14:09'! actionRow super actionRow ==> [ :nodes | LBSchematicActionRow new nodes: nodes ]! ! !LBSchematicCompiler methodsFor: 'private' stamp: 'lr 10/22/2009 14:23'! buildExpression: anArray | node count | node := nil. count := anArray detectMax: [ :each | each nodes size ]. count nodes size to: 1 by: -1 do: [ :index | node := ``(true ifTrue: [ ] ifFalse: [ `,node ]). anArray do: [ :each | each add: index to: node ] ]. ^ node! ! !LBSchematicCompiler methodsFor: 'productions' stamp: 'lr 10/22/2009 13:08'! conditionCell super conditionCell ==> #second! ! !LBSchematicCompiler methodsFor: 'productions' stamp: 'lr 10/22/2009 14:05'! conditionRow super conditionRow ==> [ :nodes | LBSchematicConditionRow new variable: nodes first; nodes: nodes second ]! ! !LBSchematicCompiler methodsFor: 'tokens' stamp: 'lr 10/22/2009 13:08'! emptyToken super emptyToken ==> [ :token | nil ]! ! !LBSchematicCompiler methodsFor: 'productions' stamp: 'lr 10/22/2009 14:13'! row super row ==> #second! ! !LBSchematicCompiler methodsFor: 'productions' stamp: 'lr 10/22/2009 14:16'! table super table ==> [ :rows | self buildExpression: rows ]! ! !LBSchematicGrammar class methodsFor: 'instance-creation' stamp: 'lr 10/22/2009 14:03'! variable: aVariableParser condition: aConditionParser action: anActionParser ^ self basicNew variable: aVariableParser condition: aConditionParser action: anActionParser; initialize; yourself! ! !LBSchematicGrammar methodsFor: 'productions' stamp: 'lr 10/22/2009 14:04'! actionCell separatorToken , action! ! !LBSchematicGrammar methodsFor: 'productions' stamp: 'lr 10/22/2009 14:04'! actionRow actionCell plus! ! !LBSchematicGrammar methodsFor: 'tokens' stamp: 'lr 10/22/2009 12:02'! beginToken '{|' token! ! !LBSchematicGrammar methodsFor: 'productions' stamp: 'lr 10/22/2009 14:07'! conditionCell separatorToken , (emptyToken / condition)! ! !LBSchematicGrammar methodsFor: 'productions' stamp: 'lr 10/22/2009 14:07'! conditionRow variable , conditionCell plus! ! !LBSchematicGrammar methodsFor: 'tokens' stamp: 'lr 10/22/2009 12:18'! emptyToken '--' token! ! !LBSchematicGrammar methodsFor: 'tokens' stamp: 'lr 10/22/2009 12:02'! endToken '|}' token! ! !LBSchematicGrammar methodsFor: 'productions' stamp: 'lr 10/22/2009 14:03'! row beginToken , (conditionRow / actionRow) , endToken! ! !LBSchematicGrammar methodsFor: 'tokens' stamp: 'lr 10/22/2009 13:48'! separatorToken $| token! ! !LBSchematicGrammar methodsFor: 'accessing' stamp: 'lr 10/22/2009 14:12'! start table! ! !LBSchematicGrammar methodsFor: 'tokens' stamp: 'lr 10/22/2009 14:13'! table row plus! ! !LBSchematicGrammar methodsFor: 'initialization' stamp: 'lr 10/22/2009 14:03'! variable: aVariableParser condition: aConditionParser action: anActionParser variable := aVariableParser. condition := aConditionParser. action := anActionParser! ! LBSchematicGrammar subclass: #LBSchematicHighlighter instanceVariableNames: '' classVariableNames: 'EndToken BeginToken SeparatorToken EmptyToken' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Schematic'! !LBSchematicHighlighter class methodsFor: 'accessing' stamp: 'lr 10/22/2009 11:40'! concern ^ #highlight:! ! !LBSchematicHighlighter class methodsFor: 'initialization' stamp: 'lr 10/22/2009 13:50'! initialize BeginToken := SeparatorToken := EndToken := Array with: Color gray with: TextEmphasis bold. EmptyToken := Array with: Color blue muchDarker with: TextEmphasis bold! ! !LBSchematicHighlighter methodsFor: 'tokens' stamp: 'lr 10/22/2009 12:06'! beginToken super beginToken ==> [ :token | token -> BeginToken ]! ! !LBSchematicHighlighter methodsFor: 'tokens' stamp: 'lr 10/22/2009 12:15'! emptyToken super emptyToken ==> [ :token | token -> EmptyToken ]! ! !LBSchematicHighlighter methodsFor: 'tokens' stamp: 'lr 10/22/2009 12:06'! endToken super endToken ==> [ :token | token -> EndToken ]! ! !LBSchematicHighlighter methodsFor: 'tokens' stamp: 'lr 10/22/2009 14:09'! separatorToken super separatorToken ==> [ :token | token -> SeparatorToken ]! ! !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 ]! ! !RxMatcher methodsFor: '*cutie-languageboxes' stamp: 'lr 8/31/2009 00:46'! matches: aString at: anInteger ^ (self matches: aString) ifTrue: [ self subexpression: anInteger ]! ! !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! LBSchematicHighlighter initialize!