3 people like it.

Another take on optics

The extra type variables can be packed to obj/unpacked from obj so that the type of Optic would have just the 's, 'a, 'b and 't type variables, but I leave that and other further developments out from this example.

 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: 
type O<'v, 'ui1, 'ui2, 'r, 'a, 'b> =
  | Over  of ('a -> 'b)
  | View  of ('a -> 'v)
  | UnIso of ('a -> 'ui1) * ('ui2 -> 'b)
  | Fold  of ('a -> 'r -> 'r)

type Optic<'v, 'ui1, 'ui2, 'r, 's, 'a, 'b, 't> =
  O<'v, 'ui1, 'ui2, 'r, 'a, 'b> -> O<'v, 'ui1, 'ui2, 'r, 's, 't>

let over o a2b =
  Over a2b |> o |> function
   | Over s2t -> s2t
   | _        -> failwith "over"

let view o =
  View id |> o |> function
   | View s2a -> s2a
   | _        -> failwith "view"

let iso sa bt = function
  | Over ab        -> Over (sa >> ab >> bt)
  | View ao        -> View (sa >> ao)
  | UnIso (au, ub) -> UnIso (sa >> au, ub >> bt)
  | Fold arr       -> Fold (sa >> arr)
let iso' o sa bt = iso sa bt o

let swapI o = iso' o <| fun (a, b) -> (b, a)
                     <| fun (b, a) -> (a, b)

let uniso o =
  UnIso (id, id) |> o |> function
   | UnIso (su, ut) -> (su, ut)
   | _              -> failwith "uniso"

let invert o = uniso o |> fun (sa, bt) -> iso bt sa

let fold o arr =
  Fold arr |> o |> function
   | Fold srr -> srr
   | _        -> failwith "fold"

let lens sa bst = function
  | Over ab  -> Over <| fun s -> bst (ab (sa s)) s
  | View ao  -> View (sa >> ao)
  | UnIso _  -> failwith "lens"
  | Fold arr -> Fold (sa >> arr)
let lens' o sa bst = lens sa bst o

let fstL o = lens' o fst <| fun b (a, c) -> (b, c)
let sndL o = lens' o snd <| fun b (c, a) -> (c, b)

let arrayT = function
  | Over ab  -> Over <| Array.map ab
  | View _   -> failwith "array"
  | UnIso _  -> failwith "array"
  | Fold arr -> Fold <| fun s r -> Array.fold (fun r a -> arr a r) r s

// Examples
let six = fold (arrayT << fstL) (+) [|(3, "a");(1, "b")|] 2
let poly = over (fstL << swapI << fstL) (sprintf "%A") ((1.0, 1), true)
type O<'v,'ui1,'ui2,'r,'a,'b> =
  | Over of ('a -> 'b)
  | View of ('a -> 'v)
  | UnIso of ('a -> 'ui1) * ('ui2 -> 'b)
  | Fold of ('a -> 'r -> 'r)

Full name: Script.O<_,_,_,_,_,_>
union case O.Over: ('a -> 'b) -> O<'v,'ui1,'ui2,'r,'a,'b>
union case O.View: ('a -> 'v) -> O<'v,'ui1,'ui2,'r,'a,'b>
union case O.UnIso: ('a -> 'ui1) * ('ui2 -> 'b) -> O<'v,'ui1,'ui2,'r,'a,'b>
union case O.Fold: ('a -> 'r -> 'r) -> O<'v,'ui1,'ui2,'r,'a,'b>
type Optic<'v,'ui1,'ui2,'r,'s,'a,'b,'t> = O<'v,'ui1,'ui2,'r,'a,'b> -> O<'v,'ui1,'ui2,'r,'s,'t>

Full name: Script.Optic<_,_,_,_,_,_,_,_>
val over : o:(O<'a,'b,'c,'d,'e,'f> -> O<'g,'h,'i,'j,'k,'l>) -> a2b:('e -> 'f) -> ('k -> 'l)

Full name: Script.over
val o : (O<'a,'b,'c,'d,'e,'f> -> O<'g,'h,'i,'j,'k,'l>)
val a2b : ('e -> 'f)
val s2t : ('k -> 'l)
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
val view : o:(O<'a,'b,'c,'d,'a,'e> -> O<'f,'g,'h,'i,'j,'k>) -> ('j -> 'f)

Full name: Script.view
val o : (O<'a,'b,'c,'d,'a,'e> -> O<'f,'g,'h,'i,'j,'k>)
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
val s2a : ('j -> 'f)
val iso : sa:('a -> 'b) -> bt:('c -> 'd) -> _arg1:O<'e,'f,'g,'h,'b,'c> -> O<'e,'f,'g,'h,'a,'d>

Full name: Script.iso
val sa : ('a -> 'b)
val bt : ('c -> 'd)
val ab : ('b -> 'c)
val ao : ('b -> 'e)
val au : ('b -> 'f)
val ub : ('g -> 'c)
val arr : ('b -> 'h -> 'h)
val iso' : o:O<'a,'b,'c,'d,'e,'f> -> sa:('g -> 'e) -> bt:('f -> 'h) -> O<'a,'b,'c,'d,'g,'h>

Full name: Script.iso'
val o : O<'a,'b,'c,'d,'e,'f>
val sa : ('g -> 'e)
val bt : ('f -> 'h)
val swapI : o:O<'a,'b,'c,'d,('e * 'f),('g * 'h)> -> O<'a,'b,'c,'d,('f * 'e),('h * 'g)>

Full name: Script.swapI
val o : O<'a,'b,'c,'d,('e * 'f),('g * 'h)>
val a : 'f
val b : 'e
val b : 'g
val a : 'h
val uniso : o:(O<'a,'b,'c,'d,'b,'c> -> O<'e,'f,'g,'h,'i,'j>) -> ('i -> 'f) * ('g -> 'j)

Full name: Script.uniso
val o : (O<'a,'b,'c,'d,'b,'c> -> O<'e,'f,'g,'h,'i,'j>)
val su : ('i -> 'f)
val ut : ('g -> 'j)
val invert : o:(O<'a,'b,'c,'d,'b,'c> -> O<'e,'f,'g,'h,'i,'j>) -> (O<'k,'l,'m,'n,'j,'i> -> O<'k,'l,'m,'n,'g,'f>)

Full name: Script.invert
val sa : ('i -> 'f)
val bt : ('g -> 'j)
val fold : o:(O<'a,'b,'c,'d,'e,'f> -> O<'g,'h,'i,'j,'k,'l>) -> arr:('e -> 'd -> 'd) -> ('k -> 'j -> 'j)

Full name: Script.fold
val arr : ('e -> 'd -> 'd)
val srr : ('k -> 'j -> 'j)
val lens : sa:('a -> 'b) -> bst:('c -> 'a -> 'd) -> _arg1:O<'e,'f,'g,'h,'b,'c> -> O<'e,'i,'j,'h,'a,'d>

Full name: Script.lens
val bst : ('c -> 'a -> 'd)
val s : 'a
val lens' : o:O<'a,'b,'c,'d,'e,'f> -> sa:('g -> 'e) -> bst:('f -> 'g -> 'h) -> O<'a,'i,'j,'d,'g,'h>

Full name: Script.lens'
val bst : ('f -> 'g -> 'h)
val fstL : o:O<'a,'b,'c,'d,'e,'f> -> O<'a,'g,'h,'d,('e * 'i),('f * 'i)>

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

Full name: Microsoft.FSharp.Core.Operators.fst
val b : 'f
val a : 'e
val c : 'i
val sndL : o:O<'a,'b,'c,'d,'e,'f> -> O<'a,'g,'h,'d,('i * 'e),('i * 'f)>

Full name: Script.sndL
val snd : tuple:('T1 * 'T2) -> 'T2

Full name: Microsoft.FSharp.Core.Operators.snd
val arrayT : _arg1:O<'a,'b,'c,'d,'e,'f> -> O<'g,'h,'i,'d,'e [],'f []>

Full name: Script.arrayT
val ab : ('e -> 'f)
module Array

from Microsoft.FSharp.Collections
val map : mapping:('T -> 'U) -> array:'T [] -> 'U []

Full name: Microsoft.FSharp.Collections.Array.map
val s : 'e []
val r : 'd
val fold : folder:('State -> 'T -> 'State) -> state:'State -> array:'T [] -> 'State

Full name: Microsoft.FSharp.Collections.Array.fold
val six : int

Full name: Script.six
val poly : (float * string) * bool

Full name: Script.poly
val sprintf : format:Printf.StringFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.sprintf
Raw view New version

More information

Link:http://fssnip.net/7Ss
Posted:2 years ago
Author:Vesa Karvonen
Tags: optics