6 people like it.

Lens Generation using TypeShape

Adaptation of https://bitbucket.org/rojepp/reflenses/overview using TypeShape

Implemenation

 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: 
64: 
65: 
66: 
67: 
68: 
69: 
70: 
71: 
72: 
73: 
74: 
75: 
76: 
77: 
78: 
79: 
80: 
81: 
82: 
83: 
84: 
85: 
86: 
87: 
88: 
89: 
90: 
91: 
92: 
93: 
94: 
95: 
96: 
97: 
98: 
99: 
type Lens<'T, 'F> =
    {
        get : 'T -> 'F
        set : 'T -> 'F -> 'T
    }

module private Impl =

    open FSharp.Quotations
    open FSharp.Quotations.Patterns
    open TypeShape.Core
    open TypeShape.Clone

    type Path = Node list
    and Node =
        | Property of string
        | Item of int

    // converts a quotation of the form <@ fun x -> x.Foo.Bar.[0].Baz @> into a path
    let extractPath (e : Expr<'T -> 'F>) : Path =
        let rec aux v acc e =
            match e with
            | Var v' when v = v' -> acc
            | PropertyGet(Some o, p, [Value((:? int as i), _)]) when p.Name = "Item" -> aux v (Item i :: acc) o
            | PropertyGet(Some o, p, []) -> aux v (Property p.Name :: acc) o
            | Call(None, m, [o ; Value(:? int as i, _)]) when m.Name = "GetArray" && o.Type.IsArray && e.Type = o.Type.GetElementType() -> aux v (Item i :: acc) o
            // we support tuples, as they are often used to encode fields in erased type providers
            | TupleGet(x, i) -> aux v (Item i :: acc) x
            | _ -> invalidArg "expr" "invalid lens expression"

        match e with
        | Lambda(v, body) -> aux v [] body
        | _ -> invalidArg "expr" "lens expressions must be lambda literals"

    let rec mkLensAux<'T, 'F> (path : Path) : Lens<'T, 'F> =
        let wrap (l : Lens<'a,'b>) : Lens<'T, 'F> = unbox l

        let nest chain (m : IShapeWriteMember<'T>) =
            m.Accept { new IWriteMemberVisitor<'T, Lens<'T, 'F>> with
                member __.Visit<'F0> (m : ShapeWriteMember<'T, 'F0>) =
                    let inner = mkLensAux<'F0, 'F> chain
                    {
                        get = fun (t:'T) -> inner.get (m.Project t)
                        set = fun (t:'T) (f:'F) -> m.Inject t (inner.set (m.Project t) f)
                    }
        
            }

        match shapeof<'T>, path with
        | _, [] -> wrap { get = id<'F> ; set = fun (_:'F) (y:'F) -> y }
        | Shape.FSharpList s, Item i :: rest ->
            s.Accept { new IFSharpListVisitor<Lens<'T,'F>> with
                member __.Visit<'t> () =
                    let inner = mkLensAux<'t, 'F> rest
                    wrap {
                        get = fun (ts : 't list) -> inner.get ts.[i]
                        set = fun (ts : 't list) (f : 'F) -> ts |> List.mapi (fun j t -> if j = i then inner.set t f else t)
                    }
            }

        | Shape.FSharpOption s, Property "Value" :: rest ->
            s.Accept { new IFSharpOptionVisitor<Lens<'T,'F>> with
                member __.Visit<'t> () =
                    let inner = mkLensAux<'t, 'F> rest
                    wrap {
                        get = fun (ts : 't option) -> inner.get (Option.get ts)
                        set = fun (ts : 't option) (f : 'F) -> inner.set (Option.get ts) f |> Some
                    }
            }

        | Shape.Tuple (:? ShapeTuple<'T> as s), Item i :: rest ->
            s.Elements.[i] |> nest rest

        | Shape.Array s, Item i :: rest when s.Rank = 1 ->
            s.Accept { new IArrayVisitor<Lens<'T,'F>> with
                member __.Visit<'t> _ =
                    let inner = mkLensAux<'t, 'F> rest
                    wrap {
                        get = fun (ts : 't[]) -> inner.get ts.[i]
                        set = fun (ts : 't[]) (f : 'F) ->  ts.[i] <- inner.set ts.[i] f ; ts
                    }
            }

        | Shape.FSharpRecord (:? ShapeFSharpRecord<'T> as s) & Shape.FSharpRef _, Property "Value" :: rest ->
            s.Fields |> Array.find (fun p -> p.Label = "contents") |> nest rest

        | Shape.FSharpRecord (:? ShapeFSharpRecord<'T> as s), Property id :: rest ->
            s.Fields |> Array.find (fun p -> p.Label = id) |> nest rest

        | _ -> failwithf "unsupported lens type %O" typeof<'T>


let mkLens<'T, 'F> (expr : Expr<'T -> 'F>) : Lens<'T, 'F> =
    let path = Impl.extractPath expr
    let lens = Impl.mkLensAux<'T, 'F> path
    {
        get = lens.get
        set = fun t f -> lens.set (clone t) f // TypeShape native lenses rely on mutation, so we clone to hide this fact
    }

Examples

 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: 
type Foo<'T> =
    {
        a : 'T
        b : string
        c : bool
    }


let l1 = mkLens <@ fun (x:int) -> x @>
let l2 = mkLens <@ fun (x:Foo<int> ref) -> x.Value.a @>
let l3 = mkLens <@ fun (x:Foo<Foo<int> list> [] list option) -> x.Value.[0].[0].a.[0] @>

l1.get 42 // 42
l2.get (ref {a = 42; b = "" ; c = false}) // 42
l3.get (Some [[| { a = [{ a = 42 ; b = "" ; c = false }] ; b = "" ; c = false } |]]) // { a = 42 ; b = "" ; c = false }

l1.set 42 1
l2.set (ref {a = 42; b = "" ; c = false}) 5
l3.set (Some [[| { a = [{ a = 42 ; b = "" ; c = false }] ; b = "" ; c = false } |]]) { a = 42 ; b = "b" ; c = true }

// working with type providers

open FSharp.Data
type Bar = CsvProvider<Schema = "A (int), B (string), C (float)", HasHeaders = false>

let l4 = mkLens <@ fun (x:Bar.Row list) -> x.[1].B @>

let values = Bar.Parse("42, bar, 3.14\n55, baz, 2.17").Rows |> Seq.toList

l4.get values
l4.set values "foo"
Lens.get: 'T -> 'F
Lens.set: 'T -> 'F -> 'T
Multiple items
namespace FSharp

--------------------
namespace Microsoft.FSharp
namespace Microsoft.FSharp.Quotations
module Patterns

from Microsoft.FSharp.Quotations
namespace TypeShape
namespace TypeShape.Core
Multiple items
namespace TypeShape

--------------------
type TypeShape =
  private new : unit -> TypeShape
  abstract member Accept : ITypeShapeVisitor<'R> -> 'R
  abstract member ShapeInfo : TypeShapeInfo
  abstract member Type : Type
  override ToString : unit -> string
  static member Create : unit -> TypeShape<'T>
  static member Create : typ:Type -> TypeShape
  static member FromValue : obj:obj -> TypeShape

Full name: TypeShape.Core.Core.TypeShape

--------------------
type TypeShape<'T> =
  inherit TypeShape
  new : unit -> TypeShape<'T>
  override Accept : v:ITypeShapeVisitor<'a1> -> 'a1
  override Equals : o:obj -> bool
  override GetHashCode : unit -> int
  override ShapeInfo : TypeShapeInfo
  override Type : Type

Full name: TypeShape.Core.Core.TypeShape<_>

--------------------
new : unit -> TypeShape<'T>
module Clone

from TypeShape
type private Path = Node list

Full name: Script.Impl.Path
type private Node =
  | Property of string
  | Item of int

Full name: Script.Impl.Node
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
union case Node.Property: string -> Node
Multiple items
val string : value:'T -> string

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

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

Full name: Microsoft.FSharp.Core.string
union case Node.Item: int -> Node
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<_>
val private extractPath : e:Expr<('T -> 'F)> -> Path

Full name: Script.Impl.extractPath
val e : Expr<('T -> 'F)>
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<_>
val aux : (Var -> Node list -> Expr -> Node list)
val v : Var
val acc : Node list
val e : Expr
Multiple items
active recognizer Var: Expr -> Var option

Full name: Microsoft.FSharp.Quotations.Patterns.( |Var|_| )

--------------------
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 v' : Var
active recognizer PropertyGet: Expr -> (Expr option * System.Reflection.PropertyInfo * Expr list) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |PropertyGet|_| )
union case Option.Some: Value: 'T -> Option<'T>
val o : Expr
val p : System.Reflection.PropertyInfo
active recognizer Value: Expr -> (obj * System.Type) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |Value|_| )
val i : int
property System.Reflection.MemberInfo.Name: string
active recognizer Call: Expr -> (Expr option * System.Reflection.MethodInfo * Expr list) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |Call|_| )
union case Option.None: Option<'T>
val m : System.Reflection.MethodInfo
property Expr.Type: System.Type
property System.Type.IsArray: bool
System.Type.GetElementType() : System.Type
active recognizer TupleGet: Expr -> (Expr * int) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |TupleGet|_| )
val x : Expr
val invalidArg : argumentName:string -> message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.invalidArg
active recognizer Lambda: Expr -> (Var * Expr) option

Full name: Microsoft.FSharp.Quotations.Patterns.( |Lambda|_| )
val body : Expr
val private mkLensAux : path:Path -> Lens<'T,'F>

Full name: Script.Impl.mkLensAux
val path : Path
type Lens<'T,'F> =
  {get: 'T -> 'F;
   set: 'T -> 'F -> 'T;}

Full name: Script.Lens<_,_>
val wrap : (Lens<'a,'b> -> Lens<'T,'F>)
val l : Lens<'a,'b>
val unbox : value:obj -> 'T

Full name: Microsoft.FSharp.Core.Operators.unbox
val nest : (Path -> IShapeWriteMember<'T> -> Lens<'T,'F>)
val chain : Path
val m : IShapeWriteMember<'T>
type IShapeWriteMember<'Record> =
  interface
    inherit IShapeMember<'Record>
    abstract member Accept : IWriteMemberVisitor<'Record,'R> -> 'R
  end

Full name: TypeShape.Core.Core.IShapeWriteMember<_>
abstract member IShapeMember.Accept : IMemberVisitor<'DeclaringType,'R> -> 'R
abstract member IShapeWriteMember.Accept : IWriteMemberVisitor<'Record,'R> -> 'R
type IWriteMemberVisitor<'TRecord,'R> =
  interface
    abstract member Visit : ShapeWriteMember<'TRecord,'Field> -> 'R
  end

Full name: TypeShape.Core.Core.IWriteMemberVisitor<_,_>
val m : ShapeWriteMember<'T,'F0>
type ShapeWriteMember<'DeclaringType,'MemberType> =
  inherit ShapeMember<'DeclaringType,'MemberType>
  interface IShapeWriteMember<'DeclaringType>
  private new : label:string * memberInfo:MemberInfo * path:MemberInfo [] -> ShapeWriteMember<'DeclaringType,'MemberType>
  member Inject : instance:'DeclaringType -> field:'MemberType -> 'DeclaringType
  member InjectExpr : instance:Expr<'DeclaringType> -> field:Expr<'MemberType> -> Expr<'DeclaringType>

Full name: TypeShape.Core.Core.ShapeWriteMember<_,_>
val inner : Lens<'F0,'F>
val t : 'T
Lens.get: 'F0 -> 'F
member ShapeMember.Project : instance:'DeclaringType -> 'MemberType
val set : elements:seq<'T> -> Set<'T> (requires comparison)

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.set
val f : 'F
member ShapeWriteMember.Inject : instance:'DeclaringType -> field:'MemberType -> 'DeclaringType
Lens.set: 'F0 -> 'F -> 'F0
val shapeof<'T> : TypeShape

Full name: TypeShape.Core.Core.shapeof
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
val y : 'F
module Shape

from TypeShape.Core.Core
active recognizer FSharpList: TypeShape -> IShapeFSharpList option

Full name: TypeShape.Core.Core.Shape.( |FSharpList|_| )
val s : IShapeFSharpList
val rest : Node list
type IFSharpListVisitor<'R> =
  interface
    abstract member Visit : unit -> 'R
  end

Full name: TypeShape.Core.Core.IFSharpListVisitor<_>
val inner : Lens<'t,'F>
val ts : 't list
Lens.get: 't -> 'F
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member GetSlice : startIndex:int option * endIndex:int option -> 'T list
  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 mapi : mapping:(int -> 'T -> 'U) -> list:'T list -> 'U list

Full name: Microsoft.FSharp.Collections.List.mapi
val j : int
val t : 't
Lens.set: 't -> 'F -> 't
active recognizer FSharpOption: TypeShape -> IShapeFSharpOption option

Full name: TypeShape.Core.Core.Shape.( |FSharpOption|_| )
val s : IShapeFSharpOption
type IFSharpOptionVisitor<'R> =
  interface
    abstract member Visit : unit -> 'R
  end

Full name: TypeShape.Core.Core.IFSharpOptionVisitor<_>
val ts : 't option
type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>
module Option

from Microsoft.FSharp.Core
val get : option:'T option -> 'T

Full name: Microsoft.FSharp.Core.Option.get
active recognizer Tuple: TypeShape -> IShapeTuple option

Full name: TypeShape.Core.Core.Shape.( |Tuple|_| )
type ShapeTuple<'Tuple> =
  interface IShapeTuple
  private new : unit -> ShapeTuple<'Tuple>
  member CreateUninitialized : unit -> 'Tuple
  member CreateUninitializedExpr : unit -> Expr<'Tuple>
  member Elements : IShapeWriteMember<'Tuple> []
  member IsStructTuple : bool

Full name: TypeShape.Core.Core.ShapeTuple<_>
val s : ShapeTuple<'T>
active recognizer Array: TypeShape -> IShapeArray option

Full name: TypeShape.Core.Core.Shape.( |Array|_| )
val s : IShapeArray
type IArrayVisitor<'R> =
  interface
    abstract member Visit : rank:int -> 'R
  end

Full name: TypeShape.Core.Core.IArrayVisitor<_>
val ts : 't []
active recognizer FSharpRecord: TypeShape -> IShapeFSharpRecord option

Full name: TypeShape.Core.Core.Shape.( |FSharpRecord|_| )
type ShapeFSharpRecord<'Record> =
  interface IShapeFSharpRecord
  private new : unit -> ShapeFSharpRecord<'Record>
  member CreateUninitialized : unit -> 'Record
  member CreateUninitializedExpr : unit -> Expr<'Record>
  member Fields : IShapeWriteMember<'Record> []
  member IsStructRecord : bool

Full name: TypeShape.Core.Core.ShapeFSharpRecord<_>
val s : ShapeFSharpRecord<'T>
active recognizer FSharpRef: TypeShape -> IShapeFSharpRef option

Full name: TypeShape.Core.Core.Shape.( |FSharpRef|_| )
Multiple items
union case TypeShapeInfo.Array: element: System.Type * rank: int -> TypeShapeInfo

--------------------
module Array

from Microsoft.FSharp.Collections
val find : predicate:('T -> bool) -> array:'T [] -> 'T

Full name: Microsoft.FSharp.Collections.Array.find
val p : IShapeWriteMember<'T>
property IShapeMember.Label: string
val id : string
val failwithf : format:Printf.StringFormat<'T,'Result> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.failwithf
val typeof<'T> : System.Type

Full name: Microsoft.FSharp.Core.Operators.typeof
val mkLens : expr:Quotations.Expr<(int -> int)> -> Lens<'T,'F>

Full name: Script.mkLens
val expr : Quotations.Expr<(int -> int)>
val path : Impl.Path
module Impl

from Script
val private extractPath : e:Quotations.Expr<('T -> 'F)> -> Impl.Path

Full name: Script.Impl.extractPath
val lens : Lens<'T,'F>
val private mkLensAux : path:Impl.Path -> Lens<'T,'F>

Full name: Script.Impl.mkLensAux
type Foo<'T> =
  {a: 'T;
   b: string;
   c: bool;}

Full name: Script.Foo<_>
Foo.a: 'a
Foo.b: string
Foo.c: bool
type bool = System.Boolean

Full name: Microsoft.FSharp.Core.bool
val l1 : Lens<int,int>

Full name: Script.l1
val x : int
val l2 : Lens<Foo<int> ref,int>

Full name: Script.l2
Multiple items
val ref : value:'T -> 'T ref

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

--------------------
type 'T ref = Ref<'T>

Full name: Microsoft.FSharp.Core.ref<_>
val l3 : Lens<Foo<Foo<int> list> [] list option,Foo<int>>

Full name: Script.l3
Lens.get: int -> int
Lens.get: Foo<int> ref -> int
Lens.get: Foo<Foo<int> list> [] list option -> Foo<int>
Lens.set: int -> int -> int
Lens.set: Foo<int> ref -> int -> Foo<int> ref
Lens.set: Foo<Foo<int> list> [] list option -> Foo<int> -> Foo<Foo<int> list> [] list option
Multiple items
namespace FSharp.Data

--------------------
namespace Microsoft.FSharp.Data
type Bar = CsvProvider<...>

Full name: Script.Bar
type CsvProvider

Full name: FSharp.Data.CsvProvider


<summary>Typed representation of a CSV file.</summary>
       <param name='Sample'>Location of a CSV sample file or a string containing a sample CSV document.</param>
       <param name='Separators'>Column delimiter(s). Defaults to `,`.</param>
       <param name='InferRows'>Number of rows to use for inference. Defaults to `1000`. If this is zero, all rows are used.</param>
       <param name='Schema'>Optional column types, in a comma separated list. Valid types are `int`, `int64`, `bool`, `float`, `decimal`, `date`, `guid`, `string`, `int?`, `int64?`, `bool?`, `float?`, `decimal?`, `date?`, `guid?`, `int option`, `int64 option`, `bool option`, `float option`, `decimal option`, `date option`, `guid option` and `string option`.
       You can also specify a unit and the name of the column like this: `Name (type&lt;unit&gt;)`, or you can override only the name. If you don't want to specify all the columns, you can reference the columns by name like this: `ColumnName=type`.</param>
       <param name='HasHeaders'>Whether the sample contains the names of the columns as its first line.</param>
       <param name='IgnoreErrors'>Whether to ignore rows that have the wrong number of columns or which can't be parsed using the inferred or specified schema. Otherwise an exception is thrown when these rows are encountered.</param>
       <param name='SkipRows'>SKips the first n rows of the CSV file.</param>
       <param name='AssumeMissingValues'>When set to true, the type provider will assume all columns can have missing values, even if in the provided sample all values are present. Defaults to false.</param>
       <param name='PreferOptionals'>When set to true, inference will prefer to use the option type instead of nullable types, `double.NaN` or `""` for missing values. Defaults to false.</param>
       <param name='Quote'>The quotation mark (for surrounding values containing the delimiter). Defaults to `"`.</param>
       <param name='MissingValues'>The set of strings recogized as missing values. Defaults to `NaN,NA,N/A,#N/A,:,-,TBA,TBD`.</param>
       <param name='CacheRows'>Whether the rows should be caches so they can be iterated multiple times. Defaults to true. Disable for large datasets.</param>
       <param name='Culture'>The culture used for parsing numbers and dates. Defaults to the invariant culture.</param>
       <param name='Encoding'>The encoding used to read the sample. You can specify either the character set name or the codepage number. Defaults to UTF8 for files, and to ISO-8859-1 the for HTTP requests, unless `charset` is specified in the `Content-Type` response header.</param>
       <param name='ResolutionFolder'>A directory that is used when resolving relative file references (at design time and in hosted execution).</param>
       <param name='EmbeddedResource'>When specified, the type provider first attempts to load the sample from the specified resource
          (e.g. 'MyCompany.MyAssembly, resource_name.csv'). This is useful when exposing types generated by the type provider.</param>
val l4 : Lens<CsvProvider<...>.Row list,string>

Full name: Script.l4
type Row =
  inherit int * string * float
  new : a: int * b: string * c: float -> Row
  member A : int
  member B : string
  member C : float

Full name: FSharp.Data.CsvProvider,Schema="A (int), B (string), C (float)",HasHeaders="False".Row
val values : CsvProvider<...>.Row list

Full name: Script.values
CsvProvider<...>.Parse(text: string) : CsvProvider<...>


Parses the specified CSV string
module Seq

from Microsoft.FSharp.Collections
val toList : source:seq<'T> -> 'T list

Full name: Microsoft.FSharp.Collections.Seq.toList
Lens.get: CsvProvider<...>.Row list -> string
Lens.set: CsvProvider<...>.Row list -> string -> CsvProvider<...>.Row list

More information

Link:http://fssnip.net/7VY
Posted:5 years ago
Author:Eirik Tsarpalis
Tags: generic programming , lens , typeshape