1 people like it.

Just because

It's probably not possible, but I'm going to see how far I can get...

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59: 
60: 
61: 
62: 
63: 

open System.Reflection
open Microsoft.FSharp.Quotations
open Microsoft.FSharp.Linq.RuntimeHelpers.LeafExpressionConverter
open Microsoft.FSharp.Reflection

type TestRecord =
    {
        AnInt : int
        AString : string
    }

let propToGetLens<'a> _ (prop : PropertyInfo) =
    let recordVar = Var("record", typeof<'a>)
    let record = Expr.Var(recordVar)
    let getMethodInfo = prop.GetGetMethod()
    let get = Expr.Call(record, getMethodInfo, [])
    Expr.Lambda(recordVar, get)

let propToSetLens<'a> index (prop : PropertyInfo) =
    let recordType = typeof<'a>
    let recordVar = Var("record", typeof<'a>)
    let record = Expr.Coerce(Expr.Var(recordVar), typeof<obj>)
    let valueVar = Var("value", prop.PropertyType)
    let value = Expr.Coerce(Expr.Var(valueVar), typeof<obj>)
    let newRecord =
        <@
            let values =
                FSharpValue.GetRecordFields((%%record : obj))
                |> List.ofArray
                |> List.mapi (fun i v ->
                    if i = index then
                        (%%value:obj)
                    else v)
                |> Array.ofList
            FSharpValue.MakeRecord((%%record).GetType(), values)
        @>
    Expr.Lambda(valueVar, Expr.Lambda(recordVar, Expr.Coerce(newRecord, recordType)))

let MakeLenses<'a> () =
    let recordType = typeof<'a>
    if not <| FSharpType.IsRecord recordType then failwith "I'm not a record"
    let fields =
        FSharpType.GetRecordFields recordType
        |> List.ofArray
    fields
    |> List.mapi (fun i f -> <@ (%%(Expr.Coerce(propToGetLens<'a> i f, typeof<obj>)):obj), (%%(Expr.Coerce(propToSetLens<'a> i f, typeof<obj>)):obj) @>)

let lenses =
    MakeLenses<TestRecord>()
    |> List.head
    |> EvaluateQuotation
    :?> obj * obj

let getLens, setLens =
    fst lenses :?> TestRecord -> int, snd lenses :?> int -> TestRecord -> TestRecord

printfn "%A" (getLens, setLens)
printfn "Get: %A" <| getLens { AnInt = 22; AString = "" }
// Get: 22
printfn "Set: %A" <| getLens (setLens 50 { AnInt = 10; AString = "" })
// Set: 50

System.Console.ReadLine() |> ignore
namespace System
namespace System.Reflection
namespace Microsoft
namespace Microsoft.FSharp
namespace Microsoft.FSharp.Quotations
namespace Microsoft.FSharp.Linq
namespace Microsoft.FSharp.Linq.RuntimeHelpers
module LeafExpressionConverter

from Microsoft.FSharp.Linq.RuntimeHelpers
namespace Microsoft.FSharp.Reflection
type TestRecord =
  {AnInt: int;
   AString: string;}

Full name: Script.TestRecord
TestRecord.AnInt: int
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
TestRecord.AString: string
Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = System.String

Full name: Microsoft.FSharp.Core.string
val propToGetLens<'a> : int -> prop:PropertyInfo -> Expr

Full name: Script.propToGetLens
val prop : PropertyInfo
type PropertyInfo =
  inherit MemberInfo
  member Attributes : PropertyAttributes
  member CanRead : bool
  member CanWrite : bool
  member Equals : obj:obj -> bool
  member GetAccessors : unit -> MethodInfo[] + 1 overload
  member GetConstantValue : unit -> obj
  member GetGetMethod : unit -> MethodInfo + 1 overload
  member GetHashCode : unit -> int
  member GetIndexParameters : unit -> ParameterInfo[]
  member GetOptionalCustomModifiers : unit -> Type[]
  ...

Full name: System.Reflection.PropertyInfo
val recordVar : Var
Multiple items
type Var =
  interface IComparable
  new : name:string * typ:Type * ?isMutable:bool -> Var
  member IsMutable : bool
  member Name : string
  member Type : Type
  static member Global : name:string * typ:Type -> Var

Full name: Microsoft.FSharp.Quotations.Var

--------------------
new : name:string * typ:System.Type * ?isMutable:bool -> Var
val typeof<'T> : System.Type

Full name: Microsoft.FSharp.Core.Operators.typeof
val record : Expr
Multiple items
type Expr =
  override Equals : obj:obj -> bool
  member GetFreeVars : unit -> seq<Var>
  member Substitute : substitution:(Var -> Expr option) -> Expr
  member ToString : full:bool -> string
  member CustomAttributes : Expr list
  member Type : Type
  static member AddressOf : target:Expr -> Expr
  static member AddressSet : target:Expr * value:Expr -> Expr
  static member Application : functionExpr:Expr * argument:Expr -> Expr
  static member Applications : functionExpr:Expr * arguments:Expr list list -> Expr
  ...

Full name: Microsoft.FSharp.Quotations.Expr

--------------------
type Expr<'T> =
  inherit Expr
  member Raw : Expr

Full name: Microsoft.FSharp.Quotations.Expr<_>
static member Expr.Var : variable:Var -> Expr
val getMethodInfo : MethodInfo
PropertyInfo.GetGetMethod() : MethodInfo
PropertyInfo.GetGetMethod(nonPublic: bool) : MethodInfo
val get : Expr
static member Expr.Call : methodInfo:MethodInfo * arguments:Expr list -> Expr
static member Expr.Call : obj:Expr * methodInfo:MethodInfo * arguments:Expr list -> Expr
static member Expr.Lambda : parameter:Var * body:Expr -> Expr
val propToSetLens<'a> : index:int -> prop:PropertyInfo -> Expr

Full name: Script.propToSetLens
val index : int
val recordType : System.Type
static member Expr.Coerce : source:Expr * target:System.Type -> Expr
type obj = System.Object

Full name: Microsoft.FSharp.Core.obj
val valueVar : Var
property PropertyInfo.PropertyType: System.Type
val value : Expr
val newRecord : Expr<obj>
val values : obj []
type FSharpValue =
  static member GetExceptionFields : exn:obj * ?bindingFlags:BindingFlags -> obj []
  static member GetRecordField : record:obj * info:PropertyInfo -> obj
  static member GetRecordFields : record:obj * ?bindingFlags:BindingFlags -> obj []
  static member GetTupleField : tuple:obj * index:int -> obj
  static member GetTupleFields : tuple:obj -> obj []
  static member GetUnionFields : value:obj * unionType:Type * ?bindingFlags:BindingFlags -> UnionCaseInfo * obj []
  static member MakeFunction : functionType:Type * implementation:(obj -> obj) -> obj
  static member MakeRecord : recordType:Type * values:obj [] * ?bindingFlags:BindingFlags -> obj
  static member MakeTuple : tupleElements:obj [] * tupleType:Type -> obj
  static member MakeUnion : unionCase:UnionCaseInfo * args:obj [] * ?bindingFlags:BindingFlags -> obj
  ...

Full name: Microsoft.FSharp.Reflection.FSharpValue
static member FSharpValue.GetRecordFields : record:obj * ?allowAccessToPrivateRepresentation:bool -> obj []
static member FSharpValue.GetRecordFields : record:obj * ?bindingFlags:BindingFlags -> obj []
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
val ofArray : array:'T [] -> 'T list

Full name: Microsoft.FSharp.Collections.List.ofArray
val mapi : mapping:(int -> 'T -> 'U) -> list:'T list -> 'U list

Full name: Microsoft.FSharp.Collections.List.mapi
val i : int
val v : obj
module Array

from Microsoft.FSharp.Collections
val ofList : list:'T list -> 'T []

Full name: Microsoft.FSharp.Collections.Array.ofList
static member FSharpValue.MakeRecord : recordType:System.Type * values:obj [] * ?allowAccessToPrivateRepresentation:bool -> obj
static member FSharpValue.MakeRecord : recordType:System.Type * values:obj [] * ?bindingFlags:BindingFlags -> obj
val MakeLenses<'a> : unit -> Expr<obj * obj> list

Full name: Script.MakeLenses
val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not
type FSharpType =
  static member GetExceptionFields : exceptionType:Type * ?bindingFlags:BindingFlags -> PropertyInfo []
  static member GetFunctionElements : functionType:Type -> Type * Type
  static member GetRecordFields : recordType:Type * ?bindingFlags:BindingFlags -> PropertyInfo []
  static member GetTupleElements : tupleType:Type -> Type []
  static member GetUnionCases : unionType:Type * ?bindingFlags:BindingFlags -> UnionCaseInfo []
  static member IsExceptionRepresentation : exceptionType:Type * ?bindingFlags:BindingFlags -> bool
  static member IsFunction : typ:Type -> bool
  static member IsModule : typ:Type -> bool
  static member IsRecord : typ:Type * ?bindingFlags:BindingFlags -> bool
  static member IsTuple : typ:Type -> bool
  ...

Full name: Microsoft.FSharp.Reflection.FSharpType
static member FSharpType.IsRecord : typ:System.Type * ?allowAccessToPrivateRepresentation:bool -> bool
static member FSharpType.IsRecord : typ:System.Type * ?bindingFlags:BindingFlags -> bool
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
val fields : PropertyInfo list
static member FSharpType.GetRecordFields : recordType:System.Type * ?allowAccessToPrivateRepresentation:bool -> PropertyInfo []
static member FSharpType.GetRecordFields : recordType:System.Type * ?bindingFlags:BindingFlags -> PropertyInfo []
val f : PropertyInfo
val lenses : obj * obj

Full name: Script.lenses
val head : list:'T list -> 'T

Full name: Microsoft.FSharp.Collections.List.head
val EvaluateQuotation : Expr -> obj

Full name: Microsoft.FSharp.Linq.RuntimeHelpers.LeafExpressionConverter.EvaluateQuotation
val getLens : (TestRecord -> int)

Full name: Script.getLens
val setLens : (int -> TestRecord -> TestRecord)

Full name: Script.setLens
val fst : tuple:('T1 * 'T2) -> 'T1

Full name: Microsoft.FSharp.Core.Operators.fst
val snd : tuple:('T1 * 'T2) -> 'T2

Full name: Microsoft.FSharp.Core.Operators.snd
val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn
type Console =
  static member BackgroundColor : ConsoleColor with get, set
  static member Beep : unit -> unit + 1 overload
  static member BufferHeight : int with get, set
  static member BufferWidth : int with get, set
  static member CapsLock : bool
  static member Clear : unit -> unit
  static member CursorLeft : int with get, set
  static member CursorSize : int with get, set
  static member CursorTop : int with get, set
  static member CursorVisible : bool with get, set
  ...

Full name: System.Console
System.Console.ReadLine() : string
val ignore : value:'T -> unit

Full name: Microsoft.FSharp.Core.Operators.ignore
Raw view Test code New version

More information

Link:http://fssnip.net/nS
Posted:10 years ago
Author:mavnn
Tags: lens , aether , metaprogramming

This web site is created using F# and Suave web server. It is hosted on Azure and the source code is on GitHub. Contributions are welcome!

The first version of fssnip.net has been created by @tomaspetricek back in 2010. This web site is a new, open-source and contribution-friendly version.