F# --- TypeProvider --- DependencyProperty自動実装

下記記事にてTypeProviderを作成する方法を記述しました。
F# --- TypeProvider --- クイックスタート - 何でもプログラミング

今回は応用としてDependencyPropertyを自動実装するTypeProviderを作成してみます。

結果としてあまり実用的ではないものであるため、TypeProviderの実装方法の参考に利用してください。

作成するTypeProvider

パラメータは、ベースクラス名とプロパティ定義の二つの文字列になります。

プロパティ定義はスペース区切りで型と名前を記述します。

Typeを直接渡す方法がわからなかったため、文字列でのやり取りをしています。

もしTypeを渡す方法がわかりましたら追記いたします。

type MyControlBase = DependencyProperty.Base<"System.Windows.Controls.UserControl", 
                                             "System.Int32  Value1 
                                              System.Double Value2">


パラメータを受け取るTypeProviderの実装

今回は実際の型が必要なので、生成型のTypeProviderを作成します。

ProvidedTypeDefinitionのIsErasedをfalseに設定します。

let asm = Assembly.GetExecutingAssembly()
let ns = "DependencyProperty"
let defType = ProvidedTypeDefinition(asm, ns, "Base", None, IsErased = false)

do  defType.DefineStaticParameters(
        [ ProvidedStaticParameter("baseClass",  typeof<string>) 
            ProvidedStaticParameter("properties", typeof<string>) ],
        (fun typeName args -> // 型定義))

    this.AddNamespace(ns, [ defType ])


型の作成

こちらもIsErasedをfalseに設定します。

また型をdllに出力する必要があるため、ProvidedAssemblyで一時dllを指定します。(一つの型につき一つのdllを利用するため、利用する際はGetTempPath等を利用してください。)

文字列からの型検索は、現状5つのdllから行うようになっています。(この型検索は力技なので、よりよい方法が見つかれば追記いたします。)

let findType name = 
    [ typeof<System.Object>.Assembly                 // mscorlib
      typeof<System.Windows.Input.ICommand>.Assembly // System
      typeof<System.Windows.Point>.Assembly          // WindowsBase
      typeof<System.Windows.Media.Color>.Assembly    // PresentationCore
      typeof<FrameworkElement>.Assembly ]            // PresentationFramework
    |> Seq.map (fun x -> x.GetType(name))
    |> Seq.tryFind ((<>) null)
    |> function | Some x -> x
                | None   -> failwith (name + " doesn't exist")

let baseClass = findType (args.[0] :?> string)

let t = ProvidedTypeDefinition(asm, ns, typeName, Some baseClass, IsErased = false)
ProvidedAssembly("c:/src/temp.dll").AddTypes([ t ])


DependencyPropertyの定義

ProvidedFieldのIsStaticが読み取り専用のため、SetFieldAttributesでstaticに設定しています。

let properties =
    args.[1] :?> string
    |> fun x -> x.Split(Array.empty<char>, StringSplitOptions.RemoveEmptyEntries)
    |> Array.chunkBySize 2
    |> Array.map (fun x -> findType x.[0], x.[1])

let fields =
    properties
    |> Array.map (fun (_, name) -> 
        let field = ProvidedField(name + "Property", typeof<DependencyProperty>)
        field.SetFieldAttributes(FieldAttributes.Public ||| FieldAttributes.Static ||| FieldAttributes.InitOnly)               
        field)
t.AddMembers(fields |> Array.toList)


コンストラクタ定義

staticコンストラクタでDependencyPropertyを初期化します。

Expr.Sequentialを利用して逐次処理を表現します。

let staticCtor = ProvidedConstructor([], IsTypeInitializer = true)
staticCtor.InvokeCode <- fun _ -> 
    Array.zip properties fields
    |> Array.map (fun ((ty, name), field) -> Expr.FieldSet(field, <@@ DependencyProperty.Register(name, ty, t) @@>))
    |> Array.fold (fun s x -> Expr.Sequential(s, x)) <@@ () @@>
t.AddMember(staticCtor)

let ctor = ProvidedConstructor([], InvokeCode = fun _ -> <@@ () @@>)
t.AddMember(ctor);


プロパティ定義

Typeクラスでの型変換はExpr.Coerceを用います。

Array.zip properties fields
|> Array.iter (fun ((ty, name), field) -> 
    let property = ProvidedProperty(name, ty)
    property.GetterCode <- fun args ->
        Expr.Coerce(
            Expr.Call(
                Expr.Coerce(args.[0], typeof<DependencyObject>),
                typeof<DependencyObject>.GetMethod("GetValue"),
                [ Expr.FieldGet(field) ]),
            ty)
    property.SetterCode <- fun args ->
        Expr.Call(
            Expr.Coerce(args.[0], typeof<DependencyObject>),
            typeof<DependencyObject>.GetMethod("SetValue", [| typeof<DependencyProperty>; typeof<obj> |]),
            [ Expr.FieldGet(field); args.[1] ])
    t.AddMember(property) )


コード全体

namespace DependencyPropertyTypeProvider

open System
open System.Windows
open System.Reflection
open Microsoft.FSharp.Core.CompilerServices
open Microsoft.FSharp.Quotations
open ProviderImplementation.ProvidedTypes

[<TypeProvider>]
type DependencyPropertyTypeProvider() as this =
    inherit TypeProviderForNamespaces()
    let asm = Assembly.GetExecutingAssembly()
    let ns = "DependencyProperty"
    let defType = ProvidedTypeDefinition(asm, ns, "Base", None, IsErased = false)

    do  defType.DefineStaticParameters(
            [ ProvidedStaticParameter("baseClass",  typeof<string>) 
              ProvidedStaticParameter("properties", typeof<string>) ],
            (fun typeName args ->

                let findType name = 
                    [ typeof<System.Object>.Assembly                 // mscorlib
                      typeof<System.Windows.Input.ICommand>.Assembly // System
                      typeof<System.Windows.Point>.Assembly          // WindowsBase
                      typeof<System.Windows.Media.Color>.Assembly    // PresentationCore
                      typeof<FrameworkElement>.Assembly ]            // PresentationFramework
                    |> Seq.map (fun x -> x.GetType(name))
                    |> Seq.tryFind ((<>) null)
                    |> function | Some x -> x
                                | None   -> failwith (name + " doesn't exist")

                let baseClass = findType (args.[0] :?> string)

                let t = ProvidedTypeDefinition(asm, ns, typeName, Some baseClass, IsErased = false)
                ProvidedAssembly("c:/src/temp.dll").AddTypes([ t ])

                let properties =
                    args.[1] :?> string
                    |> fun x -> x.Split(Array.empty<char>, StringSplitOptions.RemoveEmptyEntries)
                    |> Array.chunkBySize 2
                    |> Array.map (fun x -> findType x.[0], x.[1])

                let fields =
                    properties
                    |> Array.map (fun (_, name) -> 
                        let field = ProvidedField(name + "Property", typeof<DependencyProperty>)
                        field.SetFieldAttributes(FieldAttributes.Public ||| FieldAttributes.Static ||| FieldAttributes.InitOnly)               
                        field)
                t.AddMembers(fields |> Array.toList)

                let staticCtor = ProvidedConstructor([], IsTypeInitializer = true)
                staticCtor.InvokeCode <- fun _ -> 
                    Array.zip properties fields
                    |> Array.map (fun ((ty, name), field) -> Expr.FieldSet(field, <@@ DependencyProperty.Register(name, ty, t) @@>))
                    |> Array.fold (fun s x -> Expr.Sequential(s, x)) <@@ () @@>
                t.AddMember(staticCtor)

                let ctor = ProvidedConstructor([], InvokeCode = fun _ -> <@@ () @@>)
                t.AddMember(ctor);

                Array.zip properties fields
                |> Array.iter (fun ((ty, name), field) -> 
                    let property = ProvidedProperty(name, ty)
                    property.GetterCode <- fun args ->
                        Expr.Coerce(
                            Expr.Call(
                                Expr.Coerce(args.[0], typeof<DependencyObject>),
                                typeof<DependencyObject>.GetMethod("GetValue"),
                                [ Expr.FieldGet(field) ]),
                            ty)
                    property.SetterCode <- fun args ->
                        Expr.Call(
                            Expr.Coerce(args.[0], typeof<DependencyObject>),
                            typeof<DependencyObject>.GetMethod("SetValue", [| typeof<DependencyProperty>; typeof<obj> |]),
                            [ Expr.FieldGet(field); args.[1] ])
                    t.AddMember(property) )

                t))

        this.AddNamespace(ns, [ defType ])

[<assembly:TypeProviderAssembly>]
do ()