{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Bitraversable
-- Copyright   :  (C) 2011-2016 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- @since 4.10.0.0
----------------------------------------------------------------------------
module Data.Bitraversable
  ( Bitraversable(..)
  , bisequenceA
  , bisequence
  , bimapM
  , bifor
  , biforM
  , bimapAccumL
  , bimapAccumR
  , bimapDefault
  , bifoldMapDefault
  ) where

import Control.Applicative
import Data.Bifunctor
import Data.Bifoldable
import Data.Coerce
import Data.Functor.Identity (Identity(..))
import Data.Functor.Utils (StateL(..), StateR(..))
import GHC.Generics (K1(..))

-- | 'Bitraversable' identifies bifunctorial data structures whose elements can
-- be traversed in order, performing 'Applicative' or 'Monad' actions at each
-- element, and collecting a result structure with the same shape.
--
-- As opposed to 'Traversable' data structures, which have one variety of
-- element on which an action can be performed, 'Bitraversable' data structures
-- have two such varieties of elements.
--
-- A definition of 'bitraverse' must satisfy the following laws:
--
-- [Naturality]
--   @'bitraverse' (t . f) (t . g) ≡ t . 'bitraverse' f g@
--   for every applicative transformation @t@
--
-- [Identity]
--   @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@
--
-- [Composition]
--   @'Data.Functor.Compose.Compose' .
--    'fmap' ('bitraverse' g1 g2) .
--    'bitraverse' f1 f2
--     ≡ 'bitraverse' ('Data.Functor.Compose.Compose' . 'fmap' g1 . f1)
--                  ('Data.Functor.Compose.Compose' . 'fmap' g2 . f2)@
--
-- where an /applicative transformation/ is a function
--
-- @t :: ('Applicative' f, 'Applicative' g) => f a -> g a@
--
-- preserving the 'Applicative' operations:
--
-- @
-- t ('pure' x) = 'pure' x
-- t (f '<*>' x) = t f '<*>' t x
-- @
--
-- and the identity functor 'Identity' and composition functors
-- 'Data.Functor.Compose.Compose' are from "Data.Functor.Identity" and
-- "Data.Functor.Compose".
--
-- Some simple examples are 'Either' and '(,)':
--
-- > instance Bitraversable Either where
-- >   bitraverse f _ (Left x) = Left <$> f x
-- >   bitraverse _ g (Right y) = Right <$> g y
-- >
-- > instance Bitraversable (,) where
-- >   bitraverse f g (x, y) = (,) <$> f x <*> g y
--
-- 'Bitraversable' relates to its superclasses in the following ways:
--
-- @
-- 'bimap' f g ≡ 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)
-- 'bifoldMap' f g = 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)
-- @
--
-- These are available as 'bimapDefault' and 'bifoldMapDefault' respectively.
--
-- @since 4.10.0.0
class (Bifunctor t, Bifoldable t) => Bitraversable t where
  -- | Evaluates the relevant functions at each element in the structure,
  -- running the action, and builds a new structure with the same shape, using
  -- the results produced from sequencing the actions.
  --
  -- @'bitraverse' f g ≡ 'bisequenceA' . 'bimap' f g@
  --
  -- For a version that ignores the results, see 'bitraverse_'.
  --
  -- @since 4.10.0.0
  bitraverse :: Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
  bitraverse a -> f c
f b -> f d
g = t (f c) (f d) -> f (t c d)
forall (t :: * -> * -> *) (f :: * -> *) a b.
(Bitraversable t, Applicative f) =>
t (f a) (f b) -> f (t a b)
bisequenceA (t (f c) (f d) -> f (t c d))
-> (t a b -> t (f c) (f d)) -> t a b -> f (t c d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f c) -> (b -> f d) -> t a b -> t (f c) (f d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> f c
f b -> f d
g

-- | Alias for 'bisequence'.
--
-- @since 4.10.0.0
bisequenceA :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b)
bisequenceA :: t (f a) (f b) -> f (t a b)
bisequenceA = t (f a) (f b) -> f (t a b)
forall (t :: * -> * -> *) (f :: * -> *) a b.
(Bitraversable t, Applicative f) =>
t (f a) (f b) -> f (t a b)
bisequence

