{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
module Control.Lens.FileSystem.Internal.Combinators where

import Control.Lens
import Control.Lens.Action
import Control.Lens.Action.Internal
import Control.Applicative

-- | If a given fold fails (e.g. with an exception), recover and simply return 0 elements
-- rather than crashing.
recovering :: (Monad m, Alternative m, Monoid r, Effective m r f) => Over' p f s a -> Over' p f s a
recovering :: Over' p f s a -> Over' p f s a
recovering fld :: Over' p f s a
fld f :: p a (f a)
f s :: s
s = m r -> f s
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
m r -> f a
effective (f s -> m r
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
f a -> m r
ineffective (Over' p f s a
fld p a (f a)
f s
s) m r -> m r -> m r
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
forall a. Monoid a => a
mempty)

-- | Try the given fold, if it throws an exception then return the input as the output instead
tryOrContinue :: (Monad m, Alternative m) => Acting m r a a -> Acting m r a a
tryOrContinue :: Acting m r a a -> Acting m r a a
tryOrContinue = (Acting m r a a -> (a -> m a) -> Acting m r a a)
-> (a -> m a) -> Acting m r a a -> Acting m r a a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Acting m r a a -> (a -> m a) -> Acting m r a a
forall (m :: * -> *) r s b.
(Monad m, Alternative m) =>
Acting m r s b -> (s -> m b) -> Acting m r s b
tryCatch a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Try the given fold, if it throws an exception then use the given handler to compute a
-- replacement value and continue with that.
tryCatch :: (Monad m, Alternative m) => Acting m r s b -> (s -> m b) -> Acting m r s b
tryCatch :: Acting m r s b -> (s -> m b) -> Acting m r s b
tryCatch fld :: Acting m r s b
fld handler :: s -> m b
handler f :: b -> Effect m r b
f a :: s
a = m r -> Effect m r s
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
m r -> f a
effective (Effect m r s -> m r
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
f a -> m r
ineffective (Acting m r s b
fld b -> Effect m r b
f s
a) m r -> m r -> m r
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (s -> m b
handler s
a m b -> (b -> m r) -> m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Effect m r b -> m r
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
f a -> m r
ineffective (Effect m r b -> m r) -> (b -> Effect m r b) -> b -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Effect m r b
f))

-- | Filter a fold using a monadic action
filteredM :: (Monad m, Monoid r) => (a -> m Bool) -> Acting m r a a
filteredM :: (a -> m Bool) -> Acting m r a a
filteredM predicate :: a -> m Bool
predicate f :: a -> Effect m r a
f a :: a
a = m r -> Effect m r a
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
m r -> f a
effective m r
go
  where
    go :: m r
go = do
      a -> m Bool
predicate a
a m Bool -> (Bool -> m r) -> m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        True -> Effect m r a -> m r
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
f a -> m r
ineffective (a -> Effect m r a
f a
a)
        False -> r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
forall a. Monoid a => a
mempty

-- | Merge two folds
merging :: (Applicative f, Contravariant f) => LensLike' f s a -> LensLike' f s a -> LensLike' f s a
merging :: LensLike' f s a -> LensLike' f s a -> LensLike' f s a
merging fold1 :: LensLike' f s a
fold1 fold2 :: LensLike' f s a
fold2 nextFold :: a -> f a
nextFold s :: s
s = LensLike' f s a
fold1 a -> f a
nextFold s
s f s -> f s -> f s
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LensLike' f s a
fold2 a -> f a
nextFold s
s

-- | Include the results of an additional fold alongside the original values
including :: (Applicative f, Contravariant f) => LensLike' f a a -> LensLike' f a a
including :: LensLike' f a a -> LensLike' f a a
including = LensLike' f a a -> LensLike' f a a -> LensLike' f a a
forall (f :: * -> *) s a.
(Applicative f, Contravariant f) =>
LensLike' f s a -> LensLike' f s a -> LensLike' f s a
merging LensLike' f a a
forall a. a -> a
id