{- | 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 :: 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

-- | Get the modifier category from a Point.

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

-- | Get the setter category from a Point.

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

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

-- | Point composition.

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`

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

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 }

-- | Isomorphisms are categories.

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

-- | Flip an isomorphism.

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)

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

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

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

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)