-- |
-- Invariant monoidal functors.
-- 
-- This roughly corresponds to "Control.Applicative", but exposes a non-overlapping API so can be imported unqualified.  It does, however, use operators similar to those provided by contravariant.
{-# LANGUAGE CPP, TypeOperators, FlexibleInstances #-}
#if !(defined(VERSION_semigroupoids) && MIN_VERSION_semigroupoids(5,2,2))
{-# LANGUAGE Safe #-}
#endif
module Control.Invertible.Monoidal
  ( Bijection(..)
  , I.biCase
    -- * Functor
  , (>$<)
  , (>$), ($<)
  -- * Monoidal
  , Monoidal(..)
  , unitDefault
  , pairADefault
  , (>*), (*<)
  -- ** Tuple combinators
  , liftI2
  , liftI3
  , liftI4
  , liftI5
  , (>*<<)
  , (>*<<<)
  , (>*<<<<)
  , (>>*<)
  , (>>>*<)
  , (>>>>*<)
  , (>>*<<)
  , pureI
  , constI
  , sequenceI_
  , mapI_
  , forI_
  , sequenceMaybesI
  , mapMaybeI
  -- * MonoidalAlt
  , MonoidalAlt(..)
  , eitherADefault
  , (>|), (|<)
  , optionalI
  , defaulting
  , manyI
  , msumIndex
  , msumFirst, msumLast
  , oneOfI
  ) where

import Prelude
import Control.Applicative (liftA2, Alternative, (<|>))
import Control.Arrow ((&&&), (***))
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Void (Void)

import Data.Invertible.Bijection
import qualified Data.Invertible as I

-- |Another synonym for 'fmap' to match other operators in this module.
(>$<) :: I.Functor f => a <-> b -> f a -> f b
>$< :: forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
(>$<) = (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
I.fmap

infixl 4 $<, >$<, >$

-- |Given a value an an invariant for that value, always provide that value and ignore the produced value.
-- @'I.fmap' . flip 'I.consts' ()@
(>$) :: I.Functor f => a -> f a -> f ()
>$ :: forall (f :: * -> *) a. Functor f => a -> f a -> f ()
(>$) a
a = (a <-> ()) -> f a -> f ()
forall a b. (a <-> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
I.fmap ((a <-> ()) -> f a -> f ()) -> (a <-> ()) -> f a -> f ()
forall a b. (a -> b) -> a -> b
$ a -> () -> a <-> ()
forall a b. a -> b -> a <-> b
I.consts a
a ()

-- |@flip ('>$')@
($<) :: I.Functor f => f a -> a -> f ()
$< :: forall (f :: * -> *) a. Functor f => f a -> a -> f ()
($<) = (a -> f a -> f ()) -> f a -> a -> f ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> f a -> f ()
forall (f :: * -> *) a. Functor f => a -> f a -> f ()
(>$)

-- |Invariant monoidal functor.
-- This roughly corresponds to 'Applicative', which, for covariant functors, is equivalent to a monoidal functor.
-- Invariant functors, however, may admit a monoidal instance but not applicative.
class I.Functor f => Monoidal f where
  -- |Lift a unit value, analogous to @'Control.Applicative.pure' ()@ (but also like @const ()@).
  unit :: f ()
  -- |Merge two functors into a tuple, analogous to @'Control.Applicative.liftA2' (,)@. (Sometimes known as @**@.)
  (>*<) :: f a -> f b -> f (a, b)

-- |Default 'unit' implementation for non-invertible 'Applicative's.
unitDefault :: Applicative f => f ()
unitDefault :: forall (f :: * -> *). Applicative f => f ()
unitDefault = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- |Default '>*< implementation for non-invertible 'Applicative's.
pairADefault :: Applicative f => f a -> f b -> f (a, b)
pairADefault :: forall (f :: * -> *) a b. Applicative f => f a -> f b -> f (a, b)
pairADefault = (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.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)

-- |Sequence actions, discarding/inhabiting the unit value of the second argument.
(>*) :: Monoidal f => f a -> f () -> f a
>* :: forall (f :: * -> *) a. Monoidal f => f a -> f () -> f a
(>*) = ((a, ()) <-> a) -> f a -> f () -> f a
forall (f :: * -> *) a b c.
Monoidal f =>
((a, b) <-> c) -> f a -> f b -> f c
liftI2 (a, ()) <-> a
forall a. (a, ()) <-> a
I.fst

-- |Sequence actions, discarding/inhabiting the unit value of the first argument.
(*<) :: Monoidal f => f () -> f a -> f a
*< :: forall (f :: * -> *) a. Monoidal f => f () -> f a -> f a
(*<) = (((), a) <-> a) -> f () -> f a -> f a
forall (f :: * -> *) a b c.
Monoidal f =>
((a, b) <-> c) -> f a -> f b -> f c
liftI2 ((), a) <-> a
forall a. ((), a) <-> a
I.snd

infixl 4 >*, >*<, *<

-- |Lift an (uncurried) bijection into a monoidal functor.
liftI2 :: Monoidal f => ((a, b) <-> c) -> f a -> f b -> f c
liftI2 :: forall (f :: * -> *) a b c.
Monoidal f =>
((a, b) <-> c) -> f a -> f b -> f c
liftI2 (a, b) <-> c
f f a
a f b
b = (a, b) <-> c
f ((a, b) <-> c) -> f (a, b) -> f c
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< (f a
a f a -> f b -> f (a, b)
forall a b. f a -> f b -> f (a, b)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< f b
b)

liftI3 :: Monoidal f => ((a, b, c) <-> d) -> f a -> f b -> f c -> f d
liftI3 :: forall (f :: * -> *) a b c d.
Monoidal f =>
((a, b, c) <-> d) -> f a -> f b -> f c -> f d
liftI3 (a, b, c) <-> d
f f a
a f b
b f c
c = (a, b, c) <-> d
f ((a, b, c) <-> d) -> f (a, b, c) -> f d
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< (f a
a f a -> f b -> f (a, b)
forall a b. f a -> f b -> f (a, b)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< f b
b f (a, b) -> f c -> f (a, b, c)
forall (f :: * -> *) a b c.
Monoidal f =>
f (a, b) -> f c -> f (a, b, c)
>>*< f c
c)

liftI4 :: Monoidal f => ((a, b, c, d) <-> e) -> f a -> f b -> f c -> f d -> f e
liftI4 :: forall (f :: * -> *) a b c d e.
Monoidal f =>
((a, b, c, d) <-> e) -> f a -> f b -> f c -> f d -> f e
liftI4 (a, b, c, d) <-> e
f f a
a f b
b f c
c f d
d = (a, b, c, d) <-> e
f ((a, b, c, d) <-> e) -> f (a, b, c, d) -> f e
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< (f a
a f a -> f b -> f (a, b)
forall a b. f a -> f b -> f (a, b)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< f b
b f (a, b) -> f c -> f (a, b, c)
forall (f :: * -> *) a b c.
Monoidal f =>
f (a, b) -> f c -> f (a, b, c)
>>*< f c
c f (a, b, c) -> f d -> f (a, b, c, d)
forall (f :: * -> *) a b c d.
Monoidal f =>
f (a, b, c) -> f d -> f (a, b, c, d)
>>>*< f d
d)

liftI5 :: Monoidal f => ((a, b, c, d, e) <-> g) -> f a -> f b -> f c -> f d -> f e -> f g
liftI5 :: forall (f :: * -> *) a b c d e g.
Monoidal f =>
((a, b, c, d, e) <-> g) -> f a -> f b -> f c -> f d -> f e -> f g
liftI5 (a, b, c, d, e) <-> g
f f a
a f b
b f c
c f d
d f e
e = (a, b, c, d, e) <-> g
f ((a, b, c, d, e) <-> g) -> f (a, b, c, d, e) -> f g
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< (f a
a f a -> f b -> f (a, b)
forall a b. f a -> f b -> f (a, b)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< f b
b f (a, b) -> f c -> f (a, b, c)
forall (f :: * -> *) a b c.
Monoidal f =>
f (a, b) -> f c -> f (a, b, c)
>>*< f c
c f (a, b, c) -> f d -> f (a, b, c, d)
forall (f :: * -> *) a b c d.
Monoidal f =>
f (a, b, c) -> f d -> f (a, b, c, d)
>>>*< f d
d f (a, b, c, d) -> f e -> f (a, b, c, d, e)
forall (f :: * -> *) a b c d e.
Monoidal f =>
f (a, b, c, d) -> f e -> f (a, b, c, d, e)
>>>>*< f e
e)

(>>*<) :: Monoidal f => f (a, b) -> f c -> f (a, b, c)
>>*< :: forall (f :: * -> *) a b c.
Monoidal f =>
f (a, b) -> f c -> f (a, b, c)
(>>*<) = (((a, b), c) <-> (a, b, c)) -> f (a, b) -> f c -> f (a, b, c)
forall (f :: * -> *) a b c.
Monoidal f =>
((a, b) <-> c) -> f a -> f b -> f c
liftI2 ((a, b), c) <-> (a, b, c)
forall a b c. ((a, b), c) <-> (a, b, c)
I.flatten2_1

(>>>*<) :: Monoidal f => f (a, b, c) -> f d -> f (a, b, c, d)
>>>*< :: forall (f :: * -> *) a b c d.
Monoidal f =>
f (a, b, c) -> f d -> f (a, b, c, d)
(>>>*<) = (((a, b, c), d) <-> (a, b, c, d))
-> f (a, b, c) -> f d -> f (a, b, c, d)
forall (f :: * -> *) a b c.
Monoidal f =>
((a, b) <-> c) -> f a -> f b -> f c
liftI2 ((a, b, c), d) <-> (a, b, c, d)
forall a b c d. ((a, b, c), d) <-> (a, b, c, d)
I.flatten3_1

(>>>>*<) :: Monoidal f => f (a, b, c, d) -> f e -> f (a, b, c, d, e)
>>>>*< :: forall (f :: * -> *) a b c d e.
Monoidal f =>
f (a, b, c, d) -> f e -> f (a, b, c, d, e)
(>>>>*<) = (((a, b, c, d), e) <-> (a, b, c, d, e))
-> f (a, b, c, d) -> f e -> f (a, b, c, d, e)
forall (f :: * -> *) a b c.
Monoidal f =>
((a, b) <-> c) -> f a -> f b -> f c
liftI2 ((a, b, c, d), e) <-> (a, b, c, d, e)
forall a b c d e. ((a, b, c, d), e) <-> (a, b, c, d, e)
I.flatten4_1

infixl 4 >>*<, >>>*<, >>>>*<

(>*<<) :: Monoidal f => f a -> f (b, c) -> f (a, b, c)
>*<< :: forall (f :: * -> *) a b c.
Monoidal f =>
f a -> f (b, c) -> f (a, b, c)
(>*<<) = ((a, (b, c)) <-> (a, b, c)) -> f a -> f (b, c) -> f (a, b, c)
forall (f :: * -> *) a b c.
Monoidal f =>
((a, b) <-> c) -> f a -> f b -> f c
liftI2 (a, (b, c)) <-> (a, b, c)
forall a b c. (a, (b, c)) <-> (a, b, c)
I.flatten1_2

(>*<<<) :: Monoidal f => f a -> f (b, c, d) -> f (a, b, c, d)
>*<<< :: forall (f :: * -> *) a b c d.
Monoidal f =>
f a -> f (b, c, d) -> f (a, b, c, d)
(>*<<<) = ((a, (b, c, d)) <-> (a, b, c, d))
-> f a -> f (b, c, d) -> f (a, b, c, d)
forall (f :: * -> *) a b c.
Monoidal f =>
((a, b) <-> c) -> f a -> f b -> f c
liftI2 (a, (b, c, d)) <-> (a, b, c, d)
forall a b c d. (a, (b, c, d)) <-> (a, b, c, d)
I.flatten1_3

(>*<<<<) :: Monoidal f => f a -> f (b, c, d, e) -> f (a, b, c, d, e)
>*<<<< :: forall (f :: * -> *) a b c d e.
Monoidal f =>
f a -> f (b, c, d, e) -> f (a, b, c, d, e)
(>*<<<<) = ((a, (b, c, d, e)) <-> (a, b, c, d, e))
-> f a -> f (b, c, d, e) -> f (a, b, c, d, e)
forall (f :: * -> *) a b c.
Monoidal f =>
((a, b) <-> c) -> f a -> f b -> f c
liftI2 (a, (b, c, d, e)) <-> (a, b, c, d, e)
forall a b c d e. (a, (b, c, d, e)) <-> (a, b, c, d, e)
I.flatten1_4

infixr 3 >*<<, >*<<<, >*<<<<

(>>*<<) :: Monoidal f => f (a, b) -> f (c, d) -> f (a, b, c, d)
>>*<< :: forall (f :: * -> *) a b c d.
Monoidal f =>
f (a, b) -> f (c, d) -> f (a, b, c, d)
(>>*<<) = (((a, b), (c, d)) <-> (a, b, c, d))
-> f (a, b) -> f (c, d) -> f (a, b, c, d)
forall (f :: * -> *) a b c.
Monoidal f =>
((a, b) <-> c) -> f a -> f b -> f c
liftI2 ((a, b), (c, d)) <-> (a, b, c, d)
forall a b c d. ((a, b), (c, d)) <-> (a, b, c, d)
I.flatten2_2

infix 3 >>*<<

-- |A constant monoidal (like 'Control.Applicative.pure'), which always produces the same value and ignores everything.
pureI :: Monoidal f => a -> f a
pureI :: forall (f :: * -> *) a. Monoidal f => a -> f a
pureI a
a = a -> () <-> a
forall a. a -> () <-> a
I.const a
a (() <-> a) -> f () -> f a
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< f ()
forall (f :: * -> *). Monoidal f => f ()
unit

-- |Supply a constant value to a monoidal and ignore whatever is produced.
constI :: Monoidal f => a -> f a -> f ()
constI :: forall (f :: * -> *) a. Monoidal f => a -> f a -> f ()
constI a
a = (a <-> ()) -> f a -> f ()
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
(>$<) ((a <-> ()) -> f a -> f ()) -> (a <-> ()) -> f a -> f ()
forall a b. (a -> b) -> a -> b
$ Bijection (->) () a -> a <-> ()
forall b c. Bijection (->) b c -> Bijection (->) c b
forall (a :: * -> * -> *) b c. BiArrow a => a b c -> a c b
I.invert (Bijection (->) () a -> a <-> ())
-> Bijection (->) () a -> a <-> ()
forall a b. (a -> b) -> a -> b
$ a -> Bijection (->) () a
forall a. a -> () <-> a
I.const a
a

-- |Sequence (like 'Data.Foldable.sequenceA_') a list of monoidals, ignoring (@'I.const' ()@) all the results.
sequenceI_ :: (Foldable t, Monoidal f) => t (f ()) -> f ()
sequenceI_ :: forall (t :: * -> *) (f :: * -> *).
(Foldable t, Monoidal f) =>
t (f ()) -> f ()
sequenceI_ = (f () -> f () -> f ()) -> f () -> t (f ()) -> f ()
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 () -> f () -> f ()
forall (f :: * -> *) a. Monoidal f => f () -> f a -> f a
(*<) f ()
forall (f :: * -> *). Monoidal f => f ()
unit

-- |Map each element to a monoidal and 'sequenceI_' the results.
mapI_ :: (Foldable t, Monoidal f) => (a -> f ()) -> t a -> f ()
mapI_ :: forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Monoidal f) =>
(a -> f ()) -> t a -> f ()
mapI_ a -> f ()
f = (a -> f () -> f ()) -> f () -> t a -> f ()
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 () -> f () -> f ()
forall (f :: * -> *) a. Monoidal f => f () -> f a -> f a
(*<) (f () -> f () -> f ()) -> (a -> f ()) -> a -> f () -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f ()
f) f ()
forall (f :: * -> *). Monoidal f => f ()
unit

-- |@flip 'mapI_'@
forI_ :: (Foldable t, Monoidal f) => t a -> (a -> f ()) -> f ()
forI_ :: forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Monoidal f) =>
t a -> (a -> f ()) -> f ()
forI_ = ((a -> f ()) -> t a -> f ()) -> t a -> (a -> f ()) -> f ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> f ()) -> t a -> f ()
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Monoidal f) =>
(a -> f ()) -> t a -> f ()
mapI_

