{-# 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)

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 :: (a -> f m) -> l a -> f m
concatMapM a -> f m
f = (l m -> m) -> f (l m) -> f m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap l m -> 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)
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 :: 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 :: 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]
forall t. Container t => t -> [Element t]
toList
  where
    go :: [f Bool] -> f Bool
go []     = Bool -> f Bool
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 (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 :: 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]
forall t. Container t => t -> [Element t]
toList
  where
    go :: [f Bool] -> f Bool
go []     = Bool -> f Bool
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 (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 :: (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 (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 (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 :: (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 (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 (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 #-}