profunctor lenses

bennofs 2014-04-29 19:09:10.623314 UTC

1Profunctor lenses
2=================
3
4First, we enable the RankNTypes extension which gives us 'forall' and also import some modules:
5
6> {-# LANGUAGE RankNTypes #-}
7> {-# LANGUAGE ScopedTypeVariables #-}
8> module ProfunctorLenses where
9> import Data.Profunctor
10> import Data.Tagged
11> import Data.Bifunctor
12> import Data.Void
13> import Data.Functor.Compose
14> import Control.Arrow hiding (first, second)
15
16Isomorphisms
17------------
18
19> type Optic p s t a b = p a b -> p s t
20
21> type Iso s t a b = forall p. Profunctor p => Optic p s t a b
22
23> iso :: (s -> a) -> (b -> t) -> Iso s t a b
24> iso = dimap
25
26> view :: Optic (Forget a) s t a b -> s -> a
27> view p = runForget $ p (Forget id)
28
29> review :: Optic Tagged s t a b -> b -> t
30> review p = unTagged . p . Tagged
31
32> over :: Optic (->) s t a b -> (a -> b) -> (s -> t)
33> over = id
34
35> set :: Optic (->) s t a b -> b -> s -> t
36> set p = over p . const
37
38Reviews
39-------
40
41> type Review s t a b = forall p. (Bifunctor p, Profunctor p) => Optic p s t a b
42
43> coerce :: (Bifunctor p, Profunctor p) => p a x -> p b x
44> coerce = first absurd . lmap absurd
45
46Getters
47-------
48
49> class Bicontravariant f where
50> contrabimap :: (a -> b) -> (c -> d) -> f b d -> f a c
51> contrabimap f g = contrafirst f . contrasecond g
52>
53> contrafirst :: (a -> b) -> f b x -> f a x
54> contrafirst = flip contrabimap id
55>
56> contrasecond :: (c -> d) -> f x d -> f x c
57> contrasecond = contrabimap id
58
59> type Getter s t a b = forall p. (Bicontravariant p, Profunctor p) => Optic p s t a b
60
61> contracoerce :: (Bicontravariant p, Profunctor p) => p x a -> p x b
62> contracoerce = rmap absurd . contrasecond absurd
63
64Lenses
65------
66
67> type Lens s t a b = forall p. Strong p => Optic p s t a b
68
69> lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
70> lens f g = dimap (f &&& id) (uncurry $ flip g) . first'
71
72Prisms
73------
74
75> type Prism s t a b = forall p. Choice p => Optic p s t a b
76
77> prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
78> prism f g = dimap g (either id f) . right'
79
80Setters
81-------
82
83> class Profunctor p => Settable p where
84> mapping :: Functor f => p a b -> p (f a) (f b)
85>
86> instance Settable (->) where
87> mapping = fmap
88
89> type Setter s t a b = forall p. Settable p => Optic p s t a b
90
91> setting :: forall a b s t. ((a -> b) -> (s -> t)) -> Setter s t a b
92> setting f = dimap from to . mapping
93> where from :: s -> Compose ((,) s) ((->) a) a
94> from s = Compose (s, id)
95> to :: Compose ((,) s) ((->) a) b -> t
96> to (Compose (s, modify)) = f modify s
97
98Unoptics
99--------
100
101> type UnOptic p s t a b = p t s -> p b a
102
103> data Un p a b s t = Un { runUn :: p t s -> p b a }
104
105> instance Profunctor p => Profunctor (Un p s t) where
106> rmap f (Un p) = Un $ p . lmap f
107> lmap f (Un p) = Un $ p . rmap f
108> dimap f g (Un p) = Un $ p . dimap g f
109
110> class Profunctor p => UnStrong p where
111> unfirst' :: p (a,c) (b,c) -> p a b
112> unsecond' :: p (c,a) (c,b) -> p a b
113>
114> instance UnStrong Tagged where
115> unfirst' (Tagged a) = Tagged $ fst a
116> unsecond' (Tagged a) = Tagged $ snd a
117>
118
119> class Profunctor p => UnChoice p where
120> unleft' :: p (Either a c) (Either b c) -> p a b
121> unright' :: p (Either c a) (Either c b) -> p a b
122>
123> instance UnChoice (Forget r) where
124> unleft' (Forget f) = Forget $ f . Left
125> unright' (Forget f) = Forget $ f . Right
126
127> un :: Optic (Un p a b) s t a b -> UnOptic p s t a b
128> un p = runUn $ p $ Un id
129
130> reset :: Optic (Un (->) a b) s t a b -> s -> b -> a
131> reset = set . un
132
133> reover :: Optic (Un (->) a b) s t a b -> (t -> s) -> (b -> a)
134> reover = over . un
135
136--------------------------------------------------------------------------------
137
138> _fst :: Lens (a,c) (b,c) a b
139> _fst = first'
140>
141> _snd :: Lens (c,a) (c,b) a b
142> _snd = second'
143>
144> _Right :: Prism (Either c a) (Either c b) a b
145> _Right = right'
146>
147> _Left :: Prism (Either a c) (Either b c) a b
148> _Left = left'
149
150>
151> class Swapped f where
152> swapped :: Iso (f a b) (f c d) (f b a) (f d c)
153>
154> instance Swapped Either where
155> swapped = iso (either Right Left) (either Right Left)
156>
157> instance Swapped (,) where
158> swapped = iso (snd &&& fst) (snd &&& fst)