-- |Sequence (like 'Data.Traversable.sequenceA') and filter (like 'Data.Maybe.catMaybes') a list of monoidals, producing the list of non-'Nothing' values.
-- Shorter input lists pad with 'Nothing's and longer ones are ignored.
sequenceMaybesI :: Monoidal f => [f (Maybe a)] -> f [a]
sequenceMaybesI :: forall (f :: * -> *) a. Monoidal f => [f (Maybe a)] -> f [a]
sequenceMaybesI [] = [a] -> f [a]
forall (f :: * -> *) a. Monoidal f => a -> f a
pureI []
sequenceMaybesI (f (Maybe a)
x:[f (Maybe a)]
l) = ((Maybe a, [a]) <-> [a]) -> f (Maybe a) -> f [a] -> f [a]
forall (f :: * -> *) a b c.
Monoidal f =>
((a, b) <-> c) -> f a -> f b -> f c
liftI2 (Maybe a, [a]) <-> [a]
forall a. (Maybe a, [a]) <-> [a]
I.consMaybe f (Maybe a)
x ([f (Maybe a)] -> f [a]
forall (f :: * -> *) a. Monoidal f => [f (Maybe a)] -> f [a]
sequenceMaybesI [f (Maybe a)]
l)

-- |Map each element to a 'Maybe' monoidal and sequence the results (like 'Data.Traversable.traverse' and 'Data.Maybe.mapMaybe').
mapMaybeI :: Monoidal f => (a -> f (Maybe b)) -> [a] -> f [b]
mapMaybeI :: forall (f :: * -> *) a b.
Monoidal f =>
(a -> f (Maybe b)) -> [a] -> f [b]
mapMaybeI = ([f (Maybe b)] -> f [b]
forall (f :: * -> *) a. Monoidal f => [f (Maybe a)] -> f [a]
sequenceMaybesI ([f (Maybe b)] -> f [b]) -> ([a] -> [f (Maybe b)]) -> [a] -> f [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([a] -> [f (Maybe b)]) -> [a] -> f [b])
-> ((a -> f (Maybe b)) -> [a] -> [f (Maybe b)])
-> (a -> f (Maybe b))
-> [a]
-> f [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f (Maybe b)) -> [a] -> [f (Maybe b)]
forall a b. (a -> b) -> [a] -> [b]
map

-- |Monoidal functors that allow choice.
class Monoidal f => MonoidalAlt f where
  -- |An always-failing (and thus impossible) value.
  zero :: f Void
  -- |Associative binary choice.
  (>|<) :: f a -> f b -> f (Either a b)

-- |Default '>|<' implementation for non-invertible 'Alternative's.
eitherADefault :: Alternative f => f a -> f b -> f (Either a b)
eitherADefault :: forall (f :: * -> *) a b.
Alternative f =>
f a -> f b -> f (Either a b)
eitherADefault f a
a f b
b = a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> f a -> f (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
a f (Either a b) -> f (Either a b) -> f (Either a b)
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> f b -> f (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
b

-- |Assymetric (and therefore probably not bijective) version of '>|<' that returns whichever action succeeds but always uses the left one on inputs.
(>|) :: MonoidalAlt f => f a -> f a -> f a
f a
a >| :: forall (f :: * -> *) a. MonoidalAlt f => f a -> f a -> f a
>| f a
b = ((a -> a) -> (a -> a) -> Either a a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> a
forall a. a -> a
id a -> a
forall a. a -> a
id (Either a a -> a)
-> (a -> Either a a) -> Bijection (->) (Either a a) a
forall (a :: * -> * -> *) b c. a b c -> a c b -> Bijection a b c
:<->: a -> Either a a
forall a b. a -> Either a b
Left) Bijection (->) (Either a a) a -> f (Either a a) -> f a
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< (f a
a f a -> f a -> f (Either a a)
forall a b. f a -> f b -> f (Either a b)
forall (f :: * -> *) a b.
MonoidalAlt f =>
f a -> f b -> f (Either a b)
>|< f a
b)

-- |Assymetric (and therefore probably not bijective) version of '>|<' that returns whichever action succeeds but always uses the right one on inputs.
(|<) :: MonoidalAlt f => f a -> f a -> f a
f a
a |< :: forall (f :: * -> *) a. MonoidalAlt f => f a -> f a -> f a
|< f a
b = ((a -> a) -> (a -> a) -> Either a a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> a
forall a. a -> a
id a -> a
forall a. a -> a
id (Either a a -> a)
-> (a -> Either a a) -> Bijection (->) (Either a a) a
forall (a :: * -> * -> *) b c. a b c -> a c b -> Bijection a b c
:<->: a -> Either a a
forall a b. b -> Either a b
Right) Bijection (->) (Either a a) a -> f (Either a a) -> f a
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< (f a
a f a -> f a -> f (Either a a)
forall a b. f a -> f b -> f (Either a b)
forall (f :: * -> *) a b.
MonoidalAlt f =>
f a -> f b -> f (Either a b)
>|< f a
b)

infixl 3 >|, >|<, |<

-- |Analogous to 'Control.Applicative.optional': always succeeds.
optionalI :: MonoidalAlt f => f a -> f (Maybe a)
optionalI :: forall (f :: * -> *) a. MonoidalAlt f => f a -> f (Maybe a)
optionalI f a
f = Either a () <-> Maybe a
forall a. Either a () <-> Maybe a
I.lft (Either a () <-> Maybe a) -> f (Either a ()) -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< (f a
f f a -> f () -> f (Either a ())
forall a b. f a -> f b -> f (Either a b)
forall (f :: * -> *) a b.
MonoidalAlt f =>
f a -> f b -> f (Either a b)
>|< f ()
forall (f :: * -> *). Monoidal f => f ()
unit)

-- |Return a default value if a monoidal functor fails, and only apply it to non-default values.
defaulting :: (MonoidalAlt f, Eq a) => a -> f a -> f a
defaulting :: forall (f :: * -> *) a. (MonoidalAlt f, Eq a) => a -> f a -> f a
defaulting a
a f a
f = a -> Maybe a <-> a
forall a. Eq a => a -> Maybe a <-> a
I.fromMaybe a
a (Maybe a <-> a) -> f (Maybe a) -> f a
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< f a -> f (Maybe a)
forall (f :: * -> *) a. MonoidalAlt f => f a -> f (Maybe a)
optionalI f a
f

-- |Repeatedly apply a monoidal functor until it fails.  Analogous to 'Control.Applicative.many'.
manyI :: MonoidalAlt f => f a -> f [a]
manyI :: forall (f :: * -> *) a. MonoidalAlt f => f a -> f [a]
manyI f a
f = Maybe (a, [a]) <-> [a]
forall a. Maybe (a, [a]) <-> [a]
I.cons (Maybe (a, [a]) <-> [a]) -> f (Maybe (a, [a])) -> f [a]
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< f (a, [a]) -> f (Maybe (a, [a]))
forall (f :: * -> *) a. MonoidalAlt f => f a -> f (Maybe a)
optionalI (f a
f f a -> f [a] -> f (a, [a])
forall a b. f a -> f b -> f (a, b)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< f a -> f [a]
forall (f :: * -> *) a. MonoidalAlt f => f a -> f [a]
manyI f a
f)

-- |Try a list of monoidal actions in sequence, producing the index of the first successful action, and evaluating the action with the given index.
msumIndex :: MonoidalAlt f => [f ()] -> f Int
msumIndex :: forall (f :: * -> *). MonoidalAlt f => [f ()] -> f Int
msumIndex [] = [Char] -> f Int
forall a. HasCallStack => [Char] -> a
error [Char]
"msumIndex: empty list"
msumIndex [f ()
x]   = (       (\() -> Int
0)      (() -> Int) -> (Int -> ()) -> Bijection (->) () Int
forall (a :: * -> * -> *) b c. a b c -> a c b -> Bijection a b c
:<->: Int -> ()
forall {a}. (Ord a, Num a) => a -> ()
which) Bijection (->) () Int -> f () -> f Int
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< f ()
x where
  which :: a -> ()
which a
i = case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
i a
0 of
    Ordering
LT -> [Char] -> ()
forall a. HasCallStack => [Char] -> a
error [Char]
"msumIndex: negative index"
    Ordering
EQ -> ()
    Ordering
GT -> [Char] -> ()
forall a. HasCallStack => [Char] -> a
error [Char]
"msumIndex: index too large"
msumIndex (f ()
x:[f ()]
l) = ((() -> Int) -> (Int -> Int) -> Either () Int -> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\() -> Int
0) Int -> Int
forall a. Enum a => a -> a
succ (Either () Int -> Int)
-> (Int -> Either () Int) -> Bijection (->) (Either () Int) Int
forall (a :: * -> * -> *) b c. a b c -> a c b -> Bijection a b c
:<->: Int -> Either () Int
forall {b}. (Ord b, Num b, Enum b) => b -> Either () b
which) Bijection (->) (Either () Int) Int -> f (Either () Int) -> f Int
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< (f ()
x f () -> f Int -> f (Either () Int)
forall a b. f a -> f b -> f (Either a b)
forall (f :: * -> *) a b.
MonoidalAlt f =>
f a -> f b -> f (Either a b)
>|< [f ()] -> f Int
forall (f :: * -> *). MonoidalAlt f => [f ()] -> f Int
msumIndex [f ()]
l) where
  which :: b -> Either () b
which b
i = case b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare b
i b
0 of
    Ordering
LT -> [Char] -> Either () b
forall a. HasCallStack => [Char] -> a
error [Char]
"msumIndex: negative index"
    Ordering
EQ -> () -> Either () b
forall a b. a -> Either a b
Left ()
    Ordering
GT -> b -> Either () b
forall a b. b -> Either a b
Right (b -> b
forall a. Enum a => a -> a
pred b
i)

-- |Fold a structure with '>|' ('|<'), thus always applying the input to the first (last) item for generation.
msumFirst, msumLast :: (MonoidalAlt f, Traversable t) => t (f a) -> f a
msumFirst :: forall (f :: * -> *) (t :: * -> *) a.
(MonoidalAlt f, Traversable t) =>
t (f a) -> f a
msumFirst = (f a -> f a -> f a) -> t (f a) -> f a
forall a. (a -> a -> a) -> t a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 f a -> f a -> f a
forall (f :: * -> *) a. MonoidalAlt f => f a -> f a -> f a
(>|)
msumLast :: forall (f :: * -> *) (t :: * -> *) a.
(MonoidalAlt f, Traversable t) =>
t (f a) -> f a
msumLast = (f a -> f a -> f a) -> t (f a) -> f a
forall a. (a -> a -> a) -> t a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 f a -> f a -> f a
forall (f :: * -> *) a. MonoidalAlt f => f a -> f a -> f a
(|<)

-- |Take a list of items and apply them to the action in sequence until one succeeds and return the cooresponding item; match the input with the list and apply the corresponding action (or produce an error if the input is not an element of the list).
oneOfI :: (MonoidalAlt f, Eq a) => (a -> f ()) -> [a] -> f a
oneOfI :: forall (f :: * -> *) a.
(MonoidalAlt f, Eq a) =>
(a -> f ()) -> [a] -> f a
oneOfI a -> f ()
_ [] = [Char] -> f a
forall a. HasCallStack => [Char] -> a
error [Char]
"oneOfI: empty list"
oneOfI a -> f ()
f [a
x] = ((\() -> a
x) (() -> a) -> (a -> ()) -> Bijection (->) () a
forall (a :: * -> * -> *) b c. a b c -> a c b -> Bijection a b c
I.:<->: (\a
y -> if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y then () else [Char] -> ()
forall a. HasCallStack => [Char] -> a
error [Char]
"oneOfI: invalid option")) Bijection (->) () a -> f () -> f a
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< a -> f ()
f a
x
oneOfI a -> f ()
f (a
x:[a]
l) = (a -> Maybe a <-> a
forall a. Eq a => a -> Maybe a <-> a
I.fromMaybe a
x (Maybe a <-> a) -> (Either () a <-> Maybe a) -> Either () a <-> a
forall b c a. (b <-> c) -> (a <-> b) -> a <-> c
I.. Either () a <-> Maybe a
forall a. Either () a <-> Maybe a
I.rgt) (Either () a <-> a) -> f (Either () a) -> f a
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< (a -> f ()
f a
x f () -> f a -> f (Either () a)
forall a b. f a -> f b -> f (Either a b)
forall (f :: * -> *) a b.
MonoidalAlt f =>
f a -> f b -> f (Either a b)
>|< (a -> f ()) -> [a] -> f a
forall (f :: * -> *) a.
(MonoidalAlt f, Eq a) =>
(a -> f ()) -> [a] -> f a
oneOfI a -> f ()
f [a]
l)

instance Monoidal (Bijection (->) ()) where
  unit :: Bijection (->) () ()
unit = Bijection (->) () ()
forall a. a <-> a
I.id
  -- |Uses the 'Monoid' instance to combine '()'s.
  (() -> a
ua :<->: a -> ()
au) >*< :: forall a b.
Bijection (->) () a
-> Bijection (->) () b -> Bijection (->) () (a, b)
>*< (() -> b
ub :<->: b -> ()
bu) = () -> a
ua (() -> a) -> (() -> b) -> () -> (a, 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')
&&& () -> b
ub (() -> (a, b)) -> ((a, b) -> ()) -> Bijection (->) () (a, b)
forall (a :: * -> * -> *) b c. a b c -> a c b -> Bijection a b c
:<->: (() -> () -> ()) -> ((), ()) -> ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry () -> () -> ()
forall a. Monoid a => a -> a -> a
mappend (((), ()) -> ()) -> ((a, b) -> ((), ())) -> (a, b) -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> ()
au (a -> ()) -> (b -> ()) -> (a, b) -> ((), ())
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** b -> ()
bu)

instance I.Functor m => I.Functor (MaybeT m) where
  fmap :: forall a b. (a <-> b) -> MaybeT m a -> MaybeT m b
fmap a <-> b
f (MaybeT m (Maybe a)
m) = m (Maybe b) -> MaybeT m b
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe b) -> MaybeT m b) -> m (Maybe b) -> MaybeT m b
forall a b. (a -> b) -> a -> b
$ (Maybe a <-> Maybe b) -> m (Maybe a) -> m (Maybe b)
forall a b. (a <-> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
I.fmap ((a <-> b) -> Maybe a <-> Maybe b
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a <-> f b
I.bifmap a <-> b
f) m (Maybe a)
m

instance Monoidal m => Monoidal (MaybeT m) where
  unit :: MaybeT m ()
unit = m (Maybe ()) -> MaybeT m ()
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe ()) -> MaybeT m ()) -> m (Maybe ()) -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ Bijection (->) (Maybe ()) () -> Bijection (->) () (Maybe ())
forall b c. Bijection (->) b c -> Bijection (->) c b
forall (a :: * -> * -> *) b c. BiArrow a => a b c -> a c b
I.invert Bijection (->) (Maybe ()) ()
forall a. Maybe a <-> a
I.fromJust Bijection (->) () (Maybe ()) -> m () -> m (Maybe ())
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< m ()
forall (f :: * -> *). Monoidal f => f ()
unit
  MaybeT m (Maybe a)
