{-# LANGUAGE
FlexibleInstances
, GADTs
, MultiParamTypeClasses
, TypeOperators #-}
module Data.Label.Poly
(
Lens
, lens
, point
, get
, modify
, set
, iso
, (>-)
, for
)
where
import Control.Category
import Control.Arrow
import Prelude ()
import Data.Label.Point (Point (Point), Iso(..), identity, compose)
import qualified Data.Label.Point as Point
{-# INLINE lens #-}
{-# INLINE get #-}
{-# INLINE modify #-}
{-# INLINE set #-}
{-# INLINE (>-) #-}
{-# INLINE point #-}
{-# INLINE unpack #-}
data Lens cat f o where
Lens :: !(Point cat g i f o) -> Lens cat (f -> g) (o -> i)
Id :: ArrowApply cat => Lens cat f f
lens :: cat f o
-> cat (cat o i, f) g
-> Lens cat (f -> g) (o -> i)
lens :: cat f o -> cat (cat o i, f) g -> Lens cat (f -> g) (o -> i)
lens cat f o
g cat (cat o i, f) g
m = Point cat g i f o -> Lens cat (f -> g) (o -> i)
forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> Lens cat (f -> g) (o -> i)
Lens (cat f o -> cat (cat o i, f) g -> Point cat g i f o
forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point cat f o
g cat (cat o i, f) g
m)
point :: Point cat g i f o -> Lens cat (f -> g) (o -> i)
point :: Point cat g i f o -> Lens cat (f -> g) (o -> i)
point = Point cat g i f o -> Lens cat (f -> g) (o -> i)
forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> Lens cat (f -> g) (o -> i)
Lens
get :: Lens cat (f -> g) (o -> i) -> cat f o
get :: Lens cat (f -> g) (o -> i) -> cat f o
get = Point cat g i f o -> cat f o
forall (cat :: * -> * -> *) g i f o. Point cat g i f o -> cat f o
Point.get (Point cat g i f o -> cat f o)
-> (Lens cat (f -> g) (o -> i) -> Point cat g i f o)
-> Lens cat (f -> g) (o -> i)
-> cat f o
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens cat (f -> g) (o -> i) -> Point cat g i f o
forall (cat :: * -> * -> *) f g o i.
Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack
modify :: Lens cat (f -> g) (o -> i) -> cat (cat o i, f) g
modify :: Lens cat (f -> g) (o -> i) -> cat (cat o i, f) g
modify = Point cat g i f o -> cat (cat o i, f) g
forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> cat (cat o i, f) g
Point.modify (Point cat g i f o -> cat (cat o i, f) g)
-> (Lens cat (f -> g) (o -> i) -> Point cat g i f o)
-> Lens cat (f -> g) (o -> i)
-> cat (cat o i, f) g
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens cat (f -> g) (o -> i) -> Point cat g i f o
forall (cat :: * -> * -> *) f g o i.
Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack
set :: Arrow arr => Lens arr (f -> g) (o -> i) -> arr (i, f) g
set :: Lens arr (f -> g) (o -> i) -> arr (i, f) g
set = Point arr g i f o -> arr (i, f) g
forall (arr :: * -> * -> *) g i f o.
Arrow arr =>
Point arr g i f o -> arr (i, f) g
Point.set (Point arr g i f o -> arr (i, f) g)
-> (Lens arr (f -> g) (o -> i) -> Point arr g i f o)
-> Lens arr (f -> g) (o -> i)
-> arr (i, f) g
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens arr (f -> g) (o -> i) -> Point arr g i f o
forall (cat :: * -> * -> *) f g o i.
Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack
iso :: ArrowApply cat => Iso cat f o -> Iso cat g i -> Lens cat (f -> g) (o -> i)
iso :: Iso cat f o -> Iso cat g i -> Lens cat (f -> g) (o -> i)
iso (Iso cat f o
f cat o f
_) (Iso cat g i
_ cat i g
y) = cat f o -> cat (cat o i, f) g -> Lens cat (f -> g) (o -> i)
forall (cat :: * -> * -> *) f o i g.
cat f o -> cat (cat o i, f) g -> Lens cat (f -> g) (o -> i)
lens cat f o
f (cat (cat f g, f) g
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app cat (cat f g, f) g
-> cat (cat o i, f) (cat f g, f) -> cat (cat o i, f) g
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((cat o i, f) -> (cat f g, f)) -> cat (cat o i, f) (cat f g, f)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(cat o i
m, f
v) -> (cat i g
y cat i g -> cat f i -> cat f g
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. cat o i
m cat o i -> cat f o -> cat f i
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. cat f o
f, f
v)))
instance ArrowApply arr => Category (Lens arr) where
id :: Lens arr a a
id = Lens arr a a
forall (cat :: * -> * -> *) f. ArrowApply cat => Lens cat f f
Id
Lens Point arr g i f o
f . :: Lens arr b c -> Lens arr a b -> Lens arr a c
. Lens Point arr g i f o
g = Point arr g i f o -> Lens arr (f -> g) (o -> i)
forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> Lens cat (f -> g) (o -> i)
Lens (Point arr g i f o -> Point arr g g f f -> Point arr g i f o
forall (cat :: * -> * -> *) t i b o g f.
ArrowApply cat =>
Point cat t i b o -> Point cat g t f b -> Point cat g i f o
compose Point arr g i f o
f Point arr g g f f
Point arr g i f o
g)
Lens arr b c
Id . Lens arr a b
u = Lens arr a b
Lens arr a c
u
Lens arr b c
u . Lens arr a b
Id = Lens arr b c
Lens arr a c
u
{-# INLINE id #-}
{-# INLINE (.) #-}
infix 7 >-
(>-) :: Arrow arr => Lens arr (j -> a) (i -> b) -> Lens arr (f -> g) (o -> i) -> Point arr g j f o
>- :: Lens arr (j -> a) (i -> b)
-> Lens arr (f -> g) (o -> i) -> Point arr g j f o
(>-) (Lens (Point arr f o
f arr (arr o i, f) g
_)) (Lens Point arr g i f o
l) = arr f o -> arr (arr o f, f) g -> Point arr g f f o
forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point (Point arr g i f o -> arr f o
forall (cat :: * -> * -> *) g i f o. Point cat g i f o -> cat f o
Point.get Point arr g i f o
l) (Point arr g i f o -> arr (arr o i, f) g
forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> cat (cat o i, f) g
Point.modify Point arr g i f o
l arr (arr o i, f) g
-> arr (arr o f, f) (arr o i, f) -> arr (arr o f, f) g
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr (arr o f) (arr o o) -> arr (arr o f, f) (arr o o, f)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((arr o f -> arr o o) -> arr (arr o f) (arr o o)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (arr f o
f arr f o -> arr o f -> arr o o
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.)))
(>-) (Lens (Point arr f o
f arr (arr o i, f) g
_)) Lens arr (f -> g) (o -> i)
Id = arr f f -> arr (arr f f, f) o -> Point arr o f f f
forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point arr f f
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (arr (arr f o, f) o
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app arr (arr f o, f) o
-> arr (arr f f, f) (arr f o, f) -> arr (arr f f, f) o
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr (arr f f) (arr f o) -> arr (arr f f, f) (arr f o, f)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((arr f f -> arr f o) -> arr (arr f f) (arr f o)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (arr f o
f arr f o -> arr f f -> arr f o
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.)))
(>-) Lens arr (j -> a) (i -> b)
Id Lens arr (f -> g) (o -> i)
l = Lens arr (f -> g) (o -> i) -> Point arr g i f o
forall (cat :: * -> * -> *) f g o i.
Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack Lens arr (f -> g) (o -> i)
l
infix 7 `for`
for :: Arrow arr => Lens arr (j -> a) (i -> b) -> Lens arr (f -> g) (o -> i) -> Point arr g j f o
for :: Lens arr (j -> a) (i -> b)
-> Lens arr (f -> g) (o -> i) -> Point arr g j f o
for = Lens arr (j -> a) (i -> b)
-> Lens arr (f -> g) (o -> i) -> Point arr g j f o
forall (arr :: * -> * -> *) j a i b f g o.
Arrow arr =>
Lens arr (j -> a) (i -> b)
-> Lens arr (f -> g) (o -> i) -> Point arr g j f o
(>-)
unpack :: Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack :: Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack Lens cat (f -> g) (o -> i)
Id = Point cat g i f o
forall (arr :: * -> * -> *) f o.
ArrowApply arr =>
Point arr f f o o
identity
unpack (Lens Point cat g i f o
p) = Point cat g i f o
Point cat g i f o
p