SystemOrganization addCategory: #'Cutie-LanguageAspects'! SystemOrganization addCategory: #'Cutie-LanguageAspects-Skins'! !String methodsFor: '*cutie-languageaspects' stamp: 'lr 5/7/2009 12:17'! =~ aRegexp ^ aRegexp matches: self! ! CUCompositeParser subclass: #LAFactoryParser instanceVariableNames: 'primary message original' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects-Skins'! !LAFactoryParser class methodsFor: 'accessing' stamp: 'lr 4/8/2009 15:06'! concern ^ nil! ! !LAFactoryParser class methodsFor: 'accessing' stamp: 'lr 4/8/2009 15:05'! identifier ^ nil! ! !LAFactoryParser class methodsFor: 'instance creation' stamp: 'lr 5/7/2009 12:01'! parser: aParser primary: aPrimaryParser message: aMessageParser ^ self basicNew initializeParser: aParser primary: aPrimaryParser message: aMessageParser! ! !LAFactoryParser methodsFor: 'initialization' stamp: 'lr 5/7/2009 12:01'! initializeParser: aParser primary: aPrimaryParser message: aMessageParser original := aParser. primary := aPrimaryParser. message := aMessageParser. self initialize! ! !LAFactoryParser methodsFor: 'private' stamp: 'lr 5/7/2009 12:02'! tokenParser ^ original tokenParser! ! LAFactoryParser subclass: #LALispFactoryParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects-Skins'! LALispFactoryParser subclass: #LALispFactoryCompiler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects-Skins'! !LALispFactoryCompiler class methodsFor: 'accessing' stamp: 'lr 4/8/2009 15:17'! concern ^ #compile:! ! !LALispFactoryCompiler 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 ]! ! !LALispFactoryCompiler 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 ]! ! !LALispFactoryParser class methodsFor: 'accessing' stamp: 'lr 4/8/2009 15:41'! concern ^ #highlight:! ! !LALispFactoryParser class methodsFor: 'accessing' stamp: 'lr 4/9/2009 10:55'! identifier ^ 'builder-parens:'! ! !LALispFactoryParser methodsFor: 'token' stamp: 'lr 5/5/2009 14:31'! close $) token! ! !LALispFactoryParser methodsFor: 'token' stamp: 'lr 5/5/2009 14:31'! open $( token! ! !LALispFactoryParser methodsFor: 'grammar' stamp: 'lr 4/8/2009 15:06'! send open , message , send star , close! ! !LALispFactoryParser methodsFor: 'grammar' stamp: 'lr 4/8/2009 15:07'! start open , primary , send star , close! ! LAFactoryParser subclass: #LAPythonFactoryParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects-Skins'! LAPythonFactoryParser subclass: #LAPythonFactoryCompiler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects-Skins'! !LAPythonFactoryCompiler class methodsFor: 'accessing' stamp: 'lr 4/8/2009 15:41'! concern ^ #compile:! ! !LAPythonFactoryCompiler 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 ]! ! !LAPythonFactoryCompiler methodsFor: 'grammar' stamp: 'lr 4/8/2009 15:45'! start super start ==> [ :nodes | self halt ]! ! !LAPythonFactoryParser class methodsFor: 'accessing' stamp: 'lr 5/7/2009 12:07'! concern ^ #highlight:! ! !LAPythonFactoryParser class methodsFor: 'accessing' stamp: 'lr 4/9/2009 10:55'! identifier ^ 'builder-indent:'! ! !LAPythonFactoryParser methodsFor: 'token' stamp: 'lr 5/5/2009 15:19'! indent #tab star! ! !LAPythonFactoryParser methodsFor: 'token' stamp: 'lr 5/5/2009 14:31'! newline #cr token! ! !LAPythonFactoryParser methodsFor: 'grammar' stamp: 'lr 4/8/2009 10:36'! send indent , message , newline optional! ! !LAPythonFactoryParser methodsFor: 'grammar' stamp: 'lr 4/8/2009 10:36'! start indent , primary , send star! ! !QQTestCase class methodsFor: '*cutie-languageaspects' stamp: 'lr 2/25/2009 10:09'! languageAspectsHighlight ^ nil! ! !QQTestCase class methodsFor: '*cutie-languageaspects' stamp: 'lr 2/25/2009 10:09'! languageAspectsParser ^ nil! ! LAAspect subclass: #LAFactory instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects-Skins'! !LAFactory methodsFor: 'hooks' stamp: 'lr 5/7/2009 11:53'! advice: aParser ^ LAAdvice new before: (aParser productionAt: #cascadeExpression); parser: (self factoriesFor: aParser)! ! !LAFactory methodsFor: 'hooks' stamp: 'lr 5/7/2009 11:54'! compile: aNode ^ aNode second! ! !LAFactory methodsFor: 'parsing' stamp: 'lr 5/7/2009 12:03'! factoriesFor: aParser ^ (LAFactoryParser withAllSubclasses select: [ :class | aParser class concern = class concern ]) inject: PPChoiceParser new into: [ :parser :class | parser / (class identifier asParser token , (class on: parser primary: (aParser productionAt: #cascadeExpression) message: (aParser productionAt: #message))) ]! ! !LAFactory methodsFor: 'hooks' stamp: 'lr 5/7/2009 11:55'! highlight: aNode ^ aNode -> Color orange! ! LAAspect subclass: #LAPathAspect instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects'! !LAPathAspect class methodsFor: 'initialization' stamp: 'lr 11/6/2008 12:09'! initialize self default recompile! ! !LAPathAspect methodsFor: 'hooks' stamp: 'lr 5/7/2009 13:04'! advice: aParser ^ LAAdvice new before: (aParser productionAt: #cascadeExpression); parser: (aParser productionAt: #primary) , ('::' asParser token , (aParser productionAt: #unaryToken) , ('()' asParser token / (aParser productionAt: #block) optional)) plus! ! !LAPathAspect 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 ]! ! !LAPathAspect methodsFor: 'hooks' stamp: 'lr 4/2/2009 15:32'! highlight: aCollection ^ CHHighlighter mark: aCollection with: TextEmphasis italic! ! LAAspect subclass: #LAQuoteAspect instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects'! LAQuoteAspect subclass: #LAPrimaryQuoteAspect instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects'! !LAPrimaryQuoteAspect methodsFor: 'hooks' stamp: 'lr 5/5/2009 14:31'! advice: aParser ^ LAAdvice new choice; before: (aParser productionAt: #primary); parser: self metaParser token , (aParser productionAt: #primary)! ! !LAQuoteAspect methodsFor: 'hooks' stamp: 'lr 2/3/2009 19:08'! compile: aCollection ^ (self findMetaClass: aCollection first value) value: aCollection second! ! !LAQuoteAspect 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 ]! ! !LAQuoteAspect methodsFor: 'hooks' stamp: 'lr 2/3/2009 19:08'! highlight: aCollection ^ (self findMetaClass: aCollection first value) highlight: aCollection! ! !LAQuoteAspect methodsFor: 'testing' stamp: 'lr 2/25/2009 10:14'! includesSelector: aSelector in: aClass "The quoting operators should be available everywhere." ^ self class name ~= #LAQuoteAspect! ! !LAQuoteAspect 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 ]! ! LAQuoteAspect subclass: #LAVariableQuoteAspect instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects'! !LAVariableQuoteAspect methodsFor: 'hooks' stamp: 'lr 5/5/2009 14:30'! advice: aParser ^ LAAdvice new choice; before: (aParser productionAt: #variable); parser: self metaParser token , (aParser productionAt: #variable)! ! LAAspect subclass: #LARegexpAspect instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects'! !LARegexpAspect class methodsFor: 'initialization' stamp: 'lr 11/6/2008 12:09'! initialize self default recompile! ! !LARegexpAspect methodsFor: 'hooks' stamp: 'lr 5/5/2009 14:31'! advice: aParser ^ LAAdvice new before: (aParser productionAt: #primary); parser: ($/ asParser , $/ asParser negate star , $/ asParser) token! ! !LARegexpAspect methodsFor: 'hooks' stamp: 'lr 1/19/2009 09:49'! compile: aToken ^ QQObjectNode literalToken: aToken value: (aToken value copyFrom: 2 to: aToken size - 1) asRegex! ! !LARegexpAspect methodsFor: 'hooks' stamp: 'lr 1/19/2009 09:49'! highlight: aToken ^ aToken -> Color orange! ! !ProtoObject methodsFor: '*cutie-languageaspects' stamp: 'lr 5/7/2009 12:17'! languageAspectsHighlight ^ LASmalltalkGrammar compileUseLanguageAspects ifTrue: [ LAHighlightAction new ]! ! !ProtoObject methodsFor: '*cutie-languageaspects' stamp: 'lr 5/7/2009 12:17'! languageAspectsParser ^ LASmalltalkGrammar compileUseLanguageAspects ifTrue: [ LAParseAction new ]! ! TestCase subclass: #LATestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects'! LATestCase subclass: #LACrosscuttingTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects'! !LACrosscuttingTest class methodsFor: 'accessing' stamp: 'lr 5/7/2009 12:23'! aspects ^ Array with: LAPathAspect with: LARegexpAspect! ! !LACrosscuttingTest methodsFor: 'testing' stamp: 'lr 4/6/2009 11:56'! 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')! ! LATestCase subclass: #LAFactoryTest instanceVariableNames: '' classVariableNames: 'LALispFactory' poolDictionaries: '' category: 'Cutie-LanguageAspects-Skins'! !LAFactoryTest class methodsFor: 'accessing' stamp: 'lr 5/7/2009 12:05'! aspects ^ Array with: LAFactory! ! !LAFactoryTest methodsFor: 'testing-lisp' stamp: 'lr 5/7/2009 12:08'! testLispFactoryMorph | morph | "morph := builder-parens: (WatchMorph new (color: Color white) (submorphs (do: [ :each | each color: Color black ])))." self assert: (morph isKindOf: WatchMorph). self assert: (morph color = Color white). morph submorphs do: [ :each | self assert: each color = Color black ]! ! !LAFactoryTest methodsFor: 'testing-lisp' stamp: 'lr 5/7/2009 12:08'! testLispFactoryOrderedCollection | collection | "collection := builder-parens: (OrderedCollection new (add: 1) (add: 2) (add: OrderedCollection new (add: 3)) (add: OrderedCollection new (add: 4) (add: 5)))." 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! ! !LAFactoryTest methodsFor: 'testing-python' stamp: 'lr 5/7/2009 12:08'! testPythonFactoryMorph | morph | "morph := <>." self assert: (morph isKindOf: WatchMorph). self assert: (morph color = Color white)! ! !LAFactoryTest methodsFor: 'testing-python' stamp: 'lr 5/7/2009 12:08'! testPythonFactoryOrderedCollection | 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! ! LATestCase subclass: #LAPathAspectTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects'! !LAPathAspectTest class methodsFor: 'accessing' stamp: 'lr 5/7/2009 12:10'! aspects ^ Array with: LAPathAspect! ! !LAPathAspectTest methodsFor: 'testing' stamp: 'lr 5/7/2009 13:04'! testSimpleFilter | input output | input := #((1 2 3) (4 5) (6)). output := input::yourself[ :each | each odd ]. self assert: output = #(1 3 5)! ! !LAPathAspectTest methodsFor: 'testing' stamp: 'lr 5/7/2009 13:04'! testSimplePath | input output | input := #((1 2 3) (4 5) (6)). output := input::yourself. self assert: output = #(1 2 3 4 5 6)! ! LATestCase subclass: #LAQuoteAspectTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects'! !LAQuoteAspectTest class methodsFor: 'accessing' stamp: 'lr 5/7/2009 12:10'! aspects ^ Array with: LAQuoteAspect! ! !LAQuoteAspectTest methodsFor: 'testing-splice' stamp: 'lr 5/7/2009 13:04'! testParseSplice1 self assert: `@(10 factorial) = 3628800! ! !LAQuoteAspectTest methodsFor: 'testing-splice' stamp: 'lr 5/7/2009 13:04'! testParseSplice2 self assert: `@(DateAndTime now) < DateAndTime now! ! !LAQuoteAspectTest 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'! ! !LAQuoteAspectTest methodsFor: 'testing-quote' stamp: 'lr 5/7/2009 13:04'! testQuote2 | ast | ast := ``{ 1 }. self assert: (ast isKindOf: RBArrayNode). self assert: ast formattedCode = '{ 1 }'! ! !LAQuoteAspectTest methodsFor: 'testing-quote' stamp: 'lr 5/7/2009 13:04'! testQuote3 | ast | ast := ``[ ]. self assert: (ast isKindOf: RBBlockNode). self assert: ast formattedCode = '[ ]'! ! !LAQuoteAspectTest methodsFor: 'testing-quote' stamp: 'lr 5/7/2009 13:04'! testQuote4 | ast | ast := ``123. self assert: (ast isKindOf: RBLiteralNode). self assert: ast formattedCode = '123'! ! !LAQuoteAspectTest methodsFor: 'testing-quote' stamp: 'lr 4/3/2009 11:48'! testQuote5 | ast | ast := ``x. self assert: (ast isKindOf: RBVariableNode). self assert: ast formattedCode = 'x'! ! !LAQuoteAspectTest 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'! ! !LAQuoteAspectTest 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! ! LATestCase subclass: #LARegexpAspectTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cutie-LanguageAspects'! !LARegexpAspectTest class methodsFor: 'accessing' stamp: 'lr 5/7/2009 12:10'! aspects ^ Array with: LARegexpAspect! ! !LARegexpAspectTest methodsFor: 'accessing' stamp: 'lr 5/7/2009 12:19'! testPaper self assert: ('Nena - 99 Luftballons' =~ /.*\d+.*/)! ! !LARegexpAspectTest 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*/)! ! !LATestCase class methodsFor: 'accessing' stamp: 'lr 2/10/2009 15:24'! aspects ^ #()! ! !LATestCase class methodsFor: 'private' stamp: 'lr 5/7/2009 12:04'! compile: aString classified: aSymbol notifying: anObject trailer: anArray ifFail: aBlock "Before compilign the methods of the receiver make sure that the aspects are added." self aspects do: [ :aspect | (aspect default environments noneSatisfy: [ :env | env includesClass: self ]) ifTrue: [ aspect default addClass: self ] ]. ^ super compile: aString classified: aSymbol notifying: anObject trailer: anArray ifFail: aBlock! ! LAPathAspect initialize! LARegexpAspect initialize!