Namespace current: NoCandy! Presrc.MessageMacro subclass: #TclSwitchMacro instanceVariableNames: '' classVariableNames: 'TclSwitchInputFormat TclSwitchCaseFormat' poolDictionaries: '' category: 'Presource-newcomer macros' ! TclSwitchMacro comment: 'I expand the #tclCase:choose: pseudo-message macro, which efficiently implements something approximating the Tcl `switch'' command. A #tclCase:choose: message looks like this: someInput tclCase: #(#regex #nocase) choose: {''^ [#xmlFile]. '''' -> [#htmlFile]}. This macro matches the receiver against the keys in the choose: list in turn, invoking the first block that matches, and answering its result. Exactly what "match" means is determined by the tclCase: arguments, which must be a literal array of symbols or a single symbol. For a traditional case/switch that works with any kind of value, just use #exact here. Also available are #glob, which uses Smalltalk''s traditional #match: message on strings, and of course #regex (aka #regexp), which matches regular expression keys. Any of these accept the #nocase modifier, which enables case-insensitivity, and the default is #exact. It does not make sense to match anything but strings if you use any tclCase: arguments other than #exact, and you are likely to get a runtime error if you do this. Regex mode also supports the #sendMatch option, meaning it will send the RegexResults object to the associated block on successful match. All your blocks must accept this argument if you use this option. Finally, there is a major performance penalty if you use #(#regex #nocase) with non-literal match keys, because I must recompute these regular expressions on every test. This issue does not affect regexes specified literally, because I fix those at compile time. Be aware of this issue in performance-critical situations. You may note that this macro has far too many DWIM-style matching features, making it a summarily insane macro. This is because it is a demonstration that Presource lets you bring all kinds of syntax into Smalltalk, whatever the wisdom of such things.' ! !TclSwitchMacro class methodsFor: 'initializing'! init "Set up the class-pool and class-instance variables." (self isMemberOf: thisContext method methodClass) ifFalse: [^self]. "alter these to change the interpretation of arguments" TclSwitchInputFormat := CodeTemplate fromExpr: '`@testValue `tclCase: `@options `choose: {`@.cases}'. TclSwitchCaseFormat := CodeTemplate fromExpr: '`@caseKey -> `@caseValue'. ! ! !TclSwitchMacro methodsFor: 'expanding macros'! expandTo: testValue tclCase: options choose: cases | exactFlag globFlag regexFlag nocaseFlag sendMatchFlag flagCount testVar elseBranch outputTemplate | "parse options list" exactFlag := globFlag := regexFlag := nocaseFlag := sendMatchFlag := false. options do: [:current | {current = #glob -> [globFlag := true]. (current = #regex or: [current = #regexp]) -> [regexFlag := true]. current = #nocase -> [nocaseFlag := true]. current = #exact -> [exactFlag := true]. current = #sendMatch -> [sendMatchFlag := true]} condSelect]. flagCount := {exactFlag. globFlag. regexFlag} occurrencesOf: true. {flagCount > 1. regexFlag not & sendMatchFlag} condSome ifTrue: [self error: 'conflicting tclCase modes']. flagCount = 0 ifTrue: [exactFlag := true]. "choose the CodeTemplate to use for each case. XXX Note to self: I *really* need to come up with a way to do literal code templates that can talk with their match/expand variables." outputTemplate := CodeTemplate fromExpr: {exactFlag & nocaseFlag -> ['(`@caseKey sameAs: `testVar) ifTrue: `@caseValue ifFalse: [`@elseBranch]']. exactFlag -> ['`@caseKey = `testVar ifTrue: `@caseValue ifFalse: [`@elseBranch]']. globFlag & nocaseFlag -> ['(`@caseKey match: `testVar ignoreCase: true) ifTrue: `@caseValue ifFalse: [`@elseBranch]']. globFlag -> ['(`@caseKey match: `testVar) ifTrue: `@caseValue ifFalse: [`@elseBranch]']. regexFlag & sendMatchFlag -> ['`testVar =~ `@caseKey ifMatched: `@caseValue ifNotMatched: [`@elseBranch]']. regexFlag -> ['`testVar ~ `@caseKey ifTrue: `@caseValue ifFalse: [`@elseBranch]']} condSelect. "fix up case keys where necessary. Currently this only needs to add the i regex modifier when using regexes and #nocase." regexFlag & nocaseFlag ifTrue: [cases do: [:case | | fixedKey | fixedKey := case key. fixedKey := fixedKey isLiteral ifTrue: [STInST.RBLiteralNode value: '(?i:%1)' % {fixedKey value}] ifFalse: [(CodeTemplate fromExpr: 'Smalltalk.String join: {''(?i:''. `@val asString. '')''}') expand: (LookupTable from: {'`@val' -> fixedKey})]. case key: fixedKey value: case value]]. "expand all the cases in reverse" elseBranch := CodeTemplate parseExpr: 'nil'. testVar := MessageMacro newVariable: 'tclCaseVar'. cases reverseDo: [:case | elseBranch := outputTemplate expand: (LookupTable from: {'`@caseKey' -> case key. '`testVar' -> testVar. '`@caseValue' -> case value. '`@elseBranch' -> elseBranch})]. ^(CodeTemplate fromExpr: '[:`testVar | `@branch] value: `@testValue') expand: (LookupTable from: {'`testVar' -> testVar. '`@testValue' -> testValue. '`@branch' -> elseBranch}) ! expandMessageInPlace: aMessageNode | inputMap msgOptions | inputMap := TclSwitchInputFormat match: aMessageNode. {inputMap notNil. (inputMap at: '`@options') isLiteral. (msgOptions := (inputMap at: '`@options') value) isSymbol or: [msgOptions isArray]. (inputMap at: '`@.cases') allSatisfy: [:case | (TclSwitchCaseFormat match: case) notNil]} condEvery ifFalse: [self error: 'Invalid %1 invocation' % {selector printString}]. "finish extracting pieces and send to the helper method" ^self expandTo: (inputMap at: '`@testValue') tclCase: (msgOptions isArray ifTrue: [msgOptions] ifFalse: [{msgOptions}]) choose: ((inputMap at: '`@.cases') collect: [:case | | casePMap | casePMap := TclSwitchCaseFormat match: case. (casePMap at: '`@caseKey') -> (casePMap at: '`@caseValue')]) ! ! TclSwitchMacro init!