{-# LANGUAGE UndecidableInstances #-}

module Blucontrol.Monad.Control.Count (
  ControlCountT
, runControlCountT
, ConfigCount (..)
, CountableException (..)
) where

import Control.DeepSeq
import Control.Monad
import Control.Monad.Base
import Control.Monad.Trans.Control
import Control.Monad.Trans.Control.Default
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Default
import GHC.Generics
import Numeric.Natural

import Blucontrol.Monad.Control

newtype ControlCountT m a = ControlCountT { forall (m :: * -> *) a.
ControlCountT m a -> StateT Natural (ReaderT ConfigCount m) a
unControlCountT :: StateT Natural (ReaderT ConfigCount m) a }
  deriving (Functor (ControlCountT m)
Functor (ControlCountT m)
-> (forall a. a -> ControlCountT m a)
-> (forall a b.
    ControlCountT m (a -> b) -> ControlCountT m a -> ControlCountT m b)
-> (forall a b c.
    (a -> b -> c)
    -> ControlCountT m a -> ControlCountT m b -> ControlCountT m c)
-> (forall a b.
    ControlCountT m a -> ControlCountT m b -> ControlCountT m b)
-> (forall a b.
    ControlCountT m a -> ControlCountT m b -> ControlCountT m a)
-> Applicative (ControlCountT m)
forall a. a -> ControlCountT m a
forall a b.
ControlCountT m a -> ControlCountT m b -> ControlCountT m a
forall a b.
ControlCountT m a -> ControlCountT m b -> ControlCountT m b
forall a b.
ControlCountT m (a -> b) -> ControlCountT m a -> ControlCountT m b
forall a b c.
(a -> b -> c)
-> ControlCountT m a -> ControlCountT m b -> ControlCountT m c
forall {m :: * -> *}. Monad m => Functor (ControlCountT m)
forall (m :: * -> *) a. Monad m => a -> ControlCountT m a
forall (m :: * -> *) a b.
Monad m =>
ControlCountT m a -> ControlCountT m b -> ControlCountT m a
forall (m :: * -> *) a b.
Monad m =>
ControlCountT m a -> ControlCountT m b -> ControlCountT m b
forall (m :: * -> *) a b.
Monad m =>
ControlCountT m (a -> b) -> ControlCountT m a -> ControlCountT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ControlCountT m a -> ControlCountT m b -> ControlCountT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> ControlCountT m a
pure :: forall a. a -> ControlCountT m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
ControlCountT m (a -> b) -> ControlCountT m a -> ControlCountT m b
<*> :: forall a b.
ControlCountT m (a -> b) -> ControlCountT m a -> ControlCountT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ControlCountT m a -> ControlCountT m b -> ControlCountT m c
liftA2 :: forall a b c.
(a -> b -> c)
-> ControlCountT m a -> ControlCountT m b -> ControlCountT m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
ControlCountT m a -> ControlCountT m b -> ControlCountT m b
*> :: forall a b.
ControlCountT m a -> ControlCountT m b -> ControlCountT m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
ControlCountT m a -> ControlCountT m b -> ControlCountT m a
<* :: forall a b.
ControlCountT m a -> ControlCountT m b -> ControlCountT m a
Applicative, (forall a b. (a -> b) -> ControlCountT m a -> ControlCountT m b)
-> (forall a b. a -> ControlCountT m b -> ControlCountT m a)
-> Functor (ControlCountT m)
forall a b. a -> ControlCountT m b -> ControlCountT m a
forall a b. (a -> b) -> ControlCountT m a -> ControlCountT m b
forall (m :: * -> *) a b.
Functor m =>
a -> ControlCountT m b -> ControlCountT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ControlCountT m a -> ControlCountT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ControlCountT m a -> ControlCountT m b
fmap :: forall a b. (a -> b) -> ControlCountT m a -> ControlCountT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> ControlCountT m b -> ControlCountT m a
<$ :: forall a b. a -> ControlCountT m b -> ControlCountT m a
Functor, Applicative (ControlCountT m)
Applicative (ControlCountT m)
-> (forall a b.
    ControlCountT m a -> (a -> ControlCountT m b) -> ControlCountT m b)
-> (forall a b.
    ControlCountT m a -> ControlCountT m b -> ControlCountT m b)
-> (forall a. a -> ControlCountT m a)
-> Monad (ControlCountT m)
forall a. a -> ControlCountT m a
forall a b.
ControlCountT m a -> ControlCountT m b -> ControlCountT m b
forall a b.
ControlCountT m a -> (a -> ControlCountT m b) -> ControlCountT m b
forall (m :: * -> *). Monad m => Applicative (ControlCountT m)
forall (m :: * -> *) a. Monad m => a -> ControlCountT m a
forall (m :: * -> *) a b.
Monad m =>
ControlCountT m a -> ControlCountT m b -> ControlCountT m b
forall (m :: * -> *) a b.
Monad m =>
ControlCountT m a -> (a -> ControlCountT m b) -> ControlCountT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
ControlCountT m a -> (a -> ControlCountT m b) -> ControlCountT m b
>>= :: forall a b.
ControlCountT m a -> (a -> ControlCountT m b) -> ControlCountT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
ControlCountT m a -> ControlCountT m b -> ControlCountT m b
>> :: forall a b.
ControlCountT m a -> ControlCountT m b -> ControlCountT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> ControlCountT m a
return :: forall a. a -> ControlCountT m a
Monad, MonadBase b, MonadBaseControl b)
  deriving ((forall (m :: * -> *) a. Monad m => m a -> ControlCountT m a)
-> MonadTrans ControlCountT
forall (m :: * -> *) a. Monad m => m a -> ControlCountT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> ControlCountT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> ControlCountT m a
MonadTrans, MonadTrans ControlCountT
MonadTrans ControlCountT
-> (forall (m :: * -> *) a.
    Monad m =>
    (Run ControlCountT -> m a) -> ControlCountT m a)
-> (forall (m :: * -> *) a.
    Monad m =>
    m (StT ControlCountT a) -> ControlCountT m a)
-> MonadTransControl ControlCountT
forall (m :: * -> *) a.
Monad m =>
m (StT ControlCountT a) -> ControlCountT m a
forall (m :: * -> *) a.
Monad m =>
(Run ControlCountT -> m a) -> ControlCountT m a
forall (t :: (* -> *) -> * -> *).
MonadTrans t
-> (forall (m :: * -> *) a. Monad m => (Run t -> m a) -> t m a)
-> (forall (m :: * -> *) a. Monad m => m (StT t a) -> t m a)
-> MonadTransControl t
$cliftWith :: forall (m :: * -> *) a.
Monad m =>
(Run ControlCountT -> m a) -> ControlCountT m a
liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run ControlCountT -> m a) -> ControlCountT m a
$crestoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT ControlCountT a) -> ControlCountT m a
restoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT ControlCountT a) -> ControlCountT m a
MonadTransControl) via Stack2T (StateT Natural) (ReaderT ConfigCount)

