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

module Control.Coapplicative (
    Applicative'
  -- * Coapplicative
  , Coapplicative(..)
  -- * Coapply
  , Coapply(..)
  , apply
  , select
  , coselect
  , coeval
  -- * Select
  , Select
  , eitherS
  , branch
  , bindBool
  -- * Selective
  , Selective
  , apS
  , (<*?)
  , eliminate
  , whenS
  , whileS
  , fromMaybeS
  , untilRight
  , (<||>)
  , (<&&>)
  , anyS
  , allS
  , foldS
  , orElse
  , andAlso
  , appendl
) where

--import Control.Monad.Trans.Reader
import Data.Bool
import Data.Function ((&))
import Data.Functor.Apply
import Data.Functor.Coapply as Export
import Data.Functor.Compose
import Data.Functor.Identity
import Data.List.NonEmpty (NonEmpty(..))
import Data.Tagged
import qualified Data.List.NonEmpty as L1

eswap :: (a1 + a2) -> (a2 + a1)
eswap :: forall a1 a2. (a1 + a2) -> a2 + a1
eswap (Left a1
x) = a1 -> Either a2 a1
forall a b. b -> Either a b
Right a1
x
eswap (Right a2
x) = a2 -> Either a2 a1
forall a b. a -> Either a b
Left a2
x

type Applicative' f = (Apply f, Applicative f)

---------------------------------------------------------------------
-- Coapplicative
---------------------------------------------------------------------

-- |
--
-- @
-- 'coapply' . 'fmap' 'Right' = 'Right'
-- 'either' (f . 'copure') (g . 'copure') . 'coapply' = 'either' f g . 'copure'
-- @
--
class Coapply f => Coapplicative f where
  copure :: f a -> a

---------------------------------------------------------------------
-- Selective
---------------------------------------------------------------------

