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 rec 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: 
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 }
Lens.get: 'T -> 'F
Lens.set: 'T -> 'F -> 'T
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>
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

More information

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