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
|
https://bartoszmilewski.com/2014/01/14/functors-are-containers/
Note that I've not quite ironed out the whole deal w/ BiContainer yet, and type classes which take two parameters
For lenses, name the class Iso as Mirror instead, to keep with the theme
A profunctor value of the type p a b could then be considered a container of bs that are keyed by elements of type a.
class (Profunctor p) => TamModule (ten :: * -> * -> *) p where
leftAction :: p a b -> p (c `ten` a) (c `ten` b)
rightAction :: p a b -> p (a `ten` c) (b `ten` c)
type TamOptic ten s t a b
= forall p. TamModule ten p => p a b -> p s t
data Optic ten s t a b
= forall c. Optic (s -> c `ten` a) (c `ten` b -> t)
type TamProd p = TamModule (,) p
type TamSum p = TamModule Either p
data Pastro p a b where
Pastro :: ((y, z) -> b) -> p x y -> (a -> (x, z))
-> Pastro p a b
data Copastro p a b where
Copastro :: (Either y z -> b) -> p x y -> (a -> Either x z)
-> Copastro p a b
// https://bartoszmilewski.com/2017/07/07/profunctor-optics-the-categorical-view/
https://r6research.livejournal.com/28338.html?utm_source=3userpost - A new case for the pointed functor class
https://r6research.livejournal.com/28050.html - Grate: A new kind of Optic
https://r6research.livejournal.com/27476.html - Profunctor hierarchy for objects
class Functor c => Naperian c where
zipFWith :: Functor f => (f a -> b) -> f (c a) -> (c b)
class (Traversable v, Naperian v) => FiniteVector v where
naperianTraverse :: (Functor f, Applicative g) => (f a -> g b) -> f (v a) -> g (v b)
-- A simple example to get people started.
instance FiniteVector Triple where
naperianTraverse h fv = Triple <$> h (one <$> fv) <*> h (two <$> fv) <*> h (three <$> fv)
where
one (Triple x y z) = x
two (Triple x y z) = y
three (Triple x y z) = z
vectorSize :: FiniteVector v => Proxy (Constant () (v a)) -> Integer
vectorSize p = getSum . getConstant $ naperianTraverse (const (Constant (Sum 1)) (Constant () `asProxyTypeOf` p)
class Profunctor p => Power p where
waddle :: FiniteVector v => p a b -> p (v a) (v b)
type FiniteGrate s t a b = Power p => p a b -> p s t
type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
// Create lens for a Hours/Minutes/Seconds time type, which does the right thing
data SLens α γ β = SLens {putR :: (α, γ) → (β , γ), putL :: (β , γ) → (α, γ), missing :: γ }
(;) :: (SLens α σ1 β ) → (SLens β σ2 γ) → (SLens α (σ1,σ2) γ)
l1 ; l2 = SLens putR putL (l1.missing, l2.missing)
where putR (a, (s1, s2)) =
let (b, s′1) = putR (a, s1)
(c, s′2) = putR (b, s2)
in (c, (s′1, s′2))
putL (c, (s1, s2)) =
let (b, s′2) = putL (c, s2)
(a, s′1) = putL (b, s1)
in (a, (s′1, s′2))
idLensS :: SLens X () X
idLensS = SLens id id ()
type StateT σ τ α = σ → τ (α, σ)
instance Monad τ ⇒ Monad (StateT σ τ ) where
return a = λs. return (a, s)
m >>= k = λs. do {(a, s′) ← m s; k a s′
get :: Monad τ ⇒ StateT σ τ σ
get = λs. return (s, s)
set :: Monad τ ⇒ σ → StateT σ τ ()
set s′ = λs. return ((), s′)
lift :: Monad τ ⇒ τ α → StateT σ τ α
lift m = λs. do {a ← m; return (a, s)}
gets :: Monad τ ⇒ (σ → α) → StateT σ τ α
gets f = do {s ← get; return (f s)}
eval :: Monad τ ⇒ StateT σ τ α → σ → τ α
eval m s = do {(a, s′) ← m s; return a }
exec :: Monad τ ⇒ StateT σ τ α → σ → τ σ
exec m s = do {(a, s′) ← m s; return s′ }
data Codec g p x a = Codec { get :: g a, put :: x -> p a }
instance (Functor g, Functor p) => Profunctor (Codec g p)
instance (Monad g, Monad p) => Monad (Codec g p x)
http://oleg.fi/gists/posts/2017-03-20-affine-traversal.html
data Kiosk a b s t = Kiosk (s -> Either t a) (s -> b -> t)
sellKiosk :: Kiosk a b a b
sellKiosk = Kiosk Right (\_ -> id)
instance Profunctor (Kiosk u v) where
dimap f g (Kiosk getter setter) = Kiosk
(\a -> first g $ getter (f a))
(\a v -> g (setter (f a) v))
instance Strong (Kiosk u v) where
first' (Kiosk getter setter) = Kiosk
(\(a, c) -> first (,c) $ getter a)
(\(a, c) v -> (setter a v, c))
instance Choice (Kiosk u v) where
right' (Kiosk getter setter) = Kiosk
(\eca -> assoc (second getter eca))
(\eca v -> second (`setter` v) eca)
where
assoc :: Either a (Either b c) -> Either (Either a b) c
assoc (Left a) = Left (Left a)
assoc (Right (Left b)) = Left (Right b)
assoc (Right (Right c)) = Right c
newtype Kiask a b t = Kiask { runKiask :: (Either t a, b -> t) }
sellKiask :: a -> Kiask a b b
sellKiask a = Kiask (Right a, id)
instance Functor (Kiask a b) where
fmap f (Kiask (Left t, g)) = Kiask (Left (f t), f . g)
fmap f (Kiask (Right a, g)) = Kiask (Right a, f . g)
instance Pointed (Kiask a b) where
point x = Kiask (Left x, const x)
http://oleg.fi/gists/posts/2021-01-08-indexed-optics-dilemma.html
|
