Thursday, February 27, 2014

What the F# is that?

Over Christmas, while I was skiing, stuffing my face, and relaxing, this series of tweets came in...





Now, I'm still not sure what this code all does - I'm still working my way up to Type Providers in my "C# to F#" book - but this sort of code looks amazeballs!

(*
Copyright (c) 2013 William F. Smith
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
*)
module Cirrious.MvvmCross.ViewModels.TypeProvider
open System
open System.IO
open System.Reflection
open System.Windows.Input
open Microsoft.FSharp.Core.CompilerServices
open Microsoft.FSharp.Reflection
open Microsoft.FSharp.Quotations
open Microsoft.FSharp.Quotations.Patterns
open Microsoft.FSharp.Quotations.DerivedPatterns
open Microsoft.FSharp.Quotations.ExprShape
open ProviderImplementation
open ProviderImplementation.ProvidedTypes
open Cirrious.MvvmCross.ViewModels
/// Public
[<RequireQualifiedAccess>]
module MvxCommand =
let create (f: unit -> unit) = MvxCommand (Action (f))
// Helpers
/// Helps use a Type safely.
[<RequireQualifiedAccess>]
module internal Type =
let tryMethod name (t: Type) =
match t.GetMethod name with
| null -> None
| x -> Some x
let recordFields (t: Type) = FSharpType.GetRecordFields t |> List.ofArray
let methods (t: Type) = t.GetMethods () |> List.ofArray
let moduleFunctions (t: Type) =
methods t
|> List.filter (fun x ->
x.Name <> "GetType" &&
x.Name <> "GetHashCode" &&
x.Name <> "Equals" &&
x.Name <> "ToString")
/// Helps use an Assembly safely.
[<RequireQualifiedAccess>]
module internal Assembly =
let tryType name (asm: Assembly) =
match asm.GetType name with
| null -> None
| x -> Some x
let types (asm: Assembly) = asm.GetTypes () |> List.ofArray
[<RequireQualifiedAccess>]
module internal TypeProviderConfig =
let tryFindAssembly predicate (cfg: TypeProviderConfig) =
cfg.ReferencedAssemblies |> Array.tryFind predicate
[<RequireQualifiedAccess>]
module internal TypeProvider =
/// Load an assembly file properly for a type provider.
let loadAssemblyFile fileName = File.ReadAllBytes fileName |> Assembly.Load
// End Helpers
/// Contains the association of model and module types.
type internal MvxViewModelInfo = { ModelType: Type; ModuleType: Type; State: FieldInfo }
/// Discriminated union for methods on the view-model.
type internal MvxMethodInfo =
| Command of string * string
/// Discriminated union for types of mvx properties
type internal MvxPropertyInfo =
/// Property that has a raise property changed call in the setter.
| Observable of string * Type * string list
/// Property that returns a value based on observable(s).
| Computed of string * Type
/// Property that returns a MvxCommand. Usually causes a side effect and/or new state for the model.
| Command of string * MethodInfo
let internal (|VM|) (vm: MvxViewModelInfo) = vm.ModelType, vm.ModuleType, vm.State
let internal mvxNotifyPropertyChanged this = Expr.Coerce (this, typeof<IMvxNotifyPropertyChanged>)
let internal raisePropertyChanged = typeof<IMvxNotifyPropertyChanged>.GetMethod ("RaisePropertyChanged", [|typeof<string>|])
/// Gets the module that is associated with the given model type.
let internal moduleType (modelType: Type) asm =
let moduleName = modelType.FullName + "Module"
match Assembly.tryType moduleName asm with
| None -> failwithf "%s not found." moduleName
| Some x -> x
let internal computedFieldNames modelType expr =
let rec f modelType names = function
| Application (expr1, expr2) ->
names @ (f modelType [] expr1) @ (f modelType [] expr2)
| Call (expr, meth, exprList) ->
names @ (List.collect (f modelType []) exprList) @
match expr with
| None -> []
| Some x -> f modelType [] x
@
match Expr.TryGetReflectedDefinition (meth) with
| None -> []
| Some x -> f modelType [] x
| Lambda (_, body) -> f modelType names body
| Let (_, expr1, expr2) ->
names @ (f modelType [] expr1) @ (f modelType [] expr2)
| PropertyGet (_, propOrValInfo, _) ->
match propOrValInfo.DeclaringType = modelType with
| false -> names
| _ -> propOrValInfo.Name :: names
| _ -> names
f modelType [] expr
|> Seq.distinct
|> Seq.toList
let internal changedFieldNames modelType expr =
let rec f modelType names = function
| Application (expr1, expr2) ->
names @ (f modelType [] expr1) @ (f modelType [] expr2)
| Call (expr, meth, exprList) ->
names @ (List.collect (f modelType []) exprList) @
match expr with
| None -> []
| Some x -> f modelType [] x
@
match Expr.TryGetReflectedDefinition (meth) with
| None -> []
| Some x -> f modelType [] x
| Lambda (_, body) -> f modelType names body
| Let (_, expr1, expr2) ->
names @ (f modelType [] expr1) @ (f modelType [] expr2)
| NewRecord (recType, exprList) ->
match recType = modelType with
| false -> names
| _ ->
// Note: May need to revisit this at some point.
Type.recordFields recType
|> List.fold2 (fun names field -> function
| PropertyGet (_, propInfo, _) when propInfo.DeclaringType = recType -> names
| _ -> field.Name :: names) [] <| exprList
| _ -> names
f modelType [] expr
|> Seq.distinct
|> Seq.toList
let internal namesToSequentialPropertyChanged names this =
names |> List.map Expr.Value
|> List.map (fun x -> Expr.Call (mvxNotifyPropertyChanged this, raisePropertyChanged, [x]))
|> List.fold (fun expr x -> Expr.Sequential (expr, x)) (Expr.Value (()))
let internal propertyGetterCode (VM (modelType, moduleType, state)) = function
| Observable (name, _, _) -> function
| [this] -> Expr.PropertyGet (Expr.FieldGet (this, state), state.FieldType.GetProperty name)
| _ -> raise <| ArgumentException ()
| Computed (name, _) -> function
| [this] -> Expr.Call (moduleType.GetMethod name, [Expr.FieldGet (this, state)])
| _ -> raise <| ArgumentException ()
| Command (name, meth) -> function
| [this] ->
let var = Var ("vm", typeof<obj>)
let lambda =
Expr.Lambda (var,
<@@
fun () ->
%%Expr.Call (Expr.Coerce (Expr.Var var, meth.DeclaringType), meth, [])
() @@>)
<@@ MvxCommand.create (%%Expr.Application (lambda, Expr.Coerce (this, typeof<obj>))) @@>
| _ -> raise <| ArgumentException ()
let internal propertySetterCode (VM (modelType, moduleType, state)) = function
| Observable (name, _, computedNames) -> function
| [this; value] ->
let fields =
Type.recordFields modelType
|> List.map (fun x -> Expr.PropertyGet (Expr.FieldGet (this, state), x))
|> List.map (function
| PropertyGet (_, p, _) when p.Name = name -> value
| x -> x)
let sequentialPropertyChanged = namesToSequentialPropertyChanged computedNames this
<@@
%%Expr.FieldSet (this, state, Expr.NewRecord (state.FieldType, fields))
%%Expr.Call (mvxNotifyPropertyChanged this, raisePropertyChanged, [Expr.Value name])
%%sequentialPropertyChanged
() @@>
| _ -> raise <| ArgumentException ()
| Computed _ -> raise <| ArgumentException "Computed properties don't have setters."
| Command _ -> raise <| ArgumentException "Command properties don't have setters."
let internal generateProperty vm prop =
match prop with
| Observable (name, t, _) ->
ProvidedProperty (name, t, GetterCode = propertyGetterCode vm prop, SetterCode = propertySetterCode vm prop)
| Computed (name, t) ->
ProvidedProperty (name, t, GetterCode = propertyGetterCode vm prop)
| Command (name, _) ->
ProvidedProperty (name, typeof<ICommand>, GetterCode = propertyGetterCode vm prop)
let internal methodInvokeCode (VM (modelType, moduleType, state)) = function
| MvxMethodInfo.Command (_, name) -> function
| [this] ->
let meth = moduleType.GetMethod name
let changedNames =
match Expr.TryGetReflectedDefinition (meth) with
| None -> []
| Some x -> changedFieldNames modelType x
let sequentialPropertyChanged = namesToSequentialPropertyChanged changedNames this
<@@
%%Expr.FieldSet (this, state, Expr.Call (meth, [Expr.FieldGet (this, state)]))
%%sequentialPropertyChanged
() @@>
| _ -> raise <| ArgumentException ()
let internal generateMethod vm meth =
match meth with
| MvxMethodInfo.Command (name, _) ->
ProvidedMethod (name, [], typeof<Void>, InvokeCode = methodInvokeCode vm meth)
/// Generates a view-model
let internal generateViewModel vm =
match vm with
| VM (modelType, moduleType, state) ->
// Get record fields on the model.
let fields = Type.recordFields modelType
// Get functions that are on the module.
let init, funs =
Type.moduleFunctions moduleType
|> List.fold (fun (init, funs) x -> if x.Name = "init" then Some x, funs else init, x :: funs) (None, [])
// See if we have a valid init function.
let init =
match init with
| None -> failwithf "Unable to resolve init function in module %s." moduleType.Name
| Some x -> x
// Get command methods based on if the functions in the module have a return type of the model.
let cmdMeths =
funs |> List.filter (fun x -> x.ReturnType = modelType)
|> List.map (fun x -> MvxMethodInfo.Command (x.Name + "Fun", x.Name))
// Get computeds based on if the functions in the module do not have a return type of the model.
let comps =
funs |> List.filter (fun x -> x.ReturnType <> modelType)
|> List.map (fun x -> Computed (x.Name, x.ReturnType))
// Structure that contains which functions use the model's fields that can be computed.
// <method, fields>
let compsMap =
comps
|> List.fold (fun map -> function
| Computed (name, _) ->
match Expr.TryGetReflectedDefinition (moduleType.GetMethod (name)) with
| None -> failwithf "Reflected defintion for function, %s, could not be found." name
| Some x -> Map.add name (computedFieldNames vm.ModelType x) map
| _ -> map) Map.empty<string, string list>
// Get observables based on model fields and computed names.
let observs =
fields
|> List.fold (fun observs x ->
let computedNames =
compsMap
|> Map.fold (fun fields key -> function
| y when y |> List.exists (fun z -> z = x.Name) -> key :: fields
| _ -> fields) []
Observable (x.Name, x.PropertyType, computedNames) :: observs) []
// Generate methods based on command methods.
let meths = cmdMeths |> List.map (generateMethod vm)
// Get command properties based on the generated command methods.
let cmds =
List.map2 (fun x -> function
| MvxMethodInfo.Command (name, moduleName) ->
Command (moduleName, x)) meths cmdMeths
// Generate constructor which sets the state field by calling the init function from the module.
let ctor = ProvidedConstructor ([], InvokeCode = function
| [this] -> Expr.FieldSet (this, state, Expr.Call (init, []))
| _ -> raise <| ArgumentException ())
let baseCtor = typeof<MvxViewModel>.GetConstructor (BindingFlags.NonPublic ||| BindingFlags.Instance, null, [||], null)
ctor.BaseConstructorCall <- fun _ -> baseCtor, []
// Generate properties.
let props = observs @ comps @ cmds |> List.map (generateProperty vm)
// Create view-model type definition.
let vmp = ProvidedTypeDefinition (modelType.Name, Some typeof<MvxViewModel>, IsErased = false)
vmp.SetAttributes (TypeAttributes.Public)
vmp.AddMember state
vmp.AddMember ctor
vmp.AddMembers meths
vmp.AddMembers props
vmp
[<TypeProvider>]
type MvxViewModelTypeProvider (cfg: TypeProviderConfig) as this =
inherit TypeProviderForNamespaces ()
let asm = Assembly.GetExecutingAssembly ()
let ns = this.GetType().Namespace
let pn = "MvxViewModelProvider"
let tempAsm = ProvidedAssembly (Path.ChangeExtension (Path.GetTempFileName (), ".dll"))
let parameters = [
ProvidedStaticParameter ("modelsAssembly", typeof<string>) ]
do
// THIS IS NECESSARY
AppDomain.CurrentDomain.add_AssemblyResolve (fun _ args ->
let name = System.Reflection.AssemblyName(args.Name)
let existingAssembly =
System.AppDomain.CurrentDomain.GetAssemblies()
|> Seq.tryFind(fun a -> System.Reflection.AssemblyName.ReferenceMatchesDefinition(name, a.GetName()))
match existingAssembly with
| Some a -> a
| None -> null)
let def = ProvidedTypeDefinition (asm, ns, pn, Some typeof<obj>, IsErased = false)
tempAsm.AddTypes [def]
def.DefineStaticParameters (parameters, this.GenerateTypes)
this.AddNamespace(ns, [def])
/// FindModelsAssembly
member internal this.FindModelsAssembly fileName =
match cfg |> TypeProviderConfig.tryFindAssembly (fun fullPath -> Path.GetFileNameWithoutExtension fullPath = fileName) with
| None -> failwithf "Invalid models assembly name %s. Pick from the list of referenced assemblies." fileName
| Some masmFileName -> TypeProvider.loadAssemblyFile masmFileName
/// GenerateTypes
member internal this.GenerateTypes (typeName: string) (args: obj[]) =
let modelsAssembly = args.[0] :?> string
let masm = this.FindModelsAssembly modelsAssembly
let def = ProvidedTypeDefinition (asm, ns, typeName, Some typeof<obj>, IsErased = false)
tempAsm.AddTypes [def]
let types =
Assembly.types masm
|> List.filter (fun x -> FSharpType.IsRecord x)
|> List.map (fun x ->
let state = ProvidedField ("state", x)
state.SetFieldAttributes (FieldAttributes.Private ||| FieldAttributes.InitOnly)
{ ModelType = x; ModuleType = moduleType x masm; State = state })
def.AddMembersDelayed <| fun () ->
let defs = List.map generateViewModel types
tempAsm.AddTypes defs
defs
def
[<assembly:TypeProviderAssembly>]
do ()
view raw MvxViewModelTypeProvider.fs hosted with ❤ by GitHub

Will Smith - thank you - it is really inspiring to see devs creating the future of apps - thank you - a badge of awesomeness is **very thoroughly** deserved!


Posted by at

No comments:

Post a Comment

Subscribe to: Post Comments (Atom)