-- |
-- 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 { forall (p :: * -> * -> *) i a b. 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 . :: forall b c a.
WrappedArrow p i b c
-> WrappedArrow p i a b -> WrappedArrow p i a c
. WrapArrow p a b
g = forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (p b c
f 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 :: forall a. WrappedArrow p i a a
id                        = forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow 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 :: forall b c. (b -> c) -> WrappedArrow p i b c
arr                         = forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr
  first :: forall b c d.
WrappedArrow p i b c -> WrappedArrow p i (b, d) (c, d)
first                       = forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first  forall a b c. Coercible a b => (b -> c) -> (a -> b) -> a -> c
.# forall (p :: * -> * -> *) i a b. WrappedArrow p i a b -> p a b
unwrapArrow
  second :: forall b c d.
WrappedArrow p i b c -> WrappedArrow p i (d, b) (d, c)
second                      = forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a b c. Coercible a b => (b -> c) -> (a -> b) -> a -> c
.# forall (p :: * -> * -> *) i a b. WrappedArrow p i a b -> p a b
unwrapArrow
  WrapArrow p b c
a *** :: forall b c b' c'.
WrappedArrow p i b c
-> WrappedArrow p i b' c' -> WrappedArrow p i (b, b') (c, c')
*** WrapArrow p b' c'
b = forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (p b c
a 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 &&& :: forall b c c'.
WrappedArrow p i b c
-> WrappedArrow p i b c' -> WrappedArrow p i b (c, c')
&&& WrapArrow p b c'
b = forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (p b c
a 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 :: forall a b c d i.
(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 = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f 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 forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr c -> d
g
  lmap :: forall a b i c.
(a -> b) -> WrappedArrow p i b c -> WrappedArrow p i a c
lmap  a -> b
f   WrappedArrow p i b c
k = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f 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 :: forall c d i b.
(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 forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr c -> d
g
  {-# INLINE dimap #-}
  {-# INLINE lmap #-}
  {-# INLINE rmap #-}

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

instance Arrow p => Strong (WrappedArrow p) where
  first' :: forall i a b c.
WrappedArrow p i a b -> WrappedArrow p i (a, c) (b, c)
first'  (WrapArrow p a b
k) = forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first p a b
k)
  second' :: forall i a b c.
WrappedArrow p i a b -> WrappedArrow p i (c, a) (c, b)
second' (WrapArrow p a b
k) = forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (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' :: forall i a b c.
WrappedArrow p i a b -> WrappedArrow p i (Either a c) (Either b c)
left'  (WrapArrow p a b
k) = forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left p a b
k)
  right' :: forall i a b c.
WrappedArrow p i a b -> WrappedArrow p i (Either c a) (Either c b)
right' (WrapArrow p a b
k) = forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow (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 :: forall (is :: IxList) s t a b.
Optic An_Iso is s t a b -> arr a b -> arr s t
overA = 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 :: forall (is :: IxList) s t a b.
Optic A_Lens is s t a b -> arr a b -> arr s t
overA = 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 :: forall (is :: IxList) s t a b.
Optic A_Prism is s t a b -> arr a b -> arr s t
overA = 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 :: forall (is :: IxList) s t a b.
Optic An_AffineTraversal is s t a b -> arr a b -> arr s t
overA = 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 :: forall k (arr :: * -> * -> *) (is :: IxList) s t a b.
(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
o arr s b
p = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ 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) forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& arr s b
p forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry' 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__ :: 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__ Optic k is s t a b
o = forall (p :: * -> * -> *) i a b. WrappedArrow p i a b -> p a b
unwrapArrow forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. 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 forall a b c. Coercible a b => (b -> c) -> (a -> b) -> a -> c
.# forall (p :: * -> * -> *) i a b. p a b -> WrappedArrow p i a b
WrapArrow
{-# INLINE overA__ #-}