-- | Alias for 'bitraverse'.
--
-- @since 4.10.0.0
bimapM :: (Bitraversable t, Applicative f)
       => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM :: (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM = (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse

-- | Sequences all the actions in a structure, building a new structure with
-- the same shape using the results of the actions. For a version that ignores
-- the results, see 'bisequence_'.
--
-- @'bisequence' ≡ 'bitraverse' 'id' 'id'@
--
-- @since 4.10.0.0
bisequence :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b)
bisequence :: t (f a) (f b) -> f (t a b)
bisequence = (f a -> f a) -> (f b -> f b) -> t (f a) (f b) -> f (t a b)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse f a -> f a
forall a. a -> a
id f b -> f b
forall a. a -> a
id

-- | @since 4.10.0.0
instance Bitraversable (,) where
  bitraverse :: (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)
bitraverse a -> f c
f b -> f d
g ~(a
a, b
b) = (c -> d -> (c, d)) -> f c -> f d -> f (c, d)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (a -> f c
f a
a) (b -> f d
g b
b)

-- | @since 4.10.0.0
instance Bitraversable ((,,) x) where
  bitraverse :: (a -> f c) -> (b -> f d) -> (x, a, b) -> f (x, c, d)
bitraverse a -> f c
f b -> f d
g ~(x
x, a
a, b
b) = (c -> d -> (x, c, d)) -> f c -> f d -> f (x, c, d)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((,,) x
x) (a -> f c
f a
a) (b -> f d
g b
b)

-- | @since 4.10.0.0
instance Bitraversable ((,,,) x y) where
  bitraverse :: (a -> f c) -> (b -> f d) -> (x, y, a, b) -> f (x, y, c, d)
bitraverse a -> f c
f b -> f d
g ~(x
x, y
y, a
a, b
b) = (c -> d -> (x, y, c, d)) -> f c -> f d -> f (x, y, c, d)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((,,,) x
x y
y) (a -> f c
f a
a) (b -> f d
g b
b)

-- | @since 4.10.0.0
instance Bitraversable ((,,,,) x y z) where
  bitraverse :: (a -> f c) -> (b -> f d) -> (x, y, z, a, b) -> f (x, y, z, c, d)
bitraverse a -> f c
f b -> f d
g ~(x
x, y
y, z
z, a
a, b
b) = (c -> d -> (x, y, z, c, d)) -> f c -> f d -> f (x, y, z, c, d)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((,,,,) x
x y
y z
z) (a -> f c
f a
a) (b -> f d
g b
b)

-- | @since 4.10.0.0
instance Bitraversable ((,,,,,) x y z w) where
  bitraverse :: (a -> f c)
-> (b -> f d) -> (x, y, z, w, a, b) -> f (x, y, z, w, c, d)
bitraverse a -> f c
f b -> f d
g ~(x
x, y
y, z
z, w
w, a
a, b
b) = (c -> d -> (x, y, z, w, c, d))
-> f c -> f d -> f (x, y, z, w, c, d)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((,,,,,) x
x y
y z
z w
w) (a -> f c
f a
a) (b -> f d
g b
b)

-- | @since 4.10.0.0
instance Bitraversable ((,,,,,,) x y z w v) where
  bitraverse :: (a -> f c)
-> (b -> f d) -> (x, y, z, w, v, a, b) -> f (x, y, z, w, v, c, d)
bitraverse a -> f c
f b -> f d
g ~(x
x, y
y, z
z, w
w, v
v, a
a, b
b) =
    (c -> d -> (x, y, z, w, v, c, d))
-> f c -> f d -> f (x, y, z, w, v, c, d)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((,,,,,,) x
x y
y z
z w
w v
v) (a -> f c
f a
a) (b -> f d
g b
b)

-- | @since 4.10.0.0
instance Bitraversable Either where
  bitraverse :: (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)
bitraverse a -> f c
f b -> f d
_ (Left a
a) = c -> Either c d
forall a b. a -> Either a b
Left (c -> Either c d) -> f c -> f (Either c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
a
  bitraverse a -> f c
_ b -> f d
g (Right b
b) = d -> Either c d
forall a b. b -> Either a b
Right (d -> Either c d) -> f d -> f (Either c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f d
g b
b

-- | @since 4.10.0.0
instance Bitraversable Const where
  bitraverse :: (a -> f c) -> (b -> f d) -> Const a b -> f (Const c d)
bitraverse a -> f c
f b -> f d
_ (Const a
a) = c -> Const c d
forall k a (b :: k). a -> Const a b
Const (c -> Const c d) -> f c -> f (Const c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
a

-- | @since 4.10.0.0
instance Bitraversable (K1 i) where
  bitraverse :: (a -> f c) -> (b -> f d) -> K1 i a b -> f (K1 i c d)
bitraverse a -> f c
f b -> f d
_ (K1 a
c) = c -> K1 i c d
forall k i c (p :: k). c -> K1 i c p
K1 (c -> K1 i c d) -> f c -> f (K1 i c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
c

-- | 'bifor' is 'bitraverse' with the structure as the first argument. For a
-- version that ignores the results, see 'bifor_'.
--
-- @since 4.10.0.0
bifor :: (Bitraversable t, Applicative f)
      => t a b -> (a -> f c) -> (b -> f d) -> f (t c d)
bifor :: t a b -> (a -> f c) -> (b -> f d) -> f (t c d)
bifor t a b
t a -> f c
f b -> f d
g = (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> f c
f b -> f d
g t a b
t

-- | Alias for 'bifor'.
--
-- @since 4.10.0.0
biforM :: (Bitraversable t, Applicative f)
       => t a b -> (a -> f c) -> (b -> f d) -> f (t c d)
biforM :: t a b -> (a -> f c) -> (b -> f d) -> f (t c d)
biforM = t a b -> (a -> f c) -> (b -> f d) -> f (t c d)
forall (t :: * -> * -> *) (f :: * -> *) a b c d.
(Bitraversable t, Applicative f) =>
t a b -> (a -> f c) -> (b -> f d) -> f (t c d)
bifor

-- | The 'bimapAccumL' function behaves like a combination of 'bimap' and
-- 'bifoldl'; it traverses a structure from left to right, threading a state
-- of type @a@ and using the given actions to compute new elements for the
-- structure.
--
-- @since 4.10.0.0
bimapAccumL :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e))
            -> a -> t b d -> (a, t c e)
bimapAccumL :: (a -> b -> (a, c))
-> (a -> d -> (a, e)) -> a -> t b d -> (a, t c e)
bimapAccumL a -> b -> (a, c)
f a -> d -> (a, e)
g a
s t b d
t
  = StateL a (t c e) -> a -> (a, t c e)
forall s a. StateL s a -> s -> (s, a)
runStateL ((b -> StateL a c) -> (d -> StateL a e) -> t b d -> StateL a (t c e)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse ((a -> (a, c)) -> StateL a c
forall s a. (s -> (s, a)) -> StateL s a
StateL ((a -> (a, c)) -> StateL a c)
-> (b -> a -> (a, c)) -> b -> StateL a c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b -> (a, c)) -> b -> a -> (a, c)
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> (a, c)
f) ((a -> (a, e)) -> StateL a e
forall s a. (s -> (s, a)) -> StateL s a
StateL ((a -> (a, e)) -> StateL a e)
-> (d -> a -> (a, e)) -> d -> StateL a e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> d -> (a, e)) -> d -> a -> (a, e)
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> d -> (a, e)
g) t b d
t) a
s

-- | The 'bimapAccumR' function behaves like a combination of 'bimap' and
-- 'bifoldl'; it traverses a structure from right to left, threading a state
-- of type @a@ and using the given actions to compute new elements for the
-- structure.
--
-- @since 4.10.0.0
bimapAccumR :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e))
            -> a -> t b d -> (a, t c e)
