{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Scientist.Experiment.Run
( experimentRun
, experimentRunInternal
) where
import Prelude
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.IO.Unlift (MonadUnliftIO(..))
import Data.Bifunctor (second)
import Data.Bitraversable (bimapM)
import Data.Either (partitionEithers)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import Scientist.Control
import Scientist.Duration
import Scientist.Experiment
import Scientist.NamedCandidate
import Scientist.Result
import Scientist.Result.Evaluate
import System.Random.Shuffle (shuffleM)
import UnliftIO.Exception (handleAny, throwString)
experimentRun :: MonadUnliftIO m => Experiment m c a b -> m a
experimentRun :: Experiment m c a b -> m a
experimentRun = (Result c a b -> a) -> m (Result c a b) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result c a b -> a
forall c a b. Result c a b -> a
resultValue (m (Result c a b) -> m a)
-> (Experiment m c a b -> m (Result c a b))
-> Experiment m c a b
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Experiment m c a b -> m (Result c a b)
forall (m :: * -> *) c a b.
MonadUnliftIO m =>
Experiment m c a b -> m (Result c a b)
experimentRunInternal
experimentRunInternal
:: MonadUnliftIO m => Experiment m c a b -> m (Result c a b)
experimentRunInternal :: Experiment m c a b -> m (Result c a b)
experimentRunInternal Experiment m c a b
ex = do
Bool
enabled <- Experiment m c a b -> m Bool
forall (m :: * -> *) c a b.
Applicative m =>
Experiment m c a b -> m Bool
isExperimentEnabled Experiment m c a b
ex
let
getName :: Either a (NamedCandidate m a) -> Text
getName = \case
Left{} -> Text
"control"
Right NamedCandidate m a
nc -> NamedCandidate m a -> Text
forall (m :: * -> *) a. NamedCandidate m a -> Text
namedCandidateName NamedCandidate m a
nc
case Experiment m c a b -> Maybe (NonEmpty (NamedCandidate m b))
forall (m :: * -> *) c a b.
Experiment m c a b -> Maybe (NonEmpty (NamedCandidate m b))
getExperimentTries Experiment m c a b
ex of
Just NonEmpty (NamedCandidate m b)
candidates | Bool
enabled -> do
(ResultControl a
controlResult, NonEmpty (ResultCandidate b)
candidateResults, [Text]
order) <- m (Control a)
-> NonEmpty (NamedCandidate m b)
-> (m (Control a) -> m (ResultControl a))
-> (NamedCandidate m b -> m (ResultCandidate b))
-> (Either (m (Control a)) (NamedCandidate m b) -> Text)
-> m (ResultControl a, NonEmpty (ResultCandidate b), [Text])
forall (m :: * -> *) a b a' b'.
MonadIO m =>
a
-> NonEmpty b
-> (a -> m a')
-> (b -> m b')
-> (Either a b -> Text)
-> m (a', NonEmpty b', [Text])
runRandomized
m (Control a)
control
NonEmpty (NamedCandidate m b)
candidates
m (Control a) -> m (ResultControl a)
forall (m :: * -> *) a.
MonadIO m =>
m (Control a) -> m (ResultControl a)
runControl
NamedCandidate m b -> m (ResultCandidate b)
forall (m :: * -> *) b.
MonadUnliftIO m =>
NamedCandidate m b -> m (ResultCandidate b)
runCandidate
Either (m (Control a)) (NamedCandidate m b) -> Text
forall a (m :: * -> *) a. Either a (NamedCandidate m a) -> Text
getName
let result :: Result c a b
result = Experiment m c a b
-> ResultControl a
-> NonEmpty (ResultCandidate b)
-> [Text]
-> Result c a b
forall (m :: * -> *) c a b.
Experiment m c a b
-> ResultControl a
-> NonEmpty (ResultCandidate b)
-> [Text]
-> Result c a b
evaluateResult Experiment m c a b
ex ResultControl a
controlResult NonEmpty (ResultCandidate b)
candidateResults [Text]
order
Result c a b
result Result c a b -> m () -> m (Result c a b)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (SomeException -> m ()) -> m () -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny
(Experiment m c a b -> SomeException -> m ()
forall (m :: * -> *) c a b.
MonadIO m =>
Experiment m c a b -> SomeException -> m ()
getExperimentOnException Experiment m c a b
ex)
(Experiment m c a b -> Result c a b -> m ()
forall (m :: * -> *) c a b.
Applicative m =>
Experiment m c a b -> Result c a b -> m ()
getExperimentPublish Experiment m c a b
ex Result c a b
result)
Maybe (NonEmpty (NamedCandidate m b))
_ -> Control a -> Result c a b
forall c a b. Control a -> Result c a b
ResultSkipped (Control a -> Result c a b) -> m (Control a) -> m (Result c a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Control a)
control
where control :: m (Control a)
control = Experiment m c a b -> m (Control a)
forall (m :: * -> *) c a b. Experiment m c a b -> m (Control a)
getExperimentUse Experiment m c a b
ex
isExperimentEnabled :: Applicative m => Experiment m c a b -> m Bool
isExperimentEnabled :: Experiment m c a b -> m Bool
isExperimentEnabled Experiment m c a b
ex
| Bool -> Bool
not (Experiment m c a b -> Bool
forall (m :: * -> *) c a b. Experiment m c a b -> Bool
getExperimentRunIf Experiment m c a b
ex) = Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
| Bool
otherwise = Experiment m c a b -> m Bool
forall (m :: * -> *) c a b.
Applicative m =>
Experiment m c a b -> m Bool
getExperimentEnabled Experiment m c a b
ex
runControl :: MonadIO m => m (Control a) -> m (ResultControl a)
runControl :: m (Control a) -> m (ResultControl a)
runControl m (Control a)
control = do
(Control a
a, Duration
d) <- m (Control a) -> m (Control a, Duration)
forall (m :: * -> *) a. MonadIO m => m a -> m (a, Duration)
measureDuration m (Control a)
control
ResultControl a -> m (ResultControl a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResultControl :: forall a. Text -> a -> Duration -> ResultControl a
ResultControl
{ resultControlName :: Text
resultControlName = Text
"control"
, resultControlValue :: a
resultControlValue = a
a
, resultControlDuration :: Duration
resultControlDuration = Duration
d
}
runCandidate :: MonadUnliftIO m => NamedCandidate m b -> m (ResultCandidate b)
runCandidate :: NamedCandidate m b -> m (ResultCandidate b)
runCandidate NamedCandidate m b
nc = do
(Either SomeException b
b, Duration
d) <- m (Either SomeException b) -> m (Either SomeException b, Duration)
forall (m :: * -> *) a. MonadIO m => m a -> m (a, Duration)
measureDuration (m (Either SomeException b)
-> m (Either SomeException b, Duration))
-> m (Either SomeException b)
-> m (Either SomeException b, Duration)
forall a b. (a -> b) -> a -> b
$ NamedCandidate m b -> m (Either SomeException b)
forall (m :: * -> *) a.
MonadUnliftIO m =>
NamedCandidate m a -> m (Either SomeException a)
runNamedCandidate NamedCandidate m b
nc
ResultCandidate b -> m (ResultCandidate b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResultCandidate b -> m (ResultCandidate b))
-> ResultCandidate b -> m (ResultCandidate b)
forall a b. (a -> b) -> a -> b
$ ResultCandidate :: forall a.
Text -> Either SomeException a -> Duration -> ResultCandidate a
ResultCandidate
{ resultCandidateName :: Text
resultCandidateName = NamedCandidate m b -> Text
forall (m :: * -> *) a. NamedCandidate m a -> Text
namedCandidateName NamedCandidate m b
nc
, resultCandidateValue :: Either SomeException b
resultCandidateValue = Either SomeException b
b
, resultCandidateDuration :: Duration
resultCandidateDuration = Duration
d
}
runRandomized
:: MonadIO m
=> a
-> NonEmpty b
-> (a -> m a')
-> (b -> m b')
-> (Either a b -> Text)
-> m (a', NonEmpty b', [Text])
runRandomized :: a
-> NonEmpty b
-> (a -> m a')
-> (b -> m b')
-> (Either a b -> Text)
-> m (a', NonEmpty b', [Text])
runRandomized a
a NonEmpty b
bs a -> m a'
runA b -> m b'
runB Either a b -> Text
toName = do
[Either a b]
inputs <- IO [Either a b] -> m [Either a b]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Either a b] -> m [Either a b])
-> IO [Either a b] -> m [Either a b]
forall a b. (a -> b) -> a -> b
$ [Either a b] -> IO [Either a b]
forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
shuffleM ([Either a b] -> IO [Either a b])
-> [Either a b] -> IO [Either a b]
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
a Either a b -> [Either a b] -> [Either a b]
forall a. a -> [a] -> [a]
: (b -> Either a b) -> [b] -> [Either a b]
forall a b. (a -> b) -> [a] -> [b]
map b -> Either a b
forall a b. b -> Either a b
Right (NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
bs)
[Either a' b']
outputs <- (Either a b -> m (Either a' b'))
-> [Either a b] -> m [Either a' b']
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> m a') -> (b -> m b') -> Either a b -> m (Either a' b')
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM a -> m a'
runA b -> m b'
runB) [Either a b]
inputs
let
order :: [Text]
order = (Either a b -> Text) -> [Either a b] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Either a b -> Text
toName [Either a b]
inputs
partitioned :: ([a'], [b'])
partitioned = [Either a' b'] -> ([a'], [b'])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either a' b']
outputs
case ([b'] -> Maybe (NonEmpty b'))
-> ([a'], [b']) -> ([a'], Maybe (NonEmpty b'))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [b'] -> Maybe (NonEmpty b')
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([a'], [b'])
partitioned of
([a'
a'], Just NonEmpty b'
bs') -> (a', NonEmpty b', [Text]) -> m (a', NonEmpty b', [Text])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a'
a', NonEmpty b'
bs', [Text]
order)
([a'], Maybe (NonEmpty b'))
_ ->
String -> m (a', NonEmpty b', [Text])
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString
(String -> m (a', NonEmpty b', [Text]))
-> String -> m (a', NonEmpty b', [Text])
forall a b. (a -> b) -> a -> b
$ String
"runRandomized did not produce 1 Left and 1+ Rights, but "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([a'] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a'] -> Int) -> [a'] -> Int
forall a b. (a -> b) -> a -> b
$ ([a'], [b']) -> [a']
forall a b. (a, b) -> a
fst ([a'], [b'])
partitioned)
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Left(s), and "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([b'] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([b'] -> Int) -> [b'] -> Int
forall a b. (a -> b) -> a -> b
$ ([a'], [b']) -> [b']
forall a b. (a, b) -> b
snd ([a'], [b'])
partitioned)
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Rights(s)"