profunctor lenses

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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
Profunctor lenses
=================

First, we enable the RankNTypes extension which gives us 'forall' and also import some modules:

> {-# LANGUAGE RankNTypes #-}
> {-# LANGUAGE ScopedTypeVariables #-}
> module ProfunctorLenses where
> import Data.Profunctor
> import Data.Tagged
> import Data.Bifunctor
> import Data.Void
> import Data.Functor.Compose
> import Control.Arrow hiding (first, second)

Isomorphisms
------------

> type Optic p s t a b = p a b -> p s t

> type Iso s t a b = forall p. Profunctor p => Optic p s t a b

> iso :: (s -> a) -> (b -> t) -> Iso s t a b
> iso = dimap

> view :: Optic (Forget a) s t a b -> s -> a
> view p = runForget $ p (Forget id)

> review :: Optic Tagged s t a b -> b -> t
> review p = unTagged . p . Tagged

> over :: Optic (->) s t a b -> (a -> b) -> (s -> t)
> over = id

> set :: Optic (->) s t a b -> b -> s -> t
> set p = over p . const

Reviews
-------

> type Review s t a b = forall p. (Bifunctor p, Profunctor p) => Optic p s t a b

> coerce :: (Bifunctor p, Profunctor p) => p a x -> p b x
> coerce = first absurd . lmap absurd

Getters
-------

> class Bicontravariant f where
>   contrabimap :: (a -> b) -> (c -> d) -> f b d -> f a c
>   contrabimap f g  = contrafirst f . contrasecond g
>
>   contrafirst :: (a -> b) -> f b x -> f a x
>   contrafirst = flip contrabimap id
>
>   contrasecond :: (c -> d) -> f x d -> f x c
>   contrasecond = contrabimap id

> type Getter s t a b = forall p. (Bicontravariant p, Profunctor p) => Optic p s t a b

> contracoerce :: (Bicontravariant p, Profunctor p) => p x a -> p x b
> contracoerce = rmap absurd . contrasecond absurd

Lenses
------

> type Lens s t a b = forall p. Strong p => Optic p s t a b

> lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
> lens f g = dimap (f &&& id) (uncurry $ flip g) . first'

Prisms
------

> type Prism s t a b = forall p. Choice p => Optic p s t a b

> prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
> prism f g = dimap g (either id f) . right'

Setters
-------

> class Profunctor p => Settable p where
>   mapping :: Functor f => p a b -> p (f a) (f b)
>
> instance Settable (->) where
>   mapping = fmap

> type Setter s t a b = forall p. Settable p => Optic p s t a b

> setting :: forall a b s t. ((a -> b) -> (s -> t)) -> Setter s t a b
> setting f = dimap from to . mapping
>   where from :: s -> Compose ((,) s) ((->) a) a
>         from s = Compose (s, id)
>         to :: Compose ((,) s) ((->) a) b -> t
>         to (Compose (s, modify)) = f modify s

Unoptics
--------

> type UnOptic p s t a b = p t s -> p b a

> data Un p a b s t = Un { runUn :: p t s -> p b a }

> instance Profunctor p => Profunctor (Un p s t) where
>   rmap f (Un p) = Un $ p . lmap f
>   lmap f (Un p) = Un $ p . rmap f
>   dimap f g (Un p) = Un $ p . dimap g f

> class Profunctor p => UnStrong p where
>   unfirst' :: p (a,c) (b,c) -> p a b
>   unsecond' :: p (c,a) (c,b) -> p a b
>
> instance UnStrong Tagged where
>   unfirst' (Tagged a) = Tagged $ fst a
>   unsecond' (Tagged a) = Tagged $ snd a
>

> class Profunctor p => UnChoice p where
>   unleft' :: p (Either a c) (Either b c) -> p a b
>   unright' :: p (Either c a) (Either c b) -> p a b
>
> instance UnChoice (Forget r) where
>   unleft' (Forget f) = Forget $ f . Left
>   unright' (Forget f) = Forget $ f . Right

> un :: Optic (Un p a b) s t a b -> UnOptic p s t a b
> un p = runUn $ p $ Un id

> reset :: Optic (Un (->) a b) s t a b -> s -> b -> a
> reset = set . un

> reover :: Optic (Un (->) a b) s t a b -> (t -> s) -> (b -> a)
> reover = over . un

--------------------------------------------------------------------------------

> _fst :: Lens (a,c) (b,c) a b
> _fst = first'
>
> _snd :: Lens (c,a) (c,b) a b
> _snd = second'
>
> _Right :: Prism (Either c a) (Either c b) a b
> _Right = right'
>
> _Left :: Prism (Either a c) (Either b c) a b
> _Left = left'

>
> class Swapped f where
>   swapped :: Iso (f a b) (f c d) (f b a) (f d c)
>
> instance Swapped Either where
>   swapped = iso (either Right Left) (either Right Left)
>
> instance Swapped (,) where
>   swapped = iso (snd &&& fst) (snd &&& fst)