A generic case for strings

Do you remember the discussion about a case statement for strings?

I got this flash idea after reading Jolyon Smith’s “The case for case[]”, and remembering a comment from Francisco Ruiz on Nick Hodges’ article on THTMLWriter which suggested using a default array property in a creative fashion.

Honestly, it is not really a true case statement, and it might not be as fast as an if then else, but¬†here is how it looks when used. A bit ugly. but good fun ūüôā

program TestGenericsSwitch;
{$apptype Console}
uses
  GenericsSwitch;
begin
TStringSwitch.CaseOf('chARLie')
['Any', procedure begin
Writeln('Definitively any case');
end]
['B', procedure begin
Writeln('B all you can B');
end]
['Charlie', procedure begin
Writeln('Checkpoint C');
end]
.ElseCase(procedure begin
Writeln('Else what?');
end)
.EndCase;
end.

And here is how it is implemented.

unit GenericsSwitch;

/// Written by Lars Fosdal , December 1, 2010

interface
uses
SysUtils, Generics.Collections;

type
TSwitchProc = reference to procedure;
TGenericSwitch = class(TObjectDictionary)
private
FTheElseCase: TSwitchProc;
FTheTargetKey: KeyType;
function AddSwitchCase(const name: KeyType;
const value: TSwitchProc): TGenericSwitch;
procedure SetTheElseCase(const Value: TSwitchProc);
procedure SetTheTargetKey(const Value: KeyType);
protected
function ValidateKey(Key:KeyType):KeyType; virtual;
property TheTargetKey:KeyType read FTheTargetKey write SetTheTargetKey;
property TheElseCase:TSwitchProc read FTheElseCase write SetTheElseCase;
public
class function CaseOf(const Key: KeyType):TGenericSwitch;
function ElseCase(const Action: TSwitchProc): TGenericSwitch;
procedure EndCase;
property Cases[const name:KeyType; const value:TSwitchProc]: TGenericSwitch
read AddSwitchCase; default;
end;

TStringSwitch = class(TGenericSwitch)
function ValidateKey(key:String):String; override;
end;

implementation

{ TGenericSwitch }

function TGenericSwitch.AddSwitchCase(const name: KeyType; const value: TSwitchProc): TGenericSwitch;
begin
Result := Self;
Add(ValidateKey(Name), Value);
end;

class function TGenericSwitch.CaseOf(const Key: KeyType): TGenericSwitch;
begin
Result := Create;
Result.TheTargetKey := Key;
end;

function TGenericSwitch.ElseCase(const Action: TSwitchProc): TGenericSwitch;
begin
Result := Self;
TheElseCase := Action;
end;

procedure TGenericSwitch.EndCase;
var
DoIt : TSwitchProc;
begin
if TryGetValue(TheTargetKey, DoIt)
then DoIt
else
if Assigned(TheElseCase)
then TheElseCase;
Destroy;
end;

procedure TGenericSwitch.SetTheElseCase(const Value: TSwitchProc);
begin
FTheElseCase := Value;
end;

procedure TGenericSwitch.SetTheTargetKey(const Value: KeyType);
begin
FTheTargetKey := ValidateKey(Value);
end;

function TGenericSwitch.ValidateKey(Key: KeyType):KeyType;
begin
Result := Key;
end;

{ TStringSwitch }

function TStringSwitch.ValidateKey(key: String): String;
begin
Result := LowerCase(Key);
end;


end.

Another Generics / RTTI bug. Attributes are ignored in parametrized types.

The output from the code below, shows that you cannot enumerate attributes for properties of a parametrized type such as TOpenClass.

If you close the class as a TDecidedClass = TOpenClass, any attributes declared in TDecidedClass may have enumerable attributes, but the attributes declared for properties in TOpenClass are still not enumerable.

Output from the code:

Properties for TBaseClass
Normal
Blinged [Bling]

Properties for TBaseParam
BlingTFails <- Note the lack of a [Bling] attribute here 
BlingIntFails <- Note the lack of a [Bling] attribute here 
Normal 
Blinged [Bling] 

Properties for TBaseInt 
BlingInt [Bling] 
BlingTFails <- Note the lack of a [Bling] attribute here 
BlingIntFails <- Note the lack of a [Bling] attribute here 
Normal 
Blinged [Bling]

program AttributeFailsForParametricGenericType;

{$APPTYPE CONSOLE}

uses
ExceptionLog,
Classes,
Generics.Defaults,
RTTI;

type
Bling = class(TCustomAttribute);

TBaseClass = class
private
function GetBling: Integer;
function GetNormal: Integer;
procedure SetBling(const Value: Integer);
procedure SetNormal(const Value: Integer);
public
procedure Inspect;
property Normal:Integer read GetNormal write SetNormal;
[bling] property Blinged:Integer read GetBling write SetBling;
end;

TBaseParam = class(TBaseClass)
private
function GetBlingTFails: T;
procedure SetBlingTFails(const Value: T);
function GetBlingIntFails: Integer;
procedure SetBlingIntFails(const Value: Integer);
public
[bling] property BlingTFails:T read GetBlingTFails write SetBlingTFails;
[bling] property BlingIntFails:Integer read GetBlingIntFails write SetBlingIntFails;
end;

TBaseInt = class(TBaseParam)
private
function GetBlingInt: Integer;
procedure SetBlingInt(const Value: Integer);
public
[bling] property BlingInt:Integer read GetBlingInt write SetBlingInt;
end;


{ TBaseClass }

function TBaseClass.GetBling: Integer; begin end;
function TBaseClass.GetNormal: Integer; begin end;

procedure TBaseClass.Inspect;
var
Context : TRttiContext;
SourceType : TRttiType;
SourceProp : TRttiProperty;
SourceAttribute : TCustomAttribute;
s : String;
begin
Context := TRttiContext.Create;
try
SourceType := Context.GetType(Self.ClassType);
Writeln('');
Writeln(ClassName);

for SourceProp in SourceType.GetProperties
do begin
s := SourceProp.Name;

for SourceAttribute in SourceProp.GetAttributes
do begin
s := s + ' [' + SourceAttribute.ClassName + ']';
end;
Writeln(s);
end;
finally
Context.Free;
end;
end;

procedure TBaseClass.SetBling(const Value: Integer); begin end;
procedure TBaseClass.SetNormal(const Value: Integer); begin end;

{ TBaseParam }
function TBaseParam.GetBlingTFails: T; begin end;
function TBaseParam.GetBlingIntFails: Integer; begin end;
procedure TBaseParam.SetBlingTFails(const Value: T); begin end;
procedure TBaseParam.SetBlingIntFails(const Value: Integer); begin end;

{ TBaseInt }
function TBaseInt.GetBlingInt: Integer; begin end;
procedure TBaseInt.SetBlingInt(const Value: Integer); begin end;


var
Base : TBaseClass;
BaseT : TBaseParam;
BaseInt : TBaseInt;
begin
Base := TBaseClass.Create;
Base.Inspect;

BaseT := TBaseParam.Create;
BaseT.Inspect;

BaseInt := TBaseInt.Create;
BaseInt.Inspect;

Readln;
end.