Arrow.hs

-- |
-- 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 { unwrapArrow :: p a b }

instance C.Category p => C.Category (WrappedArrow p i) where
  WrapArrow f . WrapArrow g = WrapArrow (f C.. g)
  id                        = WrapArrow C.id
  {-# INLINE (.) #-}
  {-# INLINE id #-}

instance Arrow p => Arrow (WrappedArrow p i) where
  arr                         = WrapArrow #. arr
  first                       = WrapArrow #. first  .# unwrapArrow
  second                      = WrapArrow #. second .# unwrapArrow
  WrapArrow a *** WrapArrow b = WrapArrow (a *** b)
  WrapArrow a &&& WrapArrow b = WrapArrow (a &&& b)
  {-# INLINE arr #-}
  {-# INLINE first #-}
  {-# INLINE second #-}
  {-# INLINE (***) #-}
  {-# INLINE (&&&) #-}

instance Arrow p => Profunctor (WrappedArrow p) where
  dimap f g k = arr f >>> k >>> arr g
  lmap  f   k = arr f >>> k
  rmap    g k =           k >>> arr g
  {-# INLINE dimap #-}
  {-# INLINE lmap #-}
  {-# INLINE rmap #-}

  lcoerce' = lmap coerce
  rcoerce' = rmap coerce
  {-# INLINE lcoerce' #-}
  {-# INLINE rcoerce' #-}

instance Arrow p => Strong (WrappedArrow p) where
  first'  (WrapArrow k) = WrapArrow (first k)
  second' (WrapArrow k) = WrapArrow (second k)
  {-# INLINE first' #-}
  {-# INLINE second' #-}

instance ArrowChoice p => Choice (WrappedArrow p) where
  left'  (WrapArrow k) = WrapArrow (left k)
  right' (WrapArrow k) = WrapArrow (right 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 = overA__
  {-# INLINE overA #-}

instance Arrow arr => ArrowOptic A_Lens arr where
  overA = overA__
  {-# INLINE overA #-}

instance ArrowChoice arr => ArrowOptic A_Prism arr where
  overA = overA__
  {-# INLINE overA #-}

instance ArrowChoice arr => ArrowOptic An_AffineTraversal arr where
  overA = 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 o p = arr (flip $ set o) &&& p >>> arr (uncurry' 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__ o = unwrapArrow #. getOptic o .# WrapArrow
{-# INLINE overA__ #-}