instance MonadBaseControl IO m => MonadControl (ControlCountT m) where
  type ControlConstraint (ControlCountT m) a = CountableException a
  doInbetween :: forall a.
ControlConstraint (ControlCountT m) a =>
a -> ControlCountT m ()
doInbetween a
a = do if a -> Bool
forall a. CountableException a => a -> Bool
isException a
a
                        then StateT Natural (ReaderT ConfigCount m) () -> ControlCountT m ()
forall (m :: * -> *) a.
StateT Natural (ReaderT ConfigCount m) a -> ControlCountT m a
ControlCountT (StateT Natural (ReaderT ConfigCount m) () -> ControlCountT m ())
-> StateT Natural (ReaderT ConfigCount m) () -> ControlCountT m ()
forall a b. (a -> b) -> a -> b
$ (Natural -> Natural) -> StateT Natural (ReaderT ConfigCount m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify Natural -> Natural
forall a. Enum a => a -> a
succ
                        else StateT Natural (ReaderT ConfigCount m) () -> ControlCountT m ()
forall (m :: * -> *) a.
StateT Natural (ReaderT ConfigCount m) a -> ControlCountT m a
ControlCountT (StateT Natural (ReaderT ConfigCount m) () -> ControlCountT m ())
-> StateT Natural (ReaderT ConfigCount m) () -> ControlCountT m ()
forall a b. (a -> b) -> a -> b
$ Natural -> StateT Natural (ReaderT ConfigCount m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Natural
0
                     Natural
current <- StateT Natural (ReaderT ConfigCount m) Natural
-> ControlCountT m Natural
forall (m :: * -> *) a.
StateT Natural (ReaderT ConfigCount m) a -> ControlCountT m a
ControlCountT StateT Natural (ReaderT ConfigCount m) Natural
forall s (m :: * -> *). MonadState s m => m s
get
                     Natural
limit <- StateT Natural (ReaderT ConfigCount m) Natural
-> ControlCountT m Natural
forall (m :: * -> *) a.
StateT Natural (ReaderT ConfigCount m) a -> ControlCountT m a
ControlCountT (StateT Natural (ReaderT ConfigCount m) Natural
 -> ControlCountT m Natural)
-> (ReaderT ConfigCount m Natural
    -> StateT Natural (ReaderT ConfigCount m) Natural)
-> ReaderT ConfigCount m Natural
-> ControlCountT m Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT ConfigCount m Natural
-> StateT Natural (ReaderT ConfigCount m) Natural
forall (m :: * -> *) a. Monad m => m a -> StateT Natural m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ConfigCount m Natural -> ControlCountT m Natural)
-> ReaderT ConfigCount m Natural -> ControlCountT m Natural
forall a b. (a -> b) -> a -> b
$ (ConfigCount -> Natural) -> ReaderT ConfigCount m Natural
forall a. (ConfigCount -> a) -> ReaderT ConfigCount m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader ConfigCount -> Natural
maxCount
                     Bool -> ControlCountT m () -> ControlCountT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Natural
current Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< Natural
limit) (ControlCountT m () -> ControlCountT m ())
-> ControlCountT m () -> ControlCountT m ()
forall a b. (a -> b) -> a -> b
$
                        [Char] -> ControlCountT m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> ControlCountT m ()) -> [Char] -> ControlCountT m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"failed after " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Natural -> [Char]
