-- Copyright (C) 2017  Fraser Tweedale
--
-- hs-notmuch is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE RankNTypes #-}

{-|

Stuff that we don't want to export by default, but that we
do want to expose in the library interface.

-}

module Notmuch.Util where

import Control.Exception (bracket)
import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader, asks)
import Data.Foldable (traverse_)
import Data.Functor.Identity (Identity(..))
import Data.Profunctor (Choice)
import Data.Profunctor.Unsafe ((#.), (.#))
import Data.Tagged (Tagged(..))

type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
type Prism' s a = Prism s s a a

type Lens' a b = forall f. Functor f => (b -> f b) -> (a -> f a)

review :: MonadReader b m => Prism' t b -> m t
review :: forall b (m :: * -> *) t. MonadReader b m => Prism' t b -> m t
review Prism' t b
p = (b -> t) -> m t
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t)
-> (Tagged b (Identity b) -> Identity t)
-> Tagged b (Identity b)
-> t
forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> (a -> b) -> a -> c
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Tagged t (Identity t) -> Identity t
forall {k} (s :: k) b. Tagged s b -> b
unTagged (Tagged t (Identity t) -> Identity t)
-> (Tagged b (Identity b) -> Tagged t (Identity t))
-> Tagged b (Identity b)
-> Identity t
forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> (a -> b) -> a -> c
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Tagged b (Identity b) -> Tagged t (Identity t)
Prism' t b
p (Tagged b (Identity b) -> t)
-> (Identity b -> Tagged b (Identity b)) -> Identity b -> t
forall a b c (q :: * -> * -> *).
Coercible b a =>
(b -> c) -> q a b -> a -> c
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# Identity b -> Tagged b (Identity b)
forall {k} (s :: k) b. b -> Tagged s b
Tagged (Identity b -> t) -> (b -> Identity b) -> b -> t
forall a b c (q :: * -> * -> *).
Coercible b a =>
(b -> c) -> q a b -> a -> c
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# b -> Identity b
forall a. a -> Identity a
Identity)
{-# INLINE review #-}

-- | Variant of 'bracket' that works with ExceptT and allows
-- resource acquisition to fail, propagating the error.  If
-- resource finalisation fails, the error is discarded.
--
bracketT
  :: (MonadError e m, MonadIO m)
  => ExceptT e IO a
  -> (a -> ExceptT e IO b)
  -> (a -> ExceptT e IO c)
  -> m c
bracketT :: forall e (m :: * -> *) a b c.
(MonadError e m, MonadIO m) =>
ExceptT e IO a
-> (a -> ExceptT e IO b) -> (a -> ExceptT e IO c) -> m c
bracketT ExceptT e IO a
acq a -> ExceptT e IO b
rel a -> ExceptT e IO c
go = IO (Either e c) -> m (Either e c)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (
  IO (Either e a)
-> (Either e a -> IO (Either e ()))
-> (Either e a -> IO (Either e c))
-> IO (Either e c)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    (ExceptT e IO a -> IO (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e IO a
acq)
    (ExceptT e IO () -> IO (Either e ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e IO () -> IO (Either e ()))
-> (Either e a -> ExceptT e IO ())
-> Either e a
-> IO (Either e ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> ExceptT e IO b) -> Either e a -> ExceptT e IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ a -> ExceptT e IO b
rel)
    (ExceptT e IO c -> IO (Either e c)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e IO c -> IO (Either e c))
-> (Either e a -> ExceptT e IO c) -> Either e a -> IO (Either e c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> ExceptT e IO c)
-> (a -> ExceptT e IO c) -> Either e a -> ExceptT e IO c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> ExceptT e IO c
forall a. e -> ExceptT e IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> ExceptT e IO c
go)
  ) m (Either e c) -> (Either e c -> m c) -> m c
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (e -> m c) -> (c -> m c) -> Either e c -> m c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m c
forall a. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError c -> m c
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure