[Nemerle] Метапрограммирование в действии - AbstractFactory
От: VladD2 Российская Империя www.nemerle.org
Дата: 20.01.07 13:42
Оценка: 1 (1)
Камил Скальски в пылу порыва рефакторинга компилятора реализовал еще один паттерн проектирования. На этот раз это "Абстрактаня фабрика".

Собстенно макрос так и незывается — AbstractFactory.

Пример использования:
http://nemerle.org/svn/nemerle/trunk/snippets/designpatt/factory.n
using Nemerle.DesignPatterns;

class X['a] {
  public this (_x : int) { }    
}
class Y { 
  public this (_x : int) { }    
  public this (_x : string) { }    
}

class SX : X[int] {
  public this (x : int) { base (x) }    
}
class SY : Y {
  public this (x : int) { base (x) }    
  public this (x : string) { base (x) }    
}

class W ['a,'b] { }
class Z  { }

[AbstractFactory (X[int],Y, W [_, string], System.Exception)]
class Factory { }

[AbstractFactory (Override (SX, X[int]), Override (SY, Y), Z)]
class SubFactory : Factory { }

mutable f : Factory = Factory ();
def sf = SubFactory ();

System.Console.WriteLine (f.CreateX (1));
System.Console.WriteLine (f.CreateY (1));
System.Console.WriteLine (f.CreateY ("aa"));
System.Console.WriteLine (f.CreateW ());
System.Console.WriteLine (f.CreateException ("aa"));

f = sf;

System.Console.WriteLine (f.CreateX (1));
System.Console.WriteLine (f.CreateY (1));
System.Console.WriteLine (f.CreateY ("aa"));
System.Console.WriteLine (f.CreateW ());

System.Console.WriteLine (sf.CreateZ ());

/*
BEGIN-OUTPUT
X`1[System.Int32]
Y
Y
W`2[System.Object,System.String]
System.Exception: aa
SX
SY
SY
W`2[System.Object,System.String]
Z
END-OUTPUT
*/



Исходник находится здесь.
[Nemerle.MacroUsage (Nemerle.MacroPhase.BeforeTypedMembers, Nemerle.MacroTargets.Class)]
macro AbstractFactory (tb : TypeBuilder, params classes : list [PExpr]) 
{
    def interpret_generics (a, acc = ([], [])) {
        match (a) {
            | [] => (acc[0].Reverse (), acc[1].Reverse ())
            | <[ _ ]> :: xs => 
                def n = Macros.NewSymbol ();
                def sym = <[ $(n : name) ]>;
                interpret_generics (xs, (Splicable.Name (n) :: acc[0], sym :: acc [1]))
            | x :: xs =>
                interpret_generics (xs, (acc[0], x :: acc[1]))
        }
    }
    def interpret_expr (e) {
        | <[ $nm [..$generics] ]> =>
                def (parms, args) = interpret_generics (generics);
                (nm, parms, args, <[ $nm.[..$args] ]> )
                
        | <[ Override ($current, $overriden) ]> =>
            def (nm,parms,args,_) = interpret_expr (current);
            (nm, parms, args, overriden)
            
        | _ => (e, [], [], e)
    }
    def get_simple_name (e, nm) {
        match (e) {
            | <[ $e [..$_] ]> 
            | <[ $e . [..$_] ]> 
            | <[ $e ]> =>
                match (Util.QidOfExpr (e)) {  
                    | Some ((li, _)) => (li.Last, nm : object == e) // nm == e iff we didn't have Override specified
                    | _ => Message.FatalError (e.Location, $"invalid overriden type specified: $e");
                }
        }
    }
    
    def fetch_parameters_provider (tc : TypeInfo) {
        | tc is TypeBuilder => 
            mutable coll = [];
            foreach (ClassMember.Function (head, _, _) as f in tc.GetParsedMembers (true))
                when (f.Name == ".ctor" && (f.Attributes & NemerleAttributes.Public == NemerleAttributes.Public))
                    coll ::= (head : IParametersProvider);
            if (coll.IsEmpty)
                [Fun_header (tc.Location, null, null, [])] // empty ctor
            else coll
                
        | _ =>
            tc.GetConstructors (BindingFlags.Instance | BindingFlags.Public | BindingFlags.DeclaredOnly).Map (_.GetHeader ())
    }
        
    foreach (expr in classes) {
        def (nm, gparms, gargs, returned) = interpret_expr (expr);
     
        match (Util.QidOfExpr (nm)) {
            | Some ((li, _)) =>
                match (tb.GlobalEnv.LookupType (li, tb, gargs.Length)) {
                    | Some (tc) =>
                        def (returned_name, is_base) = get_simple_name (returned, nm);
                        foreach (head in fetch_parameters_provider (tc)) {
                            def attrs = Modifiers (NemerleAttributes.Public, []);
                            if (is_base)
                                attrs.mods |= NemerleAttributes.Virtual;
                            else
                                attrs.mods |= NemerleAttributes.Override;
                                
                            tb.Define (<[ decl: 
                                ..$attrs $("Create" + returned_name : usesite) [..$gparms] (..$(head.ParametersDeclarations)) : $returned 
                                { 
                                    $nm .[..$gargs] (..$(head.ParametersReferences))
                                } 
                            ]>)            
                        }
            
                    | _ => Message.Error (expr.Location, $"to generate factory methods, class names are required, which $nm is not");
                }
            
            | None => 
                Message.Error (expr.Location, $"to generate factory methods, simple names are required, which $expr is not");
        }
    }
}
... << RSDN@Home 1.2.0 alpha rev. 637>>

30.01.07 17:58: Перенесено модератором из 'Декларативное программирование' — IT
Есть логика намерений и логика обстоятельств, последняя всегда сильнее.
 
Подождите ...
Wait...
Пока на собственное сообщение не было ответов, его можно удалить.