bimapAccumR :: (a -> b -> (a, c))
-> (a -> d -> (a, e)) -> a -> t b d -> (a, t c e)
bimapAccumR a -> b -> (a, c)
f a -> d -> (a, e)
g a
s t b d
t
  = StateR a (t c e) -> a -> (a, t c e)
forall s a. StateR s a -> s -> (s, a)
runStateR ((b -> StateR a c) -> (d -> StateR a e) -> t b d -> StateR a (t c e)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse ((a -> (a, c)) -> StateR a c
forall s a. (s -> (s, a)) -> StateR s a
StateR ((a -> (a, c)) -> StateR a c)
-> (b -> a -> (a, c)) -> b -> StateR a c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b -> (a, c)) -> b -> a -> (a, c)
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> (a, c)
f) ((a -> (a, e)) -> StateR a e
forall s a. (s -> (s, a)) -> StateR s a
StateR ((a -> (a, e)) -> StateR a e)
-> (d -> a -> (a, e)) -> d -> StateR a e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> d -> (a, e)) -> d -> a -> (a, e)
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> d -> (a, e)
g) t b d
t) a
s

-- | A default definition of 'bimap' in terms of the 'Bitraversable'
-- operations.
--
-- @'bimapDefault' f g ≡
--     'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)@
--
-- @since 4.10.0.0
bimapDefault :: forall t a b c d . Bitraversable t
             => (a -> b) -> (c -> d) -> t a c -> t b d
-- See Note [Function coercion] in Data.Functor.Utils.
bimapDefault :: (a -> b) -> (c -> d) -> t a c -> t b d
bimapDefault = ((a -> Identity b)
 -> (c -> Identity d) -> t a c -> Identity (t b d))
-> (a -> b) -> (c -> d) -> t a c -> t b d
coerce
  ((a -> Identity b) -> (c -> Identity d) -> t a c -> Identity (t b d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse :: (a -> Identity b)
              -> (c -> Identity d) -> t a c -> Identity (t b d))
{-# INLINE bimapDefault #-}

-- | A default definition of 'bifoldMap' in terms of the 'Bitraversable'
-- operations.
--
-- @'bifoldMapDefault' f g ≡
--    'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)@
--
-- @since 4.10.0.0
bifoldMapDefault :: forall t m a b . (Bitraversable t, Monoid m)
                 => (a -> m) -> (b -> m) -> t a b -> m
-- See Note [Function coercion] in Data.Functor.Utils.
bifoldMapDefault :: (a -> m) -> (b -> m) -> t a b -> m
bifoldMapDefault = ((a -> Const m ())
 -> (b -> Const m ()) -> t a b -> Const m (t () ()))
-> (a -> m) -> (b -> m) -> t a b -> m
coerce
  ((a -> Const m ())
-> (b -> Const m ()) -> t a b -> Const m (t () ())
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse :: (a -> Const m ())
              -> (b -> Const m ()) -> t a b -> Const m (t () ()))
{-# INLINE bifoldMapDefault #-}