{-# LANGUAGE
TypeOperators
, Arrows
, FlexibleInstances
, MultiParamTypeClasses
, TypeSynonymInstances #-}
module Data.Label.Point
(
Point (Point)
, get
, modify
, set
, identity
, compose
, Iso (..)
, inv
, Total
, Partial
, Failing
, ArrowFail (..)
)
where
import Control.Arrow
import Control.Applicative
import Control.Category
import Data.Orphans ()
import Prelude hiding ((.), id, const, curry, uncurry)
{-# INLINE get #-}
{-# INLINE modify #-}
{-# INLINE set #-}
{-# INLINE identity #-}
{-# INLINE compose #-}
{-# INLINE inv #-}
{-# INLINE const #-}
{-# INLINE curry #-}
data Point cat g i f o = Point (cat f o) (cat (cat o i, f) g)
get :: Point cat g i f o -> cat f o
get :: Point cat g i f o -> cat f o
get (Point cat f o
g cat (cat o i, f) g
_) = cat f o
g
modify :: Point cat g i f o -> cat (cat o i, f) g
modify :: Point cat g i f o -> cat (cat o i, f) g
modify (Point cat f o
_ cat (cat o i, f) g
m) = cat (cat o i, f) g
m
set :: Arrow arr => Point arr g i f o -> arr (i, f) g
set :: Point arr g i f o -> arr (i, f) g
set Point arr g i f o
p = 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
modify Point arr g i f o
p arr (arr o i, f) g -> arr (i, f) (arr o i, f) -> 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
. arr i (arr o i) -> arr (i, f) (arr o i, f)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((i -> arr o i) -> arr i (arr o i)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr i -> arr o i
forall (arr :: * -> * -> *) c b. Arrow arr => c -> arr b c
const)
identity :: ArrowApply arr => Point arr f f o o
identity :: Point arr f f o o
identity = arr o o -> arr (arr o f, o) f -> Point arr f f o o
forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point arr o o
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id arr (arr o f, o) f
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app
compose :: ArrowApply cat
=> Point cat t i b o
-> Point cat g t f b
-> Point cat g i f o
compose :: Point cat t i b o -> Point cat g t f b -> Point cat g i f o
compose (Point cat b o
f cat (cat o i, b) t
m) (Point cat f b
g cat (cat b t, f) g
n)
= 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 b o
f cat b o -> cat f b -> 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
. cat f b
g) ((cat o i -> cat f g) -> cat (cat o i, f) g
forall (cat :: * -> * -> *) a b c.
ArrowApply cat =>
(a -> cat b c) -> cat (a, b) c
uncurry (cat (cat b t, f) g -> cat b t -> cat f g
forall (cat :: * -> * -> *) a b c.
Arrow cat =>
cat (a, b) c -> a -> cat b c
curry cat (cat b t, f) g
n (cat b t -> cat f g) -> (cat o i -> cat b t) -> cat o 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 (cat o i, b) t -> cat o i -> cat b t
forall (cat :: * -> * -> *) a b c.
Arrow cat =>
cat (a, b) c -> a -> cat b c
curry cat (cat o i, b) t
m))
instance Arrow arr => Functor (Point arr f i f) where
fmap :: (a -> b) -> Point arr f i f a -> Point arr f i f b
fmap a -> b
f Point arr f i f a
x = (a -> b) -> Point arr f i f (a -> b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> b
f Point arr f i f (a -> b) -> Point arr f i f a -> Point arr f i f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point arr f i f a
x
{-# INLINE fmap #-}
instance Arrow arr => Applicative (Point arr f i f) where
pure :: a -> Point arr f i f a
pure a
a = arr f a -> arr (arr a i, f) f -> Point arr f i f a
forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point (a -> arr f a
forall (arr :: * -> * -> *) c b. Arrow arr => c -> arr b c
const a
a) (((arr a i, f) -> f) -> arr (arr a i, f) f
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (arr a i, f) -> f
forall a b. (a, b) -> b
snd)
Point arr f i f (a -> b)
a <*> :: Point arr f i f (a -> b) -> Point arr f i f a -> Point arr f i f b
<*> Point arr f i f a
b = arr f b -> arr (arr b i, f) f -> Point arr f i f b
forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point (((a -> b, a) -> b) -> arr (a -> b, a) b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (a -> b, a) -> b
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app arr (a -> b, a) b -> arr f (a -> b, a) -> arr f b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Point arr f i f (a -> b) -> arr f (a -> b)
forall (cat :: * -> * -> *) g i f o. Point cat g i f o -> cat f o
get Point arr f i f (a -> b)
a arr f (a -> b) -> arr f a -> arr f (a -> b, a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Point arr f i f a -> arr f a
forall (cat :: * -> * -> *) g i f o. Point cat g i f o -> cat f o
get Point arr f i f a
b)) (arr (arr b i, f) f -> Point arr f i f b)
-> arr (arr b i, f) f -> Point arr f i f b
forall a b. (a -> b) -> a -> b
$
proc (arr b i
t, f
p) -> do (a -> b
f, a
v) <- Point arr f i f (a -> b) -> arr f (a -> b)
forall (cat :: * -> * -> *) g i f o. Point cat g i f o -> cat f o
get Point arr f i f (a -> b)
a arr f (a -> b) -> arr f a -> arr f (a -> b, a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Point arr f i f a -> arr f a
forall (cat :: * -> * -> *) g i f o. Point cat g i f o -> cat f o
get Point arr f i f a
b -< f
p
f
q <- Point arr f i f (a -> b) -> arr (arr (a -> b) i, f) f
forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> cat (cat o i, f) g
modify Point arr f i f (a -> b)
a -< (arr b i
t arr b i -> arr (a -> b) b -> arr (a -> b) i
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((a -> b) -> b) -> arr (a -> b) b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
v), f
p)
Point arr f i f a -> arr (arr a i, f) f
forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> cat (cat o i, f) g
modify Point arr f i f a
b -< (arr b i
t arr b i -> arr a b -> arr a i
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> b) -> arr a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f, f
q)
{-# INLINE pure #-}
{-# INLINE (<*>) #-}
instance Alternative (Point Partial f view f) where
empty :: Point Partial f view f a
empty = Partial f a
-> Partial (Partial a view, f) f -> Point Partial f view f a
forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point Partial f a
forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow Partial (Partial a view, f) f
forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow
Point Partial f a
a Partial (Partial a view, f) f
b <|> :: Point Partial f view f a
-> Point Partial f view f a -> Point Partial f view f a
<|> Point Partial f a
c Partial (Partial a view, f) f
d = Partial f a
-> Partial (Partial a view, f) f -> Point Partial f view f a
forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point (Partial f a
a Partial f a -> Partial f a -> Partial f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Partial f a
c) (Partial (Partial a view, f) f
b Partial (Partial a view, f) f
-> Partial (Partial a view, f) f -> Partial (Partial a view, f) f
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Partial (Partial a view, f) f
d)
infix 8 `Iso`
data Iso cat i o = Iso { Iso cat i o -> cat i o
fw :: cat i o, Iso cat i o -> cat o i
bw :: cat o i }
instance Category cat => Category (Iso cat) where
id :: Iso cat a a
id = cat a a -> cat a a -> Iso cat a a
forall (cat :: * -> * -> *) i o. cat i o -> cat o i -> Iso cat i o
Iso cat a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id cat a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
Iso cat b c
a cat c b
b . :: Iso cat b c -> Iso cat a b -> Iso cat a c
. Iso cat a b
c cat b a
d = cat a c -> cat c a -> Iso cat a c
forall (cat :: * -> * -> *) i o. cat i o -> cat o i -> Iso cat i o
Iso (cat b c
a cat b c -> cat a b -> cat a c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. cat a b
c) (cat b a
d cat b a -> cat c b -> cat c a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. cat c b
b)
{-# INLINE id #-}
{-# INLINE (.) #-}
inv :: Iso cat i o -> Iso cat o i
inv :: Iso cat i o -> Iso cat o i
inv Iso cat i o
i = cat o i -> cat i o -> Iso cat o i
forall (cat :: * -> * -> *) i o. cat i o -> cat o i -> Iso cat i o
Iso (Iso cat i o -> cat o i
forall (cat :: * -> * -> *) i o. Iso cat i o -> cat o i
bw Iso cat i o
i) (Iso cat i o -> cat i o
forall (cat :: * -> * -> *) i o. Iso cat i o -> cat i o
fw Iso cat i o
i)
type Total = (->)
type Partial = Kleisli Maybe
type Failing e = Kleisli (Either e)
class Arrow a => ArrowFail e a where
failArrow :: a e c
instance ArrowFail e Partial where
failArrow :: Partial e c
failArrow = (e -> Maybe c) -> Partial e c
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (Maybe c -> e -> Maybe c
forall (arr :: * -> * -> *) c b. Arrow arr => c -> arr b c
const Maybe c
forall a. Maybe a
Nothing)
{-# INLINE failArrow #-}
instance ArrowFail e (Failing e) where
failArrow :: Failing e e c
failArrow = (e -> Either e c) -> Failing e e c
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli e -> Either e c
forall a b. a -> Either a b
Left
{-# INLINE failArrow #-}
const :: Arrow arr => c -> arr b c
const :: c -> arr b c
const c
a = (b -> c) -> arr b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\b
_ -> c
a)
curry :: Arrow cat => cat (a, b) c -> (a -> cat b c)
curry :: cat (a, b) c -> a -> cat b c
curry cat (a, b) c
m a
i = cat (a, b) c
m cat (a, b) c -> cat b (a, b) -> cat b c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> cat b a
forall (arr :: * -> * -> *) c b. Arrow arr => c -> arr b c
const a
i cat b a -> cat b b -> cat b (a, b)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& cat b b
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)
uncurry :: ArrowApply cat => (a -> cat b c) -> cat (a, b) c
uncurry :: (a -> cat b c) -> cat (a, b) c
uncurry a -> cat b c
a = cat (cat b c, b) c
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app cat (cat b c, b) c -> cat (a, b) (cat b c, b) -> cat (a, b) c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((a, b) -> (cat b c, b)) -> cat (a, b) (cat b c, b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((a -> cat b c) -> (a, b) -> (cat b c, b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a -> cat b c
a)