externalval print :'a->unit="print"let id x = x
let f & g =fun x -> f (g x)let const x _= x
let x |> f = f x
let fst (x,_)= x
let snd (_, x)= x
let uncurry f (x, y)= f x y
let fork f g x =(f x, g x)class profunctor 'pbeginval dimap :forall'a'b'c'd.('b->'a)->('c->'d)->'p'a'c->'p'b'dendlet lmap g = dimap g id
let rmap x = dimap id x
class profunctor 'p=> strong 'pbeginval first :forall'a'b'c.'p'a'b->'p('a*'c)('b*'c)val second :forall'a'b'c.'p'a'b->'p('c*'a)('c*'b)endtypeeither'l'r=Leftof'l|Rightof'rleteither f g =function|Left x -> f x
|Right y -> g y
class profunctor 'p=> choice 'pbeginval left :forall'a'b'c.'p'a'b->'p(either'a'c)(either'b'c)val right :forall'a'b'c.'p'a'b->'p(either'c'a)(either'c'b)endclass monoid 'mbeginval(<>):'m->'m->'mval zero :'mendtype forget 'r'a'b=Forgetof'a->'rlet remember (Forget r)= r
instance profunctor (->)let dimap f g h = g & h & f
instance strong (->)let first f (x, y)=(f x, y)let second f (x, y)=(x, f y)instance choice (->)let left f =either(Left& f)Rightlet right f =eitherLeft(Right& f)instance profunctor (forget 'r)let dimap f _(Forget g)=Forget(g & f)instance monoid 'r=> choice (forget 'r)let left (Forget z)=Forget(either z (const zero))let right (Forget z)=Forget(either(const zero) z)instance strong (forget 'r)let first (Forget z)=Forget(z & fst)let second (Forget z)=Forget(z & snd)let lens get set =
dimap (fork get id)(uncurry set)& first
let view l = remember (l (Forget id))let over f = f
let set l b = over l (const b)type pair 'a'b=Pairof'a*'blet fst' (Pair(x,_))= x
let snd' (Pair(_, x))= x
let first' x = lens fst' (fun x (Pair(_, y))->Pair(x, y)) x
let second' x = lens snd' (fun y (Pair(x,_))->Pair(x, y)) x
type proxy 'a=Proxytype lens 's't'a'b<-forall'p. strong 'p=>'p'a'b->'p's'ttype lens' 's'a<- lens 's's'a'aclassAmc.row_cons 'record'key'type'new=> has_lens 'record'key'type'new|'key'new->'record'typebeginval rlens :forall'p. strong 'p=> proxy 'key->'p'type'type->'p'new'newendinstanceAmc.known_string 'key*Amc.row_cons 'record'key'type'new=> has_lens 'record'key'type'newbeginlet rlens _=let view r =let(x,_)=Amc.restrict_row @'key r
x
let set x r =let(_, r')=Amc.restrict_row @'key r
Amc.extend_row @'key x r'
lens view set
endlet r :forall'key->forall'record'type'new'p.Amc.known_string 'key* has_lens 'record'key'type'new* strong 'p=>'p'type'type->'p'new'new=fun x -> rlens @'record(Proxy: proxy 'key) x
let x :: xs =Cons(x, xs)let lens_list ()=(fun x -> r @"foo" x)::(fun x -> r @"bar" x)::Nil@(lens' __)let map f xs =[ f x |with x <- xs ]let x ={ foo =1, bar =2}let xs = map (`view` x)(lens_list ())