{-# 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 :: forall (cat :: * -> * -> *) g i f o. 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 :: forall (cat :: * -> * -> *) g i f o.
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 :: forall (arr :: * -> * -> *) g i f o.
Arrow arr =>
Point arr g i f o -> arr (i, f) g
set Point arr g i f o
p = 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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall (arr :: * -> * -> *) c b. Arrow arr => c -> arr b c
const)
identity :: ArrowApply arr => Point arr f f o o
identity :: forall (arr :: * -> * -> *) f o.
ArrowApply arr =>
Point arr f f o o
identity = forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id 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 :: 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 cat b o
f cat (cat o i, b) t
m) (Point cat f b
g cat (cat b t, f) g
n)
= 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 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) (forall (cat :: * -> * -> *) a b c.
ArrowApply cat =>
(a -> cat b c) -> cat (a, b) c
uncurry (forall (cat :: * -> * -> *) a b c.
Arrow cat =>
cat (a, b) c -> a -> cat b c
curry cat (cat b t, f) g
n forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 :: forall a b. (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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> b
f 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 :: forall a. a -> Point arr f i f a
pure a
a = forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point (forall (arr :: * -> * -> *) c b. Arrow arr => c -> arr b c
const a
a) (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a, b) -> b
snd)
Point arr f i f (a -> b)
a <*> :: forall a b.
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 = forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (forall (cat :: * -> * -> *) g i f o. Point cat g i f o -> cat f o
get Point arr f i f (a -> b)
a forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (cat :: * -> * -> *) g i f o. Point cat g i f o -> cat f o
get Point arr f i f a
b)) forall a b. (a -> b) -> a -> b
$
proc (arr b i
t, f
p) -> do (a -> b
f, a
v) <- forall (cat :: * -> * -> *) g i f o. Point cat g i f o -> cat f o
get Point arr f i f (a -> b)
a forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& 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 <- 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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a b. (a -> b) -> a -> b
$ a
v), f
p)
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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 :: forall a. Point Partial f view f a
empty = forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow
Point Partial f a
a Partial (Partial a view, f) f
b <|> :: forall a.
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 = 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Partial f a
c) (Partial (Partial a view, f) f
b 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 { forall (cat :: * -> * -> *) i o. Iso cat i o -> cat i o
fw :: cat i o, forall (cat :: * -> * -> *) i o. Iso cat i o -> cat o i
bw :: cat o i }
instance Category cat => Category (Iso cat) where
id :: forall a. Iso cat a a
id = forall (cat :: * -> * -> *) i o. cat i o -> cat o i -> Iso cat i o
Iso forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
Iso cat b c
a cat c b
b . :: forall b c a. Iso cat b c -> Iso cat a b -> Iso cat a c
. Iso cat a b
c cat b a
d = forall (cat :: * -> * -> *) i o. cat i o -> cat o i -> Iso cat i o
Iso (cat b 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 a b
c) (cat b a
d 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 :: forall (cat :: * -> * -> *) i o. Iso cat i o -> Iso cat o i
inv Iso cat i o
i = forall (cat :: * -> * -> *) i o. cat i o -> cat o i -> Iso cat i o
Iso (forall (cat :: * -> * -> *) i o. Iso cat i o -> cat o i
bw Iso cat i o
i) (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 :: forall c. Partial e c
failArrow = forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (forall (arr :: * -> * -> *) c b. Arrow arr => c -> arr b c
const forall a. Maybe a
Nothing)
{-# INLINE failArrow #-}
instance ArrowFail e (Failing e) where
failArrow :: forall c. Failing e e c
failArrow = forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli forall a b. a -> Either a b
Left
{-# INLINE failArrow #-}
const :: Arrow arr => c -> arr b c
const :: forall (arr :: * -> * -> *) c b. Arrow arr => c -> arr b c
const c
a = 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 :: forall (cat :: * -> * -> *) a b c.
Arrow cat =>
cat (a, b) c -> a -> cat b c
curry cat (a, b) c
m a
i = cat (a, b) c
m forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (forall (arr :: * -> * -> *) c b. Arrow arr => c -> arr b c
const a
i forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& 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 :: forall (cat :: * -> * -> *) a b c.
ArrowApply cat =>
(a -> cat b c) -> cat (a, b) c
uncurry a -> cat b c
a = forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a -> cat b c
a)