{-# LANGUAGE CPP          #-}
{-# LANGUAGE Trustworthy  #-}
{-# LANGUAGE TypeFamilies #-}

-- | This module exports functions which allow to process instances of
-- 'Container' type class in monadic way.

module Universum.Monad.Container
       ( concatMapM
       , concatForM

       , allM
       , anyM
       , andM
       , orM
       ) where

import Control.Applicative (Applicative (pure))
import Data.Function ((.))
import Data.Traversable (Traversable (traverse))
import Prelude (Bool (..), Monoid, flip)
#if MIN_VERSION_base(4,17,0)
import Data.Type.Equality (type (~))
#endif

import Universum.Base (IO)
import Universum.Container (Container, Element, fold, toList)
import Universum.Functor (fmap)
import Universum.Monad.Reexport (Monad (..))

-- $setup
-- :set -XOverloadedStrings
-- >>> import Universum.Base (even)
-- >>> import Universum.Monad (Maybe (..), (>=>))
-- >>> import Universum.Print (putTextLn)
-- >>> import Universum.String (readMaybe)

-- | Lifting bind into a monad. Generalized version of @concatMap@
-- that works with a monadic predicate. Old and simpler specialized to list
-- version had next type:
--
-- @
-- concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
-- @
--
-- Side note: previously it had type
--
-- @
-- concatMapM :: (Applicative q, Monad m, Traversable m)
--            => (a -> q (m b)) -> m a -> q (m b)
-- @
--
-- Such signature didn't allow to use this function when traversed container
-- type and type of returned by function-argument differed.
-- Now you can use it like e.g.
--
-- @
-- concatMapM readFile files >>= putTextLn
-- @
concatMapM
    :: ( Applicative f
       , Monoid m
       , Container (l m)
       , Element (l m) ~ m
       , Traversable l
       )
    => (a -> f m) -> l a -> f m
concatMapM :: forall (f :: * -> *) m (l :: * -> *) a.
(Applicative f, Monoid m, Container (l m), Element (l m) ~ m,
 Traversable l) =>
(a -> f m) -> l a -> f m
concatMapM a -> f m
f = (l m -> m) -> f (l m) -> f m
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap l m -> m
l m -> Element (l m)
forall t. (Container t, Monoid (Element t)) => t -> Element t
fold (f (l m) -> f m) -> (l a -> f (l m)) -> l a -> f m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f m) -> l a -> f (l m)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> l a -> f (l b)
traverse a -> f m
f
{-# INLINE concatMapM #-}

-- | Like 'concatMapM', but has its arguments flipped, so can be used
-- instead of the common @fmap concat $ forM@ pattern.
concatForM
    :: ( Applicative f
       , Monoid m
       , Container (l m)
       , Element (l m) ~ m
       , Traversable l
       )
    => l a -> (a -> f m) -> f m
concatForM :: forall (f :: * -> *) m (l :: * -> *) a.
(Applicative f, Monoid m, Container (l m), Element (l m) ~ m,
 Traversable l) =>
l a -> (a -> f m) -> f m
concatForM = ((a -> f m) -> l a -> f m) -> l a -> (a -> f m) -> f m
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> f m) -> l a -> f m
forall (f :: * -> *) m (l :: * -> *) a.
(Applicative f, Monoid m, Container (l m), Element (l m) ~ m,
 Traversable l) =>
(a -> f m) -> l a -> f m
concatMapM
{-# INLINE concatForM #-}

-- | Monadic and constrained to 'Container' version of 'Prelude.and'.
--
-- >>> andM [Just True, Just False]
-- Just False
-- >>> andM [Just True]
-- Just True
-- >>> andM [Just True, Just False, Nothing]
-- Just False
-- >>> andM [Just True, Nothing]
-- Nothing
-- >>> andM [putTextLn "1" >> pure True, putTextLn "2" >> pure False, putTextLn "3" >> pure True]
-- 1
-- 2
-- False
andM :: (Container f, Element f ~ m Bool, Monad m) => f -> m Bool
andM :: forall f (m :: * -> *).
(Container f, Element f ~ m Bool, Monad m) =>
f -> m Bool
andM = [m Bool] -> m Bool
forall {f :: * -> *}. Monad f => [f Bool] -> f Bool
go ([m Bool] -> m Bool) -> (f -> [m Bool]) -> f -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> [m Bool]
f -> [Element f]
forall t. Container t => t -> [Element t]
toList
  where
    go :: [f Bool] -> f Bool
go []     = Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    go (f Bool
p:[f Bool]
ps) = do
        Bool
q <- f Bool
p
        if Bool
q then [f Bool] -> f Bool
go [f Bool]
ps else Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | Monadic and constrained to 'Container' version of 'Prelude.or'.
--
-- >>> orM [Just True, Just False]
-- Just True
-- >>> orM [Just True, Nothing]
-- Just True
-- >>> orM [Nothing, Just True]
-- Nothing
orM :: (Container f, Element f ~ m Bool, Monad m) => f -> m Bool
orM :: forall f (m :: * -> *).
(Container f, Element f ~ m Bool, Monad m) =>
f -> m Bool
orM = [m Bool] -> m Bool
forall {f :: * -> *}. Monad f => [f Bool] -> f Bool
go ([m Bool] -> m Bool) -> (f -> [m Bool]) -> f -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> [m Bool]
f -> [Element f]
forall t. Container t => t -> [Element t]
toList
  where
    go :: [f Bool] -> f Bool
go []     = Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    go (f Bool
p:[f Bool]
ps) = do
        Bool
q <- f Bool
p
        if Bool
q then Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True else [f Bool] -> f Bool
go [f Bool]
ps

-- | Monadic and constrained to 'Container' version of 'Prelude.all'.
--
-- >>> allM (readMaybe >=> pure . even) ["6", "10"]
-- Just True
-- >>> allM (readMaybe >=> pure . even) ["5", "aba"]
-- Just False
-- >>> allM (readMaybe >=> pure . even) ["aba", "10"]
-- Nothing
allM :: (Container f, Monad m) => (Element f -> m Bool) -> f -> m Bool
allM :: forall f (m :: * -> *).
(Container f, Monad m) =>
(Element f -> m Bool) -> f -> m Bool
allM Element f -> m Bool
p = [Element f] -> m Bool
go ([Element f] -> m Bool) -> (f -> [Element f]) -> f -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> [Element f]
forall t. Container t => t -> [Element t]
toList
  where
    go :: [Element f] -> m Bool
go []     = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    go (Element f
x:[Element f]
xs) = do
        Bool
q <- Element f -> m Bool
p Element f
x
        if Bool
q then [Element f] -> m Bool
go [Element f]
xs else Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | Monadic and constrained to 'Container' version of 'Prelude.any'.
--
-- >>> anyM (readMaybe >=> pure . even) ["5", "10"]
-- Just True
-- >>> anyM (readMaybe >=> pure . even) ["10", "aba"]
-- Just True
-- >>> anyM (readMaybe >=> pure . even) ["aba", "10"]
-- Nothing
anyM :: (Container f, Monad m) => (Element f -> m Bool) -> f -> m Bool
anyM :: forall f (m :: * -> *).
(Container f, Monad m) =>
(Element f -> m Bool) -> f -> m Bool
anyM Element f -> m Bool
p = [Element f] -> m Bool
go ([Element f] -> m Bool) -> (f -> [Element f]) -> f -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> [Element f]
forall t. Container t => t -> [Element t]
toList
  where
    go :: [Element f] -> m Bool
go []     = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    go (Element f
x:[Element f]
xs) = do
        Bool
q <- Element f -> m Bool
p Element f
x
        if Bool
q then Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True else [Element f] -> m Bool
go [Element f]
xs

{-# SPECIALIZE andM :: [IO Bool] -> IO Bool #-}
{-# SPECIALIZE orM  :: [IO Bool] -> IO Bool #-}
{-# SPECIALIZE anyM :: (a -> IO Bool) -> [a] -> IO Bool #-}
{-# SPECIALIZE allM :: (a -> IO Bool) -> [a] -> IO Bool #-}