packages feed

scientist (empty) → 0.0.0.0

raw patch · 16 files changed

+1389/−0 lines, 16 filesdep +MonadRandomdep +basedep +clock

Dependencies added: MonadRandom, base, clock, hspec, markdown-unlit, random-shuffle, scientist, text, unliftio, unliftio-core

Files

+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2021 Renaissance Learning Inc++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.lhs view
@@ -0,0 +1,416 @@+# Scientist++Haskell port of+[`github/scientist`](https://github.com/github/scientist#readme).++## Usage++The following extensions are recommended:++```haskell+{-# LANGUAGE OverloadedStrings #-}+```++<!--+```haskell+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}++module Main (module Main) where++import Prelude++import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Data.Foldable (for_)+import Data.Text (Text)+import UnliftIO.Exception (SomeException, throwIO, displayException)+```+-->++Most usage will only require the top-level library:++```haskell+import Scientist+```++<!--+```haskell+import Text.Markdown.Unlit ()++theOriginalCode :: m a+theOriginalCode = undefined++theExperimentalCode :: m a+theExperimentalCode = undefined+```+-->++1. Define a new `Experiment m c a b` with,++   ```haskell+   ex0 :: Functor m => Experiment m c a b+   ex0 = newExperiment "some name" theOriginalCode+   ```++1. The type variables capture the following details:++   - `m`: Some Monad to operate in, e.g. `IO`.+   - `c`: Any context value you attach with `setExperimentContext`. It will then+     be available in the `Result c a b` you publish.+   - `a`: The result type of your original (aka "control") code, this is what is+     always returned and so is the return type of `experimentRun`.+   - `b`: The result type of your experimental (aka "candidate") code. It+     probably won't differ (and must not to use a comparison like `(==)`), but+     it can (provided you implement a comparison between `a` and `b`).++1. Configure the Experiment as desired++   ```haskell+   ex1 :: (Functor m, Eq a) => Experiment m c a a+   ex1 =+     setExperimentPublish publish0+       $ setExperimentCompare experimentCompareEq+       $ setExperimentTry theExperimentalCode+       $ newExperiment "some name" theOriginalCode++   -- Increment Statsd, Log, store in Redis, whatever+   publish0 :: Result c a b -> m ()+   publish0 = undefined+   ```++1. Run the experiment++   ```haskell+   run0 :: (MonadUnliftIO m, Eq a) => m a+   run0 =+     experimentRun+       $ setExperimentPublish publish0+       $ setExperimentCompare experimentCompareEq+       $ setExperimentTry theExperimentalCode+       $ newExperiment "some name" theOriginalCode+   ```++1. Explore things like `setExperimentIgnore`, `setExperimentEnabled`, etc.++---++The rest of this README matches section-by-section to the ported project and+shows only the differences in syntax for those features. Please follow the+header links for additional details, motivation, etc.++## [How do I science?](https://github.com/github/scientist#how-do-i-science)++<!--+```haskell+data Model = Model++data User = User++userLogin :: User -> Text+userLogin = undefined++userCanRead :: User -> Model -> m Bool+userCanRead = undefined++modelCheckUserValid :: Model -> User -> m Bool+modelCheckUserValid = undefined+```+-->++```haskell+myWidgetAllows :: MonadUnliftIO m => Model -> User -> m Bool+myWidgetAllows model user = do+  experimentRun+    $ setExperimentTry+        (userCanRead user model) -- new way+    $ newExperiment "widget-permissions"+        (modelCheckUserValid model user) -- old way+```++## [Making science useful](https://github.com/github/scientist#making-science-useful)++```haskell+run1 :: MonadUnliftIO m => m a+run1 =+  experimentRun+    $ setExperimentEnabled (pure True)+    $ setExperimentOnException onScientistException+    $ setExperimentPublish (liftIO . putStrLn . formatResult)+    $ setExperimentTry theExperimentalCode+    $ newExperiment "some name" theOriginalCode++onScientistException :: MonadIO m => SomeException -> m ()+onScientistException ex = do+  liftIO $ putStrLn "..."++  -- To re-raise+  throwIO ex++formatResult :: Result c a b -> String+formatResult = undefined+```++### [Controlling comparison](https://github.com/github/scientist#controlling-comparison)++<!--+```haskell+userServiceFetch :: m [User]+userServiceFetch = undefined++fetchAllUsers :: m [User]+fetchAllUsers = undefined+```+--->++```haskell+run2 :: MonadUnliftIO m => m [User]+run2 =+  experimentRun+    $ setExperimentCompare (experimentCompareOn $ map userLogin)+    $ setExperimentTry userServiceFetch+    $ newExperiment "users" fetchAllUsers+```++When using `experimentCompareOn`, `By`, or `Eq`, if a candidate branch raises an+exception, that will never compare equally.++### [Adding context](https://github.com/github/scientist#adding-context)++See `setExperimentContext`.++### [Expensive setup](https://github.com/github/scientist#expensive-setup)++Just do it ahead of time.++<!--+```haskell+data X = X++expensiveSetup :: m X+expensiveSetup = undefined++theOriginalCodeWith :: X -> m a+theOriginalCodeWith = undefined++theExperimentalCodeWith :: X -> m a+theExperimentalCodeWith = undefined+```+-->++```haskell+run3 :: MonadUnliftIO m => m a+run3 = do+  x <- expensiveSetup++  experimentRun+    $ setExperimentTry (theExperimentalCodeWith x)+    $ newExperiment "expensive" (theOriginalCodeWith x)+```++### [Keeping it clean](https://github.com/github/scientist#keeping-it-clean)++Not supported at this time. Format the value(s) as necessary when publishing.++### [Ignoring mismatches](https://github.com/github/scientist#ignoring-mismatches)++See `setExperimentIgnore`.++### [Enabling/disabling experiments](https://github.com/github/scientist#enablingdisabling-experiments)++See `setExperimentRunIf`.++### [Ramping up experiments](https://github.com/github/scientist#ramping-up-experiments)++```haskell+run4 :: MonadUnliftIO m => m a+run4 =+  experimentRun+    $ setExperimentEnabled (experimentEnabledPercent 30)+    $ setExperimentTry theExperimentalCode+    $ newExperiment "some name" theOriginalCode+```++### [Publishing results](https://github.com/github/scientist#publishing-results)++<!--+```haskell+data Value = Value++data Pair = Pair++toJSON :: a -> Value+toJSON = undefined++(.=) :: Text -> a -> Pair+(.=) = undefined++object :: [Pair] -> Value+object = undefined++data MyContext = MyContext++data MyPayload = MyPayload+  { name :: Text+  , context :: Maybe MyContext+  , control :: Value+  , candidate :: Value+  , execution_order :: [Text]+  }++statsdTiming :: Text -> a -> m ()+statsdTiming = undefined++statsdIncrement :: Text -> m ()+statsdIncrement = undefined++redisLpush :: Text -> Value -> m ()+redisLpush = undefined++redisLtrim :: Text -> Int -> Int -> m ()+redisLtrim = undefined+```+-->++```haskell+run5 :: MonadUnliftIO m => m User+run5 =+  experimentRun+    $ setExperimentPublish publish1+    $ setExperimentTry theExperimentalCode+    $ newExperiment "some name" theOriginalCode++publish1 :: MonadIO m => Result MyContext User User -> m ()+publish1 result = do+  -- Details are present unless it's a ResultSkipped, which we'll ignore+  for_ (resultDetails result) $ \details -> do+    let eName = resultDetailsExperimentName details++    -- Store the timing for the control value,+    statsdTiming ("science." <> eName <> ".control")+      $ resultControlDuration+      $ resultDetailsControl details++    -- for the candidate (only the first, see "Breaking the rules" below,+    statsdTiming ("science." <> eName <> ".candidate")+      $ resultCandidateDuration+      $ resultDetailsCandidate details++    -- and counts for match/ignore/mismatch:+    case result of+      ResultSkipped{} -> pure ()+      ResultMatched{} -> do+        statsdIncrement $ "science." <> eName <> ".matched"+      ResultIgnored{} -> do+        statsdIncrement $ "science." <> eName <> ".ignored"+      ResultMismatched{} -> do+        statsdIncrement $ "science." <> eName <> ".mismatched"+        -- Finally, store mismatches in redis so they can be retrieved and+        -- examined later on, for debugging and research.+        storeMismatchData details++storeMismatchData :: Monad m => ResultDetails MyContext User User -> m ()+storeMismatchData details = do+  let+    eName = resultDetailsExperimentName details+    eContext = resultDetailsExperimentContext details++    payload = MyPayload+      { name = eName+      , context = eContext+      , control = controlObservationPayload $ resultDetailsControl details+      , candidate = candidateObservationPayload $ resultDetailsCandidate details+      , execution_order = resultDetailsExecutionOrder details+      }++    key = "science." <> eName <> ".mismatch"++  redisLpush key $ toJSON payload+  redisLtrim key 0 1000++controlObservationPayload :: ResultControl User -> Value+controlObservationPayload rc =+  object ["value" .= cleanValue (resultControlValue rc)]++candidateObservationPayload :: ResultCandidate User -> Value+candidateObservationPayload rc = case resultCandidateValue rc of+  Left ex -> object ["exception" .= displayException ex]+  Right user -> object ["value" .= cleanValue user]++-- See "Keeping it clean" above+cleanValue :: User -> Text+cleanValue = userLogin+```++See `Result`, `ResultDetails`, `ResultControl` and `ResultCandidate` for all the+available data you can publish.++### [Testing](https://github.com/github/scientist#testing)++**TODO**: `raise_on_mismatches`++#### [Custom mismatch errors](https://github.com/github/scientist#custom-mismatch-errors)++**TODO**: `raise_with`++### [Handling errors](https://github.com/github/scientist#handling-errors)++#### [In candidate code](https://github.com/github/scientist#in-candidate-code)++Candidate code is wrapped in `tryAny`, resulting in `Either SomeException`+values in the result candidates list. We use the [safer][blog]+`UnliftIO.Exception` module.++[blog]: https://www.fpcomplete.com/haskell/tutorial/exceptions/++#### [In a Scientist callback](https://github.com/github/scientist#in-a-scientist-callback)++See `setExperimentOnException`.++## [Breaking the rules](https://github.com/github/scientist#breaking-the-rules)++### [Ignoring results entirely](https://github.com/github/scientist#ignoring-results-entirely)++```haskell+nope0 :: Experiment m c a b -> Experiment m c a b+nope0 = setExperimentIgnore (\_ _ -> True)+```++Or, more efficiently:++```haskell+nope1 :: Experiment m c a b -> Experiment m c a b+nope1 = setExperimentCompare (\_ _ -> True)+```++### [Trying more than one thing](https://github.com/github/scientist#trying-more-than-one-thing)++If you call `setExperimentTry` more than once, it will append (not overwrite)+candidate branches. If any candidate is deemed ignored or a mismatch, the+overall result will be.++`setExperimentTryNamed` can be used to give branches explicit names (otherwise,+they are "control", "candidate", "candidate-{n}"). These names are visible in+`ResultControl`, `ResultCandidate`, and `resultDetailsExecutionOrder`.++### [No control, just candidates](https://github.com/github/scientist#no-control-just-candidates)++Not supported.++Supporting the lack of a Control branch in the types would ultimately lead to a+runtime error if you attempt to run such an `Experiment` without having and+naming a Candidate to use instead, or severely complicate the types to account+for that safely. In our opinion, this feature is not worth either of those.++<!--+```haskell+main :: IO ()+main = pure ()+```+-->++---++[LICENSE](./LICENSE) | [CHANGELOG](./CHANGELOG.md)
+ library/Scientist.hs view
@@ -0,0 +1,14 @@+module Scientist+  ( module X+  ) where++import Scientist.Experiment as X+import Scientist.Experiment.Run as X+import Scientist.Result as X+  ( Result(..)+  , ResultCandidate(..)+  , ResultControl(..)+  , ResultDetails(..)+  , resultDetails+  , resultDetailsCandidate+  )
+ library/Scientist/Candidate.hs view
@@ -0,0 +1,7 @@+module Scientist.Candidate+  ( Candidate(..)+  ) where++newtype Candidate a = Candidate+  { unCandidate :: a+  }
+ library/Scientist/Control.hs view
@@ -0,0 +1,7 @@+module Scientist.Control+  ( Control(..)+  ) where++newtype Control a = Control+  { unControl :: a+  }
+ library/Scientist/Duration.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Scientist.Duration+  ( Duration+  , measureDuration+  , durationToSeconds+  ) where++import Prelude++import Control.Monad.IO.Class (MonadIO(..))+import Data.Fixed (Fixed(..), Nano, showFixed)+import qualified System.Clock as Clock++-- | Time elapsed in seconds up to nanosecond precision+--+-- >> 1.005+-- 1.005s+newtype Duration = Duration+  { _unDuration :: Nano+  }+  deriving stock (Eq)+  deriving newtype (Enum, Ord, Num, Real, Fractional, RealFrac)++instance Show Duration where+  show (Duration x) = showFixed True x <> "s"++measureDuration :: MonadIO m => m a -> m (a, Duration)+measureDuration f = do+  begin <- liftIO getTime+  (,) <$> f <*> liftIO+    (fromNanoSecs . Clock.toNanoSecs . subtract begin <$> getTime)+  where getTime = Clock.getTime Clock.Monotonic++-- | Convert from duration to seconds+--+-- >> toSecs 0.000001+-- 0.000001+durationToSeconds :: Duration -> Double+durationToSeconds = realToFrac++-- | Convert to duration from nanoseconds+--+-- >> fromNanoSecs 1000+-- 0.000001s+fromNanoSecs :: Integer -> Duration+fromNanoSecs = Duration . MkFixed
+ library/Scientist/Experiment.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Scientist.Experiment+  ( Experiment++  -- * Construction+  , newExperiment++  -- * Modifiying values+  , setExperimentTry+  , setExperimentTryNamed+  , setExperimentEnabled+  , setExperimentOnException+  , setExperimentCompare+  , setExperimentContext+  , setExperimentIgnore+  , setExperimentRunIf+  , setExperimentPublish++  -- * Common modifying values+  , experimentCompareEq+  , experimentCompareOn+  , experimentCompareBy+  , experimentEnabledPercent++  -- * Accessing values+  , getExperimentName+  , getExperimentUse+  , getExperimentTries+  , getExperimentEnabled+  , getExperimentOnException+  , getExperimentCompare+  , getExperimentContext+  , getExperimentIgnore+  , getExperimentRunIf+  , getExperimentPublish+  ) where++import Prelude++import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Random (evalRandIO, getRandomR)+import Data.Function (on)+import Data.List.NonEmpty+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack)+import Scientist.Candidate+import Scientist.Control+import Scientist.NamedCandidate+import Scientist.Result+import UnliftIO.Exception (SomeException, throwIO)++data Experiment m c a b = Experiment+  { experimentName :: Text+  , experimentUse :: m (Control a)+  , experimentTries :: Maybe (NonEmpty (NamedCandidate m b))+  , experimentEnabled :: Maybe (m Bool)+  , experimentOnException :: Maybe (SomeException -> m ())+  , experimentCompare+      :: Maybe (Control a -> Either SomeException (Candidate b) -> Bool)+  , experimentContext :: Maybe c+  , experimentIgnore+      :: Maybe (Control a -> Either SomeException (Candidate b) -> Bool)+  , experimentRunIf :: Maybe Bool+  , experimentPublish :: Maybe (Result c a b -> m ())+  , experimentCandidateCount :: Int+  }++newExperiment :: Functor m => Text -> m a -> Experiment m c a b+newExperiment name f = Experiment+  { experimentName = name+  , experimentUse = Control <$> f+  , experimentTries = Nothing+  , experimentEnabled = Nothing+  , experimentOnException = Nothing+  , experimentCompare = Nothing+  , experimentContext = Nothing+  , experimentIgnore = Nothing+  , experimentRunIf = Nothing+  , experimentPublish = Nothing+  , experimentCandidateCount = 0+  }++-- | A new, candidate code path+--+-- If called multiple times, adds multiple candidate paths.+--+-- By default, there are no candidate paths and running the experiment will+-- return 'ResultSkipped'.+--+setExperimentTry+  :: Functor m => m b -> Experiment m c a b -> Experiment m c a b+setExperimentTry = setExperimentTryInternal Nothing++setExperimentTryNamed+  :: Functor m => Text -> m b -> Experiment m c a b -> Experiment m c a b+setExperimentTryNamed = setExperimentTryInternal . Just++setExperimentTryInternal+  :: Functor m => Maybe Text -> m b -> Experiment m c a b -> Experiment m c a b+setExperimentTryInternal mName f ex = ex+  { experimentTries = Just updated+  , experimentCandidateCount = updatedCount+  }+ where+  thisTry = pure $ namedCandidate thisName $ Candidate <$> f+  thisName = fromMaybe inferName mName+  inferName = case currentCount of+    0 -> "candidate"+    n -> pack $ "candidate-" <> show n++  current = experimentTries ex+  updated = maybe thisTry (<> thisTry) current++  currentCount = experimentCandidateCount ex+  updatedCount = currentCount + 1++-- | If the candidate paths should be executed+--+-- See 'experimentEnabledPercent' for an example.+--+-- By default, candidate paths are always run.+--+setExperimentEnabled :: m Bool -> Experiment m c a b -> Experiment m c a b+setExperimentEnabled f ex = ex { experimentEnabled = Just f }++-- | How to handle an exception evaluating or publishing+--+-- By default, the exception is re-thrown.+--+setExperimentOnException+  :: (SomeException -> m ()) -> Experiment m c a b -> Experiment m c a b+setExperimentOnException f ex = ex { experimentOnException = Just f }++-- | Decide if a given result is a match.+--+-- See 'experimentCompareEq' and 'experimentCompareBy'.+--+-- By default, all comparisons fail.+--+setExperimentCompare+  :: (Control a -> Either SomeException (Candidate b) -> Bool)+  -> Experiment m c a b+  -> Experiment m c a b+setExperimentCompare f ex = ex { experimentCompare = Just f }++-- | Decide if a given result should be ignored+--+-- By default, no results are ignored.+--+setExperimentIgnore+  :: (Control a -> Either SomeException (Candidate b) -> Bool)+  -> Experiment m c a b+  -> Experiment m c a b+setExperimentIgnore f ex = ex { experimentIgnore = Just f }++-- | Decide if the experiment should run at all+--+-- By default, experiments are run.+--+setExperimentRunIf :: Bool -> Experiment m c a b -> Experiment m c a b+setExperimentRunIf b ex = ex { experimentRunIf = Just b }++-- | How to publish results+--+-- By default, results are not published.+--+setExperimentPublish+  :: (Result c a b -> m ()) -> Experiment m c a b -> Experiment m c a b+setExperimentPublish f ex = ex { experimentPublish = Just f }++getExperimentName :: Experiment m c a b -> Text+getExperimentName = experimentName++getExperimentUse :: Experiment m c a b -> m (Control a)+getExperimentUse = experimentUse++getExperimentTries+  :: Experiment m c a b -> Maybe (NonEmpty (NamedCandidate m b))+getExperimentTries = experimentTries++getExperimentEnabled :: Applicative m => Experiment m c a b -> m Bool+getExperimentEnabled = fromMaybe (pure True) . experimentEnabled++getExperimentOnException+  :: MonadIO m => Experiment m c a b -> SomeException -> m ()+getExperimentOnException = fromMaybe throwIO . experimentOnException++getExperimentCompare+  :: Experiment m c a b+  -> (Control a -> Either SomeException (Candidate b) -> Bool)+getExperimentCompare = fromMaybe (\_ _ -> False) . experimentCompare++setExperimentContext :: c -> Experiment m c a b -> Experiment m c a b+setExperimentContext x ex = ex { experimentContext = Just x }++getExperimentContext :: Experiment m c a b -> Maybe c+getExperimentContext = experimentContext++getExperimentIgnore+  :: Experiment m c a b+  -> (Control a -> Either SomeException (Candidate b) -> Bool)+getExperimentIgnore = fromMaybe (\_ _ -> False) . experimentIgnore++getExperimentRunIf :: Experiment m c a b -> Bool+getExperimentRunIf = fromMaybe True . experimentRunIf++getExperimentPublish+  :: Applicative m => Experiment m c a b -> (Result c a b -> m ())+getExperimentPublish = fromMaybe (const $ pure ()) . experimentPublish++-- | Compare non-exception candidates with the control by '(==)'+--+-- Exception candidates fail comparison.+--+experimentCompareEq+  :: Eq a => Control a -> Either SomeException (Candidate a) -> Bool+experimentCompareEq = experimentCompareBy (==)++-- | Compare by equality on some function+--+-- Exception candidates fail comparison.+--+experimentCompareOn+  :: Eq b => (a -> b) -> Control a -> Either SomeException (Candidate a) -> Bool+experimentCompareOn f = experimentCompareBy ((==) `on` f)++-- | Compare by some function+--+-- Exception candidates fail comparison.+--+experimentCompareBy+  :: (a -> b -> Bool) -> Control a -> Either SomeException (Candidate b) -> Bool+experimentCompareBy f (Control a) = \case+  Left _ -> False+  Right (Candidate b) -> f a b++-- | Enable the experiment in the given percentage of runs+experimentEnabledPercent :: MonadIO m => Int -> m Bool+experimentEnabledPercent n+  | n <= 0 = pure False+  | n >= 100 = pure True+  | otherwise = liftIO $ evalRandIO $ (<= n) <$> getRandomR (0, 100)
+ library/Scientist/Experiment/Run.hs view
@@ -0,0 +1,122 @@+{-# 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 = fmap resultValue . experimentRunInternal++-- | 'experimentRun' but returning the full 'Result'+--+-- Used for testing.+--+experimentRunInternal+  :: MonadUnliftIO m => Experiment m c a b -> m (Result c a b)+experimentRunInternal ex = do+  enabled <- isExperimentEnabled ex++  let+    getName = \case+      Left{} -> "control"+      Right nc -> namedCandidateName nc++  case getExperimentTries ex of+    Just candidates | enabled -> do+      (controlResult, candidateResults, order) <- runRandomized+        control+        candidates+        runControl+        runCandidate+        getName++      let result = evaluateResult ex controlResult candidateResults order++      result <$ handleAny+        (getExperimentOnException ex)+        (getExperimentPublish ex result)++    _ -> ResultSkipped <$> control+  where control = getExperimentUse ex++isExperimentEnabled :: Applicative m => Experiment m c a b -> m Bool+isExperimentEnabled ex+  | not (getExperimentRunIf ex) = pure False+  | otherwise = getExperimentEnabled ex++runControl :: MonadIO m => m (Control a) -> m (ResultControl a)+runControl control = do+  (Control a, d) <- measureDuration control+  pure ResultControl+    { resultControlName = "control"+    , resultControlValue = a+    , resultControlDuration = d+    }++runCandidate :: MonadUnliftIO m => NamedCandidate m b -> m (ResultCandidate b)+runCandidate nc = do+  (b, d) <- measureDuration $ runNamedCandidate nc+  pure $ ResultCandidate+    { resultCandidateName = namedCandidateName nc+    , resultCandidateValue = b+    , resultCandidateDuration = 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 bs runA runB toName = do+  inputs <- liftIO $ shuffleM $ Left a : map Right (NE.toList bs)+  outputs <- traverse (bimapM runA runB) inputs++  let+    order = map toName inputs+    partitioned = partitionEithers outputs++  case second NE.nonEmpty partitioned of+    ([a'], Just bs') -> pure (a', bs', order)+    _ ->+      -- 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.+      --+      throwString+        $ "runRandomized did not produce 1 Left and 1+ Rights, but "+        <> show (length $ fst partitioned)+        <> " Left(s), and "+        <> show (length $ snd partitioned)+        <> " Rights(s)"
+ library/Scientist/NamedCandidate.hs view
@@ -0,0 +1,25 @@+module Scientist.NamedCandidate+  ( NamedCandidate+  , namedCandidate+  , namedCandidateName+  , runNamedCandidate+  ) where++import Prelude++import Control.Monad.IO.Unlift (MonadUnliftIO)+import Data.Text (Text)+import Scientist.Candidate+import UnliftIO.Exception (SomeException, tryAny)++data NamedCandidate m a = NamedCandidate Text (m (Candidate a))++namedCandidate :: Text -> m (Candidate a) -> NamedCandidate m a+namedCandidate = NamedCandidate++namedCandidateName :: NamedCandidate m a -> Text+namedCandidateName (NamedCandidate x _) = x++runNamedCandidate+  :: MonadUnliftIO m => NamedCandidate m a -> m (Either SomeException a)+runNamedCandidate (NamedCandidate _ f) = tryAny $ unCandidate <$> f
+ library/Scientist/Result.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}++module Scientist.Result+  ( Result(..)+  , resultValue+  , resultDetails+  , ResultDetails(..)+  , resultDetailsCandidate+  , ResultControl(..)+  , ResultCandidate(..)+  ) where++import Prelude++import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE+import Data.Text (Text)+import Scientist.Control+import Scientist.Duration+import UnliftIO.Exception (SomeException)++data Result c a b+    = ResultSkipped (Control a)+    | ResultMatched (ResultDetails c a b)+    | ResultIgnored (ResultDetails c a b)+    | ResultMismatched (ResultDetails c a b)++resultValue :: Result c a b -> a+resultValue = \case+  ResultSkipped (Control a) -> a+  ResultMatched rd -> resultDetailsControlValue rd+  ResultIgnored rd -> resultDetailsControlValue rd+  ResultMismatched rd -> resultDetailsControlValue rd++resultDetails :: Result c a b -> Maybe (ResultDetails c a b)+resultDetails = \case+  ResultSkipped{} -> Nothing+  ResultMatched rd -> Just rd+  ResultIgnored rd -> Just rd+  ResultMismatched rd -> Just rd++data ResultDetails c a b = ResultDetails+  { resultDetailsExperimentName :: Text+  , resultDetailsExperimentContext :: Maybe c+  , resultDetailsControl :: ResultControl a+  , resultDetailsCandidates :: NonEmpty (ResultCandidate b)+  , resultDetailsExecutionOrder :: [Text]+  }++resultDetailsControlValue :: ResultDetails c a b -> a+resultDetailsControlValue = resultControlValue . resultDetailsControl++resultDetailsCandidate :: ResultDetails c a b -> ResultCandidate b+resultDetailsCandidate = NE.head . resultDetailsCandidates++data ResultControl a = ResultControl+  { resultControlName :: Text+  , resultControlValue :: a+  , resultControlDuration :: Duration+  }++data ResultCandidate a = ResultCandidate+  { resultCandidateName :: Text+  , resultCandidateValue :: Either SomeException a+  , resultCandidateDuration :: Duration+  }
+ library/Scientist/Result/Evaluate.hs view
@@ -0,0 +1,41 @@+module Scientist.Result.Evaluate+  ( evaluateResult+  ) where++import Prelude++import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import Scientist.Candidate+import Scientist.Control+import Scientist.Experiment+import Scientist.Result++evaluateResult+  :: Experiment m c a b+  -> ResultControl a+  -> NonEmpty (ResultCandidate b)+  -> [Text]+  -> Result c a b+evaluateResult ex control candidates order+  | any (ignore control) candidates = ResultIgnored details+  | all (match control) candidates = ResultMatched details+  | otherwise = ResultMismatched details+ where+  ignore a b = getExperimentIgnore+    ex+    (Control $ resultControlValue a)+    (Candidate <$> resultCandidateValue b)++  match a b = getExperimentCompare+    ex+    (Control $ resultControlValue a)+    (Candidate <$> resultCandidateValue b)++  details = ResultDetails+    { resultDetailsExperimentName = getExperimentName ex+    , resultDetailsExperimentContext = getExperimentContext ex+    , resultDetailsControl = control+    , resultDetailsCandidates = candidates+    , resultDetailsExecutionOrder = order+    }
+ scientist.cabal view
@@ -0,0 +1,101 @@+cabal-version: 1.12+name:          scientist+version:       0.0.0.0+license:       MIT+license-file:  LICENSE+maintainer:    Freckle Education+homepage:      https://github.com/freckle/scientist-hs#readme+bug-reports:   https://github.com/freckle/scientist-hs/issues+synopsis:      A Haskell library for carefully refactoring critical paths.+description:   Please see README.md+category:      Utils+build-type:    Simple++source-repository head+    type:     git+    location: https://github.com/freckle/scientist-hs++library+    exposed-modules:+        Scientist+        Scientist.Candidate+        Scientist.Control+        Scientist.Duration+        Scientist.Experiment+        Scientist.Experiment.Run+        Scientist.NamedCandidate+        Scientist.Result+        Scientist.Result.Evaluate++    hs-source-dirs:     library+    other-modules:      Paths_scientist+    default-language:   Haskell2010+    default-extensions: NoImplicitPrelude+    ghc-options:+        -Weverything -Wno-missing-exported-signatures+        -Wno-missing-import-lists -Wno-missing-local-signatures+        -Wno-monomorphism-restriction -Wno-unsafe -Wno-safe++    build-depends:+        MonadRandom >=0.5.1.1,+        base >4 && <5,+        clock >=0.7.2,+        random-shuffle >=0.0.4,+        text >=1.2.3.1,+        unliftio >=0.2.9.0,+        unliftio-core >=0.1.2.0++    if impl(ghc >=8.10)+        ghc-options:+            -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module++test-suite readme+    type:               exitcode-stdio-1.0+    main-is:            README.lhs+    other-modules:      Paths_scientist+    default-language:   Haskell2010+    default-extensions: NoImplicitPrelude+    ghc-options:+        -Weverything -Wno-missing-exported-signatures+        -Wno-missing-import-lists -Wno-missing-local-signatures+        -Wno-monomorphism-restriction -Wno-unsafe -Wno-safe -pgmL+        markdown-unlit++    build-depends:+        base >4 && <5,+        markdown-unlit >=0.5.0,+        scientist -any,+        text >=1.2.3.1,+        unliftio >=0.2.9.0,+        unliftio-core >=0.1.2.0++    if impl(ghc >=8.10)+        ghc-options:+            -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module++test-suite spec+    type:               exitcode-stdio-1.0+    main-is:            Spec.hs+    hs-source-dirs:     tests+    other-modules:+        Scientist.Experiment.RunSpec+        Scientist.ExperimentSpec+        Scientist.Test+        Paths_scientist++    default-language:   Haskell2010+    default-extensions: NoImplicitPrelude+    ghc-options:+        -Weverything -Wno-missing-exported-signatures+        -Wno-missing-import-lists -Wno-missing-local-signatures+        -Wno-monomorphism-restriction -Wno-unsafe -Wno-safe++    build-depends:+        base >4 && <5,+        hspec >=2.5.5,+        scientist -any,+        unliftio >=0.2.9.0++    if impl(ghc >=8.10)+        ghc-options:+            -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module
+ tests/Scientist/Experiment/RunSpec.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Scientist.Experiment.RunSpec+  ( spec+  ) where++import Scientist.Test++import Data.Either (partitionEithers)+import qualified Data.List.NonEmpty as NE+import Scientist.Candidate+import Scientist.Control+import Scientist.Duration+import Scientist.Experiment+import Scientist.Experiment.Run+import Scientist.Result+import UnliftIO.Concurrent+import UnliftIO.Exception (fromException, throwString)++data ExampleResult = A | B | C+  deriving stock (Eq, Show)++spec :: Spec+spec = do+  describe "experimentRun" $ do+    it "is ResultSkipped based on runIf" $ do+      result <-+        experimentRunInternal+        $ setExperimentRunIf False+        $ setExperimentTry (pure A)+        $ newExperiment "test" (pure A)++      expectSkippedWith result A++    it "is ResultSkipped based on enabled" $ do+      result <-+        experimentRunInternal+        $ setExperimentEnabled (pure False)+        $ setExperimentTry (pure A)+        $ newExperiment "test" (pure A)++      expectSkippedWith result A++    it "is ResultSkipped when no Candidates present" $ do+      result <- experimentRunInternal $ newExperiment "test" (pure A)++      expectSkippedWith result A++    it "is ResultMatched if all candidates match" $ do+      result <-+        experimentRunInternal+        $ setExperimentCompare experimentCompareEq+        $ setExperimentTry (pure A)+        $ setExperimentTry (pure A)+        $ newExperiment "test" (A <$ threadDelay (100 * 1000))++      expectMatched result $ \rd -> do+        resultDetailsExperimentName rd `shouldBe` "test"++        let control = resultDetailsControl rd+        resultControlValue control `shouldBe` A+        resultControlDuration control `shouldSatisfy` isDurationNear 0.100++        let+          (failed, succeeded) =+            partitionEithers+              $ map resultCandidateValue+              $ NE.toList+              $ resultDetailsCandidates rd++        succeeded `shouldMatchList` [A, A]+        length failed `shouldBe` 0++    it "is ResultIgnored if any candidates are ignored" $ do+      let+        ignoreB _ = \case+          Right (Candidate B) -> True+          _ -> False++      result <-+        experimentRunInternal+        $ setExperimentIgnore ignoreB+        $ setExperimentTry (pure C)+        $ setExperimentTry (pure B)+        $ newExperiment "test" (pure A)++      expectIgnored result $ \rd -> do+        resultDetailsExperimentName rd `shouldBe` "test"++        let control = resultDetailsControl rd+        resultControlValue control `shouldBe` A++        let+          (failed, succeeded) =+            partitionEithers+              $ map resultCandidateValue+              $ NE.toList+              $ resultDetailsCandidates rd++        succeeded `shouldMatchList` [B, C]+        length failed `shouldBe` 0++    it "is ResultMismatched if any candidates mismatched" $ do+      result <-+        experimentRunInternal+        $ setExperimentCompare experimentCompareEq+        $ setExperimentTry (pure B)+        $ setExperimentTry (pure A)+        $ newExperiment "test" (pure A)++      expectMismatched result $ \rd -> do+        resultDetailsExperimentName rd `shouldBe` "test"++        let control = resultDetailsControl rd+        resultControlValue control `shouldBe` A++        let+          (failed, succeeded) =+            partitionEithers+              $ map resultCandidateValue+              $ NE.toList+              $ resultDetailsCandidates rd++        succeeded `shouldMatchList` [A, B]+        length failed `shouldBe` 0++    it "rescues exceptions in the Candidate branch" $ do+      result <-+        experimentRunInternal+        $ setExperimentTry (throwString "boom")+        $ newExperiment "test" (pure A)++      expectMismatched result $ \rd -> do+        resultDetailsExperimentName rd `shouldBe` "test"++        let+          control = resultDetailsControl rd+          mCandidateException =+            either fromException (const Nothing)+              $ resultCandidateValue+              $ NE.head+              $ resultDetailsCandidates rd++        resultControlValue control `shouldBe` A+        mCandidateException `shouldSatisfyMaybe` isStringException "boom"++    it "does not rescue exceptions in the Control branch" $ do+      experimentRunInternal (newExperiment "test" (throwString "boom"))+        `shouldThrowString` "boom"++    it "does not rescue exceptions in publishing" $ do+      experimentRunInternal+          (setExperimentPublish (\_ -> throwString "boom")+          $ setExperimentTry (pure B)+          $ newExperiment "test" (pure A)+          )+        `shouldThrowString` "boom"++    it "can be configured to rescue exceptions in publishing" $ do+      result <-+        experimentRunInternal+        $ setExperimentOnException (\_ -> pure ())+        $ setExperimentPublish (\_ -> throwString "boom")+        $ setExperimentTry (pure B)+        $ newExperiment "test" (pure A)++      expectMismatched result $ \_ -> pure ()++    it "supports implicitly named candidates" $ do+      result <-+        experimentRunInternal+        $ setExperimentCompare experimentCompareEq+        $ setExperimentTry (pure A)+        $ setExperimentTry (pure A)+        $ setExperimentTry (pure A)+        $ newExperiment "test" (pure A)++      expectMatched result $ \rd -> do+        resultControlName (resultDetailsControl rd) `shouldBe` "control"++        map resultCandidateName (NE.toList $ resultDetailsCandidates rd)+          `shouldMatchList` ["candidate", "candidate-1", "candidate-2"]++    it "supports explicitly named candidates" $ do+      result <-+        experimentRunInternal+        $ setExperimentCompare experimentCompareEq+        $ setExperimentTryNamed "who" (pure A)+        $ setExperimentTryNamed "what" (pure A)+        $ setExperimentTryNamed "when" (pure A)+        $ newExperiment "test" (pure A)++      expectMatched result $ \rd -> do+        resultControlName (resultDetailsControl rd) `shouldBe` "control"++        map resultCandidateName (NE.toList $ resultDetailsCandidates rd)+          `shouldMatchList` ["who", "what", "when"]++expectSkippedWith :: (Eq a, Show a) => Result c a b -> a -> IO ()+expectSkippedWith result a =+  expectSkipped result $ \(Control b) -> b `shouldBe` a++expectSkipped :: Result c a b -> (Control a -> IO ()) -> IO ()+expectSkipped result f = case result of+  ResultSkipped x -> f x+  _ -> expectationFailure "Expected result to be Skipped"++expectMatched :: Result c a b -> (ResultDetails c a b -> IO ()) -> IO ()+expectMatched result f = case result of+  ResultMatched rd -> f rd+  _ -> expectationFailure "Expected result to be Matched"++expectIgnored :: Result c a b -> (ResultDetails c a b -> IO ()) -> IO ()+expectIgnored result f = case result of+  ResultIgnored rd -> f rd+  _ -> expectationFailure "Expected result to be Ignored"++expectMismatched :: Result c a b -> (ResultDetails c a b -> IO ()) -> IO ()+expectMismatched result f = case result of+  ResultMismatched rd -> f rd+  _ -> expectationFailure "Expected result to be Mismatched"++isDurationNear :: Duration -> Duration -> Bool+isDurationNear x = isWithinOf x 0.050
+ tests/Scientist/ExperimentSpec.hs view
@@ -0,0 +1,16 @@+module Scientist.ExperimentSpec+  ( spec+  ) where++import Scientist.Test++import Control.Monad (replicateM)+import Scientist.Experiment++spec :: Spec+spec = do+  describe "experimentEnabledPercent" $ do+    it "returns True the given percent of the time" $ do+      results <- replicateM 10000 $ experimentEnabledPercent 23++      length (filter id results) `shouldSatisfy` isWithinOf 500 2300
+ tests/Scientist/Test.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE LambdaCase #-}++module Scientist.Test+  ( module X+  , module Scientist.Test+  ) where++import Prelude as X++import Test.Hspec as X+import UnliftIO.Exception (StringException(..))++shouldSatisfyMaybe+  :: (HasCallStack, Show a) => Maybe a -> (a -> Bool) -> Expectation+x `shouldSatisfyMaybe` f = x `shouldSatisfy` maybe False f++infix 1 `shouldSatisfyMaybe`++isWithinOf :: (Num a, Ord a) => a -> a -> a -> Bool+isWithinOf tolerance desired = \case+  n | n >= desired + tolerance -> False+  n | n <= desired - tolerance -> False+  _ -> True++shouldThrowString :: HasCallStack => IO a -> String -> Expectation+f `shouldThrowString` msg = f `shouldThrow` isStringException msg++infix 1 `shouldThrowString`++isStringException :: String -> StringException -> Bool+isStringException a = \case+  StringException b _cs -> b == a
+ tests/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}