{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
module RIO.Prelude.Extra
  ( mapLeft
  , fromFirst
  , mapMaybeA
  , mapMaybeM
  , forMaybeA
  , forMaybeM
  , foldMapM
  , nubOrd
  , whenM
  , unlessM
  , (<&>)
  , asIO
  ) where

import Prelude
import qualified Data.Set as Set
import Data.Monoid (First (..))
import Data.Foldable (foldlM)
import Data.Functor
import Data.Maybe
import Control.Monad

-- | Apply a function to a 'Left' constructor
mapLeft :: (a1 -> a2) -> Either a1 b -> Either a2 b
mapLeft :: (a1 -> a2) -> Either a1 b -> Either a2 b
mapLeft a1 -> a2
f (Left a1
a1) = a2 -> Either a2 b
forall a b. a -> Either a b
Left (a1 -> a2
f a1
a1)
mapLeft a1 -> a2
_ (Right b
b) = b -> Either a2 b
forall a b. b -> Either a b
Right b
b

-- | Get a 'First' value with a default fallback
fromFirst :: a -> First a -> a
fromFirst :: a -> First a -> a
fromFirst a
x = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
x (Maybe a -> a) -> (First a -> Maybe a) -> First a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. First a -> Maybe a
forall a. First a -> Maybe a
getFirst

-- | Applicative 'mapMaybe'.
mapMaybeA :: Applicative f => (a -> f (Maybe b)) -> [a] -> f [b]
mapMaybeA :: (a -> f (Maybe b)) -> [a] -> f [b]
mapMaybeA a -> f (Maybe b)
f = ([Maybe b] -> [b]) -> f [Maybe b] -> f [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe b] -> [b]
forall a. [Maybe a] -> [a]
catMaybes (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 [Maybe b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f (Maybe b)
f

-- | @'forMaybeA' '==' 'flip' 'mapMaybeA'@
forMaybeA :: Applicative f => [a] -> (a -> f (Maybe b)) -> f [b]
forMaybeA :: [a] -> (a -> f (Maybe b)) -> f [b]
forMaybeA = ((a -> f (Maybe b)) -> [a] -> f [b])
-> [a] -> (a -> f (Maybe b)) -> f [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> f (Maybe b)) -> [a] -> f [b]
forall (f :: * -> *) a b.
Applicative f =>
(a -> f (Maybe b)) -> [a] -> f [b]
mapMaybeA

-- | Monadic 'mapMaybe'.
mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM :: (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM a -> m (Maybe b)
f = ([Maybe b] -> [b]) -> m [Maybe b] -> m [b]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Maybe b] -> [b]
forall a. [Maybe a] -> [a]
catMaybes (m [Maybe b] -> m [b]) -> ([a] -> m [Maybe b]) -> [a] -> m [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m (Maybe b)) -> [a] -> m [Maybe b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m (Maybe b)
f

-- | @'forMaybeM' '==' 'flip' 'mapMaybeM'@
forMaybeM :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM :: [a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM = ((a -> m (Maybe b)) -> [a] -> m [b])
-> [a] -> (a -> m (Maybe b)) -> m [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m (Maybe b)) -> [a] -> m [b]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM

-- | Extend 'foldMap' to allow side effects.
--
-- Internally, this is implemented using a strict left fold. This is used for
-- performance reasons. It also necessitates that this function has a @Monad@
-- constraint and not just an @Applicative@ constraint. For more information,
-- see
-- <https://github.com/commercialhaskell/rio/pull/99#issuecomment-394179757>.
--
-- @since 0.1.3.0
foldMapM
  :: (Monad m, Monoid w, Foldable t)
  => (a -> m w)
  -> t a
  -> m w
foldMapM :: (a -> m w) -> t a -> m w
foldMapM a -> m w
f = (w -> a -> m w) -> w -> t a -> m w
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
  (\w
acc a
a -> do
    w
w <- a -> m w
f a
a
    w -> m w
forall (m :: * -> *) a. Monad m => a -> m a
return (w -> m w) -> w -> m w
forall a b. (a -> b) -> a -> b
$! w -> w -> w
forall a. Monoid a => a -> a -> a
mappend w
acc w
w)
  w
forall a. Monoid a => a
mempty

-- | Strip out duplicates
nubOrd :: Ord a => [a] -> [a]
nubOrd :: [a] -> [a]
nubOrd =
  Set a -> [a] -> [a]
forall a. Ord a => Set a -> [a] -> [a]
loop Set a
forall a. Monoid a => a
mempty
  where
    loop :: Set a -> [a] -> [a]
loop Set a
_ [] = []
    loop !Set a
s (a
a:[a]
as)
      | a
a a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
s = Set a -> [a] -> [a]
loop Set a
s [a]
as
      | Bool
otherwise = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
loop (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
a Set a
s) [a]
as

-- | Run the second value if the first value returns 'True'
whenM :: Monad m => m Bool -> m () -> m ()
whenM :: m Bool -> m () -> m ()
whenM m Bool
boolM m ()
action = m Bool
boolM m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`when` m ()
action)

-- | Run the second value if the first value returns 'False'
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM :: m Bool -> m () -> m ()
unlessM m Bool
boolM m ()
action = m Bool
boolM m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`unless` m ()
action)

#if !MIN_VERSION_base(4, 11, 0)
(<&>) :: Functor f => f a -> (a -> b) -> f b
as <&> f = f <$> as

infixl 1 <&>
#endif


-- | Helper function to force an action to run in 'IO'. Especially
-- useful for overly general contexts, like hspec tests.
--
-- @since 0.1.3.0
asIO :: IO a -> IO a
asIO :: IO a -> IO a
asIO = IO a -> IO a
forall a. a -> a
id