{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
module Data.Registry.Warmup where
import qualified Control.Monad.Catch as Catch
import Data.Semigroup ((<>))
#if MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)
import Protolude as P hiding ((<>))
#else
import Protolude as P hiding ((<>))
import Data.Typeable
#endif
newtype Warmup =
Warmup
{ Warmup -> [IO Result]
_warmUp :: [IO Result]
} deriving (Semigroup Warmup
Warmup
Semigroup Warmup
-> Warmup
-> (Warmup -> Warmup -> Warmup)
-> ([Warmup] -> Warmup)
-> Monoid Warmup
[Warmup] -> Warmup
Warmup -> Warmup -> Warmup
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Warmup] -> Warmup
$cmconcat :: [Warmup] -> Warmup
mappend :: Warmup -> Warmup -> Warmup
$cmappend :: Warmup -> Warmup -> Warmup
mempty :: Warmup
$cmempty :: Warmup
$cp1Monoid :: Semigroup Warmup
Monoid, b -> Warmup -> Warmup
NonEmpty Warmup -> Warmup
Warmup -> Warmup -> Warmup
(Warmup -> Warmup -> Warmup)
-> (NonEmpty Warmup -> Warmup)
-> (forall b. Integral b => b -> Warmup -> Warmup)
-> Semigroup Warmup
forall b. Integral b => b -> Warmup -> Warmup
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Warmup -> Warmup
$cstimes :: forall b. Integral b => b -> Warmup -> Warmup
sconcat :: NonEmpty Warmup -> Warmup
$csconcat :: NonEmpty Warmup -> Warmup
<> :: Warmup -> Warmup -> Warmup
$c<> :: Warmup -> Warmup -> Warmup
Semigroup)
warmupOf :: Typeable a => a -> IO () -> Warmup
warmupOf :: a -> IO () -> Warmup
warmupOf a
a IO ()
action = IO Result -> Warmup
createWarmup (IO Result -> Warmup) -> IO Result -> Warmup
forall a b. (a -> b) -> a -> b
$
do Either SomeException ()
res <- IO () -> IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Catch.try IO ()
action :: IO (Either SomeException ())
Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$
case Either SomeException ()
res of
Left SomeException
e -> Text -> Result
failed (Text -> Result) -> Text -> Result
forall a b. (a -> b) -> a -> b
$ Text
"KO: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show SomeException
e
Right ()
_ -> Text -> Result
ok (Text -> Result) -> Text -> Result
forall a b. (a -> b) -> a -> b
$ Text
"OK: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a)
createWarmup :: IO Result -> Warmup
createWarmup :: IO Result -> Warmup
createWarmup IO Result
t = [IO Result] -> Warmup
Warmup [IO Result
t]
noWarmup :: Warmup
noWarmup :: Warmup
noWarmup = [IO Result] -> Warmup
Warmup [Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
Empty]
declareWarmup :: Typeable a => a -> Warmup
declareWarmup :: a -> Warmup
declareWarmup a
a = a -> IO () -> Warmup
forall a. Typeable a => a -> IO () -> Warmup
warmupOf a
a (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
data Result =
Empty
| Ok [Text]
| Failed [Text]
deriving (Result -> Result -> Bool
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq, Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show)
isSuccess :: Result -> Bool
isSuccess :: Result -> Bool
isSuccess Result
Empty = Bool
True
isSuccess (Ok [Text]
_) = Bool
True
isSuccess (Failed [Text]
_) = Bool
False
ok :: Text -> Result
ok :: Text -> Result
ok Text
t = [Text] -> Result
Ok [Text
t]
failed :: Text -> Result
failed :: Text -> Result
failed Text
t = [Text] -> Result
Failed [Text
t]
messages :: Result -> [Text]
messages :: Result -> [Text]
messages Result
Empty = []
messages (Ok [Text]
ms) = [Text]
ms
messages (Failed [Text]
ms) = [Text]
ms
instance Monoid Result where
mempty :: Result
mempty = Result
Empty
mappend :: Result -> Result -> Result
mappend = Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
(<>)
instance Semigroup Result where
Result
r <> :: Result -> Result -> Result
<> Result
Empty = Result
r
Result
Empty <> Result
r = Result
r
Failed [Text]
ts <> Result
r = [Text] -> Result
Failed ([Text]
ts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Result -> [Text]
messages Result
r)
Result
r <> Failed [Text]
ts = [Text] -> Result
Failed (Result -> [Text]
messages Result
r [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
ts)
Ok [Text]
ts1 <> Ok [Text]
ts2 = [Text] -> Result
Ok ([Text]
ts1 [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
ts2)
runWarmup :: Warmup -> IO Result
runWarmup :: Warmup -> IO Result
runWarmup (Warmup [IO Result]
as) = (IO Result -> IO Result -> IO Result)
-> IO Result -> [IO Result] -> IO Result
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' IO Result -> IO Result -> IO Result
runBoth (Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
Empty) [IO Result]
as
runBoth :: IO Result -> IO Result -> IO Result
runBoth :: IO Result -> IO Result -> IO Result
runBoth IO Result
io1 IO Result
io2 = do
Either SomeException Result
res1 <- IO Result -> IO (Either SomeException Result)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Catch.try IO Result
io1 :: IO (Either SomeException Result)
Either SomeException Result
res2 <- IO Result -> IO (Either SomeException Result)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Catch.try IO Result
io2 :: IO (Either SomeException Result)
Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$
case (Either SomeException Result
res1, Either SomeException Result
res2) of
(Right Result
r1, Right Result
r2) -> Result
r1 Result -> Result -> Result
forall a. Monoid a => a -> a -> a
`mappend` Result
r2
(Left SomeException
r1, Right Result
r2) -> Text -> Result
failed (SomeException -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show SomeException
r1) Result -> Result -> Result
forall a. Monoid a => a -> a -> a
`mappend` Result
r2
(Right Result
r1, Left SomeException
r2) -> Result
r1 Result -> Result -> Result
forall a. Monoid a => a -> a -> a
`mappend` Text -> Result
failed (SomeException -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show SomeException
r2)
(Left SomeException
r1, Left SomeException
r2) -> [Text] -> Result
Failed [SomeException -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show SomeException
r1, SomeException -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show SomeException
r2]