f >*< :: forall a b. MaybeT m a -> MaybeT m b -> MaybeT m (a, b)
>*< MaybeT m (Maybe b)
g = m (Maybe (a, b)) -> MaybeT m (a, b)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT
    (m (Maybe (a, b)) -> MaybeT m (a, b))
-> m (Maybe (a, b)) -> MaybeT m (a, b)
forall a b. (a -> b) -> a -> b
$ ((Maybe a -> Maybe b -> Maybe (a, b))
-> (Maybe a, Maybe b) -> Maybe (a, b)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe a -> Maybe b -> Maybe (a, b)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f (a, b)
pairADefault ((Maybe a, Maybe b) -> Maybe (a, b))
-> (Maybe (a, b) -> (Maybe a, Maybe b))
-> Bijection (->) (Maybe a, Maybe b) (Maybe (a, b))
forall (a :: * -> * -> *) b c. a b c -> a c b -> Bijection a b c
:<->: (Maybe a, Maybe b)
-> ((a, b) -> (Maybe a, Maybe b))
-> Maybe (a, b) -> (Maybe a, Maybe b)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe a
forall a. Maybe a
Nothing, Maybe b
forall a. Maybe a
Nothing) (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (b -> Maybe b) -> (a, b) -> (Maybe a, Maybe b)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** b -> Maybe b
forall a. a -> Maybe a
Just))
    Bijection (->) (Maybe a, Maybe b) (Maybe (a, b))
