{-# LANGUAGE UndecidableInstances #-}

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

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

import Blucontrol.Control

newtype ControlCountT m a = ControlCountT { ControlCountT m a -> StateT Natural (ReaderT ConfigCount m) a
unControlCountT :: StateT Natural (ReaderT ConfigCount m) a }
  deriving (Functor (ControlCountT m)
a -> ControlCountT m a
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)
ControlCountT m a -> ControlCountT m b -> ControlCountT m b
ControlCountT m a -> ControlCountT m b -> ControlCountT m a
ControlCountT m (a -> b) -> ControlCountT m a -> ControlCountT m b
(a -> b -> c)
-> ControlCountT m a -> ControlCountT m b -> ControlCountT m c
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
<* :: ControlCountT m a -> ControlCountT m b -> ControlCountT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
ControlCountT m a -> ControlCountT m b -> ControlCountT m a
*> :: ControlCountT m a -> ControlCountT m b -> ControlCountT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
ControlCountT m a -> ControlCountT m b -> ControlCountT m b
liftA2 :: (a -> b -> c)
-> ControlCountT m a -> ControlCountT m b -> ControlCountT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ControlCountT m a -> ControlCountT m b -> ControlCountT m c
<*> :: ControlCountT m (a -> b) -> ControlCountT m a -> ControlCountT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
ControlCountT m (a -> b) -> ControlCountT m a -> ControlCountT m b
pure :: a -> ControlCountT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> ControlCountT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (ControlCountT m)
Applicative, a -> ControlCountT m b -> ControlCountT m a
(a -> b) -> ControlCountT m a -> ControlCountT m b
(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
<$ :: a -> ControlCountT m b -> ControlCountT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> ControlCountT m b -> ControlCountT m a
fmap :: (a -> b) -> ControlCountT m a -> ControlCountT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ControlCountT m a -> ControlCountT m b
Functor, Applicative (ControlCountT m)
a -> ControlCountT m a
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)
ControlCountT m a -> (a -> ControlCountT m b) -> ControlCountT m b
ControlCountT m a -> ControlCountT m b -> ControlCountT m b
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
return :: a -> ControlCountT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> ControlCountT m a
>> :: ControlCountT m a -> ControlCountT m b -> ControlCountT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
ControlCountT m a -> ControlCountT m b -> ControlCountT m b
>>= :: ControlCountT m a -> (a -> ControlCountT m b) -> ControlCountT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
ControlCountT m a -> (a -> ControlCountT m b) -> ControlCountT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (ControlCountT m)
Monad, MonadBase b, MonadBaseControl b)

instance MonadTrans ControlCountT where
  lift :: m a -> ControlCountT m a
lift = StateT Natural (ReaderT ConfigCount m) a -> ControlCountT m a
forall (m :: * -> *) a.
StateT Natural (ReaderT ConfigCount m) a -> ControlCountT m a
ControlCountT (StateT Natural (ReaderT ConfigCount m) a -> ControlCountT m a)
-> (m a -> StateT Natural (ReaderT ConfigCount m) a)
-> m a
-> ControlCountT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT ConfigCount m a -> StateT Natural (ReaderT ConfigCount m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ConfigCount m a
 -> StateT Natural (ReaderT ConfigCount m) a)
-> (m a -> ReaderT ConfigCount m a)
-> m a
-> StateT Natural (ReaderT ConfigCount m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT ConfigCount m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MonadBaseControl IO m => MonadControl (ControlCountT m) where
  type ControlConstraint (ControlCountT m) a = CountableException a
  doInbetween :: 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 (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 r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader ConfigCount -> Natural
maxCount
                     if Natural
current Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
limit
                        then [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"
                        else () -> ControlCountT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

runControlCountT :: Monad m => ConfigCount -> ControlCountT m a -> m a
runControlCountT :: ConfigCount -> ControlCountT m a -> m a
runControlCountT ConfigCount
conf ControlCountT m a
tma = ReaderT ConfigCount m a -> ConfigCount -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT Natural (ReaderT ConfigCount m) a
-> Natural -> ReaderT ConfigCount m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (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
/= :: ConfigCount -> ConfigCount -> Bool
$c/= :: ConfigCount -> ConfigCount -> Bool
== :: ConfigCount -> ConfigCount -> Bool
$c== :: 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
$cto :: forall x. Rep ConfigCount x -> ConfigCount
$cfrom :: forall x. ConfigCount -> Rep ConfigCount x
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
min :: ConfigCount -> ConfigCount -> ConfigCount
$cmin :: ConfigCount -> ConfigCount -> ConfigCount
max :: ConfigCount -> ConfigCount -> ConfigCount
$cmax :: ConfigCount -> ConfigCount -> ConfigCount
>= :: ConfigCount -> ConfigCount -> Bool
$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
compare :: ConfigCount -> ConfigCount -> Ordering
$ccompare :: ConfigCount -> ConfigCount -> Ordering
$cp1Ord :: Eq 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
readListPrec :: ReadPrec [ConfigCount]
$creadListPrec :: ReadPrec [ConfigCount]
readPrec :: ReadPrec ConfigCount
$creadPrec :: ReadPrec ConfigCount
readList :: ReadS [ConfigCount]
$creadList :: ReadS [ConfigCount]
readsPrec :: Int -> ReadS ConfigCount
$creadsPrec :: Int -> ReadS 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
showList :: [ConfigCount] -> [Char] -> [Char]
$cshowList :: [ConfigCount] -> [Char] -> [Char]
show :: ConfigCount -> [Char]
$cshow :: ConfigCount -> [Char]
showsPrec :: Int -> ConfigCount -> [Char] -> [Char]
$cshowsPrec :: Int -> ConfigCount -> [Char] -> [Char]
Show)

instance NFData ConfigCount

instance Default ConfigCount where
  def :: ConfigCount
def = ConfigCount :: Natural -> ConfigCount
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