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

{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# 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 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 g _) = g

-- | Get the modifier category from a Point.

modify :: Point cat g i f o -> cat (cat o i, f) g
modify (Point _ m) = m

-- | Get the setter category from a Point.

set :: Arrow arr => Point arr g i f o -> arr (i, f) g
set p = modify p . first (arr const)

-- | Identity Point. Cannot change the type.

identity :: ArrowApply arr => Point arr f f o o
identity = Point id 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 f m) (Point g n)
  = Point (f . g) (uncurry (curry n . curry m))

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

instance Arrow arr => Functor (Point arr f i f) where
  fmap f x = pure f <*> x
  {-# INLINE fmap #-}

instance Arrow arr => Applicative (Point arr f i f) where
  pure a  = Point (const a) (arr snd)
  a <*> b = Point (arr app . (get a &&& get b)) $
    proc (t, p) -> do (f, v) <- get a &&& get b -< p
                      q <- modify a             -< (t . arr ($ v), p)
                      modify b                  -< (t . arr f, q)
  {-# INLINE pure  #-}
  {-# INLINE (<*>) #-}

instance Alternative (Point Partial f view f) where
  empty = Point zeroArrow zeroArrow
  Point a b <|> Point c d = Point (a <|> c) (b <|> d)

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

infix 8 `Iso`

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

data Iso cat i o = Iso { fw :: cat i o, bw :: cat o i }

-- | Isomorphisms are categories.

instance Category cat => Category (Iso cat) where
  id = Iso id id
  Iso a b . Iso c d = Iso (a . c) (d . b)
  {-# INLINE id  #-}
  {-# INLINE (.) #-}

-- | Flip an isomorphism.

inv :: Iso cat i o -> Iso cat o i
inv i = Iso (bw i) (fw 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 = Kleisli (const Nothing)
  {-# INLINE failArrow #-}

instance ArrowFail e (Failing e) where
  failArrow = Kleisli Left
  {-# INLINE failArrow #-}

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

-- | Missing Functor instance for Kleisli.

instance Functor f => Functor (Kleisli f i) where
  fmap f (Kleisli m) = Kleisli (fmap f . m)

-- | Missing Applicative instance for Kleisli.

instance Applicative f => Applicative (Kleisli f i) where
  pure a = Kleisli (const (pure a))
  Kleisli a <*> Kleisli b = Kleisli ((<*>) <$> a <*> b)

-- | Missing Alternative instance for Kleisli.

instance Alternative f => Alternative (Kleisli f i) where
  empty = Kleisli (const empty)
  Kleisli a <|> Kleisli b = Kleisli ((<|>) <$> a <*> b)

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

const :: Arrow arr => c -> arr b c
const a = arr (\_ -> a)

curry :: Arrow cat => cat (a, b) c -> (a -> cat b c)
curry m i = m . (const i &&& id)

uncurry :: ArrowApply cat => (a -> cat b c) -> cat (a, b) c
uncurry a = app . arr (first a)