Flipped pure 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
{-# LANGUAGE Rank2Types #-}

import Data.Profunctor (Profunctor, dimap)
import Control.Arrow (first, (&&&))

type Lens s t a b = forall p. Costrong p => p t s -> p b a

class Profunctor p => Costrong p where
  cofirst :: p (a, c) (b, c) -> p a b

data A s x y = A { runA :: s -> y }

data B r x y = B { runB :: (y -> x) -> r }

instance Profunctor (A s) where
  dimap _ g (A h) = A (g . h)

instance Costrong (A s) where
  cofirst (A h) = A (fst . h)

instance Profunctor (B t) where
  dimap f g (B h) = B (\z -> h (f . z . g))
  
instance Costrong (B t) where
  cofirst (B h) = B (h . first)

view :: Lens s t a b -> s -> a
view l = runA (l (A id))

over :: Lens s t a b -> (a -> b) -> s -> t
over l = runB (l (B id))

toLens :: (s -> (a, b -> t)) -> Lens s t a b
toLens getset p = cofirst (dimap set' get' p)
  where get =  fst . getset
        set = snd . getset
        get' = get &&& id
        set' = uncurry (flip set)

_1 :: Lens (a, z) (b, z) a b
_1 = toLens (\(a, z) -> (a, \a' -> (a', z)))

_2 :: Lens (z, a) (z, b) a b
_2 = toLens (\(z, a) -> (a, \a' -> (z, a')))

first_of_second :: Lens (y, (a, z)) (y, (b, z)) a b
first_of_second = _1 . _2

tuple :: (Int, (String, Bool))
tuple = (1, ("hello", True))

exampleView :: String
exampleView = view first_of_second tuple

exampleOver :: (Int, (String, Bool))
exampleOver = over first_of_second (++" there") tuple
47:1: Warning: Use camelCase
Found:
first_of_second = ...
Why not:
firstOfSecond = ...