-- |
-- Module: Optics.Arrow
-- Description: Turn optics into arrow transformers.
module Optics.Arrow
  ( ArrowOptic(..)
  , assignA
  ) where

import Control.Arrow
import Data.Coerce
import qualified Control.Category as C

import Data.Profunctor.Indexed

import Optics.AffineTraversal
import Optics.Prism
import Optics.Setter
import Optics.Internal.Optic
import Optics.Internal.Utils

newtype WrappedArrow p i a b = WrapArrow { WrappedArrow p i a b -> p a b
unwrapArrow :: p a b }

instance C.Category p => C.Category (WrappedArrow p i) where
  WrapArrow p b c
f . :: WrappedArrow p i b c
-> WrappedArrow p i a b -> WrappedArrow p i a c
. WrapArrow p a b
g = p a c -> WrappedArrow p i a c
forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (p b c
f p b c -> p a b -> p a c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
C.. p a b
g)
  id :: WrappedArrow p i a a
id                        = p a a -> WrappedArrow p i a a
forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow p a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
C.id
  {-# INLINE (.) #-}
  {-# INLINE id #-}

instance Arrow p => Arrow (WrappedArrow p i) where
  arr :: (b -> c) -> WrappedArrow p i b c
arr                         = p b c -> WrappedArrow p i b c
forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (p b c -> WrappedArrow p i b c)
-> ((b -> c) -> p b c) -> (b -> c) -> WrappedArrow p i b c
forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. (b -> c) -> p b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr
  first :: WrappedArrow p i b c -> WrappedArrow p i (b, d) (c, d)
first                       = p (b, d) (c, d) -> WrappedArrow p i (b, d) (c, d)
forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (p (b, d) (c, d) -> WrappedArrow p i (b, d) (c, d))
-> (p b c -> p (b, d) (c, d))
-> p b c
-> WrappedArrow p i (b, d) (c, d)
forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. p b c -> p (b, d) (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first  (p b c -> WrappedArrow p i (b, d) (c, d))
-> (WrappedArrow p i b c -> p b c)
-> WrappedArrow p i b c
-> WrappedArrow p i (b, d) (c, d)
forall a b c. Coercible a b => (b -> c) -> (a -> b) -> a -> c
.# WrappedArrow p i b c -> p b c
forall (p :: * -> * -> *) i a b. WrappedArrow p i a b -> p a b
unwrapArrow
  second :: WrappedArrow p i b c -> WrappedArrow p i (d, b) (d, c)
second                      = p (d, b) (d, c) -> WrappedArrow p i (d, b) (d, c)
forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (p (d, b) (d, c) -> WrappedArrow p i (d, b) (d, c))
-> (p b c -> p (d, b) (d, c))
-> p b c
-> WrappedArrow p i (d, b) (d, c)
forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. p b c -> p (d, b) (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (p b c -> WrappedArrow p i (d, b) (d, c))
-> (WrappedArrow p i b c -> p b c)
-> WrappedArrow p i b c
-> WrappedArrow p i (d, b) (d, c)
forall a b c. Coercible a b => (b -> c) -> (a -> b) -> a -> c
.# WrappedArrow p i b c -> p b c
forall (p :: * -> * -> *) i a b. WrappedArrow p i a b -> p a b
unwrapArrow
  WrapArrow p b c
a *** :: WrappedArrow p i b c
-> WrappedArrow p i b' c' -> WrappedArrow p i (b, b') (c, c')
*** WrapArrow p b' c'
b = p (b, b') (c, c') -> WrappedArrow p i (b, b') (c, c')
forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (p b c
a p b c -> p b' c' -> p (b, b') (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** p b' c'
b)
  WrapArrow p b c
a &&& :: WrappedArrow p i b c
-> WrappedArrow p i b c' -> WrappedArrow p i b (c, c')
&&& WrapArrow p b c'
b = p b (c, c') -> WrappedArrow p i b (c, c')
forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (p b c
a p b c -> p b c' -> p b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& p b c'
b)
  {-# INLINE arr #-}
  {-# INLINE first #-}
  {-# INLINE second #-}
  {-# INLINE (***) #-}
  {-# INLINE (&&&) #-}

instance Arrow p => Profunctor (WrappedArrow p) where
  dimap :: (a -> b)
-> (c -> d) -> WrappedArrow p i b c -> WrappedArrow p i a d
dimap a -> b
f c -> d
g WrappedArrow p i b c
k = (a -> b) -> WrappedArrow p i a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f WrappedArrow p i a b
-> WrappedArrow p i b d -> WrappedArrow p i a d
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> WrappedArrow p i b c
k WrappedArrow p i b c
-> WrappedArrow p i c d -> WrappedArrow p i b d
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (c -> d) -> WrappedArrow p i c d
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr c -> d
g
  lmap :: (a -> b) -> WrappedArrow p i b c -> WrappedArrow p i a c
lmap  a -> b
f   WrappedArrow p i b c
k = (a -> b) -> WrappedArrow p i a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f WrappedArrow p i a b
-> WrappedArrow p i b c -> WrappedArrow p i a c
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> WrappedArrow p i b c
k
  rmap :: (c -> d) -> WrappedArrow p i b c -> WrappedArrow p i b d
rmap    c -> d
g WrappedArrow p i b c
k =           WrappedArrow p i b c
k WrappedArrow p i b c
-> WrappedArrow p i c d -> WrappedArrow p i b d
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (c -> d) -> WrappedArrow p i c d
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr c -> d
g
  {-# INLINE dimap #-}
  {-# INLINE lmap #-}
  {-# INLINE rmap #-}

  lcoerce' :: WrappedArrow p i a c -> WrappedArrow p i b c
lcoerce' = (b -> a) -> WrappedArrow p i a c -> WrappedArrow p i b c
forall (p :: * -> * -> * -> *) a b i c.
Profunctor p =>
(a -> b) -> p i b c -> p i a c
lmap b -> a
coerce
  rcoerce' :: WrappedArrow p i c a -> WrappedArrow p i c b
rcoerce' = (a -> b) -> WrappedArrow p i c a -> WrappedArrow p i c b
forall (p :: * -> * -> * -> *) c d i b.
Profunctor p =>
(c -> d) -> p i b c -> p i b d
rmap a -> b
coerce
  {-# INLINE lcoerce' #-}
  {-# INLINE rcoerce' #-}

instance Arrow p => Strong (WrappedArrow p) where
  first' :: WrappedArrow p i a b -> WrappedArrow p i (a, c) (b, c)
first'  (WrapArrow p a b
k) = p (a, c) (b, c) -> WrappedArrow p i (a, c) (b, c)
forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (p a b -> p (a, c) (b, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first p a b
k)
  second' :: WrappedArrow p i a b -> WrappedArrow p i (c, a) (c, b)
second' (WrapArrow p a b
k) = p (c, a) (c, b) -> WrappedArrow p i (c, a) (c, b)
forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (p a b -> p (c, a) (c, b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second p a b
k)
  {-# INLINE first' #-}
  {-# INLINE second' #-}

instance ArrowChoice p => Choice (WrappedArrow p) where
  left' :: WrappedArrow p i a b -> WrappedArrow p i (Either a c) (Either b c)
left'  (WrapArrow p a b
k) = p (Either a c) (Either b c)
-> WrappedArrow p i (Either a c) (Either b c)
forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (p a b -> p (Either a c) (Either b c)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left p a b
k)
  right' :: WrappedArrow p i a b -> WrappedArrow p i (Either c a) (Either c b)
right' (WrapArrow p a b
k) = p (Either c a) (Either c b)
-> WrappedArrow p i (Either c a) (Either c b)
forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (p a b -> p (Either c a) (Either c b)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right p a b
k)
  {-# INLINE left' #-}
  {-# INLINE right' #-}

instance ArrowChoice p => Visiting (WrappedArrow p)

class Arrow arr => ArrowOptic k arr where
  -- | Turn an optic into an arrow transformer.
  overA :: Optic k is s t a b -> arr a b -> arr s t

instance Arrow arr => ArrowOptic An_Iso arr where
  overA :: Optic An_Iso is s t a b -> arr a b -> arr s t
overA = Optic An_Iso is s t a b -> arr a b -> arr s t
forall (p :: * -> * -> * -> *) (arr :: * -> * -> *) k
       (is :: IxList) s t a b.
(p ~ WrappedArrow arr, Profunctor p, Constraints k p) =>
Optic k is s t a b -> arr a b -> arr s t
overA__
  {-# INLINE overA #-}

instance Arrow arr => ArrowOptic A_Lens arr where
  overA :: Optic A_Lens is s t a b -> arr a b -> arr s t
overA = Optic A_Lens is s t a b -> arr a b -> arr s t
forall (p :: * -> * -> * -> *) (arr :: * -> * -> *) k
       (is :: IxList) s t a b.
(p ~ WrappedArrow arr, Profunctor p, Constraints k p) =>
Optic k is s t a b -> arr a b -> arr s t
overA__
  {-# INLINE overA #-}

instance ArrowChoice arr => ArrowOptic A_Prism arr where
  overA :: Optic A_Prism is s t a b -> arr a b -> arr s t
overA = Optic A_Prism is s t a b -> arr a b -> arr s t
forall (p :: * -> * -> * -> *) (arr :: * -> * -> *) k
       (is :: IxList) s t a b.
(p ~ WrappedArrow arr, Profunctor p, Constraints k p) =>
Optic k is s t a b -> arr a b -> arr s t
overA__
  {-# INLINE overA #-}

instance ArrowChoice arr => ArrowOptic An_AffineTraversal arr where
  overA :: Optic An_AffineTraversal is s t a b -> arr a b -> arr s t
overA = Optic An_AffineTraversal is s t a b -> arr a b -> arr s t
forall (p :: * -> * -> * -> *) (arr :: * -> * -> *) k
       (is :: IxList) s t a b.
(p ~ WrappedArrow arr, Profunctor p, Constraints k p) =>
Optic k is s t a b -> arr a b -> arr s t
overA__
  {-# INLINE overA #-}

-- | Run an arrow command and use the output to set all the targets of an optic
-- to the result.
--
-- @
-- runKleisli action ((), (), ()) where
--   action =      assignA _1 (Kleisli (const getVal1))
--            \>>> assignA _2 (Kleisli (const getVal2))
--            \>>> assignA _3 (Kleisli (const getVal3))
--   getVal1 :: Either String Int
--   getVal1 = ...
--   getVal2 :: Either String Bool
--   getVal2 = ...
--   getVal3 :: Either String Char
--   getVal3 = ...
-- @
--
-- has the type @'Either' 'String' ('Int', 'Bool', 'Char')@
assignA
  :: (Is k A_Setter, Arrow arr)
  => Optic k is s t a b
  -> arr s b -> arr s t
assignA :: Optic k is s t a b -> arr s b -> arr s t
assignA Optic k is s t a b
o arr s b
p = (s -> b -> t) -> arr s (b -> t)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((b -> s -> t) -> s -> b -> t
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((b -> s -> t) -> s -> b -> t) -> (b -> s -> t) -> s -> b -> t
forall a b. (a -> b) -> a -> b
$ Optic k is s t a b -> b -> s -> t
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic k is s t a b
o) arr s (b -> t) -> arr s b -> arr s (b -> t, b)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& arr s b
p arr s (b -> t, b) -> arr (b -> t, b) t -> arr s t
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((b -> t, b) -> t) -> arr (b -> t, b) t
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (((b -> t) -> b -> t) -> (b -> t, b) -> t
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry' (b -> t) -> b -> t
forall a. a -> a
id)
{-# INLINE assignA #-}

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

-- | Internal implementation of overA.
overA__
  :: (p ~ WrappedArrow arr, Profunctor p, Constraints k p)
  => Optic k is s t a b
  -> arr a b -> arr s t
overA__ :: Optic k is s t a b -> arr a b -> arr s t
overA__ Optic k is s t a b
o = WrappedArrow arr (Curry is Any) s t -> arr s t
forall (p :: * -> * -> *) i a b. WrappedArrow p i a b -> p a b
unwrapArrow (WrappedArrow arr (Curry is Any) s t -> arr s t)
-> (WrappedArrow arr Any a b
    -> WrappedArrow arr (Curry is Any) s t)
-> WrappedArrow arr Any a b
-> arr s t
forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. Optic k is s t a b
-> Optic_ k (WrappedArrow arr) Any (Curry is Any) s t a b
forall (p :: * -> * -> * -> *) k (is :: IxList) s t a b i.
Profunctor p =>
Optic k is s t a b -> Optic_ k p i (Curry is i) s t a b
getOptic Optic k is s t a b
o (WrappedArrow arr Any a b -> arr s t)
-> (arr a b -> WrappedArrow arr Any a b) -> arr a b -> arr s t
forall a b c. Coercible a b => (b -> c) -> (a -> b) -> a -> c
.# arr a b -> WrappedArrow arr Any a b
forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow
{-# INLINE overA__ #-}