SystemOrganization addCategory: #'Cutie-LanguageBoxes'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-Skins'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-Schematic'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-SQL'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-Quote'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-Cadr'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-Roman'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-Positional'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-Regexp'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-Path'! SystemOrganization addCategory: #'Cutie-LanguageBoxes-Pipe'! !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! ! !RxMatcher methodsFor: '*cutie-languageboxes' stamp: 'lr 8/31/2009 00:46'! matches: aString at: anInteger ^ (self matches: aString) ifTrue: [ self subexpression: anInteger ]! ! 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 9/2/2010 22:52'! close $) smalltalkToken! ! !LBLispFactoryParser methodsFor: 'token' stamp: 'lr 9/2/2010 22:52'! open $( smalltalkToken! ! !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-Roman'! !LBRomanGrammar methodsFor: 'productions' stamp: 'lr 10/2/2009 11:27'! romanCharacter $I / $V / $X / $L / $C / $D / $M! ! !LBRomanGrammar methodsFor: 'productions' stamp: 'lr 9/2/2010 22:58'! romanNumber (romanCharacter plus , #word not) smalltalkToken ==> [ :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 9/2/2010 23:02'! beginToken '{|' smalltalkToken! ! !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 9/2/2010 23:03'! emptyToken '--' smalltalkToken! ! !LBSchematicGrammar methodsFor: 'tokens' stamp: 'lr 9/2/2010 23:03'! endToken '|}' smalltalkToken! ! !LBSchematicGrammar methodsFor: 'productions' stamp: 'lr 10/22/2009 14:03'! row beginToken , (conditionRow / actionRow) , endToken! ! !LBSchematicGrammar methodsFor: 'tokens' stamp: 'lr 9/2/2010 23:03'! separatorToken $| smalltalkToken! ! !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: 'BeginToken EmptyToken EndToken SeparatorToken' 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 14:30'! initialize BeginToken := SeparatorToken := EndToken := EmptyToken := Array with: Color gray 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 ]! ! TestCase subclass: #LBTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes'! LBTestCase subclass: #LBCadrTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Cadr'! !LBCadrTest class methodsFor: 'accessing' stamp: 'lr 11/10/2009 17:25'! languageBoxes ^ Array with: LBCadrBox! ! !LBCadrTest methodsFor: 'testing' stamp: 'lr 9/2/2010 15:58'! testExample1 self assert: #(1 2 3) car = 1. self assert: #(1 2 3) cdr = #(2 3)! ! !LBCadrTest methodsFor: 'testing' stamp: 'lr 9/2/2010 15:58'! testExample2 self assert: #(1 2 3) cdar = 2. self assert: #(1 2 3) cddar = 3! ! !LBCadrTest methodsFor: 'testing' stamp: 'lr 9/2/2010 15:58'! testExample3 self assert: #(((1))) caaar = 1. self assert: #(1 (2 (3))) cdadaar = 3! ! 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 9/3/2010 08:33'! 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 9/2/2010 23:04'! 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 9/2/2010 18:59'! testLispFactoryOrderedCollection self assert: false "| 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-Path'! !LBPathBoxTest class methodsFor: 'accessing' stamp: 'lr 6/23/2009 11:45'! languageBoxes ^ Array with: LBPathBox! ! !LBPathBoxTest methodsFor: 'testing' stamp: 'lr 9/2/2010 22:54'! 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 9/2/2010 22:54'! testSimplePath | input output | input := #((1 2 3) (4 5) (6)). output := input::yourself. self assert: output = #(1 2 3 4 5 6)! ! LBTestCase subclass: #LBPipeBoxTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Pipe'! !LBPipeBoxTest class methodsFor: 'accessing' stamp: 'lr 9/2/2010 23:09'! languageBoxes ^ Array with: LBPipeBox! ! !LBPipeBoxTest methodsFor: 'tests' stamp: 'lr 9/2/2010 23:20'! testBinary1 | result | result := 1 :> + 2. self assert: result = 3! ! !LBPipeBoxTest methodsFor: 'tests' stamp: 'lr 9/2/2010 23:19'! testBinary2 | result | result := 1 :> + 2 :> -3. self assert: result = 0! ! !LBPipeBoxTest methodsFor: 'tests' stamp: 'lr 9/2/2010 23:19'! testKeyword1 | result | result := (1 to: 4) :> select: [ :x | x odd ]. self assert: result = #(1 3)! ! !LBPipeBoxTest methodsFor: 'tests' stamp: 'lr 9/2/2010 23:19'! testKeyword2 | result | result := (1 to: 4) :> select: [ :x | x odd ] :> collect: [ :x | x + 1 ]. self assert: result = #(2 4)! ! !LBPipeBoxTest methodsFor: 'tests' stamp: 'lr 9/3/2010 13:50'! testKeyword3 | result | result := (1 to: 10) :> select: [ :each | each odd ] :> collect: [ :each | each * each ] :> inject: 0 into: [ :sum :each | sum + each ]. self assert: result = 165! ! !LBPipeBoxTest methodsFor: 'tests' stamp: 'lr 9/2/2010 23:20'! testUnary1 | result | result := 1 :> negated. self assert: result = -1! ! !LBPipeBoxTest methodsFor: 'tests' stamp: 'lr 9/2/2010 23:20'! testUnary2 | result | result := 1 :> negated :> abs. self assert: result = 1! ! LBTestCase subclass: #LBPositionalBoxTest instanceVariableNames: 'seen' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Positional'! !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 9/2/2010 22:55'! 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 9/2/2010 22:55'! 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 9/2/2010 22:55'! 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 9/2/2010 22:55'! 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 9/2/2010 22:55'! 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 9/2/2010 22:55'! testNestedExpression self foo(('a' , 'b'), (1 + 2)). self assertSeen: #(foo:with: 'ab' 3)! ! !LBPositionalBoxTest methodsFor: 'testing-arguments' stamp: 'lr 9/2/2010 22:55'! testOneArgument self foo('abc'). self assertSeen: #(foo: 'abc')! ! !LBPositionalBoxTest methodsFor: 'testing-arguments' stamp: 'lr 9/2/2010 22:55'! 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-Quote'! !LBQuoteBoxTest class methodsFor: 'accessing' stamp: 'lr 6/23/2009 11:45'! languageBoxes ^ Array with: LBQuoteBox! ! !LBQuoteBoxTest methodsFor: 'testing-splice' stamp: 'lr 9/2/2010 16:10'! testParseSplice1 self assert: `@(10 factorial) = 3628800! ! !LBQuoteBoxTest methodsFor: 'testing-splice' stamp: 'lr 9/2/2010 16:10'! 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 9/2/2010 16:11'! 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-Regexp'! !LBRegexpBoxTest class methodsFor: 'accessing' stamp: 'lr 8/27/2009 16:05'! languageBoxes ^ Array with: LBRegexpBox! ! !LBRegexpBoxTest methodsFor: 'accessing' stamp: 'lr 9/3/2010 08:33'! testPaper self assert: ('Nena - 99 Luftballons' =~ /.*\d+.*/)! ! !LBRegexpBoxTest methodsFor: 'accessing' stamp: 'lr 9/3/2010 08:33'! testRegexp self assert: ('10010100' =~ /[01]+/). self assert: ('aaaaab' =~ /a*b/). self assert: ('abbbbbbc' =~ /ab+c/). self assert: ('abbb' =~ /ab*/)! ! LBTestCase subclass: #LBRomanBoxTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Roman'! !LBRomanBoxTest class methodsFor: 'accessing' stamp: 'lr 9/29/2009 11:25'! languageBoxes ^ Array with: LBRomanBox! ! !LBRomanBoxTest methodsFor: 'testing' stamp: 'lr 9/2/2010 23:00'! 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 9/3/2010 08:31'! 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: 'FROM SELECT 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 9/3/2010 08:33'! 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 9/2/2010 19:01'! testUser | email | email := self findEmail: 'sle'. self assert: email = 'info@planet-sl.org'! ! !LBTestCase class methodsFor: 'private' stamp: 'lr 9/2/2010 15:44'! compile: aString classified: aSymbol notifying: anObject trailer: anArray ifFail: aBlock "Before compiling the methods of the receiver make sure that the respective language boxes are added, this makes it possible to have the boxes and the tests in the same package." 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 ^ #()! ! !LBTestCase class methodsFor: 'accessing-helvetia' stamp: 'lr 9/2/2010 19:27'! languageBoxesHighlight ^ LBHighlightAction new! ! !LBTestCase class methodsFor: 'accessing-helvetia' stamp: 'lr 9/2/2010 15:44'! languageBoxesParser ^ LBParseAction new! ! LBLanguageBox subclass: #LBCadrBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Cadr'! !LBCadrBox class methodsFor: 'initialization' stamp: 'lr 11/10/2009 17:23'! initialize self default recompile! ! !LBCadrBox methodsFor: 'hooks' stamp: 'lr 9/2/2010 23:01'! change: aGrammar ^ LBChange new replace: (aGrammar productionAt: #primary); fragment: (aGrammar productionAt: #primary) copy , ($c asParser , ($a asParser / $d asParser) star , $r asParser) smalltalkToken optional! ! !LBCadrBox methodsFor: 'hooks' stamp: 'lr 11/10/2009 18:07'! compile: anArray | receiver token | receiver := anArray first. token := anArray second ifNil: [ ^ receiver ]. (token value copyFrom: 2 to: token size - 1) do: [ :char | receiver := char = $a ifTrue: [ ``(`,receiver first) ] ifFalse: [ ``(`,receiver allButFirst) ] ]. ^ receiver! ! !LBCadrBox methodsFor: 'hooks' stamp: 'lr 11/10/2009 18:08'! highlight: anArray ^ Array with: anArray first "receiver" with: (CHHighlighter mark: anArray second with: Color orange)! ! 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 9/2/2010 18:56'! factoriesFor: aParser ^ (LBFactoryParser withAllSubclasses select: [ :class | aParser class concern = class concern ]) inject: PPChoiceParser new into: [ :parser :class | parser / ('<<' asParser token trim , class identifier asParser token trim , (class primary: (aParser productionAt: #cascadeExpression) message: (aParser productionAt: #message)) , '>>' asParser token trim) ]! ! !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-Path'! !LBPathBox class methodsFor: 'initialization' stamp: 'lr 11/6/2008 12:09'! initialize self default recompile! ! !LBPathBox methodsFor: 'hooks' stamp: 'lr 9/2/2010 22:54'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #cascadeExpression); fragment: (aGrammar productionAt: #primary) , ('::' asParser smalltalkToken , (aGrammar productionAt: #unaryToken) , ('()' asParser smalltalkToken / (aGrammar productionAt: #block) optional)) plus! ! !LBPathBox methodsFor: 'hooks' stamp: 'lr 9/2/2010 16:07'! 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 9/2/2010 16:07'! highlight: aCollection ^ CHHighlighter mark: aCollection with: TextEmphasis italic! ! LBLanguageBox subclass: #LBPipeBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Pipe'! !LBPipeBox methodsFor: 'hooks' stamp: 'lr 9/3/2010 08:28'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #cascadeExpression); fragment: (aGrammar productionAt: #keywordExpression) , (':>' asParser smalltalkToken , (aGrammar productionAt: #message)) plus! ! !LBPipeBox methodsFor: 'hooks' stamp: 'lr 9/3/2010 08:28'! compile: aCollection ^ aCollection last inject: aCollection first into: [ :receiver :array | RBMessageNode receiver: receiver selectorParts: array second first arguments: array second second ]! ! !LBPipeBox methodsFor: 'hooks' stamp: 'lr 9/2/2010 23:24'! highlight: aCollection ^ Array with: aCollection first with: (aCollection last collect: [ :each | Array with: (CHHighlighter mark: each first with: Color orange) with: each last ])! ! LBLanguageBox subclass: #LBPositionalBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Positional'! !LBPositionalBox class methodsFor: 'initialization' stamp: 'lr 5/18/2009 11:17'! initialize self default recompile! ! !LBPositionalBox methodsFor: 'hooks' stamp: 'lr 9/2/2010 22:55'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #unaryMessage); fragment: (aGrammar productionAt: #unary) token , $( asParser smalltalkToken , ((aGrammar productionAt: #primary) separatedBy: $, asParser smalltalkToken) optional , $) asParser smalltalkToken! ! !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-Quote'! LBQuoteBox subclass: #LBPrimaryQuoteBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageBoxes-Quote'! !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: '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-Quote'! !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-Regexp'! !LBRegexpBox class methodsFor: 'initialization' stamp: 'lr 11/6/2008 12:09'! initialize self default recompile! ! !LBRegexpBox methodsFor: 'hooks' stamp: 'lr 9/3/2010 08:33'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #primary); fragment: ($/ asParser , $/ asParser negate star , $/ asParser) smalltalkToken! ! !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-Roman'! !LBRomanBox methodsFor: 'hooks' stamp: 'lr 9/2/2010 22:57'! change: aGrammar ^ LBChange new before: (aGrammar productionAt: #numberLiteral); fragment: LBRomanGrammar new! ! !LBRomanBox methodsFor: 'hooks' stamp: 'lr 9/2/2010 23:00'! compile: aToken ^ RBLiteralNode literalToken: (RBNumberLiteralToken value: aToken value romanToArabic start: aToken start stop: aToken stop source: aToken value)! ! !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 9/2/2010 19:03'! 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 value: each value) ] ] ] ifFalse: [ each isNil ifFalse: [ expressions addLast: ``(`,each asString) ] ] ]. ^ ``(LBSqlBox execute: `,(expressions fold: [ :a :b | ``(`,a , `,b) ]))! ! !LBSqlBox methodsFor: 'private' stamp: 'lr 9/2/2010 22:50'! 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 smalltalkToken , (aSmalltalkGrammar productionAt: #cascadeExpression) , $) asParser smalltalkToken); modify: grammar with: nil. ^ grammar! ! LBSchematicHighlighter initialize! LBCadrBox initialize! LBPathBox initialize! LBPositionalBox initialize! LBRegexpBox initialize!