this repo has no description
updates
+758
+159
aoc-2019/AOC19-02.ipynb
+159
aoc-2019/AOC19-02.ipynb
···
1
+
{
2
+
"cells": [
3
+
{
4
+
"cell_type": "code",
5
+
"execution_count": 4,
6
+
"metadata": {},
7
+
"outputs": [],
8
+
"source": [
9
+
":set -XNoImplicitPrelude\n",
10
+
":set -XOverloadedStrings\n",
11
+
":set -XLambdaCase"
12
+
]
13
+
},
14
+
{
15
+
"cell_type": "code",
16
+
"execution_count": 5,
17
+
"metadata": {},
18
+
"outputs": [],
19
+
"source": [
20
+
"import Papa\n",
21
+
"import Control.Monad.State\n",
22
+
"import qualified Prelude as P (read, undefined)\n",
23
+
"import qualified Data.IntMap as IM\n",
24
+
"import Data.Monoid\n"
25
+
]
26
+
},
27
+
{
28
+
"cell_type": "code",
29
+
"execution_count": 23,
30
+
"metadata": {},
31
+
"outputs": [],
32
+
"source": [
33
+
"type Input = [Int]\n",
34
+
"type Output = IM.IntMap Int\n",
35
+
"\n",
36
+
"data ParseResult' a = Halt' Output | Result' Input a | Unknown' deriving (Show)\n",
37
+
"\n",
38
+
"instance Functor ParseResult' where\n",
39
+
" _ `fmap` Halt' a = Halt' a\n",
40
+
" _ `fmap` Unknown' = Unknown'\n",
41
+
" f `fmap` Result' i a = Result' i (f a)\n",
42
+
"\n",
43
+
"isHalt' :: ParseResult' a -> Bool\n",
44
+
"isHalt' (Halt' _) = True\n",
45
+
"isHalt' _ = False\n",
46
+
"\n",
47
+
"isError :: ParseResult' a -> Bool\n",
48
+
"isError Unknown' = True\n",
49
+
"isError _ = False\n",
50
+
"\n",
51
+
"onResult :: ParseResult' a -> \n",
52
+
" (Input -> a -> ParseResult' b) -> \n",
53
+
" ParseResult' b\n",
54
+
"onResult Unknown' _ = Unknown'\n",
55
+
"onResult (Halt' i) _ = Halt' i\n",
56
+
"onResult (Result' i a) k = k i a\n",
57
+
"\n",
58
+
"onHalt :: ParseResult' a -> Maybe Output\n",
59
+
"onHalt (Halt' i) = Just i\n",
60
+
"onHalt _ = Nothing\n",
61
+
"\n",
62
+
"newtype Parser' a = Parser' (Input -> ParseResult' a) \n",
63
+
"\n",
64
+
"parse' :: Parser' a -> Input -> ParseResult' a\n",
65
+
"parse' (Parser' p) = p\n",
66
+
"\n",
67
+
"instance Functor Parser' where\n",
68
+
" f `fmap` (Parser' p) = Parser' (fmap f . p )\n",
69
+
"\n",
70
+
"instance Applicative Parser' where\n",
71
+
" pure a = Parser' (`Result'` a) -- valueParser\n",
72
+
" \n",
73
+
" (Parser' f) <*> (Parser' p) = Parser' (\\i -> case p i of\n",
74
+
" Halt' a -> Halt' a\n",
75
+
" Unknown' -> Unknown'\n",
76
+
" Result' j a -> (\\g -> g a) <$> f j)\n",
77
+
" \n",
78
+
"instance Monad Parser' where\n",
79
+
" (Parser' p) >>= f = Parser' (\\i ->\n",
80
+
" onResult (p i) (\\j a -> parse' (f a) j))\n",
81
+
" \n",
82
+
"\n",
83
+
"\n",
84
+
"addParser :: Parser' Output\n",
85
+
"addParser = Parser' (\n",
86
+
" \\case\n",
87
+
" l@(o : a : b : c : xs) | o == 1 -> \n",
88
+
" let v = IM.fromList $ itoList l\n",
89
+
" in\n",
90
+
" Result' xs $ \n",
91
+
" maybe \n",
92
+
" v\n",
93
+
" ((`IM.union` v) . IM.singleton c) \n",
94
+
" (liftA2 (liftA2 (+)) (!! a) (!! b) l)\n",
95
+
" _ -> Unknown')\n",
96
+
" \n",
97
+
" \n",
98
+
"prodParser :: Parser' Output\n",
99
+
"prodParser = Parser' (\n",
100
+
" \\case \n",
101
+
" l@(o : a : b : c : xs) | o == 2 -> \n",
102
+
" let v = IM.fromList $ itoList l\n",
103
+
" in\n",
104
+
" Result' xs $ \n",
105
+
" maybe \n",
106
+
" v \n",
107
+
" ((`IM.union` v) . IM.singleton c) \n",
108
+
" (liftA2 (liftA2 (*)) (!! a) (!! b) l) \n",
109
+
" _ -> Unknown')\n",
110
+
" \n",
111
+
"haltParser :: Parser' Output\n",
112
+
"haltParser = Parser' (\n",
113
+
" \\case\n",
114
+
" l@(o : _) | o == 99 -> Halt' (IM.fromList $ itoList l)\n",
115
+
" _ -> Unknown')\n",
116
+
" \n",
117
+
"\n",
118
+
"(|||) :: Parser' a -> Parser' a -> Parser' a\n",
119
+
"(Parser' p1) ||| (Parser' p2) = Parser' (\\i -> let v = p1 i in bool v (p2 i) (isError v))\n",
120
+
" "
121
+
]
122
+
},
123
+
{
124
+
"cell_type": "code",
125
+
"execution_count": null,
126
+
"metadata": {},
127
+
"outputs": [
128
+
{
129
+
"data": {
130
+
"text/plain": [
131
+
"Result' [5,99] (fromList [(0,2),(1,2),(2,3),(3,4),(4,12),(5,99)])"
132
+
]
133
+
},
134
+
"metadata": {},
135
+
"output_type": "display_data"
136
+
}
137
+
],
138
+
"source": [
139
+
"parse' (addParser ||| prodParser ||| haltParser) [2,2,3,4,5,99]"
140
+
]
141
+
}
142
+
],
143
+
"metadata": {
144
+
"kernelspec": {
145
+
"display_name": "Haskell",
146
+
"language": "haskell",
147
+
"name": "haskell"
148
+
},
149
+
"language_info": {
150
+
"codemirror_mode": "ihaskell",
151
+
"file_extension": ".hs",
152
+
"name": "haskell",
153
+
"pygments_lexer": "Haskell",
154
+
"version": "8.6.5"
155
+
}
156
+
},
157
+
"nbformat": 4,
158
+
"nbformat_minor": 2
159
+
}
+11
aoc-2019/default.nix
+11
aoc-2019/default.nix
logical-equivalences-in-haskell.ipynb
logical-equivalences/logical-equivalences-in-haskell.ipynb
logical-equivalences-in-haskell.ipynb
logical-equivalences/logical-equivalences-in-haskell.ipynb
+6
logical-equivalences/default.nix
+6
logical-equivalences/default.nix
+582
logical-equivalences/profunctors.ipynb
+582
logical-equivalences/profunctors.ipynb
···
1
+
{
2
+
"cells": [
3
+
{
4
+
"cell_type": "code",
5
+
"execution_count": 1,
6
+
"metadata": {},
7
+
"outputs": [],
8
+
"source": [
9
+
":set -XRankNTypes\n",
10
+
":set -XTypeOperators\n",
11
+
":set -XKindSignatures\n",
12
+
":set -XInstanceSigs\n",
13
+
":set -XLambdaCase"
14
+
]
15
+
},
16
+
{
17
+
"cell_type": "code",
18
+
"execution_count": 2,
19
+
"metadata": {},
20
+
"outputs": [],
21
+
"source": [
22
+
"f :: a -> b\n",
23
+
"f = undefined"
24
+
]
25
+
},
26
+
{
27
+
"cell_type": "code",
28
+
"execution_count": 3,
29
+
"metadata": {},
30
+
"outputs": [],
31
+
"source": [
32
+
"type P = (->)"
33
+
]
34
+
},
35
+
{
36
+
"cell_type": "code",
37
+
"execution_count": 4,
38
+
"metadata": {},
39
+
"outputs": [],
40
+
"source": [
41
+
"\n",
42
+
"\n",
43
+
"f' :: a `P` b\n",
44
+
"f' = undefined\n",
45
+
"\n",
46
+
"f'' :: P a b\n",
47
+
"f'' = undefined\n",
48
+
"\n",
49
+
"generateA :: i -> a\n",
50
+
"generateA = undefined\n",
51
+
"\n",
52
+
"useB :: b -> o\n",
53
+
"useB = undefined\n",
54
+
"\n",
55
+
"f''' :: (i -> a) -> (b -> o) -> P a b -> P i o\n",
56
+
"f''' g u f = u . f . g\n",
57
+
"\n",
58
+
"class Profunctor (p :: * -> * -> *) where\n",
59
+
" dimap :: (i -> a) -> (b -> o) -> p a b -> p i o \n",
60
+
" \n",
61
+
"instance Profunctor (->) where\n",
62
+
" dimap g u f = u . f . g\n",
63
+
"\n"
64
+
]
65
+
},
66
+
{
67
+
"cell_type": "markdown",
68
+
"metadata": {},
69
+
"source": [
70
+
"So how to get a `Functor` be a `Profunctor`. For that we need a new data type that somehow talks about `Functor f`, the type contained within `f` i.e `a`, and the other type which is required for `Profunctor` i.e. `b`. Let's call it `Star` (we will get to the reason later)"
71
+
]
72
+
},
73
+
{
74
+
"cell_type": "code",
75
+
"execution_count": 5,
76
+
"metadata": {},
77
+
"outputs": [],
78
+
"source": [
79
+
"\n",
80
+
"-- if you look closely, a here is in covariant position and b in contra\n",
81
+
"newtype Star f a b = Star {runStar :: a -> f b} \n",
82
+
"\n",
83
+
"-- now lets lift the Functor \n",
84
+
"instance Functor f => Profunctor (Star f) where\n",
85
+
" dimap :: (i -> a) -> (b -> o) -> Star f a b -> Star f i o\n",
86
+
" dimap f g s = Star (fmap g . runStar s . f)"
87
+
]
88
+
},
89
+
{
90
+
"cell_type": "markdown",
91
+
"metadata": {},
92
+
"source": [
93
+
"So `Star` is another `Profunctor` like `(->)`. Let's just see one more. Like `Star` which uses all three type variables `f`, `a`, and `b`, this one will take 3 but use only 2 in a way that will enable us to make a `Profunctor` out of it. Since it forgets a type in its implementation, we will call it `Forget`"
94
+
]
95
+
},
96
+
{
97
+
"cell_type": "code",
98
+
"execution_count": 6,
99
+
"metadata": {},
100
+
"outputs": [],
101
+
"source": [
102
+
"newtype Forget f a b = Forget {runForget :: a -> f} -- again, a here is covariant, f is contravariant, and b is forgotten\n",
103
+
"\n",
104
+
"-- hence for it to be a Profunctor we don't need the Functor constraint like Star\n",
105
+
"instance Profunctor (Forget f) where\n",
106
+
" dimap :: (i -> a) -> (b -> o) -> Forget f a b -> Forget f i o\n",
107
+
" dimap f _ fo = Forget (runForget fo . f)\n"
108
+
]
109
+
},
110
+
{
111
+
"cell_type": "markdown",
112
+
"metadata": {},
113
+
"source": [
114
+
"As `functors` provide ways to map objects of a container (read a data structure), `natural transformations` provide ways to map `functors` i.e `type Natural f g = forall a. f a -> g a`. Of course, `natural transformations` need to adhere to some laws. For `profunctors`, `natural transformations` happen in couple of ways (one loose way to reason it is as profunctors deal with 2 type parameters)."
115
+
]
116
+
},
117
+
{
118
+
"cell_type": "markdown",
119
+
"metadata": {},
120
+
"source": [
121
+
"**First**, is when both type parameters are lifted to a `product` type i.e. `p a b |-> p (a, c) (b, c)` or `p a b |-> p (c, a) (c, b)`. Here, the type parameter `c` can be considered to be providing additional information as a result of the transformation. It's encoded in a type class named `Strong`."
122
+
]
123
+
},
124
+
{
125
+
"cell_type": "code",
126
+
"execution_count": 7,
127
+
"metadata": {},
128
+
"outputs": [],
129
+
"source": [
130
+
"class Profunctor p => Strong p where\n",
131
+
" first' :: p a b -> p (a, c) (b, c)\n",
132
+
" second' :: p a b -> p (c, a) (c, b)\n",
133
+
" \n",
134
+
"-- let's lift (->) to be a Strong one\n",
135
+
"instance Strong (->) where\n",
136
+
" first' f = \\(a, c) -> (f a, c)\n",
137
+
" second' f = \\(c, a) -> (c, f a)\n",
138
+
" \n",
139
+
"-- let's lift Star to be a Strong one\n",
140
+
"instance Functor f => Strong (Star f) where\n",
141
+
" first' :: Star f a b -> Star f (a, c) (b, c)\n",
142
+
" first' s = Star (\\(a, c) -> fmap (\\b -> (b, c)) $ runStar s a)\n",
143
+
" \n",
144
+
" second' :: Star f a b -> Star f (c, a) (c, b)\n",
145
+
" second' s = Star (\\(c, a) -> fmap (\\b -> (c, b)) $ runStar s a)\n",
146
+
" \n",
147
+
"-- simillarly, let's lift Forget to be a Strong one\n",
148
+
"instance Strong (Forget f) where\n",
149
+
" first' fo = Forget (runForget fo . fst)\n",
150
+
" second' fo = Forget (runForget fo . snd)"
151
+
]
152
+
},
153
+
{
154
+
"cell_type": "markdown",
155
+
"metadata": {},
156
+
"source": [
157
+
"__Second__, when both type parameters are lifted to a `sum` type i.e. `p a b -> p (Either a c) (Either b c)` or `p a b -> p (Either c a) (Either c b)`. Here the type parameter `c` can be considered to be `maybe` providing additional information. It's encoded in a type class named `Choice`"
158
+
]
159
+
},
160
+
{
161
+
"cell_type": "code",
162
+
"execution_count": 8,
163
+
"metadata": {},
164
+
"outputs": [],
165
+
"source": [
166
+
"\n",
167
+
"class Profunctor p => Choice p where\n",
168
+
" left' :: p a b -> p (Either a c) (Either b c)\n",
169
+
" right' :: p a b -> p (Either c a) (Either c b)\n",
170
+
" \n",
171
+
"instance Choice (->) where\n",
172
+
" left' f (Left a) = Left (f a)\n",
173
+
" left' _ (Right c) = Right c\n",
174
+
" \n",
175
+
" right' = fmap\n",
176
+
" \n",
177
+
"-- we need Applicative constraint to lift Right\n",
178
+
"instance Applicative f => Choice (Star f) where\n",
179
+
" left' (Star s) = Star $ either (fmap Left . s) (pure . Right)\n",
180
+
" \n",
181
+
" right' (Star s) = Star $ either (pure . Left) (fmap Right . s)\n",
182
+
" \n",
183
+
"-- we need Monoid constraint to get mempty for the forgotten case\n",
184
+
"instance Monoid fo => Choice (Forget fo) where\n",
185
+
" left' (Forget fo) = Forget $ either fo (const mempty)\n",
186
+
" \n",
187
+
" right' (Forget fo) = Forget $ either (const mempty) fo"
188
+
]
189
+
},
190
+
{
191
+
"cell_type": "markdown",
192
+
"metadata": {},
193
+
"source": [
194
+
"`Strong` and `Choice` above are also seen as refinements of `Profunctor` which concerns its interaction with sum and product types."
195
+
]
196
+
},
197
+
{
198
+
"cell_type": "raw",
199
+
"metadata": {},
200
+
"source": [
201
+
"There is a **third** refinement of `Profunctor`s that concerns with composition (esp. parallel composition) of individual `Profunctor`s. It's encoded in a type class named `Monoidal`. The name is such as the operations of the `Monoidal` type class satisfy laws that make them isomorphic with monoids on the value types."
202
+
]
203
+
},
204
+
{
205
+
"cell_type": "code",
206
+
"execution_count": 9,
207
+
"metadata": {},
208
+
"outputs": [],
209
+
"source": [
210
+
"cross :: (a -> c) -> (b -> d) -> (a , b) -> (c, d)\n",
211
+
"cross f g (a, c) = (f a, g c)\n",
212
+
"\n",
213
+
"class Profunctor p => Monoidal p where\n",
214
+
" par :: p a b -> p c d -> p (a,c) (b,d)\n",
215
+
" empty :: p () ()\n",
216
+
" \n",
217
+
"instance Monoidal (->) where\n",
218
+
" empty = id\n",
219
+
" par = cross\n",
220
+
" \n",
221
+
"instance Applicative f => Monoidal (Star f) where\n",
222
+
" empty = Star pure\n",
223
+
" par (Star f) (Star g) = Star (\\(a,c) -> (,) <$> f a <*> g c)\n",
224
+
" \n",
225
+
"instance Monoid f => Monoidal (Forget f) where\n",
226
+
" empty = Forget (const mempty)\n",
227
+
" par (Forget f) (Forget g) = Forget (\\(a,c) -> f a <> g c)"
228
+
]
229
+
},
230
+
{
231
+
"cell_type": "markdown",
232
+
"metadata": {},
233
+
"source": [
234
+
"#### Profunctor Optics"
235
+
]
236
+
},
237
+
{
238
+
"cell_type": "code",
239
+
"execution_count": 10,
240
+
"metadata": {},
241
+
"outputs": [],
242
+
"source": [
243
+
"type Optic p a b s t = p a b -> p s t"
244
+
]
245
+
},
246
+
{
247
+
"cell_type": "markdown",
248
+
"metadata": {},
249
+
"source": [
250
+
"Profunctor Optics : Modular Data Accessors. Matthew Pickering, Jeremy Gibbons, and Nicolas Wua\n",
251
+
"\n",
252
+
"> When `S` is a composite type with some component of type `A`, and `T` similarly a composite type in which that component has type `B`, and `P` is some notion of `transformer`, then we can think of a data accessor of type `Optic P A B S T` as lifting a component transformer of type `P A B` to a whole-structure transformer of type `P S T`. We will retrieve equivalents of our original definitions of lens, prism, and so on by placing various constraints on `P`"
253
+
]
254
+
},
255
+
{
256
+
"cell_type": "markdown",
257
+
"metadata": {},
258
+
"source": [
259
+
"**Adapters**\n",
260
+
"\n",
261
+
"Adapters are the concrete representation of optics in which the things which is viewed or matched is the whole structure. hence it just need to pair of functions i.e. one for view/match `S -> A` and one for update/build `B -> T`"
262
+
]
263
+
},
264
+
{
265
+
"cell_type": "code",
266
+
"execution_count": 11,
267
+
"metadata": {},
268
+
"outputs": [],
269
+
"source": [
270
+
"\n",
271
+
"\n",
272
+
"data Adapter a b s t = Adapter {from :: s -> a, to :: b -> t}\n",
273
+
"-- profunctor constraint to note that polymorphically the notion of an abstracter is simply a function from `P A B` to `P S T`\n",
274
+
"type AdapterP a b s t = forall p. Profunctor p => Optic p a b s t"
275
+
]
276
+
},
277
+
{
278
+
"cell_type": "markdown",
279
+
"metadata": {},
280
+
"source": [
281
+
"Establishing isomorphism between `Adapter` and `AdapterP`"
282
+
]
283
+
},
284
+
{
285
+
"cell_type": "code",
286
+
"execution_count": 12,
287
+
"metadata": {},
288
+
"outputs": [],
289
+
"source": [
290
+
"-- the type is equivalent to\n",
291
+
"-- Profunctor p => Adapter a b s t -> p a b -> p s t\n",
292
+
"adapterC2P :: Adapter a b s t -> AdapterP a b s t\n",
293
+
"adapterC2P (Adapter f t) = dimap f t\n",
294
+
"\n",
295
+
"instance Profunctor (Adapter a b) where\n",
296
+
" dimap :: (i -> c) -> (d -> o) -> Adapter a b c d -> Adapter a b i o\n",
297
+
" dimap f g (Adapter r s) = Adapter (r . f) (g . s)\n",
298
+
"\n",
299
+
"-- the type is equivalent to\n",
300
+
"-- Profunctor p q => p a b -> p s t -> Adapter a b s t\n",
301
+
"adapterP2C :: AdapterP a b s t -> Adapter a b s t\n",
302
+
"adapterP2C f = f (Adapter id id)"
303
+
]
304
+
},
305
+
{
306
+
"cell_type": "markdown",
307
+
"metadata": {},
308
+
"source": [
309
+
"**Lens**\n",
310
+
"\n",
311
+
"Lenses provide ways to\n",
312
+
"\n",
313
+
"- _view_ the contained type `A` inside the container type `S` and \n",
314
+
"- _update_ the container type `S` to a container type `T` having elements of contained type `B`\n"
315
+
]
316
+
},
317
+
{
318
+
"cell_type": "code",
319
+
"execution_count": 13,
320
+
"metadata": {},
321
+
"outputs": [],
322
+
"source": [
323
+
"data Lens a b s t = Lens {view :: s -> a, update :: (b, s) -> t}\n",
324
+
"\n",
325
+
"-- Strong profunctors produce the notion of lenses as there is product type involved here\n",
326
+
"type LensP a b s t = forall p. Strong p => Optic p a b s t"
327
+
]
328
+
},
329
+
{
330
+
"cell_type": "markdown",
331
+
"metadata": {},
332
+
"source": [
333
+
"Establishing isomorphism between `Lens` and `LensP`"
334
+
]
335
+
},
336
+
{
337
+
"cell_type": "code",
338
+
"execution_count": 14,
339
+
"metadata": {},
340
+
"outputs": [],
341
+
"source": [
342
+
"lensC2P :: Lens a b s t -> LensP a b s t\n",
343
+
"lensC2P (Lens v u) = dimap (\\s -> (v s, s)) u . first'\n",
344
+
"\n",
345
+
"instance Profunctor (Lens a b) where\n",
346
+
" dimap :: (i -> c) -> (d -> o) -> Lens a b c d -> Lens a b i o\n",
347
+
" dimap f g (Lens v u) = Lens (v . f) (\\(b,i) -> g $ u (b, f i))\n",
348
+
"\n",
349
+
"instance Strong (Lens a b) where\n",
350
+
" first' :: Lens a b c d -> Lens a b (c, e) (d, e)\n",
351
+
" first' (Lens v u) = Lens (v . fst) (\\(b, (c, e)) -> (u (b, c), e))\n",
352
+
" \n",
353
+
" second' :: Lens a b c d -> Lens a b (e, c) (e, d)\n",
354
+
" second' (Lens v u) = Lens (v . snd) (\\(b, (e, c)) -> (e, u (b, c)))\n",
355
+
"\n",
356
+
"lensP2C :: LensP a b s t -> Lens a b s t\n",
357
+
"lensP2C f = f (Lens id fst)"
358
+
]
359
+
},
360
+
{
361
+
"cell_type": "markdown",
362
+
"metadata": {},
363
+
"source": [
364
+
"**Prisms**\n",
365
+
"\n",
366
+
"Prisms provide ways to\n",
367
+
" - _match_ the probable contained type `A` (and may be transform it to `B`) inside the compound type `S` (if no match then it reverts to `S` or may be transform to `T`) and \n",
368
+
" - _build_ the compound type `T` from one of the contained types `B`\n"
369
+
]
370
+
},
371
+
{
372
+
"cell_type": "code",
373
+
"execution_count": 15,
374
+
"metadata": {},
375
+
"outputs": [],
376
+
"source": [
377
+
"data Prism a b s t = Prism {match :: s -> Either t a, build :: b -> t}\n",
378
+
"\n",
379
+
"-- Choice profunctors produce the notion of prisms as there is sum type involved here\n",
380
+
"type PrismP a b s t = forall p. Choice p => Optic p a b s t"
381
+
]
382
+
},
383
+
{
384
+
"cell_type": "markdown",
385
+
"metadata": {},
386
+
"source": [
387
+
"Establishing isomorphism between `Prism` and `PrismP`"
388
+
]
389
+
},
390
+
{
391
+
"cell_type": "code",
392
+
"execution_count": 16,
393
+
"metadata": {},
394
+
"outputs": [],
395
+
"source": [
396
+
"prismC2P :: Prism a b s t -> PrismP a b s t\n",
397
+
"prismC2P (Prism m b) = dimap m (either id b) . right'\n",
398
+
"\n",
399
+
"instance Profunctor (Prism a b) where\n",
400
+
" dimap :: (i -> c) -> (d -> o) -> Prism a b c d -> Prism a b i o\n",
401
+
" dimap f g (Prism m b) = Prism (either (Left . g) (Right) . m . f) (g . b)\n",
402
+
" \n",
403
+
"instance Choice (Prism a b) where\n",
404
+
" left' :: Prism a b c d -> Prism a b (Either c e) (Either d e)\n",
405
+
" left' (Prism m b) = Prism (either (either (Left . Left) Right . m) (Left . Right))\n",
406
+
" (Left . b)\n",
407
+
" \n",
408
+
" right' :: Prism a b c d -> Prism a b (Either e c) (Either e d)\n",
409
+
" right' (Prism m b) = Prism (either (Left . Left) (either (Left . Right) Right . m))\n",
410
+
" (Right . b)\n",
411
+
"\n",
412
+
"prismP2C :: PrismP a b s t -> Prism a b s t\n",
413
+
"prismP2C f = f (Prism Right id)"
414
+
]
415
+
},
416
+
{
417
+
"cell_type": "markdown",
418
+
"metadata": {},
419
+
"source": [
420
+
"**Traversals**\n",
421
+
"\n",
422
+
"- traversal datatype is a container with finite number of elements having an ordering. It can be _traversed_ whereby each element is visited in the given order\n",
423
+
"\n",
424
+
"- a container type `S` with elements of type `A` is a _traversal_ when there exists types `B`, `T`, and a traversal function of type `(A -> F B) -> (S -> F T)` for each applicative functor `F` (additionally satisfying some traversal laws)\n",
425
+
"\n",
426
+
"- as a **generalisation of lenses and prisms**, traversals provides access not just to a single component within a whole structure but onto an entire sequence of such components\n",
427
+
"\n",
428
+
"- traversal type `S` is equivalent to `∃n. A^n x (B^n -> T)`, where `n` is the number of elements in `S`. This tupling represents both yielding of sequence of elements inside container in the order mentioned and also replacing the container with a sequence of new elements\n",
429
+
"\n",
430
+
"- above equivalence can be captured as a datatype"
431
+
]
432
+
},
433
+
{
434
+
"cell_type": "code",
435
+
"execution_count": 17,
436
+
"metadata": {},
437
+
"outputs": [],
438
+
"source": [
439
+
"data FunList a b t = Done t | More a (FunList a b (b -> t))\n",
440
+
"\n",
441
+
"instance Functor (FunList a b) where\n",
442
+
" fmap f (Done t) = Done $ f t\n",
443
+
" fmap f (More x l) = More x (fmap (f .) l)\n",
444
+
" \n",
445
+
"instance Applicative (FunList a b) where\n",
446
+
" pure = Done\n",
447
+
" Done f <*> f' = fmap f f'\n",
448
+
" More x l <*> f' = More x (flip <$> l <*> f')"
449
+
]
450
+
},
451
+
{
452
+
"cell_type": "markdown",
453
+
"metadata": {},
454
+
"source": [
455
+
"This datatype also is isomorphic to `Either T (A , FunList A B (B -> T))`"
456
+
]
457
+
},
458
+
{
459
+
"cell_type": "code",
460
+
"execution_count": 18,
461
+
"metadata": {},
462
+
"outputs": [],
463
+
"source": [
464
+
"out :: FunList a b t -> Either t (a, FunList a b (b -> t))\n",
465
+
"out (Done t) = Left t\n",
466
+
"out (More a l) = Right (a, l)\n",
467
+
"\n",
468
+
"inn :: Either t (a, FunList a b (b -> t)) -> FunList a b t\n",
469
+
"inn = either Done (\\(a,l) -> More a l)"
470
+
]
471
+
},
472
+
{
473
+
"cell_type": "markdown",
474
+
"metadata": {},
475
+
"source": [
476
+
"Based on the above isomorphism, it can be proved that traversal function of type `(A -> F B) -> (S -> F T)` for each applicative functor `F` yields an isomorphism `S ≍ FunList A B T`\n",
477
+
"\n",
478
+
"The definition of concrete traversal then is"
479
+
]
480
+
},
481
+
{
482
+
"cell_type": "code",
483
+
"execution_count": 22,
484
+
"metadata": {},
485
+
"outputs": [],
486
+
"source": [
487
+
"newtype Traversal a b s t = Traversal {extract::s -> FunList a b t}\n",
488
+
"\n",
489
+
"-- traversal being the generalisation, we need all notions of sum, product, and empty\n",
490
+
"type TraversalP a b s t = forall p. (Strong p, Choice p, Monoidal p) => Optic p a b s t"
491
+
]
492
+
},
493
+
{
494
+
"cell_type": "markdown",
495
+
"metadata": {},
496
+
"source": [
497
+
"To establish the isomorphism we need a notion of `traverse` that lifts a transformation of `A`s to `B`s to act on each of the elements of `FunList`"
498
+
]
499
+
},
500
+
{
501
+
"cell_type": "code",
502
+
"execution_count": 27,
503
+
"metadata": {},
504
+
"outputs": [],
505
+
"source": [
506
+
"traverse :: (Choice p, Monoidal p) => p a b -> p (FunList a c t) (FunList b c t)\n",
507
+
"traverse k = dimap out inn (right' $ par k $ traverse k)"
508
+
]
509
+
},
510
+
{
511
+
"cell_type": "code",
512
+
"execution_count": 52,
513
+
"metadata": {},
514
+
"outputs": [],
515
+
"source": [
516
+
"fuse :: FunList b b t -> t\n",
517
+
"fuse (Done t) = t\n",
518
+
"fuse (More x l) = fuse l x\n",
519
+
"\n",
520
+
"single :: a -> FunList a b b\n",
521
+
"single x = More x (Done id)\n",
522
+
"\n",
523
+
"traversalC2P :: Traversal a b s t -> TraversalP a b s t\n",
524
+
"traversalC2P (Traversal f) p = dimap f fuse (traverse p)\n",
525
+
"\n",
526
+
"instance Profunctor (Traversal a b) where\n",
527
+
" dimap :: (i -> c) -> (d -> o) -> Traversal a b c d -> Traversal a b i o\n",
528
+
" dimap f g (Traversal h) = Traversal (fmap g . h . f)\n",
529
+
"\n",
530
+
"instance Strong (Traversal a b) where\n",
531
+
" first' :: Traversal a b c d -> Traversal a b (c, e) (d, e)\n",
532
+
" first' (Traversal s) = Traversal (\\(c,e) -> (,) <$> s c <*> pure e)\n",
533
+
" \n",
534
+
" second' :: Traversal a b c d -> Traversal a b (e, c) (e, d)\n",
535
+
" second' (Traversal s) = Traversal (\\(e, c) -> (,) <$> pure e <*> s c) \n",
536
+
" \n",
537
+
"instance Choice (Traversal a b) where\n",
538
+
" left' :: Traversal a b c d -> Traversal a b (Either c e) (Either d e)\n",
539
+
" left' (Traversal s) = Traversal (either (fmap Left . s) (fmap Right . pure))\n",
540
+
" \n",
541
+
" right' :: Traversal a b c d -> Traversal a b (Either e c) (Either e d)\n",
542
+
" right' (Traversal s) = Traversal (either (fmap Left . pure) (fmap Right . s))\n",
543
+
" \n",
544
+
"instance Monoidal (Traversal a b) where\n",
545
+
" empty :: Traversal a b () ()\n",
546
+
" empty = Traversal pure\n",
547
+
" \n",
548
+
" par :: Traversal a b c d -> Traversal a b e f -> Traversal a b (c, e) (d, f)\n",
549
+
" par (Traversal s) (Traversal t) = Traversal (\\(c,e) -> (,) <$> s c <*> t e)\n",
550
+
"\n",
551
+
"traversalP2C :: TraversalP a b s t -> Traversal a b s t\n",
552
+
"traversalP2C f = f $ Traversal single"
553
+
]
554
+
},
555
+
{
556
+
"cell_type": "code",
557
+
"execution_count": 54,
558
+
"metadata": {},
559
+
"outputs": [],
560
+
"source": [
561
+
"traverseOf :: TraversalP a b s t -> (forall f. Applicative f => (a -> f b) -> (s -> f t))\n",
562
+
"traverseOf p f = runStar $ p $ Star f "
563
+
]
564
+
}
565
+
],
566
+
"metadata": {
567
+
"kernelspec": {
568
+
"display_name": "Haskell",
569
+
"language": "haskell",
570
+
"name": "haskell"
571
+
},
572
+
"language_info": {
573
+
"codemirror_mode": "ihaskell",
574
+
"file_extension": ".hs",
575
+
"name": "haskell",
576
+
"pygments_lexer": "Haskell",
577
+
"version": "8.4.4"
578
+
}
579
+
},
580
+
"nbformat": 4,
581
+
"nbformat_minor": 2
582
+
}