WPF Type Provider

WpfTypeProvider.fs

namespace WpfTypeProvider

open System
open System.Reflection
open Samples.FSharpPreviewRelease2011.ProvidedTypes
open Microsoft.FSharp.Core.CompilerServices
open Microsoft.FSharp.Quotations
open Xaml
open System.Linq.Expressions
open System.IO
open System.Windows
open System.ComponentModel
open System.Windows.Data
open Microsoft.FSharp.Linq.QuotationEvaluation

module WpfTypeProvider =

  let splitPropertyFunc bindings exprs = 
    let twoWayFlags = bindings |> List.map ( fun (_,_,b) -> b)
    let pathes = bindings |> List.map (fun (_, name, _) -> name)
    let (getters, setters) = 
        (List.zip3 exprs twoWayFlags pathes) 
        |> List.partition (fun (_,twf, _) -> twf)

    let mutable getters = []
    let mutable setters = []
            
    let mutable setterFlag = false
    for (twoWay, path, f) in (exprs |> List.zip3 twoWayFlags pathes) do
      if setterFlag then
        setters <- (path, f) :: setters
        setterFlag <- false
      else if twoWay then
        getters <- (path, f) :: getters
        setterFlag <- true
      else
        getters <- (path, f) :: getters
    (getters, setters) 


    //(getters:(string *Expr) list, setters:(string *Expr) list)
  type ViewModelBase (args) = 
    let propertyChanged = Event<_, _>()

    let mutable getters = Map.ofList ([] : (string *Expr) list)
    let mutable setters = Map.ofList ([] : (string *Expr) list)

    //new (bindings,funcList:(Expr list)) = ViewModelBase ()
       //( splitPropertyFunc  bindings funcList)
//       { getters = [], setters = [] }
//       this.getters <- []
//       this.setters <- []
    
    member internal x.PropertyGetter name = 
      let f = (Map.find name getters)
      let linq = f.ToLinqExpression ()
      let typed = linq :?> Expression<Func<unit, obj>>
      (fun () ->
        (typed.Compile ()).Invoke ()
      )
      

    member internal x.PropertySetter name = 
      let f = (Map.find name setters)
      let linq = f.ToLinqExpression ()
      let typed = linq :?> Expression<Func<obj, unit>>
      (fun arg ->
        (typed.Compile ()).Invoke (arg)
        propertyChanged.Trigger(x, new PropertyChangedEventArgs(name))
      )

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

  let bindsTwoWayByDefault (binding:BindingExpression) = 
    let metadata = binding.TargetProperty.GetMetadata (binding.Target.GetType ()) :?> FrameworkPropertyMetadata
    metadata.BindsTwoWayByDefault
  
  type BindingsClass (typ, path, twoWay) = 
    class
      member x.Type = typ
      member x.Path = path
      member x.TwoWay = twoWay
    end

  type BindingsAndArgs (bindings, args)= 
    class
      member x.Bindings = bindings
      member x.Args = args
    end
  

  let createBindings xaml = 
    (Xaml.loadAsync xaml Xaml.getBindingExpressions)
    |> List.map (fun b -> (b.TargetProperty.PropertyType, b.ParentBinding.Path.Path, bindsTwoWayByDefault b))

  let createBindings2  xaml =  createBindings xaml
  let createBindingsAndArgs a b = [ new BindingsAndArgs (a, b) ] 


  let transBindings (bindings: (Type * string * bool) list ) = bindings |> List.map (fun (t, s , b) -> BindingsClass (t, s, b))


  [<TypeProvider>]
  type TypeProvider(config: TypeProviderConfig) as this = 
      inherit TypeProviderForNamespaces()
      let ns = "WpfTypeProvider"
      let asm = Assembly.GetExecutingAssembly()

      let viewModelType = ProvidedTypeDefinition(asm, ns, "ViewModel", Some(typeof<obj>))
      let resourceLocator = ProvidedStaticParameter("resourceLocator", typeof<string>)

      let generate typeName ([| (:? string as locator)  |] :obj []) =
        let resolvedFilename = Path.Combine(config.ResolutionFolder, locator)
        let bindings = createBindings resolvedFilename

        let typ = ProvidedTypeDefinition(asm, ns, typeName, Some(typeof<ViewModelBase>))
        
        
        let func fromType toType = typedefof<FSharpFunc<_,_>>.MakeGenericType ([| fromType ; toType |])
        let paramsList = bindings |> (List.collect) (function 
          | (propType, propPath, true) -> 
                 [  ProvidedParameter (propPath, func typeof<unit> propType) ;
                    ProvidedParameter (propPath, func propType typeof<unit> ) ]
          | (propType, propPath, false) -> [  ProvidedParameter (propPath, func typeof<unit> propType) ]
          ) 

        let b = transBindings bindings
        let o = new obj ()
        typ.AddMember(ProvidedConstructor(paramsList, InvokeCode = fun args -> 
          
          <@@ ViewModelBase ( Expr.Coerce ( args.[0], typeof<obj>) ) @@>
          ))

        
        for (propType, propPath, twoWay) in bindings do
          let getterCode = (fun [vm] -> <@@ (%%vm:ViewModelBase).PropertyGetter propPath @@> )
          let setterCode = (fun [vm; newval] -> <@@ (%%vm:ViewModelBase).PropertySetter propPath %%(Expr.Coerce(newval,typeof<obj>))  @@> )
          if twoWay then
            typ.AddMember (ProvidedProperty(propPath, propType, GetterCode = getterCode, SetterCode = setterCode ))
          else
            typ.AddMember (ProvidedProperty(propPath, propType, GetterCode = getterCode))

        typ

      do viewModelType.DefineStaticParameters ([resourceLocator], generate)

      do this.AddNamespace(ns, [viewModelType])
                            
  [<assembly:TypeProviderAssembly>] 
  do()

Xaml.fs

// Learn more about F# at http://fsharp.net

module Xaml

open System.Xaml
open System.Windows
open System
open System.ComponentModel
open System.Linq
open System.Windows.Data
open System.Reflection
open System.Windows.Markup
open System.IO
open System.Threading


let load (resourceLocator:string) = 
  use fs = new FileStream (resourceLocator, FileMode.Open) in
    XamlReader.Load (fs) :?> FrameworkElement

let loadAsync (resourceLocator:string) (loader:FrameworkElement->'a) = 
  let result = ref<'a> (Unchecked.defaultof<'a>)
  let thread = Thread (ThreadStart (fun _ -> ( result.Value <-  (loader <| load (resourceLocator)) )))
  thread.SetApartmentState ( ApartmentState.STA)
  thread.Start ()
  thread.Join ()
  result.Value

let getBindingExpressionsCore (element:FrameworkElement) = 
  [
    let props = TypeDescriptor.GetProperties element
    let props = props.Cast<PropertyDescriptor> ()
    let props = props |> Seq.map DependencyPropertyDescriptor.FromProperty |> Seq.filter ((<>) null)
    let props = props |> Seq.filter (fun p -> BindingOperations.IsDataBound (element, p.DependencyProperty))
    yield! props |> Seq.map (fun p -> BindingOperations.GetBindingExpression(element, p.DependencyProperty))
  ]

let getChildren (element:FrameworkElement) = (LogicalTreeHelper.GetChildren(element)).OfType<FrameworkElement>()

let rec getBindingExpressions (element:FrameworkElement) =
  [
    yield! getBindingExpressionsCore element   
    for child in getChildren element do
      yield! getBindingExpressions child
  ]