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

Next Version Raw view Test code New version

More information

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