4 people like it.

WIP: Lenses and Traversals

Work in progress example on lenses and traversals.

 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: 
let inline (^) x = x
let inline flip f y x = f x y

type Fn = class end
type Ap = class inherit Fn end

type C<'c, 'a> = private Over of 'a | View

let (<&>) a2b (aA: C<'c, _>) : C<'c, _> =
  match aA with
   | Over a -> Over ^ a2b a
   | View -> View

let (<*>) (a2bA: C<Ap, _>) (aA: C<Ap, _>) : C<Ap, _> =
  match a2bA, aA with
   | Over a2b, Over a -> Over (a2b a)
   | _, _ -> View

type Optic<'c, 's, 't, 'a, 'b> = ('a -> C<'c, 'b>) -> 's -> C<'c, 't>

let view (o: Optic<Fn, _, _, _, _>) s =
  let r = ref Unchecked.defaultof<_>
  s |> o ^ fun a -> r := a; View
    |> ignore
  !r
let fold (o: Optic<#Fn, _, _, _, _>) a f s =
  let r = ref a
  s |> o ^ fun a -> r := f !r a ; View
    |> ignore
  !r
let over (o: Optic<#Fn, _, _, _, _>) a2b =
  a2b >> Over |> o >> function
   | Over t -> t
   | _ -> failwith "Impossible"
let inline set l b s = s |> over l ^ fun _ -> b

let inline optic s2a b2s2t f s = flip b2s2t s <&> f ^ s2a s
let inline morph s2a b2t   f s = b2t <&> f ^ s2a s

let inline fstO f = f |> optic fst ^ fun x (_, y) -> (x, y)
let inline sndO f = f |> optic snd ^ fun y (x, _) -> (x, y)

let rec listT = fun a2bF -> function
  | x::xs -> (fun x xs -> x::xs) <&> a2bF x <*> listT a2bF xs
  | []    -> Over []

let arrayT f = morph List.ofArray Array.ofList << listT <| f

do (true, [| [1], "Why"; [2;3], "so"; [4;5;6], "serious?" |])
   |> over (sndO << arrayT << fstO << listT) ^ fun x -> 100.0 + 0.1 * float x
   |> printfn "%A"

   (true, [| [1], "Why"; [2;3], "so"; [4;5;6], "serious?" |])
   |> fold (sndO << arrayT << fstO << listT) "" ^ fun s x -> s + string x
   |> printfn "%A"
val x : 'a
val flip : f:('a -> 'b -> 'c) -> y:'b -> x:'a -> 'c

Full name: Script.flip
val f : ('a -> 'b -> 'c)
val y : 'b
type Fn

Full name: Script.Fn
type Ap =
  inherit Fn

Full name: Script.Ap
type C<'c,'a> =
  private | Over of 'a
          | View

Full name: Script.C<_,_>
union case C.Over: 'a -> C<'c,'a>
union case C.View: C<'c,'a>
val a2b : ('a -> 'b)
val aA : C<'c,'a>
val a : 'a
val a2bA : C<Ap,('a -> 'b)>
val aA : C<Ap,'a>
type Optic<'c,'s,'t,'a,'b> = ('a -> C<'c,'b>) -> 's -> C<'c,'t>

Full name: Script.Optic<_,_,_,_,_>
val view : o:Optic<Fn,'a,'b,'c,'d> -> s:'a -> 'c

Full name: Script.view
val o : Optic<Fn,'a,'b,'c,'d>
val s : 'a
val r : 'c ref
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<_>
module Unchecked

from Microsoft.FSharp.Core.Operators
val defaultof<'T> : 'T

Full name: Microsoft.FSharp.Core.Operators.Unchecked.defaultof
val a : 'c
val ignore : value:'T -> unit

Full name: Microsoft.FSharp.Core.Operators.ignore
val fold : o:Optic<#Fn,'b,'c,'d,'e> -> a:'f -> f:('f -> 'd -> 'f) -> s:'b -> 'f

Full name: Script.fold
val o : Optic<#Fn,'b,'c,'d,'e>
val a : 'f
val f : ('f -> 'd -> 'f)
val s : 'b
val r : 'f ref
val a : 'd
val over : o:Optic<#Fn,'b,'c,'d,'e> -> a2b:('d -> 'e) -> ('b -> 'c)

Full name: Script.over
val a2b : ('d -> 'e)
val t : 'c
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
val set : l:Optic<#Fn,'b,'c,'d,'e> -> b:'e -> s:'b -> 'c

Full name: Script.set
val l : Optic<#Fn,'b,'c,'d,'e>
val b : 'e
val optic : s2a:('a -> 'b) -> b2s2t:('c -> 'a -> 'd) -> f:('b -> C<'e,'c>) -> s:'a -> C<'e,'d>

Full name: Script.optic
val s2a : ('a -> 'b)
val b2s2t : ('c -> 'a -> 'd)
val f : ('b -> C<'e,'c>)
val morph : s2a:('a -> 'b) -> b2t:('c -> 'd) -> f:('b -> C<'e,'c>) -> s:'a -> C<'e,'d>

Full name: Script.morph
val b2t : ('c -> 'd)
val fstO : f:('a -> C<'b,'c>) -> ('a * 'd -> C<'b,('c * 'd)>)

Full name: Script.fstO
val f : ('a -> C<'b,'c>)
val fst : tuple:('T1 * 'T2) -> 'T1

Full name: Microsoft.FSharp.Core.Operators.fst
val x : 'c
val y : 'd
val sndO : f:('a -> C<'b,'c>) -> ('d * 'a -> C<'b,('d * 'c)>)

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

Full name: Microsoft.FSharp.Core.Operators.snd
val y : 'c
val x : 'd
val listT : a2bF:('a -> C<Ap,'b>) -> _arg1:'a list -> C<Ap,'b list>

Full name: Script.listT
val a2bF : ('a -> C<Ap,'b>)
val xs : 'a list
val x : 'b
val xs : 'b list
val arrayT : f:('a -> C<Ap,'b>) -> ('a [] -> C<Ap,'b []>)

Full name: Script.arrayT
val f : ('a -> C<Ap,'b>)
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 ofArray : array:'T [] -> 'T list

Full name: Microsoft.FSharp.Collections.List.ofArray
module Array

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

Full name: Microsoft.FSharp.Collections.Array.ofList
val x : int
Multiple items
val float : value:'T -> float (requires member op_Explicit)

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

--------------------
type float = System.Double

Full name: Microsoft.FSharp.Core.float

--------------------
type float<'Measure> = float

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

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn
val s : 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
Raw view Test code New version

More information

Link:http://fssnip.net/7Pn
Posted:7 years ago
Author:Vesa Karvonen
Tags: haskell , lens , traversal