type Selective f = (Coapply f, Applicative' f)

{-| Recover the application operator '<*>' from '<*?'. /Rigid/ selective
functors satisfy the law '<*>' @=@ 'apS' and furthermore, the resulting
applicative functor satisfies all laws of 'Applicative':

* Identity:

    > pure id <*> v = v

* Homomorphism:

    > pure f <*> pure x = pure (f x)

* Interchange:

    > u <*> pure y = pure ($y) <*> u

* Composition:

    > (.) <$> u <*> v <*> w = u <*> (v <*> w)
-}
apS :: Selective f => f (a -> b) -> f a -> f b
apS :: forall (f :: * -> *) a b. Selective f => f (a -> b) -> f a -> f b
apS f (a -> b)
f f a
x = ((a -> b) -> Either (a -> b) b
forall a b. a -> Either a b
Left ((a -> b) -> Either (a -> b) b)
-> f (a -> b) -> f (Either (a -> b) b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a -> b)
f) f (Either (a -> b) b) -> f ((a -> b) -> b) -> f b
forall (f :: * -> *) a b.
Selective f =>
f (a + b) -> f (a -> b) -> f b
<*? (a -> (a -> b) -> b
forall a b. a -> (a -> b) -> b
(&) (a -> (a -> b) -> b) -> f a -> f ((a -> b) -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x)

infixl 4 <*?

--
--
-- (Right "foo" :| [Right "bar"]) <*? (pure $ const "baz")
-- "foo" :| ["bar"]
-- (Left "foo" :| [Right "bar"]) <*? (pure $ const "baz")
-- "baz" :| []
--
-- See < http://hackage.haskell.org/package/selective/docs/Control-Selective.html >
--
(<*?) :: Selective f => f (a + b) -> f (a -> b) -> f b
<*? :: forall (f :: * -> *) a b.
Selective f =>
f (a + b) -> f (a -> b) -> f b
(<*?) f (a + b)
ab f (a -> b)
f = f (a + b) -> f (a -> b) -> f (b -> b) -> f b
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 -> b)
f (f (b -> b) -> f b) -> f (b -> b) -> f b
forall a b. (a -> b) -> a -> b
$ (b -> b) -> f (b -> b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b -> b
forall a. a -> a
id

-- | Eliminate the @a@ from @f (a + b)@ and replace with the provided @f b@.
--
-- >>> eliminate 1.0 ["foo","bar"] [Left 1.0] :: [Float + String]
-- [Right "foo",Right "bar"]
-- >>> eliminate 1.0 ["foo","bar"] [Left 3.4] :: [Float + String]
-- [Left 3.4]
--
eliminate :: Eq a => Selective f => a -> f b -> f (a + b) -> f (a + b)
eliminate :: forall a (f :: * -> *) b.
(Eq a, Selective f) =>
a -> f b -> f (a + b) -> f (a + b)
eliminate a
a f b
fb f (a + b)
fa = ((a + b) -> () + (a + b)) -> f (a + 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 (a -> (a + b) -> () + (a + b)
forall {a} {b}. Eq a => a -> Either a b -> Either () (Either a b)
match a
a) f (a + b)
fa f (() + (a + b)) -> f (() -> a + b) -> f (a + b)
forall (f :: * -> *) a b.
Selective f =>
f (a + b) -> f (a -> b) -> f b
<*? (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 ((a + b) -> () -> a + b
forall a b. a -> b -> a
const ((a + b) -> () -> a + b) -> (b -> a + b) -> b -> () -> a + b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a + b
forall a b. b -> Either a b
Right) f b
fb
  where
    match :: a -> Either a b -> Either () (Either a b)
match a
_ (Right b
y) = Either a b -> Either () (Either a b)
forall a b. b -> Either a b
Right (b -> Either a b
forall a b. b -> Either a b
Right b
y)
    match a
x (Left  a
y) = if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y then () -> Either () (Either a b)
forall a b. a -> Either a b
Left () else Either a b -> Either () (Either a b)
forall a b. b -> Either a b
Right (a -> Either a b
forall a b. a -> Either a b
Left a
y)

-- | Conditionally perform an effect.
whenS :: Selective f => f Bool -> f () -> f ()
whenS :: forall (f :: * -> *). Selective f => f Bool -> f () -> f ()
whenS f Bool
x f ()
y = ((() + ()) -> (() + ()) -> 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) f (() + ()) -> f (() -> ()) -> f ()
forall (f :: * -> *) a b.
Selective f =>
f (a + b) -> f (a -> b) -> f b
<*? (() -> () -> ()
forall a b. a -> b -> a
const (() -> () -> ()) -> f () -> f (() -> ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f ()
y)

-- | Keep checking an effectful condition while it holds.
whileS :: Selective f => f Bool -> f ()
whileS :: forall (f :: * -> *). Selective f => f Bool -> f ()
whileS f Bool
act = f Bool -> f () -> f ()
forall (f :: * -> *). Selective f => f Bool -> f () -> f ()
whenS f Bool
act (f Bool -> f ()
forall (f :: * -> *). Selective f => f Bool -> f ()
whileS f Bool
act)

-- | A lifted version of 'Data.Maybe.fromMaybe'.
fromMaybeS :: Selective f => f a -> f (Maybe a) -> f a
fromMaybeS :: forall (f :: * -> *) a. Selective f => f a -> f (Maybe a) -> f a
fromMaybeS f a
x f (Maybe a)
mx = (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 ((() + a) -> (a -> () + a) -> Maybe a -> () + a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> () + a
forall a b. a -> Either a b
Left ()) a -> () + a
forall a b. b -> Either a b
Right) f (Maybe a)
mx f (() + a) -> f (() -> a) -> f a
forall (f :: * -> *) a b.
Selective f =>
f (a + b) -> f (a -> b) -> f b
<*? (a -> () -> a) -> f 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 a -> () -> a
forall a b. a -> b -> a
const f a
x

-- | Keep running an effectful computation until it returns a @Right@ value,
-- collecting the @Left@'s using a supplied @Monoid@ instance.
untilRight :: Monoid a => Selective f => f (a + b) -> f (a , b)
untilRight :: forall a (f :: * -> *) b.
(Monoid a, Selective f) =>
f (a + b) -> f (a, b)
untilRight f (a + b)
x = f (Either a (a, b))
y f (Either a (a, b)) -> f (a -> (a, b)) -> f (a, b)
forall (f :: * -> *) a b.
Selective f =>
f (a + b) -> f (a -> b) -> f b
<*? f (a -> (a, b))
h
  where
    -- y :: f (Either a (a, b))
    y :: f (Either a (a, b))
y = (b -> (a, b)) -> (a + b) -> Either a (a, b)
forall a b. (a -> b) -> Either a a -> Either a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
forall a. Monoid a => a
mempty,) ((a + b) -> Either a (a, b)) -> f (a + b) -> f (Either a (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a + b)
x
    -- h :: f (a -> (a, b))
    h :: f (a -> (a, b))
h = (\(a
as, b
b) a
a -> (a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
a a
as, b
b)) ((a, b) -> a -> (a, b)) -> f (a, b) -> f (a -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a + b) -> f (a, b)
forall a (f :: * -> *) b.
(Monoid a, Selective f) =>
f (a + b) -> f (a, b)
untilRight f (a + b)
x

-- | A lifted version of lazy Boolean OR.
(<||>) :: Selective f => f Bool -> f Bool -> f Bool
f Bool
a <||> :: forall (f :: * -> *). Selective f => f Bool -> f Bool -> f Bool
<||> f Bool
b = f Bool -> f Bool -> f Bool -> f Bool
forall (f :: * -> *) a. Select f => f Bool -> f a -> f a -> f a
branch f Bool
a (Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) f Bool
b

-- | A lifted version of lazy Boolean AND.
(<&&>) :: Selective f => f Bool -> f Bool -> f Bool
f Bool
a <&&> :: forall (f :: * -> *). Selective f => f Bool -> f Bool -> f Bool
<&&> f Bool
b = f Bool -> f Bool -> f Bool -> f Bool
forall (f :: * -> *) a. Select f => f Bool -> f a -> f a -> f a
branch f Bool
a f Bool
b (Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

-- | A lifted version of 'any'. Retains the short-circuiting behaviour.
anyS :: Selective f => (a -> f Bool) -> [a] -> f Bool
anyS :: forall (f :: * -> *) a.
Selective f =>
(a -> f Bool) -> [a] -> f Bool
anyS a -> f Bool
p = (a -> f Bool -> f Bool) -> f Bool -> [a] -> f Bool
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (f Bool -> f Bool -> f Bool
forall (f :: * -> *). Selective f => f Bool -> f Bool -> f Bool
(<||>) (f Bool -> f Bool -> f Bool)
-> (a -> f Bool) -> a -> f Bool -> f Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f Bool
p) (Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

-- | A lifted version of 'all'. Retains the short-circuiting behaviour.
allS :: Selective f => (a -> f Bool) -> [a] -> f Bool
allS :: forall (f :: * -> *) a.
Selective f =>
(a -> f Bool) -> [a] -> f Bool
allS a -> f Bool
p = (a -> f Bool -> f Bool) -> f Bool -> [a] -> f Bool
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (f Bool -> f Bool -> f Bool
forall (f :: * -> *). Selective f => f Bool -> f Bool -> f Bool
(<&&>) (f Bool -> f Bool -> f Bool)
-> (a -> f Bool) -> a -> f Bool -> f Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f Bool
p) (Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)

-- | Generalised folding with the short-circuiting behaviour.
foldS :: (Selective f, Foldable t, Monoid b) => t (f (a + b)) -> f (a + b)
foldS :: forall (f :: * -> *) (t :: * -> *) b a.
(Selective f, Foldable t, Monoid b) =>
t (f (a + b)) -> f (a + b)
foldS = (f (a + b) -> f (a + b) -> f (a + b))
-> f (a + b) -> t (f (a + b)) -> f (a + b)
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr f (a + b) -> f (a + b) -> f (a + b)
forall b (f :: * -> *) a.
(Semigroup b, Selective f) =>
f (a + b) -> f (a + b) -> f (a + b)
andAlso ((a + b) -> f (a + b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> a + b
forall a b. b -> Either a b
Right b
forall a. Monoid a => a
mempty))

-- | Return the first @Right@ value. If both are @Left@'s, accumulate errors.
orElse :: Semigroup a => Selective f => f (a + b) -> f (a + b) -> f (a + b)
orElse :: forall a (f :: * -> *) b.
(Semigroup a, Selective f) =>
f (a + b) -> f (a + b) -> f (a + b)
orElse f (a + b)
x f (a + b)
y = f (a + b) -> f (a -> a + b) -> f (b -> a + b) -> f (a + b)
forall (f :: * -> *) a b c.
Select f =>
f (a + b) -> f (a -> c) -> f (b -> c) -> f c
eitherS f (a + b)
x ((a -> (a + b) -> a + b) -> (a + b) -> a -> a + b
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> (a + b) -> a + b
forall a b. Semigroup a => a -> (a + b) -> a + b
appendl ((a + b) -> a -> a + b) -> f (a + b) -> f (a -> a + b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a + b)
y) ((b -> a + b) -> f (b -> a + b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b -> a + b
forall a b. b -> Either a b
Right)

-- | Accumulate the @Right@ values, or return the first @Left@.
--
-- >>> andAlso [Right "foo", Right "bar", Right "baz"] [Right "!"]
-- [Right "foo!",Right "bar!",Right "baz!"]
-- >>> andAlso [Right "foo", Right "bar", Left 'e'] [Right "!"]
-- [Right "foo!",Right "bar!"]
-- >>> andAlso [Right "foo", Right "bar", Left 'e'] [Left 'f']
-- [Left 'f',Left 'f']
--
andAlso :: Semigroup b => Selective f => f (a + b) -> f (a + b) -> f (a + b)
andAlso :: forall b (f :: * -> *) a.
(Semigroup b, Selective f) =>
f (a + b) -> f (a + b) -> f (a + b)
andAlso f (a + b)
x f (a + b)
y = (b + a) -> a + b
forall a1 a2. (a1 + a2) -> a2 + a1
eswap ((b + a) -> a + b) -> f (b + a) -> f (a + b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (b + a) -> f (b + a) -> f (b + a)
forall a (f :: * -> *) b.
(Semigroup a, Selective f) =>
f (a + b) -> f (a + b) -> f (a + b)
orElse ((a + b) -> b + a
forall a1 a2. (a1 + a2) -> a2 + a1
eswap ((a + b) -> b + a) -> f (a + b) -> f (b + a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a + b)
x) ((a + b) -> b + a
forall a1 a2. (a1 + a2) -> a2 + a1
eswap ((a + b) -> b + a) -> f (a + b) -> f (b + a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a + b)
y)

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

instance Coapplicative Identity where
  copure :: forall a. Identity a -> a
copure (Identity a
a) = a
a

instance Coapplicative (Tagged k) where
  copure :: forall a. Tagged k a -> a
copure (Tagged a
a) = a
a

instance Coapplicative ((,) r) where
  copure :: forall a. (r, a) -> a
copure (r
_, a
a) = a
a

instance Monoid r => Coapplicative ((->) r) where
  copure :: forall a. (r -> a) -> a
copure r -> a
f = r -> a
f r
forall a. Monoid a => a
mempty

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

instance Coapplicative NonEmpty where
  copure :: forall a. NonEmpty a -> a
copure = NonEmpty a -> a
forall a. NonEmpty a -> a
L1.head

instance (Coapplicative f, Coapplicative g) => Coapplicative (Compose f g) where
  copure :: forall a. Compose f g a -> a
copure (Compose f (g a)
a) = f a -> a
forall a. f a -> a
forall (f :: * -> *) a. Coapplicative f => f a -> a
copure (f a -> a) -> (f (g a) -> f a) -> f (g a) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g a -> a) -> f (g 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 g a -> a
forall a. g a -> a
forall (f :: * -> *) a. Coapplicative f => f a -> a
copure (f (g a) -> a) -> f (g a) -> a
forall a b. (a -> b) -> a -> b
$ f (g a)
a