-> m (Maybe a, Maybe b) -> m (Maybe (a, b))
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< (m (Maybe a)
f m (Maybe a) -> m (Maybe b) -> m (Maybe a, Maybe b)
forall a b. m a -> m b -> m (a, b)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< m (Maybe b)
g)

instance Monoidal m => MonoidalAlt (MaybeT m) where
  zero :: MaybeT m Void
zero = m (Maybe Void) -> MaybeT m Void
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Void) -> MaybeT m Void)
-> m (Maybe Void) -> MaybeT m Void
forall a b. (a -> b) -> a -> b
$ Maybe Void -> () <-> Maybe Void
forall a. a -> () <-> a
I.const Maybe Void
forall a. Maybe a
Nothing (() <-> Maybe Void) -> m () -> m (Maybe Void)
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< m ()
forall (f :: * -> *). Monoidal f => f ()
unit
  MaybeT m (Maybe a)
f >|< :: forall a b. MaybeT m a -> MaybeT m b -> MaybeT m (Either a b)
>|< MaybeT m (Maybe b)
g = m (Maybe (Either a b)) -> MaybeT m (Either a b)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT
    (m (Maybe (Either a b)) -> MaybeT m (Either a b))
-> m (Maybe (Either a b)) -> MaybeT m (Either a b)
forall a b. (a -> b) -> a -> b
$ ((Maybe a -> Maybe b -> Maybe (Either a b))
-> (Maybe a, Maybe b) -> Maybe (Either a b)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe a -> Maybe b -> Maybe (Either a b)
forall (f :: * -> *) a b.
Alternative f =>
f a -> f b -> f (Either a b)
eitherADefault ((Maybe a, Maybe b) -> Maybe (Either a b))
-> (Maybe (Either a b) -> (Maybe a, Maybe b))
-> Bijection (->) (Maybe a, Maybe b) (Maybe (Either a b))
forall (a :: * -> * -> *) b c. a b c -> a c b -> Bijection a b c
:<->: Maybe (Either a b) -> (Maybe a, Maybe b)
forall {a} {a}. Maybe (Either a a) -> (Maybe a, Maybe a)
ue)
    Bijection (->) (Maybe a, Maybe b) (Maybe (Either a b))
-> m (Maybe a, Maybe b) -> m (Maybe (Either a b))
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< (m (Maybe a)
f m (Maybe a) -> m (Maybe b) -> m (Maybe a, Maybe b)
forall a b. m a -> m b -> m (a, b)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< m (Maybe b)
g)
    where
    ue :: Maybe (Either a a) -> (Maybe a, Maybe a)
ue Maybe (Either a a)
Nothing = (Maybe a
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing)
    ue (Just (Left a
a)) = (a -> Maybe a
forall a. a -> Maybe a
Just a
a, Maybe a
forall a. Maybe a
Nothing)
    ue (Just (Right a
b)) = (Maybe a
forall a. Maybe a
Nothing, a -> Maybe a
forall a. a -> Maybe a
Just a
b)