F#でWPF --- Elm Architectureで実装されたUserControl

あるアプリケーションを作成した後に、それをコントロール化して更に大きなアプリケーションを作成したい時があります。

今回は、下記記事で作成したカウンタアプリケーションをコントロール化してみたいと思います。
F#でWPF --- Elm Architectureを利用したMVVM - 何でもプログラミング

アプリケーションコード

Counterコントロールは、表示する値の"Value"と、値が変更されたときのコマンド"ValueChanged"からなります。

IncrementなのかDecrementなのかは、ユーザーは気にする必要はありません。

F#側は送られてきた値を保持して、Valueに通知しているだけです。

以降は、これを実現するCounterを作っていきます。

f:id:any-programming:20170531163613p:plain
Xaml

<Window xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"
        xmlns:local="clr-namespace:WPFApplication;assembly=WPFApplication"
        Title="MainWindow" Height="100" Width="200">
    <Grid>
        <local:Counter Value="{Binding Value}" ValueChanged="{Binding SetValue}" Margin="10" Height="23" />
    </Grid>
</Window>

F#

type Model = { Value : int }

let initialModel = { Value = 0 }

type Msg = SetValue of int

let update model msg =
    match msg with
    | SetValue x -> 
        { Value = x }        


Counter(Xaml

Xamlは下記のように定義しました。

UserControlのContentに代入するため、外枠はGridで定義してあります。

また、コントロールとしてMainWindow.xamlに貼り付けた際にデザイナーでエラーが発生しないよう、ビルドアクションを埋め込みリソースにしておきます。
f:id:any-programming:20170531165433p:plain

f:id:any-programming:20170531164948p:plain

<Grid xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"
             xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" 
             xmlns:d="http://schemas.microsoft.com/expression/blend/2008" 
             mc:Ignorable="d" 
             d:DesignHeight="23" d:DesignWidth="200">
    <Grid.ColumnDefinitions>
        <ColumnDefinition Width="23"/>
        <ColumnDefinition Width="*"/>
        <ColumnDefinition Width="23"/>
    </Grid.ColumnDefinitions>
    <Button Command="{Binding Decrement}" Content="◀" Grid.Column="0" />
    <TextBox Text="{Binding Count}" Grid.Column="1" IsReadOnly="True" TextAlignment="Center" VerticalContentAlignment="Center" />
    <Button Command="{Binding Increment}" Content="▶" Grid.Column="2" />
</Grid>


Counter(F#)

最終的なCounterクラスは下記のようになります。

以降、順を追って説明していきます。

type CounterModel = { Count : int }

let initialCounterModel = { Count = 0 }

type CounterMsg =
    | Increment
    | Decrement
    | SetCount of int

type Counter() as this = 
    inherit UserControl()
    static let value = DependencyProperty<Counter, int>()
    static let valueChanged = DependencyProperty<Counter, ICommand>()

    let update model msg =
        match msg with
        | Increment ->
            model, Post.Command(valueChanged.Get(this), model.Count + 1)
        | Decrement ->
            model, Post.Command(valueChanged.Get(this), model.Count - 1)
        | SetCount x ->
            { Count = x }, Post.None

    do this.Start("Counter.xaml", DataContext(initialCounterModel, update, id), (value, SetCount))

    static member val ValueProperty = value.Register()
    member this.Value with get() = value.Get(this) and set(x) = value.Set(this, x)

    static member val ValueChangedProperty = valueChanged.Register()
    member this.ValueChanged with get() = valueChanged.Get(this) and set(x) = valueChanged.Set(this, x)


まずはDependencyPropertyを作成します。

コード内のDependencyProperty<_, _>クラスは下記記事を参照してください。
DependencyProperty定義の記述量削減(F#) - 何でもプログラミング

static let value = DependencyProperty<Counter, int>()
static let valueChanged = DependencyProperty<Counter, ICommand>()

static member val ValueProperty = value.Register()
member this.Value with get() = value.Get(this) and set(x) = value.Set(this, x)

static member val ValueChangedProperty = valueChanged.Register()
member this.ValueChanged with get() = valueChanged.Get(this) and set(x) = valueChanged.Set(this, x)


続いてロジック部分を実装します。

アプリケーションの時と異なり、UIからのコマンド内でアプリケーション側のコマンドを呼びだしています。(Increment、Decrement)

またアプリケーション側からValue変更通知があった時にCountを更新しています。(SetCount)(Value変更通知とSetCountの接続は後ほど行います。)

アプリケーション側のコマンドを呼び出すために、DataContextクラスをPostを受け取るように変更しました。

type CounterModel = { Count : int }

let initialCounterModel = { Count = 0 }

type CounterMsg =
    | Increment
    | Decrement
    | SetCount of int

let update model msg =
    match msg with
    | Increment ->
        model, Post.Command(valueChanged.Get(this), model.Count + 1)
    | Decrement ->
        model, Post.Command(valueChanged.Get(this), model.Count - 1)
    | SetCount x ->
        { Count = x }, Post.None
type Post =
    | None
    | Command of ICommand * obj

type DataContext<'msg, 'm, 'vm>(initialModel    : 'm, 
                                updateModel     : 'm -> 'msg -> 'm * Post, 
                                createViewModel : 'm -> 'vm) as this =
    inherit DynamicObject()
    let propertyChanged   = Event<_, _>()
    let mutable model     = initialModel
    let mutable viewModel = createViewModel model

    let propertyDictionary = 
        typeof<'vm>.GetProperties()
        |> Array.map (fun x -> x.Name, x)
        |> dict

    let commandDictionary =
        let messageDictionary =
            FSharpType.GetUnionCases(typeof<'msg>)
            |> Array.map (fun x -> x.Name, x)
            |> dict
    
        let executeMessage name value =
            let args = match value with
                       | null                                   -> [||]
                       | x when FSharpType.IsTuple(x.GetType()) -> FSharpValue.GetTupleFields(x)
                       | x                                      -> [| x |]            
            let msg = FSharpValue.MakeUnion(messageDictionary.Item(name), args) :?> 'msg
            let updated = updateModel model msg
            model <- fst updated
            let prevViewModel = viewModel
            viewModel <- createViewModel model
            typeof<'vm>.GetProperties()
            |> Array.iter (fun x -> if x.GetValue(viewModel) <> x.GetValue(prevViewModel) then 
                                        propertyChanged.Trigger(this, PropertyChangedEventArgs(x.Name)))

            // View更新後の処理(Commandの呼び出し)
            match snd updated with
            | None                        -> ()
            | Command(command, parameter) -> if command <> null then command.Execute(parameter)

        let createCommand (msg:UnionCaseInfo) =
            { new ICommand with
                member this.CanExecute _ = true
                [<CLIEvent>]
                member this.CanExecuteChanged = Event<_, _>().Publish 
                member this.Execute parameter = executeMessage msg.Name parameter }

        FSharpType.GetUnionCases(typeof<'msg>)
        |> Array.map (fun x -> x.Name, createCommand x)
        |> dict

    // Post処理がない時用のコンストラクタ
    new(initialModel, updateModel : 'm -> 'msg -> 'm, createViewModel) = 
        DataContext(initialModel, (fun x y -> updateModel x y, Post.None), createViewModel)

    interface INotifyPropertyChanged with
        [<CLIEvent>]
        member this.PropertyChanged = propertyChanged.Publish

    override this.TryGetMember(binder : GetMemberBinder, [<Out>] result : obj byref) = 
        if propertyDictionary.ContainsKey binder.Name then
            result <- propertyDictionary.Item(binder.Name).GetValue(viewModel)
        else
            result <- commandDictionary.Item(binder.Name)
        true


最後に、Xamlを読み込んでDataContextをセットし、それをUserControlのContentにセットして、さらにDependencyPropertyとMsgの接続を行う関数を定義します。

対象のMsgを呼び出すところは、もう少しスマートに記述できるかもしれません。

type UserControl with
    member this.Start(xamlPath : string, dataContext : DataContext<'msg, 'm, 'vm>, [<ParamArray>] maps : (DependencyProperty<'owner, 'value> * ('value -> 'msg))[]) = 
        let grid = loadEmbeddedXaml<Grid> xamlPath    
        grid.DataContext <- dataContext
        this.Content <- grid
        maps |> Array.iter (fun (property, msg) -> 
            property.Changed(this :?> 'owner).Add(fun x ->
                dataContext.TryGetMember(SimpleGetMemberBinder(caseName (msg x)))
                |> snd :?> ICommand
                |> (fun c -> c.Execute(x))))
let loadEmbeddedXaml<'a> fileName = 
    Assembly.GetExecutingAssembly().GetManifestResourceStream(fileName)
    |> XamlReader.Load
    :?> 'a

let caseName (x : obj) =
    FSharpValue.GetUnionFields(x, x.GetType()) |> fst |> (fun x -> x.Name)

type SimpleGetMemberBinder(name) =
    inherit GetMemberBinder(name, false)
    override this.FallbackGetMember(target, errorSuggestion) = raise (NotImplementedException())