{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}

module Data.Functor.Coapply (
  -- * Types
    type (+)
  -- * Coapply
  , Coapply(..)
  , apply
  , select
  , coselect
  , coeval
  , appendl
  , concatl
  , concatr
  , concatl'
  , concatr'
  -- * Select
  , Select
  , eitherS
  , branch
  , bindBool
  -- * Distributive1
  , Distributive1(..)
  , cotraverse1
) where

import Control.Arrow
import Control.Monad.Trans.Reader
import Data.Bifunctor
import Data.Bool
import Data.Coerce
import Data.Foldable (foldr')
import Data.Functor.Apply
import Data.Functor.Compose
import Data.Functor.Const
import Data.Functor.Identity
import Data.Functor.Product
import Data.List.NonEmpty (NonEmpty(..))
import Data.Tagged
import GHC.Generics (U1(..), (:*:)(..), (:.:)(..), Par1(..)) -- , Rec1(..), M1(..)

-- Inlined from Test.Logic (lawz)
type (+) = Either

{-
foo :: Coapplicative f => (a -> c) -> (b -> c) -> f (Either a b) -> c
foo f g = either (f . copure) (g . copure) . coapply

foo' :: Coapplicative f => (a -> c) -> (b -> c) -> f (Either a b) -> c
foo' f g = either f g . copure

--TODO refactor w/ idempotent prop
coapplyl :: Coapply f => f a -> f a + f b
coapplyl = coapply . fmap Left

coevall' :: Coapply f => f a -> f (a + b)
coevall' = coeval . fmap Left

coapplyr :: Coapply f => f b -> f a + f b
coapplyr = coapply . fmap Right

coevalr' :: Coapply f => f b -> f (a + b)
coevalr' = coeval . fmap Right
-}

---------------------------------------------------------------------
-- Coapply
---------------------------------------------------------------------

-- |
--
-- @
-- 'coapply' . 'fmap' 'Left' = 'Left'
-- 'coeval' . 'fmap' 'Left' = 'fmap' 'Left'
-- 'coeval' . 'fmap' 'Right' = 'fmap' 'Right'
-- @
--
class Functor f => Coapply f where
  coapply :: f (a + b) -> (f a + f b)

apply :: Apply f => (f a , f b) -> f (a , b)
apply :: forall (f :: * -> *) a b. Apply f => (f a, f b) -> f (a, b)
apply = (f a -> f b -> f (a, b)) -> (f a, f b) -> f (a, b)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((f a -> f b -> f (a, b)) -> (f a, f b) -> f (a, b))
-> (f a -> f b -> f (a, b)) -> (f a, f b) -> f (a, b)
forall a b. (a -> b) -> a -> b
$ (a -> b -> (a, b)) -> f a -> f b -> f (a, b)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> f a -> f b -> f c
liftF2 (,)

select :: Functor f => f (a , b) -> (f a , f b)
select :: forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
select = ((a, b) -> a) -> f (a, b) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> a
forall a b. (a, b) -> a
fst (f (a, b) -> f a) -> (f (a, b) -> f b) -> f (a, b) -> (f a, f b)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((a, b) -> b) -> f (a, b) -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> b
forall a b. (a, b) -> b
snd

coselect :: Functor f => (f a + f b) -> f (a + b)
coselect :: forall (f :: * -> *) a b. Functor f => (f a + f b) -> f (a + b)
coselect = (a -> a + b) -> f a -> f (a + b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a + b
forall a b. a -> Either a b
Left (f a -> f (a + b))
-> (f b -> f (a + b)) -> Either (f a) (f b) -> f (a + b)
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| (b -> a + b) -> f b -> f (a + b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> a + b
forall a b. b -> Either a b
Right

-- | Evaluate a coapplicative expression, exiting on the first 'Left' if it exists.
--
-- >>> coeval $ Left "foo" :| [Right "bar"]
-- Left "foo" :| []
-- >>> coeval $ Right "foo" :| [Right "bar"]
-- Right "foo" :| [Right "bar"]
--
coeval :: Coapply f => f (a + b) -> f (a + b)
coeval :: forall (f :: * -> *) a b. Coapply f => f (a + b) -> f (a + b)
coeval = (f a + f b) -> f (a + b)
forall (f :: * -> *) a b. Functor f => (f a + f b) -> f (a + b)
coselect ((f a + f b) -> f (a + b))
-> (f (a + b) -> f a + f b) -> f (a + b) -> f (a + b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (a + b) -> f a + f b
forall a b. f (a + b) -> f a + f b
forall (f :: * -> *) a b. Coapply f => f (a + b) -> f a + f b
coapply

-- | Append two semigroup values or return the @Right@ one.
appendl :: Semigroup a => a -> a + b -> a + b
appendl :: forall a b. Semigroup a => a -> (a + b) -> a + b
appendl a
a1 (Left a
a2) = a -> Either a b
forall a b. a -> Either a b
Left (a
a1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a2)
appendl a
_  (Right b
b) = b -> Either a b
forall a b. b -> Either a b
Right b
b

concatl :: [a + b] -> [a]
concatl :: forall a b. [a + b] -> [a]
concatl = ((a + b) -> [a] -> [a]) -> [a] -> [a + b] -> [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((a -> [a] -> [a]) -> (b -> [a] -> [a]) -> (a + b) -> [a] -> [a]
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
either (:) (([a] -> [a]) -> b -> [a] -> [a]
forall a b. a -> b -> a
const [a] -> [a]
forall a. a -> a
id)) []

concatr :: [a + b] -> [b]
concatr :: forall a b. [a + b] -> [b]
concatr = ((a + b) -> [b] -> [b]) -> [b] -> [a + b] -> [b]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((a -> [b] -> [b]) -> (b -> [b] -> [b]) -> (a + b) -> [b] -> [b]
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
either (([b] -> [b]) -> a -> [b] -> [b]
forall a b. a -> b -> a
const [b] -> [b]
forall a. a -> a
id) (:)) []

concatl' :: [a + b] -> [a]
concatl' :: forall a b. [a + b] -> [a]
concatl' = ((a + b) -> [a] -> [a]) -> [a] -> [a + b] -> [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' ((a -> [a] -> [a]) -> (b -> [a] -> [a]) -> (a + b) -> [a] -> [a]
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
either (:) (([a] -> [a]) -> b -> [a] -> [a]
forall a b. a -> b -> a
const [a] -> [a]
forall a. a -> a
id)) []

concatr' :: [a + b] -> [b]
concatr' :: forall a b. [a + b] -> [b]
concatr' = ((a + b) -> [b] -> [b]) -> [b] -> [a + b] -> [b]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' ((a -> [b] -> [b]) -> (b -> [b] -> [b]) -> (a + b) -> [b] -> [b]
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
either (([b] -> [b]) -> a -> [b] -> [b]
forall a b. a -> b -> a
const [b] -> [b]
forall a. a -> a
id) (:)) []

---------------------------------------------------------------------
-- Select
---------------------------------------------------------------------

type Select f = (Coapply f, Apply f)

eitherS :: Select f => f (a + b) -> f (a -> c) -> f (b -> c) -> f c
eitherS :: forall (f :: * -> *) a b c.
Select f =>
f (a + b) -> f (a -> c) -> f (b -> c) -> f c
eitherS f (a + b)
ab f (a -> c)
f f (b -> c)
g = (f a -> f c) -> (f b -> f c) -> Either (f a) (f b) -> f c
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
either (f (a -> c)
f f (a -> c) -> f a -> f c
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.>) (f (b -> c)
g f (b -> c) -> f b -> f c
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.>) (Either (f a) (f b) -> f c) -> Either (f a) (f b) -> f c
forall a b. (a -> b) -> a -> b
$ f (a + b) -> Either (f a) (f b)
forall a b. f (a + b) -> f a + f b
forall (f :: * -> *) a b. Coapply f => f (a + b) -> f a + f b
coapply f (a + b)
ab

-- | Branch on a boolean value, skipping unnecessary effects.
--
-- >>> head $ branch (True :| []) (print "foo" :| []) (print "bar" :| [])
-- "foo"
--
branch :: Select f => f Bool -> f a -> f a -> f a
branch :: forall (f :: * -> *) a. Select f => f Bool -> f a -> f a -> f a
branch f Bool
x f a
t f a
e = f (() + ()) -> f (() -> a) -> f (() -> a) -> f a
forall (f :: * -> *) a b c.
Select f =>
f (a + b) -> f (a -> c) -> f (b -> c) -> f c
eitherS ((() + ()) -> (() + ()) -> Bool -> () + ()
forall a. a -> a -> Bool -> a
bool (() -> () + ()
forall a b. b -> Either a b
Right ()) (() -> () + ()
forall a b. a -> Either a b
Left ()) (Bool -> () + ()) -> f Bool -> f (() + ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Bool
x) (a -> () -> a
forall a b. a -> b -> a
const (a -> () -> a) -> f a -> f (() -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
t) (a -> () -> a
forall a b. a -> b -> a
const (a -> () -> a) -> f a -> f (() -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
e)

bindBool :: Select f => f Bool -> (Bool -> f a) -> f a
bindBool :: forall (f :: * -> *) a. Select f => f Bool -> (Bool -> f a) -> f a
bindBool f Bool
x Bool -> f a
f = f Bool -> f a -> f a -> f a
forall (f :: * -> *) a. Select f => f Bool -> f a -> f a -> f a
branch f Bool
x (Bool -> f a
f Bool
False) (Bool -> f a
f Bool
True)

---------------------------------------------------------------------
-- Distributive1
---------------------------------------------------------------------

class Functor g => Distributive1 g where
  {-# MINIMAL distribute1 | collect1 #-}

  -- | The dual of 'Data.Semigroup.Traversable.sequence1'
  --
  -- @
  -- 'distribute1' = 'collect1' 'id'
  -- 'distribute1' . 'distribute1' = 'id'
  -- @
  distribute1 :: Coapply f => f (g a) -> g (f a)
  distribute1 = (g a -> g a) -> f (g a) -> g (f a)
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive1 g, Coapply f) =>
(a -> g b) -> f a -> g (f b)
forall (f :: * -> *) a b. Coapply f => (a -> g b) -> f a -> g (f b)
collect1 g a -> g a
forall a. a -> a
id

  -- |
  -- @
  -- 'collect1' f = 'distribute1' . 'fmap' f
  -- 'fmap' f = 'runIdentity' . 'collect1' ('Identity' . f)
  -- 'fmap' 'distribute1' . 'collect1' f = 'getCompose' . 'collect1' ('Compose' . f)
  -- @
  collect1 :: Coapply f => (a -> g b) -> f a -> g (f b)
  collect1 a -> g b
f = f (g b) -> g (f b)
forall (g :: * -> *) (f :: * -> *) a.
(Distributive1 g, Coapply f) =>
f (g a) -> g (f a)
forall (f :: * -> *) a. Coapply f => f (g a) -> g (f a)
distribute1 (f (g b) -> g (f b)) -> (f a -> f (g b)) -> f a -> g (f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> g b) -> f a -> f (g b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> g b
f

-- | The dual of 'Data.Semigroup.Traversable.traverse1'
--
-- @
-- 'cotraverse1' f = 'fmap' f . 'distribute1'
-- @
cotraverse1 :: Coapply f => Distributive1 g => (f a -> b) -> f (g a) -> g b
cotraverse1 :: forall (f :: * -> *) (g :: * -> *) a b.
(Coapply f, Distributive1 g) =>
(f a -> b) -> f (g a) -> g b
cotraverse1 f a -> b
f = (f a -> b) -> g (f a) -> g b
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> b
f (g (f a) -> g b) -> (f (g a) -> g (f a)) -> f (g a) -> g b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (g a) -> g (f a)
forall (g :: * -> *) (f :: * -> *) a.
(Distributive1 g, Coapply f) =>
f (g a) -> g (f a)
forall (f :: * -> *) a. Coapply f => f (g a) -> g (f a)
distribute1

---------------------------------------------------------------------
-- Instances
---------------------------------------------------------------------

instance Coapply Identity where
  coapply :: forall a b. Identity (a + b) -> Identity a + Identity b
coapply (Identity a + b
ab) = (a -> Identity a + Identity b)
-> (b -> Identity a + Identity b)
-> (a + b)
-> Identity a + Identity b
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
either (Identity a -> Identity a + Identity b
forall a b. a -> Either a b
Left (Identity a -> Identity a + Identity b)
-> (a -> Identity a) -> a -> Identity a + Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Identity a
forall a. a -> Identity a
Identity) (Identity b -> Identity a + Identity b
forall a b. b -> Either a b
Right (Identity b -> Identity a + Identity b)
-> (b -> Identity b) -> b -> Identity a + Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Identity b
forall a. a -> Identity a
Identity) a + b
ab

instance Coapply (Const r) where
  coapply :: forall a b. Const r (a + b) -> Const r a + Const r b
coapply (Const r
r) = Const r a -> Either (Const r a) (Const r b)
forall a b. a -> Either a b
Left (r -> Const r a
forall {k} a (b :: k). a -> Const a b
Const r
r)

instance Coapply (Tagged k) where
  coapply :: forall a b. Tagged k (a + b) -> Tagged k a + Tagged k b
coapply (Tagged a + b
ab) = (a -> Tagged k a + Tagged k b)
-> (b -> Tagged k a + Tagged k b)
-> (a + b)
-> Tagged k a + Tagged k b
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
either (Tagged k a -> Tagged k a + Tagged k b
forall a b. a -> Either a b
Left (Tagged k a -> Tagged k a + Tagged k b)
-> (a -> Tagged k a) -> a -> Tagged k a + Tagged k b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Tagged k a
forall {k} (s :: k) b. b -> Tagged s b
Tagged) (Tagged k b -> Tagged k a + Tagged k b
forall a b. b -> Either a b
Right (Tagged k b -> Tagged k a + Tagged k b)
-> (b -> Tagged k b) -> b -> Tagged k a + Tagged k b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Tagged k b
forall {k} (s :: k) b. b -> Tagged s b
Tagged) a + b
ab

instance Coapply Maybe where
  coapply :: forall a b. Maybe (a + b) -> Maybe a + Maybe b
coapply Maybe (a + b)
Nothing = Maybe a -> Either (Maybe a) (Maybe b)
forall a b. a -> Either a b
Left Maybe a
forall a. Maybe a
Nothing
  coapply (Just a + b
e) = (a -> Maybe a)
-> (b -> Maybe b) -> (a + b) -> Either (Maybe a) (Maybe b)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> Maybe a
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b -> Maybe b
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a + b
e

instance Coapply [] where
  coapply :: forall a b. [a + b] -> [a] + [b]
coapply [] = [a] -> Either [a] [b]
forall a b. a -> Either a b
Left []
  coapply (Left a
x : [a + b]
es) = [a] -> Either [a] [b]
forall a b. a -> Either a b
Left ([a] -> Either [a] [b]) -> [a] -> Either [a] [b]
forall a b. (a -> b) -> a -> b
$ a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a + b] -> [a]
forall a b. [a + b] -> [a]
concatl' [a + b]
es
  coapply (Right b
y : [a + b]
es) = [b] -> Either [a] [b]
forall a b. b -> Either a b
Right ([b] -> Either [a] [b]) -> [b] -> Either [a] [b]
forall a b. (a -> b) -> a -> b
$ b
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [a + b] -> [b]
forall a b. [a + b] -> [b]
concatr' [a + b]
es

instance Coapply NonEmpty where
  coapply :: forall a b. NonEmpty (a + b) -> NonEmpty a + NonEmpty b
coapply (Left a
x :| [a + b]
es) = NonEmpty a -> Either (NonEmpty a) (NonEmpty b)
forall a b. a -> Either a b
Left (NonEmpty a -> Either (NonEmpty a) (NonEmpty b))
-> NonEmpty a -> Either (NonEmpty a) (NonEmpty b)
forall a b. (a -> b) -> a -> b
$ a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a + b] -> [a]
forall a b. [a + b] -> [a]
concatl' [a + b]
es
  coapply (Right b
y :| [a + b]
es) = NonEmpty b -> Either (NonEmpty a) (NonEmpty b)
forall a b. b -> Either a b
Right (NonEmpty b -> Either (NonEmpty a) (NonEmpty b))
-> NonEmpty b -> Either (NonEmpty a) (NonEmpty b)
forall a b. (a -> b) -> a -> b
$ b
y b -> [b] -> NonEmpty b
forall a. a -> [a] -> NonEmpty a
:| [a + b] -> [b]
forall a b. [a + b] -> [b]
concatr' [a + b]
es

instance Coapply ((,) r) where
  coapply :: forall a b. (r, a + b) -> (r, a) + (r, b)
coapply (r
r, a + b
a) = (a -> (r, a) + (r, b))
-> (b -> (r, a) + (r, b)) -> (a + b) -> (r, a) + (r, b)
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
either ((r, a) -> (r, a) + (r, b)
forall a b. a -> Either a b
Left ((r, a) -> (r, a) + (r, b))
-> (a -> (r, a)) -> a -> (r, a) + (r, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r
r,)) ((r, b) -> (r, a) + (r, b)
forall a b. b -> Either a b
Right ((r, b) -> (r, a) + (r, b))
-> (b -> (r, b)) -> b -> (r, a) + (r, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r
r,)) a + b
a

instance Monoid r => Coapply ((->) r) where
  coapply :: forall a b. (r -> (a + b)) -> (r -> a) + (r -> b)
coapply r -> (a + b)
f = (a -> (r -> a) + (r -> b))
-> (b -> (r -> a) + (r -> b)) -> (a + b) -> (r -> a) + (r -> b)
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
either ((r -> a) -> (r -> a) + (r -> b)
forall a b. a -> Either a b
Left ((r -> a) -> (r -> a) + (r -> b))
-> (a -> r -> a) -> a -> (r -> a) + (r -> b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> r -> a
forall a b. a -> b -> a
const) ((r -> b) -> (r -> a) + (r -> b)
forall a b. b -> Either a b
Right ((r -> b) -> (r -> a) + (r -> b))
-> (b -> r -> b) -> b -> (r -> a) + (r -> b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> r -> b
forall a b. a -> b -> a
const) ((a + b) -> (r -> a) + (r -> b)) -> (a + b) -> (r -> a) + (r -> b)
forall a b. (a -> b) -> a -> b
$ r -> (a + b)
f r
forall a. Monoid a => a
mempty

--instance Monoid m => Coapply (ReaderT r m) where

instance (Coapply f, Coapply g) => Coapply (Compose f g) where
  coapply :: forall a b. Compose f g (a + b) -> Compose f g a + Compose f g b
coapply (Compose f (g (a + b))
ab) = (f (g a) -> Compose f g a)
-> (f (g b) -> Compose f g b)
-> Either (f (g a)) (f (g b))
-> Either (Compose f g a) (Compose f g b)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap f (g a) -> Compose f g a
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose f (g b) -> Compose f g b
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Either (f (g a)) (f (g b))
 -> Either (Compose f g a) (Compose f g b))
-> (f (g (a + b)) -> Either (f (g a)) (f (g b)))
-> f (g (a + b))
-> Either (Compose f g a) (Compose f g b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (g a + g b) -> Either (f (g a)) (f (g b))
forall a b. f (a + b) -> f a + f b
forall (f :: * -> *) a b. Coapply f => f (a + b) -> f a + f b
coapply (f (g a + g b) -> Either (f (g a)) (f (g b)))
-> (f (g (a + b)) -> f (g a + g b))
-> f (g (a + b))
-> Either (f (g a)) (f (g b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g (a + b) -> g a + g b) -> f (g (a + b)) -> f (g a + g b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g (a + b) -> g a + g b
forall a b. g (a + b) -> g a + g b
forall (f :: * -> *) a b. Coapply f => f (a + b) -> f a + f b
coapply (f (g (a + b)) -> Either (Compose f g a) (Compose f g b))
-> f (g (a + b)) -> Either (Compose f g a) (Compose f g b)
forall a b. (a -> b) -> a -> b
$ f (g (a + b))
ab


--TODO: push upstream?
--instance Distributive (Either e) where
--  distribute' = first copure . coapply

instance Distributive1 Identity where
  distribute1 :: forall (f :: * -> *) a.
Coapply f =>
f (Identity a) -> Identity (f a)
distribute1 = f a -> Identity (f a)
forall a. a -> Identity a
Identity (f a -> Identity (f a))
-> (f (Identity a) -> f a) -> f (Identity a) -> Identity (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identity a -> a) -> f (Identity a) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity a -> a
forall a. Identity a -> a
runIdentity

instance Distributive1 (Tagged t) where
  distribute1 :: forall (f :: * -> *) a.
Coapply f =>
f (Tagged t a) -> Tagged t (f a)
distribute1 = f a -> Tagged t (f a)
forall {k} (s :: k) b. b -> Tagged s b
Tagged (f a -> Tagged t (f a))
-> (f (Tagged t a) -> f a) -> f (Tagged t a) -> Tagged t (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tagged t a -> a) -> f (Tagged t a) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tagged t a -> a
forall {k} (s :: k) b. Tagged s b -> b
unTagged

instance Distributive1 Maybe where
  distribute1 :: forall (f :: * -> *) a. Coapply f => f (Maybe a) -> Maybe (f a)
distribute1 = (f () -> Maybe (f a))
-> (f a -> Maybe (f a)) -> Either (f ()) (f a) -> Maybe (f a)
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
either f () -> Maybe (f a)
forall {b} {a}. b -> Maybe a
l f a -> Maybe (f a)
forall a. a -> Maybe a
r (Either (f ()) (f a) -> Maybe (f a))
-> (f (Maybe a) -> Either (f ()) (f a))
-> f (Maybe a)
-> Maybe (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (() + a) -> Either (f ()) (f a)
forall a b. f (a + b) -> f a + f b
forall (f :: * -> *) a b. Coapply f => f (a + b) -> f a + f b
coapply (f (() + a) -> Either (f ()) (f a))
-> (f (Maybe a) -> f (() + a))
-> f (Maybe a)
-> Either (f ()) (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> () + a) -> f (Maybe a) -> f (() + a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe a -> () + a
forall {b}. Maybe b -> Either () b
proj where
    l :: b -> Maybe a
l = Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing
    r :: a -> Maybe a
r = a -> Maybe a
forall a. a -> Maybe a
Just
    proj :: Maybe b -> Either () b
proj = Either () b -> (b -> Either () b) -> Maybe b -> Either () b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either () b
forall a b. a -> Either a b
Left ()) b -> Either () b
forall a b. b -> Either a b
Right

-- >>> distribute1 ["hi","jk"]
-- ["hj","ik"]
instance Distributive1 [] where
  distribute1 :: forall (f :: * -> *) a. Coapply f => f [a] -> [f a]
distribute1 = (f () -> [f a])
-> (f (a, [a]) -> [f a]) -> Either (f ()) (f (a, [a])) -> [f a]
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
either f () -> [f a]
forall {b} {a}. b -> [a]
l f (a, [a]) -> [f a]
forall {f :: * -> *} {a}. Coapply f => f (a, [a]) -> [f a]
r (Either (f ()) (f (a, [a])) -> [f a])
-> (f [a] -> Either (f ()) (f (a, [a]))) -> f [a] -> [f a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (() + (a, [a])) -> Either (f ()) (f (a, [a]))
forall a b. f (a + b) -> f a + f b
forall (f :: * -> *) a b. Coapply f => f (a + b) -> f a + f b
coapply (f (() + (a, [a])) -> Either (f ()) (f (a, [a])))
-> (f [a] -> f (() + (a, [a])))
-> f [a]
-> Either (f ()) (f (a, [a]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> () + (a, [a])) -> f [a] -> f (() + (a, [a]))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> () + (a, [a])
forall {a}. [a] -> Either () (a, [a])
proj where
    l :: b -> [a]
l = [a] -> b -> [a]
forall a b. a -> b -> a
const []
    r :: f (a, [a]) -> [f a]
r f (a, [a])
f = ((f a, f [a]) -> f a
forall a b. (a, b) -> a
fst ((f a, f [a]) -> f a) -> (f a, f [a]) -> f a
forall a b. (a -> b) -> a -> b
$ f (a, [a]) -> (f a, f [a])
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
select f (a, [a])
f) f a -> [f a] -> [f a]
forall a. a -> [a] -> [a]
: (f [a] -> [f a]
forall (g :: * -> *) (f :: * -> *) a.
(Distributive1 g, Coapply f) =>
f (g a) -> g (f a)
forall (f :: * -> *) a. Coapply f => f [a] -> [f a]
distribute1 (f [a] -> [f a])
-> ((f a, f [a]) -> f [a]) -> (f a, f [a]) -> [f a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a, f [a]) -> f [a]
forall a b. (a, b) -> b
snd ((f a, f [a]) -> [f a]) -> (f a, f [a]) -> [f a]
forall a b. (a -> b) -> a -> b
$ f (a, [a]) -> (f a, f [a])
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
select f (a, [a])
f)
    proj :: [a] -> Either () (a, [a])
proj [] = () -> Either () (a, [a])
forall a b. a -> Either a b
Left ()
    proj (a
x:[a]
xs) = (a, [a]) -> Either () (a, [a])
forall a b. b -> Either a b
Right (a
x, [a]
xs)

-- >>> distribute1 $ ('h' :| ['i']) :| [('j' :| ['k'])]
-- ('h' :| "j") :| ['i' :| "k"]
instance Distributive1 NonEmpty where
  distribute1 :: forall (f :: * -> *) a.
Coapply f =>
f (NonEmpty a) -> NonEmpty (f a)
distribute1 = (f a -> NonEmpty (f a))
-> (f (a, [a]) -> NonEmpty (f a))
-> Either (f a) (f (a, [a]))
-> NonEmpty (f a)
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
either f a -> NonEmpty (f a)
forall {a}. a -> NonEmpty a
l f (a, [a]) -> NonEmpty (f a)
forall {f :: * -> *} {a}. Coapply f => f (a, [a]) -> NonEmpty (f a)
r (Either (f a) (f (a, [a])) -> NonEmpty (f a))
-> (f (NonEmpty a) -> Either (f a) (f (a, [a])))
-> f (NonEmpty a)
-> NonEmpty (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (a + (a, [a])) -> Either (f a) (f (a, [a]))
forall a b. f (a + b) -> f a + f b
forall (f :: * -> *) a b. Coapply f => f (a + b) -> f a + f b
coapply (f (a + (a, [a])) -> Either (f a) (f (a, [a])))
-> (f (NonEmpty a) -> f (a + (a, [a])))
-> f (NonEmpty a)
-> Either (f a) (f (a, [a]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty a -> a + (a, [a])) -> f (NonEmpty a) -> f (a + (a, [a]))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty a -> a + (a, [a])
forall {a}. NonEmpty a -> Either a (a, [a])
proj where
    l :: a -> NonEmpty a
l = a -> NonEmpty a
forall {a}. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    r :: f (a, [a]) -> NonEmpty (f a)
r f (a, [a])
f = ((f a, f [a]) -> f a
forall a b. (a, b) -> a
fst ((f a, f [a]) -> f a) -> (f a, f [a]) -> f a
forall a b. (a -> b) -> a -> b
$ f (a, [a]) -> (f a, f [a])
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
select f (a, [a])
f) f a -> [f a] -> NonEmpty (f a)
forall a. a -> [a] -> NonEmpty a
:| (f [a] -> [f a]
forall (g :: * -> *) (f :: * -> *) a.
(Distributive1 g, Coapply f) =>
f (g a) -> g (f a)
forall (f :: * -> *) a. Coapply f => f [a] -> [f a]
distribute1 (f [a] -> [f a])
-> ((f a, f [a]) -> f [a]) -> (f a, f [a]) -> [f a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a, f [a]) -> f [a]
forall a b. (a, b) -> b
snd ((f a, f [a]) -> [f a]) -> (f a, f [a]) -> [f a]
forall a b. (a -> b) -> a -> b
$ f (a, [a]) -> (f a, f [a])
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
select f (a, [a])
f)
    proj :: NonEmpty a -> Either a (a, [a])
proj (a
x :| []) = a -> Either a (a, [a])
forall a b. a -> Either a b
Left a
x
    proj (a
x :| [a]
xs) = (a, [a]) -> Either a (a, [a])
forall a b. b -> Either a b
Right (a
x, [a]
xs)

instance Distributive1 ((->) r) where
  distribute1 :: forall (f :: * -> *) a. Coapply f => f (r -> a) -> r -> f a
distribute1 f (r -> a)
a r
e = ((r -> a) -> a) -> f (r -> a) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((r -> a) -> r -> a
forall a b. (a -> b) -> a -> b
$ r
e) f (r -> a)
a
  collect1 :: forall (f :: * -> *) a b.
Coapply f =>
(a -> r -> b) -> f a -> r -> f b
collect1 a -> r -> b
f f a
q r
e = (a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> r -> b) -> r -> a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> r -> b
f r
e) f a
q

instance Distributive1 m => Distributive1 (ReaderT r m) where
  distribute1 :: forall (f :: * -> *) a.
Coapply f =>
f (ReaderT r m a) -> ReaderT r m (f a)
distribute1 f (ReaderT r m a)
a = (r -> m (f a)) -> ReaderT r m (f a)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m (f a)) -> ReaderT r m (f a))
-> (r -> m (f a)) -> ReaderT r m (f a)
forall a b. (a -> b) -> a -> b
$ \r
e -> (ReaderT r m a -> m a) -> f (ReaderT r m a) -> m (f a)
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive1 g, Coapply f) =>
(a -> g b) -> f a -> g (f b)
forall (f :: * -> *) a b. Coapply f => (a -> m b) -> f a -> m (f b)
collect1 ((ReaderT r m a -> r -> m a) -> r -> ReaderT r m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT r
e) f (ReaderT r m a)
a
  collect1 :: forall (f :: * -> *) a b.
Coapply f =>
(a -> ReaderT r m b) -> f a -> ReaderT r m (f b)
collect1 a -> ReaderT r m b
f f a
x = (r -> m (f b)) -> ReaderT r m (f b)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m (f b)) -> ReaderT r m (f b))
-> (r -> m (f b)) -> ReaderT r m (f b)
forall a b. (a -> b) -> a -> b
$ \r
e -> (a -> m b) -> f a -> m (f b)
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive1 g, Coapply f) =>
(a -> g b) -> f a -> g (f b)
forall (f :: * -> *) a b. Coapply f => (a -> m b) -> f a -> m (f b)
collect1 (\a
a -> ReaderT r m b -> r -> m b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m b
f a
a) r
e) f a
x

instance (Distributive1 f, Distributive1 g) => Distributive1 (Product f g) where
  -- It might be tempting to write a 'collect1' implementation that
  -- composes the passed function with fstP and sndP. This could be bad,
  -- because it would lead to the passed function being evaluated twice
  -- for each element of the underlying functor.
  distribute1 :: forall (f :: * -> *) a.
Coapply f =>
f (Product f g a) -> Product f g (f a)
distribute1 f (Product f g a)
wp = f (f a) -> g (f a) -> Product f g (f a)
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair ((Product f g a -> f a) -> f (Product f g a) -> f (f a)
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive1 g, Coapply f) =>
(a -> g b) -> f a -> g (f b)
forall (f :: * -> *) a b. Coapply f => (a -> f b) -> f a -> f (f b)
collect1 Product f g a -> f a
forall {f :: * -> *} {g :: * -> *} {a}. Product f g a -> f a
fstP f (Product f g a)
wp) ((Product f g a -> g a) -> f (Product f g a) -> g (f a)
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive1 g, Coapply f) =>
(a -> g b) -> f a -> g (f b)
forall (f :: * -> *) a b. Coapply f => (a -> g b) -> f a -> g (f b)
collect1 Product f g a -> g a
forall {f :: * -> *} {g :: * -> *} {a}. Product f g a -> g a
sndP f (Product f g a)
wp) where
    fstP :: Product f g a -> f a
fstP (Pair f a
a g a
_) = f a
a
    sndP :: Product f g a -> g a
sndP (Pair f a
_ g a
b) = g a
b

instance Distributive1 U1 where
  distribute1 :: forall (f :: * -> *) a. Coapply f => f (U1 a) -> U1 (f a)
distribute1 f (U1 a)
_ = U1 (f a)
forall k (p :: k). U1 p
U1

instance (Distributive1 a, Distributive1 b) => Distributive1 (a :*: b) where
  -- It might be tempting to write a 'collect' implementation that
  -- composes the passed function with fstP and sndP. This could be bad,
  -- because it would lead to the passed function being evaluated twice
  -- for each element of the underlying functor.
  distribute1 :: forall (f :: * -> *) a.
Coapply f =>
f ((:*:) a b a) -> (:*:) a b (f a)
distribute1 f ((:*:) a b a)
f = ((:*:) a b a -> a a) -> f ((:*:) a b a) -> a (f a)
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive1 g, Coapply f) =>
(a -> g b) -> f a -> g (f b)
forall (f :: * -> *) a b. Coapply f => (a -> a b) -> f a -> a (f b)
collect1 (:*:) a b a -> a a
forall {f :: * -> *} {g :: * -> *} {p}. (:*:) f g p -> f p
fstP f ((:*:) a b a)
f a (f a) -> b (f a) -> (:*:) a b (f a)
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: ((:*:) a b a -> b a) -> f ((:*:) a b a) -> b (f a)
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive1 g, Coapply f) =>
(a -> g b) -> f a -> g (f b)
forall (f :: * -> *) a b. Coapply f => (a -> b b) -> f a -> b (f b)
collect1 (:*:) a b a -> b a
forall {f :: * -> *} {g :: * -> *} {p}. (:*:) f g p -> g p
sndP f ((:*:) a b a)
f where
    fstP :: (:*:) f g p -> f p
fstP (f p
l :*: g p
_) = f p
l
    sndP :: (:*:) f g p -> g p
sndP (f p
_ :*: g p
r) = g p
r

instance (Distributive1 a, Distributive1 b) => Distributive1 (a :.: b) where
  distribute1 :: forall (f :: * -> *) a.
Coapply f =>
f ((:.:) a b a) -> (:.:) a b (f a)
distribute1 = a (b (f a)) -> (:.:) a b (f a)
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (a (b (f a)) -> (:.:) a b (f a))
-> (f ((:.:) a b a) -> a (b (f a)))
-> f ((:.:) a b a)
-> (:.:) a b (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (b a) -> b (f a)) -> a (f (b a)) -> a (b (f a))
forall a b. (a -> b) -> a a -> a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (b a) -> b (f a)
forall (g :: * -> *) (f :: * -> *) a.
(Distributive1 g, Coapply f) =>
f (g a) -> g (f a)
forall (f :: * -> *) a. Coapply f => f (b a) -> b (f a)
distribute1 (a (f (b a)) -> a (b (f a)))
-> (f ((:.:) a b a) -> a (f (b a)))
-> f ((:.:) a b a)
-> a (b (f a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((:.:) a b a -> a (b a)) -> f ((:.:) a b a) -> a (f (b a))
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive1 g, Coapply f) =>
(a -> g b) -> f a -> g (f b)
forall (f :: * -> *) a b. Coapply f => (a -> a b) -> f a -> a (f b)
collect1 (:.:) a b a -> a (b a)
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1
  collect1 :: forall (f :: * -> *) a b.
Coapply f =>
(a -> (:.:) a b b) -> f a -> (:.:) a b (f b)
collect1 a -> (:.:) a b b
f = a (b (f b)) -> (:.:) a b (f b)
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (a (b (f b)) -> (:.:) a b (f b))
-> (f a -> a (b (f b))) -> f a -> (:.:) a b (f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (b b) -> b (f b)) -> a (f (b b)) -> a (b (f b))
forall a b. (a -> b) -> a a -> a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (b b) -> b (f b)
forall (g :: * -> *) (f :: * -> *) a.
(Distributive1 g, Coapply f) =>
f (g a) -> g (f a)
forall (f :: * -> *) a. Coapply f => f (b a) -> b (f a)
distribute1 (a (f (b b)) -> a (b (f b)))
-> (f a -> a (f (b b))) -> f a -> a (b (f b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a (b b)) -> f a -> a (f (b b))
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive1 g, Coapply f) =>
(a -> g b) -> f a -> g (f b)
forall (f :: * -> *) a b. Coapply f => (a -> a b) -> f a -> a (f b)
collect1 ((a -> (:.:) a b b) -> a -> a (b b)
forall a b. Coercible a b => a -> b
coerce a -> (:.:) a b b
f)

instance Distributive1 Par1 where
  distribute1 :: forall (f :: * -> *) a. Coapply f => f (Par1 a) -> Par1 (f a)
distribute1 = f a -> Par1 (f a)
forall p. p -> Par1 p
Par1 (f a -> Par1 (f a))
-> (f (Par1 a) -> f a) -> f (Par1 a) -> Par1 (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Par1 a -> a) -> f (Par1 a) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Par1 a -> a
forall p. Par1 p -> p
unPar1
  collect1 :: forall (f :: * -> *) a b.
Coapply f =>
(a -> Par1 b) -> f a -> Par1 (f b)
collect1 = ((a -> b) -> f a -> f b) -> (a -> Par1 b) -> f a -> Par1 (f b)
forall a b. Coercible a b => a -> b
coerce ((a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap :: (a -> b) -> f a -> f b)
    :: forall f a b . Functor f => (a -> Par1 b) -> f a -> Par1 (f b)

{-
instance Distributive1 f => Distributive1 (Rec1 f) where
  distribute1 = Rec1 . collect1 unRec1
  collect1 = coerce (collect1 :: (a -> f b) -> g a -> f (g b))
    :: forall g a b . Functor g
    => (a -> Rec1 f b) -> g a -> Rec1 f (g b)

instance Distributive1 f => Distributive1 (M1 i c f) where
  distribute1 = M1 . collect1 unM1
  collect1 = coerce (collect1 :: (a -> f b) -> g a -> f (g b))
    :: forall g a b . Functor g
    => (a -> M1 i c f b) -> g a -> M1 i c f (g b)
-}