{- | The Point data type which generalizes the different lenses and forms the
basis for vertical composition using the `Applicative` type class.
-}

{-# LANGUAGE
    TypeOperators
  , Arrows
  , FlexibleInstances
  , MultiParamTypeClasses
  , TypeSynonymInstances #-}

module Data.Label.Point
(
-- * The point data type that generalizes lens.
  Point (Point)
, get
, modify
, set
, identity
, compose

-- * Working with isomorphisms.
, Iso (..)
, inv

-- * Specialized lens contexts.
, Total
, Partial
, Failing

-- * Arrow type class for failing with some error.
, 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    #-}

-------------------------------------------------------------------------------

-- | Abstract Point datatype. The getter and modifier operations work in some
-- category. The type of the value pointed to might change, thereby changing
-- the type of the outer structure.

data Point cat g i f o = Point (cat f o) (cat (cat o i, f) g)

-- | Get the getter category from a Point.

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

-- | Get the modifier category from a Point.

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

-- | Get the setter category from a Point.

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 Point. Cannot change the type.

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

-- | Point composition.

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`

-- | An isomorphism is like a `Category` that works in two directions.

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 }

-- | Isomorphisms are categories.

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 (.) #-}

-- | Flip an isomorphism.

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)

-------------------------------------------------------------------------------

-- | Context that represents computations that always produce an output.

type Total = (->)

-- | Context that represents computations that might silently fail.

type Partial = Kleisli Maybe

-- | Context that represents computations that might fail with some error.

type Failing e = Kleisli (Either e)

-- | The ArrowFail class is similar to `ArrowZero`, but additionally embeds
-- some error value in the computation instead of throwing it away.

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 #-}

-------------------------------------------------------------------------------
-- Common operations experessed in a generalized form.

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)