{-# 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

-- | 'experimentRun' but returning the full 'Result'
--
-- Used for testing.
--
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') -- ^ How to run the @a@
  -> (b -> m b') -- ^ How to run each @b@
  -> (Either a b -> Text)
  -- ^ How to identify each item in the reported order
  -> 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'))
_ ->
      -- Justification for this being "impossible":
      --
      -- - We cannot produce an a or b out of thin air
      -- - We were given an a and NonEmpty b
      -- - We cannot forget to use a without an unused warning
      -- - We cannot forget to use bs without an unused warning
      -- - We're doing no filtering anywhere
      --
      -- Therefore, there's no way to not get 1 Left and 1+ Rights here.
      --
      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)"