forall a. Show a => a -> [Char]
show Natural
limit [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" consecutive tries"

runControlCountT :: Monad m => ConfigCount -> ControlCountT m a -> m (a, Natural)
runControlCountT :: forall (m :: * -> *) a.
Monad m =>
ConfigCount -> ControlCountT m a -> m (a, Natural)
runControlCountT !ConfigCount
conf ControlCountT m a
tma = ReaderT ConfigCount m (a, Natural) -> ConfigCount -> m (a, Natural)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT Natural (ReaderT ConfigCount m) a
-> Natural -> ReaderT ConfigCount m (a, Natural)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ControlCountT m a -> StateT Natural (ReaderT ConfigCount m) a
forall (m :: * -> *) a.
ControlCountT m a -> StateT Natural (ReaderT ConfigCount m) a
unControlCountT ControlCountT m a
tma) Natural
0) ConfigCount
conf

newtype ConfigCount = ConfigCount { ConfigCount -> Natural
maxCount :: Natural
                                  }
  deriving (ConfigCount -> ConfigCount -> Bool
(ConfigCount -> ConfigCount -> Bool)
-> (ConfigCount -> ConfigCount -> Bool) -> Eq ConfigCount
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConfigCount -> ConfigCount -> Bool
== :: ConfigCount -> ConfigCount -> Bool
$c/= :: ConfigCount -> ConfigCount -> Bool
/= :: ConfigCount -> ConfigCount -> Bool
Eq, (forall x. ConfigCount -> Rep ConfigCount x)
-> (forall x. Rep ConfigCount x -> ConfigCount)
-> Generic ConfigCount
forall x. Rep ConfigCount x -> ConfigCount
forall x. ConfigCount -> Rep ConfigCount x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ConfigCount -> Rep ConfigCount x
from :: forall x. ConfigCount -> Rep ConfigCount x
$cto :: forall x. Rep ConfigCount x -> ConfigCount
to :: forall x. Rep ConfigCount x -> ConfigCount
Generic, Eq ConfigCount
Eq ConfigCount
-> (ConfigCount -> ConfigCount -> Ordering)
-> (ConfigCount -> ConfigCount -> Bool)
-> (ConfigCount -> ConfigCount -> Bool)
-> (ConfigCount -> ConfigCount -> Bool)
-> (ConfigCount -> ConfigCount -> Bool)
-> (ConfigCount -> ConfigCount -> ConfigCount)
-> (ConfigCount -> ConfigCount -> ConfigCount)
-> Ord ConfigCount
ConfigCount -> ConfigCount -> Bool
ConfigCount -> ConfigCount -> Ordering
ConfigCount -> ConfigCount -> ConfigCount
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ConfigCount -> ConfigCount -> Ordering
compare :: ConfigCount -> ConfigCount -> Ordering
$c< :: ConfigCount -> ConfigCount -> Bool
< :: ConfigCount -> ConfigCount -> Bool
$c<= :: ConfigCount -> ConfigCount -> Bool
<= :: ConfigCount -> ConfigCount -> Bool
$c> :: ConfigCount -> ConfigCount -> Bool
> :: ConfigCount -> ConfigCount -> Bool
$c>= :: ConfigCount -> ConfigCount -> Bool
>= :: ConfigCount -> ConfigCount -> Bool
$cmax :: ConfigCount -> ConfigCount -> ConfigCount
max :: ConfigCount -> ConfigCount -> ConfigCount
$cmin :: ConfigCount -> ConfigCount -> ConfigCount
min :: ConfigCount -> ConfigCount -> ConfigCount
Ord, ReadPrec [ConfigCount]
ReadPrec ConfigCount
Int -> ReadS ConfigCount
ReadS [ConfigCount]
(Int -> ReadS ConfigCount)
-> ReadS [ConfigCount]
-> ReadPrec ConfigCount
-> ReadPrec [ConfigCount]
-> Read ConfigCount
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ConfigCount
readsPrec :: Int -> ReadS ConfigCount
$creadList :: ReadS [ConfigCount]
readList :: ReadS [ConfigCount]
$creadPrec :: ReadPrec ConfigCount
readPrec :: ReadPrec ConfigCount
$creadListPrec :: ReadPrec [ConfigCount]
readListPrec :: ReadPrec [ConfigCount]
Read, Int -> ConfigCount -> [Char] -> [Char]
[ConfigCount] -> [Char] -> [Char]
ConfigCount -> [Char]
(Int -> ConfigCount -> [Char] -> [Char])
-> (ConfigCount -> [Char])
-> ([ConfigCount] -> [Char] -> [Char])
-> Show ConfigCount
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ConfigCount -> [Char] -> [Char]
showsPrec :: Int -> ConfigCount -> [Char] -> [Char]
$cshow :: ConfigCount -> [Char]
show :: ConfigCount -> [Char]
$cshowList :: [ConfigCount] -> [Char] -> [Char]
showList :: [ConfigCount] -> [Char] -> [Char]
Show)

instance NFData ConfigCount

instance Default ConfigCount where
  def :: ConfigCount
def = ConfigCount { maxCount :: Natural
maxCount = Natural
5
                    }

class CountableException a where
  isException :: a -> Bool

instance CountableException () where
  isException :: () -> Bool
isException () = Bool
False

instance CountableException a => CountableException (Maybe a) where
  isException :: Maybe a -> Bool
isException Maybe a
Nothing = Bool
True
  isException (Just a
a) = a -> Bool
forall a. CountableException a => a -> Bool
isException a
a

instance CountableException a => CountableException (Either b a) where
  isException :: Either b a -> Bool
isException (Left b
_) = Bool
True
  isException (Right a
a) = a -> Bool
forall a. CountableException a => a -> Bool
isException a
a