{-# LANGUAGE BangPatterns         #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE Strict               #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TupleSections        #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns         #-}

module Experimenter.Run
    ( DatabaseSetting (..)
    , MkExperimentSetting
    , execExperiments
    , runExperiments
    , runExperimentsM
    , runExperimentsIO
    -- , loadStateAfterPreparation
    -- , loadStateAfterPreparation2
    ) where

import           Control.Arrow                (first, second, (&&&), (***))
import           Control.Concurrent.MVar
import           Control.DeepSeq
import           Control.Lens
import           Control.Monad.IO.Class
import           Control.Monad.Logger         (filterLogger, logDebug, logError, logInfo, runStdoutLoggingT)
import           Control.Monad.Reader
import qualified Data.ByteString              as B
import           Data.Function                (on)
import           Data.IORef
import           Data.Int                     (Int64)
import           Data.List                    (foldl')
import qualified Data.List                    as L
import           Data.Maybe                   (fromJust, fromMaybe, isNothing)
import           Data.Serialize               hiding (get)
import qualified Data.Serialize               as S
import qualified Data.Text                    as T
import qualified Data.Text.Encoding           as E
import           Data.Time                    (addUTCTime, diffUTCTime, getCurrentTime)
import qualified Data.Vector                  as V
import           Database.Persist.Postgresql
import           GHC.Generics
import           Network.HostName             (getHostName)
import           Prelude                      hiding (exp)
import           System.IO
import           System.IO.Unsafe             (unsafePerformIO)
import           System.Posix.Process
import           System.Process               (callProcess, spawnProcess)
import           System.Random.MWC


import           Experimenter.Availability
import           Experimenter.DB
import           Experimenter.DatabaseSetting
import           Experimenter.Experiment
import           Experimenter.Input
import           Experimenter.MasterSlave
import           Experimenter.Measure
import           Experimenter.Models
import           Experimenter.Parameter
import           Experimenter.Result
import           Experimenter.Setting
import           Experimenter.StepResult
import           Experimenter.Util


type Updated = Bool
type InitialState a = a
type InitialInputState a = InputState a
type SkipPreparation = Bool
type Rands = ([Seed],[Seed],[Seed]) -- ^ Preparation, Warm Up and Evaluation random generators

data Mode = Master | Slave
  deriving (Mode -> Mode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c== :: Mode -> Mode -> Bool
Eq, Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show)

execExperiments :: (ExperimentDef a) => (ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)) -> DatabaseSetting -> MkExperimentSetting a -> InputState a -> a -> IO (Experiments a)
execExperiments :: forall a.
ExperimentDef a =>
(ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a))
-> DatabaseSetting
-> MkExperimentSetting a
-> InputState a
-> a
-> IO (Experiments a)
execExperiments ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)
runExpM DatabaseSetting
dbSetup MkExperimentSetting a
setup InputState a
initInpSt a
initSt = forall a. NFData a => a -> a
force forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ExperimentDef a =>
(ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a))
-> DatabaseSetting
-> MkExperimentSetting a
-> InputState a
-> a
-> IO (Bool, Experiments a)
runExperiments ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)
runExpM DatabaseSetting
dbSetup MkExperimentSetting a
setup InputState a
initInpSt a
initSt

-- | Run an experiment with non-monadic initial state. In case the initial state requires monadic effect (e.g. building
-- a Tensorflow model), use `runExperimentsM`!
runExperiments :: (ExperimentDef a) => (ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)) -> DatabaseSetting -> MkExperimentSetting a -> InputState a -> a -> IO (Bool, Experiments a)
runExperiments :: forall a.
ExperimentDef a =>
(ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a))
-> DatabaseSetting
-> MkExperimentSetting a
-> InputState a
-> a
-> IO (Bool, Experiments a)
runExperiments ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)
runExpM DatabaseSetting
dbSetup MkExperimentSetting a
setup InputState a
initInpSt a
initSt = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. NFData a => a -> a
force forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ExperimentDef a =>
(ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a))
-> DatabaseSetting
-> MkExperimentSetting a
-> InputState a
-> ExpM a a
-> IO (Bool, Experiments a)
runner ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)
runExpM DatabaseSetting
dbSetup MkExperimentSetting a
setup InputState a
initInpSt (forall (m :: * -> *) a. Monad m => a -> m a
return a
initSt)

runExperimentsM :: (ExperimentDef a) => (ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)) -> DatabaseSetting -> MkExperimentSetting a -> InputState a -> ExpM a a -> IO (Bool, Experiments a)
runExperimentsM :: forall a.
ExperimentDef a =>
(ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a))
-> DatabaseSetting
-> MkExperimentSetting a
-> InputState a
-> ExpM a a
-> IO (Bool, Experiments a)
runExperimentsM = forall a.
ExperimentDef a =>
(ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a))
-> DatabaseSetting
-> MkExperimentSetting a
-> InputState a
-> ExpM a a
-> IO (Bool, Experiments a)
runner

runExperimentsIO :: (ExperimentDef a, IO ~ ExpM a) => DatabaseSetting -> MkExperimentSetting a -> InputState a -> a -> IO (Bool, Experiments a)
runExperimentsIO :: forall a.
(ExperimentDef a, IO ~ ExpM a) =>
DatabaseSetting
-> MkExperimentSetting a
-> InputState a
-> a
-> IO (Bool, Experiments a)
runExperimentsIO DatabaseSetting
dbSetup MkExperimentSetting a
setup InputState a
initInpSt a
initSt = forall a.
ExperimentDef a =>
(ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a))
-> DatabaseSetting
-> MkExperimentSetting a
-> InputState a
-> ExpM a a
-> IO (Bool, Experiments a)
runner forall a. a -> a
id DatabaseSetting
dbSetup MkExperimentSetting a
setup InputState a
initInpSt (forall (m :: * -> *) a. Monad m => a -> m a
return a
initSt)

runner :: (ExperimentDef a) => (ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)) -> DatabaseSetting -> MkExperimentSetting a -> InputState a -> ExpM a a -> IO (Bool, Experiments a)
runner :: forall a.
ExperimentDef a =>
(ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a))
-> DatabaseSetting
-> MkExperimentSetting a
-> InputState a
-> ExpM a a
-> IO (Bool, Experiments a)
runner ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)
runExpM DatabaseSetting
dbSetup MkExperimentSetting a
setup InputState a
initInpSt ExpM a a
mkInitSt =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. NFData a => a -> a
force) forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStdoutLoggingT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m) =>
ConnectionString -> Int -> (Pool SqlBackend -> m a) -> m a
withPostgresqlPool (DatabaseSetting -> ConnectionString
connectionString DatabaseSetting
dbSetup) (DatabaseSetting -> Int
parallelConnections DatabaseSetting
dbSetup) forall a b. (a -> b) -> a -> b
$ forall backend (m :: * -> *) a.
(MonadIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend (NoLoggingT (ResourceT IO)) a
-> Pool backend -> m a
liftSqlPersistMPool forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Migration -> ReaderT SqlBackend m ()
runMigration Migration
migrateAll forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
MonadIO m =>
ReaderT SqlBackend (NoLoggingT (ResourceT m)) ()
indexCreation
    ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)
runExpM forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a.
MonadUnliftIO m =>
DatabaseSetting -> DB m a -> m a
runDB DatabaseSetting
dbSetup forall a b. (a -> b) -> a -> b
$ do
        -- liftIO $ putStrLn "Running maintainance command: VACUUM"
        -- rawExecute "VACUUM" []
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DatabaseSetting -> IO ()
vacuum DatabaseSetting
dbSetup
        a
initSt <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ExpM a a
mkInitSt
        $(logInfo) Text
"Created initial state and will now check the DB for loading or creating experiments"
        let expSetting :: ExperimentSetting
expSetting = MkExperimentSetting a
setup a
initSt
        forall a.
ExperimentDef a =>
ExperimentSetting
-> InputState a -> a -> DB (ExpM a) (Experiments a)
loadExperiments ExperimentSetting
expSetting InputState a
initInpSt a
initSt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
Monad m =>
Experiments a -> m (Experiments a)
checkUniqueParamNames forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a.
ExperimentDef a =>
DatabaseSetting
-> ExperimentSetting
-> InputState a
-> a
-> Experiments a
-> DB (ExpM a) (Bool, Experiments a)
runExperimenter DatabaseSetting
dbSetup ExperimentSetting
expSetting InputState a
initInpSt a
initSt

-- | Vacuum the database. Usually you should not use 'full'! As it takes much longer and the table is locked for the duration of the process..
vacuum :: DatabaseSetting -> IO ()
vacuum :: DatabaseSetting -> IO ()
vacuum (DatabaseSetting ConnectionString
bs Int
_) = do
  let baseTxt :: [Text]
baseTxt = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[Text]
ts (Text
from, Text
to) -> forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
T.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
from Text
to) [Text]
ts) (Text -> Text -> [Text]
T.splitOn Text
" " forall a b. (a -> b) -> a -> b
$ ConnectionString -> Text
E.decodeUtf8 ConnectionString
bs) [(Text
"dbname=", Text
"--dbname="), (Text
"host=", Text
"--host="), (Text
"port=", Text
"--port="), (Text
"user=", Text
"--username=")]
      txts :: [Text]
txts = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Bool
T.isInfixOf Text
"password=") [Text]
baseTxt forall a. [a] -> [a] -> [a]
++ [Text
"-w"] -- Do *not* use full! ["-f" | full]
  forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStdoutLoggingT forall a b. (a -> b) -> a -> b
$ $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Running: vacuumdb " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " [Text]
txts
  String -> [String] -> IO ()
callProcess String
"vacuumdb" (forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
txts)

  -- vacuumdb --host=localhost --port=5432 --username=experimenter -w experimenter

  -- [-d experimenter - f - h HOST - p PORT - u USER - q]
  -- "host=localhost dbname=experimenter user=experimenter password= port=5432"


-- loadStateAfterPreparation2 ::
--      ExperimentDef a => (ExpM a b -> IO b) -> DatabaseSetting -> (a -> ExperimentSetting) -> InputState a -> ExpM a a -> Int -> Int -> (a -> ExpM a b) -> IO b
-- loadStateAfterPreparation2 runExpM dbSetup setup initInpSt mkInitSt expNr repNr runOnExperiments = do
--   runStdoutLoggingT $ withPostgresqlPool (connectionString dbSetup) (parallelConnections dbSetup) $ liftSqlPersistMPool $ runMigration migrateAll
--   runExpM $ runDB dbSetup $ do
--     initSt <- lift $ lift $ lift mkInitSt
--     $(logInfo) "Created initial state and will now check the DB for loading or creating experiments"
--     let expSetting = setup initSt
--     exps <- loadExperiments expSetting initInpSt initSt
--     let xs = exps ^.. experiments . traversed . filtered isExp . experimentResults . traversed . filtered isExpRep . preparationResults . traversed . endState
--         isExp x = x ^. experimentNumber == expNr
--         isExpRep x = x ^. repetitionNumber == repNr
--         fromAvailable (Available x) = x
--         fromAvailable _             = error "unexpected AvailableOnDemand in loadStateAfterPreparation"
--     borl <- fromAvailable <$> mkAvailable (head xs)
--     $(logInfo) "Made BORL available"
--     lift $ lift $ lift $ runOnExperiments (fromJust borl)


-- loadStateAfterPreparation :: (ExperimentDef a) => DatabaseSetting -> Int64 -> Int -> Int -> ExpM a (Maybe a)
-- loadStateAfterPreparation dbSetup expsId expNr _ =
--   runStdoutLoggingT $
--   filterLogger (\s _ -> s /= "SQL") $
--   withPostgresqlConn (connectionString dbSetup) $ \(backend :: SqlBackend) ->
--     flip runSqlConn backend $ do
--       (Entity expId _) <- fromMaybe (error "experiments not found") <$> selectFirst [ExpExps ==. toSqlKey expsId, ExpNumber ==. expNr] []
--       (Entity _ expRes) <- fromMaybe (error "experiment not found") <$> selectFirst [ExpResultExp ==. expId] []
--       case expRes ^. expResultPrepResultData of
--         Nothing -> return Nothing
--         Just prepResDataId -> do
--           parts' <- fmap (view prepEndStatePartData . entityVal) <$> selectList [PrepEndStatePartResultData ==. prepResDataId] [Asc PrepEndStatePartNumber]
--           if null parts'
--             then return Nothing
--             else do
--               !mSer <- lift $! deserialise (T.pack "end state") (B.concat parts')
--               !res <- lift $! lift $ maybe (return Nothing) (fmap Just . deserialisable) mSer
--               force <$!> traverse (setParams expId) res


checkUniqueParamNames :: (Monad m) => Experiments a -> m (Experiments a)
checkUniqueParamNames :: forall (m :: * -> *) a.
Monad m =>
Experiments a -> m (Experiments a)
checkUniqueParamNames Experiments a
exps = do
  let paramNames :: [Text]
paramNames = forall a b. (a -> b) -> [a] -> [b]
map forall a. ParameterSetup a -> Text
parameterName (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (Experiments a) [ParameterSetup a]
experimentsParameters Experiments a
exps)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Ord a => a -> a -> Bool
> Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length) (forall a. Eq a => [a] -> [[a]]
L.group forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort [Text]
paramNames)) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Parameter names must be unique! " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
>Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length) (forall a. Eq a => [a] -> [[a]]
L.group forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort [Text]
paramNames))
  forall (m :: * -> *) a. Monad m => a -> m a
return Experiments a
exps


runExperimenter :: (ExperimentDef a) => DatabaseSetting -> ExperimentSetting -> InputState a -> a -> Experiments a -> DB (ExpM a) (Bool, Experiments a)
runExperimenter :: forall a.
ExperimentDef a =>
DatabaseSetting
-> ExperimentSetting
-> InputState a
-> a
-> Experiments a
-> DB (ExpM a) (Bool, Experiments a)
runExperimenter DatabaseSetting
dbSetup ExperimentSetting
setup InputState a
initInpSt a
initSt Experiments a
exps = do
  !ProcessID
pid <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProcessID
getProcessID
  !String
hostName <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getHostName
  !UTCTime
time <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [forall typ. (typ ~ UTCTime) => EntityField ExpsMaster typ
ExpsMasterLastAliveSign forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
<=. NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (-NominalDiffTime
2forall a. Num a => a -> a -> a
*forall t. Num t => t
keepAliveTimeout) UTCTime
time]
  !Maybe (Key ExpsMaster)
maybeMaster <- forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Maybe (Key record))
insertUnique forall a b. (a -> b) -> a -> b
$ ExpsId -> Text -> Int -> UTCTime -> ExpsMaster
ExpsMaster (Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsId
experimentsKey) (String -> Text
T.pack String
hostName) (forall a b. (Integral a, Num b) => a -> b
fromIntegral ProcessID
pid) UTCTime
time
  forall (m :: * -> *). MonadIO m => ReaderT SqlBackend m ()
transactionSave
  case Maybe (Key ExpsMaster)
maybeMaster of
    Just Key ExpsMaster
masterId -> do
      !IORef WorkerStatus
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DatabaseSetting
-> (UTCTime -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
-> IO (IORef WorkerStatus)
createKeepAliveFork DatabaseSetting
dbSetup (\UTCTime
t -> forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update Key ExpsMaster
masterId [forall typ. (typ ~ UTCTime) => EntityField ExpsMaster typ
ExpsMasterLastAliveSign forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. UTCTime
t]) (forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
delete Key ExpsMaster
masterId)
      $(logInfo) Text
"Running in MASTER mode!"
      !(Bool, Experiments a)
res <- forall a.
ExperimentDef a =>
DatabaseSetting
-> Mode -> Experiments a -> DB (ExpM a) (Bool, Experiments a)
runExperiment DatabaseSetting
dbSetup Mode
Master Experiments a
exps
      !Bool
waitResult <- forall (m :: * -> *) a. MonadIO m => Experiments a -> DB m Bool
waitForSlaves Experiments a
exps
      if Bool
waitResult
        then do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> a -> IO ()
writeIORef IORef WorkerStatus
ref WorkerStatus
Finished)
          Experiments a
exps' <- forall a.
ExperimentDef a =>
ExperimentSetting
-> InputState a -> a -> DB (ExpM a) (Experiments a)
loadExperiments ExperimentSetting
setup InputState a
initInpSt a
initSt -- done, reload all data!
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a, b) -> a
fst (Bool, Experiments a)
res, Experiments a
exps')
        else forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
delete Key ExpsMaster
masterId forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DB (ExpM a) (Bool, Experiments a)
restartExperimenter -- slave died
    Maybe (Key ExpsMaster)
Nothing -> do
      $(logInfo) Text
"Running in SLAVE mode!"
      forall a.
ExperimentDef a =>
DatabaseSetting
-> Mode -> Experiments a -> DB (ExpM a) (Bool, Experiments a)
runExperiment DatabaseSetting
dbSetup Mode
Slave Experiments a
exps
  where
    restartExperimenter :: DB (ExpM a) (Bool, Experiments a)
restartExperimenter = forall a.
ExperimentDef a =>
ExperimentSetting
-> InputState a -> a -> DB (ExpM a) (Experiments a)
loadExperiments ExperimentSetting
setup InputState a
initInpSt a
initSt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a.
ExperimentDef a =>
DatabaseSetting
-> ExperimentSetting
-> InputState a
-> a
-> Experiments a
-> DB (ExpM a) (Bool, Experiments a)
runExperimenter DatabaseSetting
dbSetup ExperimentSetting
setup InputState a
initInpSt a
initSt

runExperiment :: (ExperimentDef a) => DatabaseSetting -> Mode -> Experiments a -> DB (ExpM a) (Bool, Experiments a)
runExperiment :: forall a.
ExperimentDef a =>
DatabaseSetting
-> Mode -> Experiments a -> DB (ExpM a) (Bool, Experiments a)
runExperiment DatabaseSetting
dbSetup Mode
mode Experiments a
exps = do
  (Bool
anyChange, Experiments a
exps') <- forall a.
ExperimentDef a =>
DatabaseSetting
-> Mode -> Experiments a -> DB (ExpM a) (Bool, Experiments a)
continueExperiments DatabaseSetting
dbSetup Mode
mode Experiments a
exps
  if Bool
anyChange
    then forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall a b. a -> b -> a
const Bool
True) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ExperimentDef a =>
DatabaseSetting
-> Mode -> Experiments a -> DB (ExpM a) (Bool, Experiments a)
runExperiment DatabaseSetting
dbSetup Mode
mode Experiments a
exps'
    else forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
anyChange, Experiments a
exps')


continueExperiments :: (ExperimentDef a) => DatabaseSetting -> Mode -> Experiments a -> DB (ExpM a) (Bool, Experiments a)
continueExperiments :: forall a.
ExperimentDef a =>
DatabaseSetting
-> Mode -> Experiments a -> DB (ExpM a) (Bool, Experiments a)
continueExperiments DatabaseSetting
dbSetup Mode
mode Experiments a
exp = do
  $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Processing set of experiments with ID " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (BackendKey SqlBackend -> Int64
unSqlBackendKey forall a b. (a -> b) -> a -> b
$ ExpsId -> BackendKey SqlBackend
unExpsKey forall a b. (a -> b) -> a -> b
$ Experiments a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsId
experimentsKey)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
stdout
  let exps :: [Experiment a]
exps = Experiments a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) [Experiment a]
experiments
  if Mode
mode forall a. Eq a => a -> a -> Bool
== Mode
Slave Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Experiment a]
exps
    then do
      $(logInfo) Text
"No experiments found and running in slave mode. Check whether the master has initialised the experiment yet!"
      forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Experiments a
exp)
    else do
      ReaderT SqlBackend (LoggingT (ResourceT (ExpM a))) ()
printInfoParamSetup
      Rands
rands <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Experiment a] -> IO Rands
mkRands [Experiment a]
exps
      [Experiment a]
newExps <-
        if Mode
mode forall a. Eq a => a -> a -> Bool
== Mode
Slave
          then forall (m :: * -> *) a. Monad m => a -> m a
return []
          else forall a.
ExperimentDef a =>
Experiments a -> [Experiment a] -> DB (ExpM a) [Experiment a]
mkNewExps Experiments a
exp [Experiment a]
exps
      let expsList :: [Experiment a]
expsList = [Experiment a]
exps forall a. [a] -> [a] -> [a]
++ [Experiment a]
newExps
      $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Number of experiments loaded: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Experiment a]
exps)
      $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Number of new experiments: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Experiment a]
newExps)
      [(Bool, Experiment a)]
expRes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a.
ExperimentDef a =>
DatabaseSetting
-> Rands
-> Experiments a
-> Experiment a
-> DB (ExpM a) (Bool, Experiment a)
continueExperiment DatabaseSetting
dbSetup Rands
rands Experiments a
exp) [Experiment a]
expsList
      let updated :: Bool
updated = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a b. (a, b) -> a
fst [(Bool, Experiment a)]
expRes
          res :: [Experiment a]
res = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, Experiment a)]
expRes
      if Bool
updated
        then do
          Maybe UTCTime
endT <- forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
          forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update (Experiments a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsId
experimentsKey) [forall typ. (typ ~ Maybe UTCTime) => EntityField Exps typ
ExpsEndTime forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Maybe UTCTime
endT]
          forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
updated, forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (Experiments a) [Experiment a]
experiments [Experiment a]
res forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (Experiments a) (Maybe UTCTime)
experimentsEndTime Maybe UTCTime
endT Experiments a
exp)
        else forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
updated, forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (Experiments a) [Experiment a]
experiments [Experiment a]
res Experiments a
exp)
  where
    printInfoParamSetup :: ReaderT SqlBackend (LoggingT (ResourceT (ExpM a))) ()
printInfoParamSetup = do
      $(logInfo) Text
"------------------------------"
      $(logInfo) Text
"--   INFO PARAMETER SETUP   --"
      $(logInfo) Text
"------------------------------"
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (Experiments a) [ExperimentInfoParameter]
experimentsInfoParameters Experiments a
exp)
        then $(logDebug) Text
"No info parameters set."
        else forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *}.
MonadLogger m =>
ExperimentInfoParameter -> m ()
printInfoParam (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (Experiments a) [ExperimentInfoParameter]
experimentsInfoParameters Experiments a
exp)
      $(logInfo) Text
"------------------------------"
    printInfoParam :: ExperimentInfoParameter -> m ()
printInfoParam (ExperimentInfoParameter Text
p b
v) = $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
p forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow b
v
    mkRands :: [Experiment a] -> IO Rands
    mkRands :: forall a. [Experiment a] -> IO Rands
mkRands [] = do
      [Seed]
prep <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
repetits (IO GenIO
createSystemRandom forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Seed
save)
      [Seed]
wmUp <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
repetits forall a. Num a => a -> a -> a
* Int
replicats) (IO GenIO
createSystemRandom forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Seed
save)
      [Seed]
repl <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
repetits forall a. Num a => a -> a -> a
* Int
replicats) (IO GenIO
createSystemRandom forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Seed
save)
      forall (m :: * -> *) a. Monad m => a -> m a
return ([Seed]
prep, [Seed]
wmUp, [Seed]
repl)
    mkRands (Experiment a
x:[Experiment a]
_) = do
      [Seed]
currentPrep <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Seed
save (Experiment a
x forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall a. Lens' (Experiment a) [ExperimentResult a]
experimentResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (ExperimentResult a) (Maybe (ResultData a))
preparationResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (ResultData a) GenIO
startRandGen)
      [Seed]
currentWmUp <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Seed
save (Experiment a
x forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall a. Lens' (Experiment a) [ExperimentResult a]
experimentResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (ExperimentResult a) [ReplicationResult a]
evaluationResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (ReplicationResult a) (Maybe (ResultData a))
warmUpResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (ResultData a) GenIO
startRandGen)
      [Seed]
currentRepl <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Seed
save (Experiment a
x forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall a. Lens' (Experiment a) [ExperimentResult a]
experimentResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (ExperimentResult a) [ReplicationResult a]
evaluationResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (ReplicationResult a) (Maybe (ResultData a))
evalResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (ResultData a) GenIO
startRandGen)
      [Seed]
prepNew <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
repetits forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Seed]
currentPrep) (IO GenIO
createSystemRandom forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Seed
save)
      [Seed]
wmUpNew <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
repetits forall a. Num a => a -> a -> a
* Int
replicats forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Seed]
currentWmUp) (IO GenIO
createSystemRandom forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Seed
save)
      [Seed]
replNew <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
repetits forall a. Num a => a -> a -> a
* Int
replicats forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Seed]
currentRepl) (IO GenIO
createSystemRandom forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Seed
save)
      forall (m :: * -> *) a. Monad m => a -> m a
return ([Seed]
currentPrep forall a. [a] -> [a] -> [a]
++ [Seed]
prepNew, [Seed]
currentWmUp forall a. [a] -> [a] -> [a]
++ [Seed]
wmUpNew, [Seed]
currentRepl forall a. [a] -> [a] -> [a]
++ [Seed]
replNew)
    repetits :: Int
repetits = Experiments a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsSetup
experimentsSetup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Int -> f Int) -> ExpsSetup -> f ExpsSetup
expsSetupRepetitions
    replicats :: Int
replicats = Experiments a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsSetup
experimentsSetup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Int -> f Int) -> ExpsSetup -> f ExpsSetup
expsSetupEvaluationReplications

saveParamSettings :: (MonadIO m) =>Key Exp -> [ParameterSetting a] -> DB m ()
saveParamSettings :: forall (m :: * -> *) a.
MonadIO m =>
Key Exp -> [ParameterSetting a] -> DB m ()
saveParamSettings Key Exp
kExp = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(ParameterSetting Text
n ConnectionString
bs Bool
drp ExperimentDesign
design) -> forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert forall a b. (a -> b) -> a -> b
$ Key Exp -> Text -> ConnectionString -> Bool -> Int -> ParamSetting
ParamSetting Key Exp
kExp Text
n ConnectionString
bs Bool
drp (forall a. Enum a => a -> Int
fromEnum ExperimentDesign
design))


initParams :: Experiments a -> [ParameterSetting a]
initParams :: forall a. Experiments a -> [ParameterSetting a]
initParams Experiments a
exp = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Experiments a -> ParameterSetup a -> ParameterSetting a
mkParamSetting Experiments a
exp) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (Experiments a) [ParameterSetup a]
experimentsParameters Experiments a
exp)
  where
    mkParamSetting :: Experiments a -> ParameterSetup a -> ParameterSetting a
    mkParamSetting :: forall a. Experiments a -> ParameterSetup a -> ParameterSetting a
mkParamSetting Experiments a
exp' (ParameterSetup Text
name b -> a -> a
_ a -> b
getter Maybe (b -> IO [b])
_ Maybe (b, b)
_ Maybe (b -> Bool)
drp Maybe (b -> ExperimentDesign)
design) =
      let v :: b
v = a -> b
getter (Experiments a
exp' forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) a
experimentsInitialState)
      in forall a.
Text
-> ConnectionString
-> Bool
-> ExperimentDesign
-> ParameterSetting a
ParameterSetting Text
name (Put -> ConnectionString
runPut forall a b. (a -> b) -> a -> b
$ forall t. Serialize t => Putter t
put forall a b. (a -> b) -> a -> b
$ a -> b
getter (Experiments a
exp' forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) a
experimentsInitialState)) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\b -> Bool
x -> b -> Bool
x b
v) Maybe (b -> Bool)
drp) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExperimentDesign
FullFactory (\b -> ExperimentDesign
x -> b -> ExperimentDesign
x b
v) Maybe (b -> ExperimentDesign)
design)


mkNoParamExp :: (ExperimentDef a) => Experiments a -> DB (ExpM a) [Experiment a]
mkNoParamExp :: forall a.
ExperimentDef a =>
Experiments a -> DB (ExpM a) [Experiment a]
mkNoParamExp Experiments a
exp = do
  $(logInfo) Text
"Initializing new experiment without any parameters..."
  [Entity Exp]
existing <- forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [forall typ. (typ ~ ExpsId) => EntityField Exp typ
ExpExps forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. (Experiments a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsId
experimentsKey)] []
  if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Entity Exp]
existing)
    then forall (m :: * -> *) a. Monad m => a -> m a
return []
    else do
      UTCTime
startT <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      Key Exp
kExp <- forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert forall a b. (a -> b) -> a -> b
$ ExpsId -> Int -> UTCTime -> Maybe UTCTime -> Exp
Exp (Experiments a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsId
experimentsKey) Int
1 UTCTime
startT forall a. Maybe a
Nothing
      forall (m :: * -> *) a.
MonadIO m =>
Key Exp -> [ParameterSetting a] -> DB m ()
saveParamSettings Key Exp
kExp (forall a. Experiments a -> [ParameterSetting a]
initParams Experiments a
exp)
      forall (m :: * -> *) a. Monad m => a -> m a
return [forall a.
Key Exp
-> Int
-> UTCTime
-> Maybe UTCTime
-> [ParameterSetting a]
-> [ExperimentResult a]
-> Experiment a
Experiment Key Exp
kExp Int
1 UTCTime
startT forall a. Maybe a
Nothing (forall a. Experiments a -> [ParameterSetting a]
initParams Experiments a
exp) []]


mkNewExps :: (ExperimentDef a) => Experiments a -> [Experiment a] -> DB (ExpM a) [Experiment a]
mkNewExps :: forall a.
ExperimentDef a =>
Experiments a -> [Experiment a] -> DB (ExpM a) [Experiment a]
mkNewExps Experiments a
exp [Experiment a]
expsDone = do
  $(logInfo) Text
"Checking whether adding further experiments is necessary..."
  let params :: [ParameterSetup a]
params = forall a. ExperimentDef a => a -> [ParameterSetup a]
parameters (Experiments a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) a
experimentsInitialState)
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParameterSetup a]
params
    then forall a.
ExperimentDef a =>
Experiments a -> DB (ExpM a) [Experiment a]
mkNoParamExp Experiments a
exp
    else do
      $(logInfo) Text
"Creating new experiment variants"
      UTCTime
startT <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      let sortParamSettings :: [[ParameterSetting a1]] -> [[ParameterSetting a1]]
sortParamSettings = forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a1 a2.
Lens (ParameterSetting a1) (ParameterSetting a2) Text Text
parameterSettingName))
      [[ParameterSetting a]]
existParamSettings <- forall {a1}. [[ParameterSetting a1]] -> [[ParameterSetting a1]]
sortParamSettings forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ExperimentDef a, MonadIO m) =>
Experiments a -> DB m [[ParameterSetting a]]
existingParamSettings Experiments a
exp
      --  $(logInfo) $ "Existing Parameter settings: " <> tshow (map (map showVal) $ map (\xs -> zip (L.sortBy (compare `on` parameterName) params) xs) existParamSettings)
      [[ParameterSetting a]]
paramSettings <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
MonadIO m =>
Experiments a -> ParameterSetup a -> DB m [ParameterSetting a]
mkParamModifications Experiments a
exp) [ParameterSetup a]
params
      let paramCombs :: [[ParameterSetting a]]
paramCombs = forall a. [[a]] -> [[a]]
combinations [[ParameterSetting a]]
paramSettings
      let paramSingleInstances :: [[ParameterSetting a]]
paramSingleInstances = forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== ExperimentDesign
SingleInstance) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a1 a2.
Lens
  (ParameterSetting a1)
  (ParameterSetting a2)
  ExperimentDesign
  ExperimentDesign
parameterSettingExperimentDesign)) [[ParameterSetting a]]
paramSettings
      let settings :: [[ParameterSetting a]]
settings = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[ParameterSetting a]]
existParamSettings) forall a b. (a -> b) -> a -> b
$ forall {a1}. [[ParameterSetting a1]] -> [[ParameterSetting a1]]
sortParamSettings forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {t :: * -> *} {a}. (Foldable t, Eq a) => [t a] -> a -> [t a]
mkSingleInstance [[ParameterSetting a]]
paramCombs (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ParameterSetting a]]
paramSingleInstances)
          mkSingleInstance :: [t a] -> a -> [t a]
mkSingleInstance [t a]
combs a
param =
            let occurrences :: [t a]
occurrences = forall a. (a -> Bool) -> [a] -> [a]
filter (a
param forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) [t a]
combs
                noOccurances :: [t a]
noOccurances = forall a. (a -> Bool) -> [a] -> [a]
filter (a
param forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`) [t a]
combs
             in [t a]
noOccurances forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
take Int
1 [t a]
occurrences
      let nrs :: [Int]
nrs = [Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Experiment a]
expsDone .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [Experiment a]
expsDone forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [[ParameterSetting a]]
settings]
      [Key Exp]
kExps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
nr -> forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert forall a b. (a -> b) -> a -> b
$ ExpsId -> Int -> UTCTime -> Maybe UTCTime -> Exp
Exp (Experiments a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsId
experimentsKey) Int
nr UTCTime
startT forall a. Maybe a
Nothing) [Int]
nrs
      forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ forall (m :: * -> *) a.
MonadIO m =>
Key Exp -> [ParameterSetting a] -> DB m ()
saveParamSettings [Key Exp]
kExps [[ParameterSetting a]]
settings
      let exps :: [Experiment a]
exps = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (\Key Exp
key Int
nr [ParameterSetting a]
parms -> forall a.
Key Exp
-> Int
-> UTCTime
-> Maybe UTCTime
-> [ParameterSetting a]
-> [ExperimentResult a]
-> Experiment a
Experiment Key Exp
key Int
nr UTCTime
startT forall a. Maybe a
Nothing [ParameterSetting a]
parms []) [Key Exp]
kExps [Int]
nrs [[ParameterSetting a]]
settings
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Experiment a]
exps) forall a b. (a -> b) -> a -> b
$ $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Created " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Experiment a]
exps) forall a. Semigroup a => a -> a -> a
<> Text
" new experiments variations!"
      forall (m :: * -> *). MonadIO m => ReaderT SqlBackend m ()
transactionSave
      forall (m :: * -> *) a. Monad m => a -> m a
return [Experiment a]
exps


combinations :: [[a]] -> [[a]]
combinations :: forall a. [[a]] -> [[a]]
combinations []       = []
combinations [[a]
xs] = forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Monad m => a -> m a
return [a]
xs
combinations ([a]
xs:[[a]]
xss) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\a
x -> forall a b. (a -> b) -> [a] -> [b]
map (a
xforall a. a -> [a] -> [a]
:) [[a]]
ys) [a]
xs
  where ys :: [[a]]
ys = forall a. [[a]] -> [[a]]
combinations [[a]]
xss


mkParamModifications :: (MonadIO m) => Experiments a -> ParameterSetup a -> DB m [ParameterSetting a]
mkParamModifications :: forall (m :: * -> *) a.
MonadIO m =>
Experiments a -> ParameterSetup a -> DB m [ParameterSetting a]
mkParamModifications Experiments a
exps setup :: ParameterSetup a
setup@(ParameterSetup Text
n b -> a -> a
_ a -> b
getter Maybe (b -> IO [b])
_ Maybe (b, b)
_ Maybe (b -> Bool)
drp Maybe (b -> ExperimentDesign)
design) = forall (m :: * -> *) a.
MonadIO m =>
ParameterSetup a
-> [ParameterSetting a]
-> ParameterSetting a
-> DB m [ParameterSetting a]
modifyParam ParameterSetup a
setup [] (forall a.
Text
-> ConnectionString
-> Bool
-> ExperimentDesign
-> ParameterSetting a
ParameterSetting Text
n ConnectionString
bs (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\b -> Bool
x -> b -> Bool
x b
v) Maybe (b -> Bool)
drp) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExperimentDesign
FullFactory (\b -> ExperimentDesign
x -> b -> ExperimentDesign
x b
v) Maybe (b -> ExperimentDesign)
design))
  where v :: b
v = a -> b
getter (Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) a
experimentsInitialState)
        bs :: ConnectionString
bs = Put -> ConnectionString
runPut forall a b. (a -> b) -> a -> b
$ forall t. Serialize t => Putter t
put b
v

modifyParam :: (MonadIO m) => ParameterSetup a -> [ParameterSetting a] -> ParameterSetting a -> DB m [ParameterSetting a]
modifyParam :: forall (m :: * -> *) a.
MonadIO m =>
ParameterSetup a
-> [ParameterSetting a]
-> ParameterSetting a
-> DB m [ParameterSetting a]
modifyParam (ParameterSetup Text
_ b -> a -> a
_ a -> b
_ Maybe (b -> IO [b])
Nothing Maybe (b, b)
_ Maybe (b -> Bool)
_ Maybe (b -> ExperimentDesign)
_) ![ParameterSetting a]
_ !ParameterSetting a
sett = forall (m :: * -> *) a. Monad m => a -> m a
return [ParameterSetting a
sett]
modifyParam setup :: ParameterSetup a
setup@(ParameterSetup Text
n b -> a -> a
_ a -> b
_ (Just b -> IO [b]
modifier) Maybe (b, b)
mBounds Maybe (b -> Bool)
drp Maybe (b -> ExperimentDesign)
design) ![ParameterSetting a]
acc !ParameterSetting a
sett = do
  case forall a. Get a -> ConnectionString -> Either String a
S.runGet forall t. Serialize t => Get t
S.get (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a1 a2.
Lens
  (ParameterSetting a1)
  (ParameterSetting a2)
  ConnectionString
  ConnectionString
parameterSettingValue ParameterSetting a
sett) of
    Left String
err -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not deserialize a value for parameter " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
n forall a. Semigroup a => a -> a -> a
<> String
". Cannot proceed! The error was: " forall a. Semigroup a => a -> a -> a
<>  String
err
    Right b
val -> do
      let filterBounds :: b -> Bool
filterBounds b
x =
            case Maybe (b, b)
mBounds of
              Maybe (b, b)
Nothing           -> Bool
True
              Just (b
minB, b
maxB) -> b
x forall a. Ord a => a -> a -> Bool
<= b
maxB Bool -> Bool -> Bool
&& b
x forall a. Ord a => a -> a -> Bool
>= b
minB
          filterExperimentDesign :: [(b, ConnectionString)] -> [(b, ConnectionString)]
filterExperimentDesign [(b, ConnectionString)]
xs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [(b, ConnectionString)] -> [(b, ConnectionString)]
filt' forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) [(b, ConnectionString)]
xs
          filt' :: [(b, ConnectionString)] -> [(b, ConnectionString)]
filt' xs :: [(b, ConnectionString)]
xs@((b
v, ConnectionString
_):[(b, ConnectionString)]
_) =
            case Maybe (b -> ExperimentDesign)
design of
              Just b -> ExperimentDesign
dsgn
                | b -> ExperimentDesign
dsgn b
v forall a. Eq a => a -> a -> Bool
== ExperimentDesign
SingleInstance -> forall a. Int -> [a] -> [a]
take Int
1 [(b, ConnectionString)]
xs
              Maybe (b -> ExperimentDesign)
_ -> [(b, ConnectionString)]
xs
          filt' [(b, ConnectionString)]
_ = forall a. HasCallStack => String -> a
error String
"Empty list in filt', e.g. in filtering of the experiments design, in modifyParam in Run.hs"
      [(b, ConnectionString)]
bss <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [(b, ConnectionString)] -> [(b, ConnectionString)]
filterExperimentDesign forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> a
id forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Put -> ConnectionString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Serialize t => Putter t
put) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter b -> Bool
filterBounds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> IO [b]
modifier b
val
      let params' :: [ParameterSetting a]
params' = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ParameterSetting a]
acc) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(b
v, ConnectionString
bs) -> forall a.
Text
-> ConnectionString
-> Bool
-> ExperimentDesign
-> ParameterSetting a
ParameterSetting Text
n ConnectionString
bs (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\b -> Bool
x -> b -> Bool
x b
v) Maybe (b -> Bool)
drp) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExperimentDesign
FullFactory (\b -> ExperimentDesign
x -> b -> ExperimentDesign
x b
v) Maybe (b -> ExperimentDesign)
design)) [(b, ConnectionString)]
bss
      forall a (m :: * -> *) b.
(NFData a, Monad m) =>
(a -> b -> m a) -> a -> [b] -> m a
foldM' (forall (m :: * -> *) a.
MonadIO m =>
ParameterSetup a
-> [ParameterSetting a]
-> ParameterSetting a
-> DB m [ParameterSetting a]
modifyParam ParameterSetup a
setup) ([ParameterSetting a]
acc forall a. [a] -> [a] -> [a]
++ [ParameterSetting a]
params') [ParameterSetting a]
params'


existingParamSettings :: (ExperimentDef a, MonadIO m) => Experiments a -> DB m [[ParameterSetting a]]
existingParamSettings :: forall a (m :: * -> *).
(ExperimentDef a, MonadIO m) =>
Experiments a -> DB m [[ParameterSetting a]]
existingParamSettings Experiments a
exp = do
  let params :: [ParameterSetup a]
params = forall a. ExperimentDef a => a -> [ParameterSetup a]
parameters (Experiments a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) a
experimentsInitialState)
  [Key Exp]
expIds <- forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Key record]
selectKeysList [forall typ. (typ ~ ExpsId) => EntityField Exp typ
ExpExps forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Experiments a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsId
experimentsKey] []
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {t :: * -> *} {a} {a}.
Foldable t =>
t (ParameterSetup a) -> ParamSetting -> [ParameterSetting a]
toParameterSetting [ParameterSetup a]
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Key Exp
e -> forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [forall typ. (typ ~ Key Exp) => EntityField ParamSetting typ
ParamSettingExp forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Exp
e] []) [Key Exp]
expIds
  where
    toParameterSetting :: t (ParameterSetup a) -> ParamSetting -> [ParameterSetting a]
toParameterSetting t (ParameterSetup a)
params (ParamSetting Key Exp
_ Text
n ConnectionString
vBs Bool
drp Int
dsgn) =
      case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((forall a. Eq a => a -> a -> Bool
== Text
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ParameterSetup a -> Text
parameterName) t (ParameterSetup a)
params of
        Maybe (ParameterSetup a)
Nothing -> []
        Maybe (ParameterSetup a)
_       -> [forall a.
Text
-> ConnectionString
-> Bool
-> ExperimentDesign
-> ParameterSetting a
ParameterSetting Text
n ConnectionString
vBs Bool
drp (forall a. Enum a => Int -> a
toEnum Int
dsgn)]

-- deleteExperiment :: (MonadIO m) => Experiment a -> DB m ()
-- deleteExperiment (Experiment k _ _ _ _ expRes) = mapM_ deleteExperimentResult expRes >> delete k


deleteExperimentResult :: (MonadIO m) => ExperimentResult a -> DB m ()
deleteExperimentResult :: forall (m :: * -> *) a. MonadIO m => ExperimentResult a -> DB m ()
deleteExperimentResult (ExperimentResult Key ExpResult
k Int
_ Maybe (ResultData a)
_ [ReplicationResult a]
repls) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) a. MonadIO m => ReplicationResult a -> DB m ()
deleteReplicationResult [ReplicationResult a]
repls forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
delete Key ExpResult
k


-- | Loads parameters of an experiment into all initial and end states of the given experiments variable.
loadParameters  :: (ExperimentDef a) => Experiments a -> Experiment a  -> DB (ExpM a) (Experiments a)
loadParameters :: forall a.
ExperimentDef a =>
Experiments a -> Experiment a -> DB (ExpM a) (Experiments a)
loadParameters Experiments a
exps Experiment a
exp = forall a (m :: * -> *) b.
(NFData a, Monad m) =>
(a -> b -> m a) -> a -> [b] -> m a
foldM' Experiments a
-> ParameterSetting a
-> ReaderT
     SqlBackend (LoggingT (ResourceT (ExpM a))) (Experiments a)
setParam Experiments a
exps (Experiment a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiment a) [ParameterSetting a]
parameterSetup)
  where
    setParam :: Experiments a
-> ParameterSetting a
-> ReaderT
     SqlBackend (LoggingT (ResourceT (ExpM a))) (Experiments a)
setParam Experiments a
e (ParameterSetting Text
n ConnectionString
bs Bool
_ ExperimentDesign
_) =
      case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\(ParameterSetup Text
name b -> a -> a
_ a -> b
_ Maybe (b -> IO [b])
_ Maybe (b, b)
_ Maybe (b -> Bool)
_ Maybe (b -> ExperimentDesign)
_) -> Text
name forall a. Eq a => a -> a -> Bool
== Text
n) [ParameterSetup a]
parameterSetups of
        Maybe (ParameterSetup a)
Nothing -> do
          $(logError) forall a b. (a -> b) -> a -> b
$ Text
"Could not find parameter with name " forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
" in the current parameter setting. Thus it cannot be modified!"
          forall (m :: * -> *) a. Monad m => a -> m a
return Experiments a
e
        Just (ParameterSetup Text
_ b -> a -> a
setter a -> b
_ Maybe (b -> IO [b])
_ Maybe (b, b)
_ Maybe (b -> Bool)
_ Maybe (b -> ExperimentDesign)
_) ->
          case forall a. Get a -> ConnectionString -> Either String a
runGet forall t. Serialize t => Get t
S.get ConnectionString
bs of
            Left String
err -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not read value of parameter " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
n forall a. Semigroup a => a -> a -> a
<> String
". Aborting! Serializtion error was: " forall a. [a] -> [a] -> [a]
++ String
err
            Right b
val -> do
              $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Loaded parameter '" forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
"' value: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow b
val
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall a. Lens' (Experiments a) a
experimentsInitialState (b -> a -> a
setter b
val) Experiments a
e
    parameterSetups :: [ParameterSetup a]
parameterSetups = forall a. ExperimentDef a => a -> [ParameterSetup a]
parameters (Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) a
experimentsInitialState)


continueExperiment :: (ExperimentDef a) => DatabaseSetting -> Rands -> Experiments a -> Experiment a  -> DB (ExpM a) (Updated, Experiment a)
continueExperiment :: forall a.
ExperimentDef a =>
DatabaseSetting
-> Rands
-> Experiments a
-> Experiment a
-> DB (ExpM a) (Bool, Experiment a)
continueExperiment DatabaseSetting
dbSetup Rands
rands Experiments a
exps Experiment a
expIn = do
  ProcessID
pid <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProcessID
getProcessID
  String
hostName <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getHostName
  UTCTime
time <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [forall typ. (typ ~ UTCTime) => EntityField ExpExecutionLock typ
ExpExecutionLockLastAliveSign forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
<=. NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (-NominalDiffTime
2 forall a. Num a => a -> a -> a
* forall t. Num t => t
keepAliveTimeout) UTCTime
time]
  Maybe (Key ExpExecutionLock)
maybeLocked <- forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Maybe (Key record))
insertUnique forall a b. (a -> b) -> a -> b
$ Key Exp -> Text -> Int -> UTCTime -> ExpExecutionLock
ExpExecutionLock Key Exp
expId (String -> Text
T.pack String
hostName) (forall a b. (Integral a, Num b) => a -> b
fromIntegral ProcessID
pid) UTCTime
time
  forall (m :: * -> *). MonadIO m => ReaderT SqlBackend m ()
transactionSave
  case Maybe (Key ExpExecutionLock)
maybeLocked of
    Maybe (Key ExpExecutionLock)
Nothing -> do
      $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Skipping experiment with ID " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (forall record.
ToBackendKey SqlBackend record =>
Key record -> Int64
fromSqlKey Key Exp
expId) forall a. Semigroup a => a -> a -> a
<> Text
" as it is currently locked by another worker."
      forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Experiment a
expIn)
    Just Key ExpExecutionLock
lock -> do
      [ExperimentResult a]
expResults <- forall a.
ExperimentDef a =>
Key Exp -> DB (ExpM a) [ExperimentResult a]
loadExperimentResults Key Exp
expId -- update data
      let exp :: Experiment a
exp = forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (Experiment a) [ExperimentResult a]
experimentResults [ExperimentResult a]
expResults Experiment a
expIn
      Experiment a
-> ReaderT SqlBackend (LoggingT (ResourceT (ExpM a))) ()
printParamSetup Experiment a
exp
      $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Processing experiment with ID " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (forall record.
ToBackendKey SqlBackend record =>
Key record -> Int64
fromSqlKey Key Exp
expId) forall a. Semigroup a => a -> a -> a
<> Text
"."
      IORef WorkerStatus
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DatabaseSetting
-> (UTCTime -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
-> IO (IORef WorkerStatus)
createKeepAliveFork DatabaseSetting
dbSetup (\UTCTime
t -> forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update Key ExpExecutionLock
lock [forall typ. (typ ~ UTCTime) => EntityField ExpExecutionLock typ
ExpExecutionLockLastAliveSign forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. UTCTime
t]) (forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
delete Key ExpExecutionLock
lock)
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> a -> IO ()
writeIORef IORef WorkerStatus
ref WorkerStatus
Working)
      Experiments a
exps' <- forall a.
ExperimentDef a =>
Experiments a -> Experiment a -> DB (ExpM a) (Experiments a)
loadParameters Experiments a
exps Experiment a
exp -- loads parameters into the init state
      $(logInfo) Text
"Checking if new experiments repetitions can be created"
      ![ExperimentResult a]
expResList <- forall a. NFData a => a -> a
force forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a.
MonadIO m =>
[ExperimentResult a] -> DB m [ExperimentResult a]
getExpRes (Experiment a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiment a) [ExperimentResult a]
experimentResults) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {a}.
MonadIO m =>
Int
-> [ExperimentResult a]
-> ReaderT SqlBackend (LoggingT (ResourceT m)) [ExperimentResult a]
truncateExperiments Int
repetits)
      $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Number of experiment repetition results loaded: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExperimentResult a]
expResList)
      let skipPrep :: Bool
skipPrep = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall s a. s -> Getting a s a -> a
^. forall a1 a2.
Lens (ParameterSetting a1) (ParameterSetting a2) Bool Bool
parameterSettingSkipPreparationPhase) (Experiment a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiment a) [ParameterSetting a]
parameterSetup)
      [(Bool, ExperimentResult a)]
expRes <- forall a. NFData a => a -> a
force forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a.
ExperimentDef a =>
Bool
-> Rands
-> Experiments a
-> Key Exp
-> Int
-> ExperimentResult a
-> DB (ExpM a) (Bool, ExperimentResult a)
runExperimentResult Bool
skipPrep Rands
rands Experiments a
exps' Key Exp
expId Int
expNr) [ExperimentResult a]
expResList
      let updated :: Bool
updated = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a b. (a, b) -> a
fst [(Bool, ExperimentResult a)]
expRes
          res :: [ExperimentResult a]
res = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, ExperimentResult a)]
expRes
      [(Bool, ExperimentResult a)]
expRes seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> a -> IO ()
writeIORef IORef WorkerStatus
ref WorkerStatus
Finished)
      if Bool
updated
        then do
          Maybe UTCTime
eTime <- forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
          forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update (Experiment a
exp forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiment a) (Key Exp)
experimentKey) [forall typ. (typ ~ Maybe UTCTime) => EntityField Exp typ
ExpEndTime forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Maybe UTCTime
eTime]
          forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
delete Key ExpExecutionLock
lock
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DatabaseSetting -> IO ()
vacuum DatabaseSetting
dbSetup
          forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
updated, forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (Experiment a) [ExperimentResult a]
experimentResults [ExperimentResult a]
res forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (Experiment a) (Maybe UTCTime)
experimentEndTime Maybe UTCTime
eTime Experiment a
exp)
        else forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
delete Key ExpExecutionLock
lock forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
updated, forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (Experiment a) [ExperimentResult a]
experimentResults [ExperimentResult a]
res Experiment a
exp)
  where
    printParamSetup :: Experiment a
-> ReaderT SqlBackend (LoggingT (ResourceT (ExpM a))) ()
printParamSetup Experiment a
exp = do
      $(logInfo) Text
"------------------------------"
      $(logInfo) Text
"--  LOADED PARAMETER SETUP  --"
      $(logInfo) Text
"------------------------------"
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (Experiment a) [ParameterSetting a]
parameterSetup Experiment a
expIn)
        then $(logDebug) Text
"No info parameters set."
        else forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a.
ExperimentDef a =>
Experiments a -> ParameterSetting a -> DB (ExpM a) ()
printParamSetting Experiments a
exps) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (Experiment a) [ParameterSetting a]
parameterSetup Experiment a
exp)
      $(logInfo) Text
"------------------------------"
    expNr :: Int
expNr = Experiment a
expIn forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiment a) Int
experimentNumber
    expId :: Key Exp
expId = Experiment a
expIn forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiment a) (Key Exp)
experimentKey
    repetits :: Int
repetits = Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsSetup
experimentsSetup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Int -> f Int) -> ExpsSetup -> f ExpsSetup
expsSetupRepetitions
    getExpRes :: (MonadIO m) => [ExperimentResult a] -> DB m [ExperimentResult a]
    getExpRes :: forall (m :: * -> *) a.
MonadIO m =>
[ExperimentResult a] -> DB m [ExperimentResult a]
getExpRes [ExperimentResult a]
expResDone =
      ([ExperimentResult a]
expResDone forall a. [a] -> [a] -> [a]
++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
        [forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExperimentResult a]
expResDone forall a. Num a => a -> a -> a
+ Int
1 .. Int
repetits]
        (\Int
nr -> do
           Key ExpResult
kExpRes <- forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert forall a b. (a -> b) -> a -> b
$ Key Exp -> Int -> Maybe PrepResultDataId -> ExpResult
ExpResult Key Exp
expId Int
nr forall a. Maybe a
Nothing
           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Key ExpResult
-> Int
-> Maybe (ResultData a)
-> [ReplicationResult a]
-> ExperimentResult a
ExperimentResult Key ExpResult
kExpRes Int
nr forall a. Maybe a
Nothing [])
    truncateExperiments :: Int
-> [ExperimentResult a]
-> ReaderT SqlBackend (LoggingT (ResourceT m)) [ExperimentResult a]
truncateExperiments Int
nr [ExperimentResult a]
xs = do
      let dels :: [ExperimentResult a]
dels = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
> Int
nr) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (ExperimentResult a) Int
repetitionNumber) [ExperimentResult a]
xs
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExperimentResult a]
dels) forall a b. (a -> b) -> a -> b
$ $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Number of experiment repetitions being deleted " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExperimentResult a]
dels)
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) a. MonadIO m => ExperimentResult a -> DB m ()
deleteExperimentResult [ExperimentResult a]
dels
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExperimentResult a]
dels) forall (m :: * -> *). MonadIO m => ReaderT SqlBackend m ()
transactionSave
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
<= Int
nr) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (ExperimentResult a) Int
repetitionNumber) [ExperimentResult a]
xs

printParamSetting :: (ExperimentDef a) => Experiments a -> ParameterSetting a -> DB (ExpM a) ()
printParamSetting :: forall a.
ExperimentDef a =>
Experiments a -> ParameterSetting a -> DB (ExpM a) ()
printParamSetting Experiments a
exps (ParameterSetting Text
n ConnectionString
bs Bool
skipPrep ExperimentDesign
expDes) =
  case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((forall a. Eq a => a -> a -> Bool
== Text
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ParameterSetup a -> Text
parameterName) (Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) [ParameterSetup a]
experimentsParameters) of
    (Just (ParameterSetup Text
_ b -> a -> a
setter a -> b
_ Maybe (b -> IO [b])
_ Maybe (b, b)
_ Maybe (b -> Bool)
_ Maybe (b -> ExperimentDesign)
_)) ->
      case forall a. Get a -> ConnectionString -> Either String a
S.runGet forall t. Serialize t => Get t
S.get ConnectionString
bs of
        Left String
_ -> DB (ExpM a) ()
err
        Right b
val -> do
          let a
_ = b -> a -> a
setter b
val (Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) a
experimentsInitialState) -- only needed for type inference
          $(logInfo) forall a b. (a -> b) -> a -> b
$
            Text
n forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow b
val forall a. Semigroup a => a -> a -> a
<>
            if Bool
skipPrep
              then Text
" [SkipPreparation] "
              else Text
"" forall a. Semigroup a => a -> a -> a
<>
                   if ExperimentDesign
expDes forall a. Eq a => a -> a -> Bool
== ExperimentDesign
SingleInstance
                     then Text
" [SingleInstance] "
                     else Text
""
    Maybe (ParameterSetup a)
_ -> DB (ExpM a) ()
err
  where
    err :: DB (ExpM a) ()
err = $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
n forall a. Semigroup a => a -> a -> a
<> Text
": Could not deserialise value as this parameter does not exist anymore. Thus keeping it unchanged."


data RepResultType
  = Prep !(Key ExpResult)
  | WarmUp !(Key RepResult)
  | Rep !(Key RepResult)


newResultData :: (ExperimentDef a) => Seed -> RepResultType -> a -> InputState a -> DB (ExpM a) (ResultData a)
newResultData :: forall a.
ExperimentDef a =>
Seed
-> RepResultType -> a -> InputState a -> DB (ExpM a) (ResultData a)
newResultData Seed
seed RepResultType
repResType a
st InputState a
inpSt = do
  UTCTime
time <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  ResultDataKey
k <-
    case RepResultType
repResType of
      Prep Key ExpResult
expResId -> do
        Serializable a
serSt <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. ExperimentDef a => a -> ExpM a (Serializable a)
serialisable a
st
        PrepResultDataId
prepId <- forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert (UTCTime
-> Maybe UTCTime
-> ConnectionString
-> Maybe ConnectionString
-> ConnectionString
-> Maybe ConnectionString
-> PrepResultData
PrepResultData UTCTime
time forall a. Maybe a
Nothing (Seed -> ConnectionString
serialiseSeed Seed
seed) forall a. Maybe a
Nothing (Put -> ConnectionString
runPut forall a b. (a -> b) -> a -> b
$ forall t. Serialize t => Putter t
put InputState a
inpSt) forall a. Maybe a
Nothing)
        forall (m :: * -> *).
MonadIO m =>
StartStateType -> ConnectionString -> ReaderT SqlBackend m ()
setResDataStartState (PrepResultDataId -> StartStateType
StartStatePrep PrepResultDataId
prepId) (Put -> ConnectionString
runPut forall a b. (a -> b) -> a -> b
$ forall t. Serialize t => Putter t
put Serializable a
serSt)
        forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update Key ExpResult
expResId [forall typ.
(typ ~ Maybe PrepResultDataId) =>
EntityField ExpResult typ
ExpResultPrepResultData forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. forall a. a -> Maybe a
Just PrepResultDataId
prepId]
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PrepResultDataId -> ResultDataKey
ResultDataPrep PrepResultDataId
prepId
      WarmUp Key RepResult
repResId -> do
        Serializable a
serSt <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. ExperimentDef a => a -> ExpM a (Serializable a)
serialisable a
st
        Key WarmUpResultData
wmUpId <- forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert (UTCTime
-> Maybe UTCTime
-> ConnectionString
-> Maybe ConnectionString
-> ConnectionString
-> Maybe ConnectionString
-> WarmUpResultData
WarmUpResultData UTCTime
time forall a. Maybe a
Nothing (Seed -> ConnectionString
serialiseSeed Seed
seed) forall a. Maybe a
Nothing (Put -> ConnectionString
runPut forall a b. (a -> b) -> a -> b
$ forall t. Serialize t => Putter t
put InputState a
inpSt) forall a. Maybe a
Nothing)
        forall (m :: * -> *).
MonadIO m =>
StartStateType -> ConnectionString -> ReaderT SqlBackend m ()
setResDataStartState (Key WarmUpResultData -> StartStateType
StartStateWarmUp Key WarmUpResultData
wmUpId) (Put -> ConnectionString
runPut forall a b. (a -> b) -> a -> b
$ forall t. Serialize t => Putter t
put Serializable a
serSt)
        forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update Key RepResult
repResId [forall typ.
(typ ~ Maybe (Key WarmUpResultData)) =>
EntityField RepResult typ
RepResultWarmUpResultData forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. forall a. a -> Maybe a
Just Key WarmUpResultData
wmUpId]
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Key WarmUpResultData -> ResultDataKey
ResultDataWarmUp Key WarmUpResultData
wmUpId
      Rep Key RepResult
repResId -> do
        Serializable a
serSt <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. ExperimentDef a => a -> ExpM a (Serializable a)
serialisable a
st
        Key RepResultData
repResDataId <- forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert (UTCTime
-> Maybe UTCTime
-> ConnectionString
-> Maybe ConnectionString
-> ConnectionString
-> Maybe ConnectionString
-> RepResultData
RepResultData UTCTime
time forall a. Maybe a
Nothing (Seed -> ConnectionString
serialiseSeed Seed
seed) forall a. Maybe a
Nothing (Put -> ConnectionString
runPut forall a b. (a -> b) -> a -> b
$ forall t. Serialize t => Putter t
put InputState a
inpSt) forall a. Maybe a
Nothing)
        forall (m :: * -> *).
MonadIO m =>
StartStateType -> ConnectionString -> ReaderT SqlBackend m ()
setResDataStartState (Key RepResultData -> StartStateType
StartStateRep Key RepResultData
repResDataId) (Put -> ConnectionString
runPut forall a b. (a -> b) -> a -> b
$ forall t. Serialize t => Putter t
put Serializable a
serSt)
        forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update Key RepResult
repResId [forall typ.
(typ ~ Maybe (Key RepResultData)) =>
EntityField RepResult typ
RepResultRepResultData forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. forall a. a -> Maybe a
Just Key RepResultData
repResDataId]
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Key RepResultData -> ResultDataKey
ResultDataRep Key RepResultData
repResDataId
  let (a
fInp, b
fMeas) = (forall a. HasCallStack => String -> a
error String
"called Conduit for input on unsaved result data", forall a. HasCallStack => String -> a
error String
"called Conduit for measures on unsaved result data")
  Gen RealWorld
g <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PrimMonad m => Seed -> m (Gen (PrimState m))
restore Seed
seed
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
ResultDataKey
-> UTCTime
-> Maybe UTCTime
-> GenIO
-> Maybe GenIO
-> AvailabilityList (ExpM a) (Input a)
-> AvailabilityList (ExpM a) Measure
-> Availability (ExpM a) a
-> Availability (ExpM a) (Maybe a)
-> InputState a
-> Maybe (InputState a)
-> ResultData a
ResultData ResultDataKey
k UTCTime
time forall a. Maybe a
Nothing Gen RealWorld
g forall a. Maybe a
Nothing (forall (m :: * -> *) b.
(Int, [b])
-> (AvailabilityListWhere -> ConduitT () b (DB m) ())
-> AvailabilityList m b
AvailableList (Int
0, []) forall {a}. a
fInp) (forall (m :: * -> *) b.
(Int, [b])
-> (AvailabilityListWhere -> ConduitT () b (DB m) ())
-> AvailabilityList m b
AvailableList (Int
0, []) forall {a}. a
fMeas) (forall (m :: * -> *) b. b -> Availability m b
Available a
st) (forall (m :: * -> *) b. b -> Availability m b
Available forall a. Maybe a
Nothing) InputState a
inpSt forall a. Maybe a
Nothing


runExperimentResult ::
     (ExperimentDef a)
  => SkipPreparation
  -> Rands
  -> Experiments a
  -> Key Exp
  -> ExperimentNumber
  -> ExperimentResult a
  -> DB (ExpM a) (Updated, ExperimentResult a)
runExperimentResult :: forall a.
ExperimentDef a =>
Bool
-> Rands
-> Experiments a
-> Key Exp
-> Int
-> ExperimentResult a
-> DB (ExpM a) (Bool, ExperimentResult a)
runExperimentResult Bool
skipPrep rands :: Rands
rands@([Seed]
prepRands, [Seed]
_, [Seed]
_) Experiments a
exps Key Exp
expId Int
expNr ExperimentResult a
expRes = do
  a
expInitSt <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. ExperimentDef a => Int -> a -> ExpM a a
beforeExperimentStartHook Int
expNr (Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) a
experimentsInitialState)
  let repetNr :: Int
repetNr = ExperimentResult a
expRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ExperimentResult a) Int
repetitionNumber
  let prepSeed :: Seed
prepSeed = [Seed]
prepRands forall a. [a] -> Int -> a
!! (Int
repetNr forall a. Num a => a -> a -> a
- Int
1)
  (a
prepInitSt, Bool
delPrep) <-
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return (a
expInitSt, Bool
False)) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a
expInitSt, Bool
True) (, Bool
False)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) b. Monad m => Availability m b -> DB m b
mkTransientlyAvailable) (ExperimentResult a
expRes forall s a. s -> Getting (First a) s a -> Maybe a
^? forall a. Lens' (ExperimentResult a) (Maybe (ResultData a))
preparationResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (ResultData a) (Availability (ExpM a) (Maybe a))
endState)
  (Bool
prepUpdated, Maybe (ResultData a)
prepRes) <-
    if Bool
skipPrep
      then do
        $(logInfo) Text
"Skipping preparation phase as provided by the parameter setting (skipPreparationPhase)."
        forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, forall a. Maybe a
Nothing)
      else forall a.
ExperimentDef a =>
Seed
-> Experiments a
-> Key Exp
-> Key ExpResult
-> CharPos
-> Bool
-> a
-> Maybe (ResultData a)
-> DB (ExpM a) (Bool, Maybe (ResultData a))
runPreparation Seed
prepSeed Experiments a
exps Key Exp
expId Key ExpResult
expResId (Int
expNr, Int
repetNr) Bool
delPrep a
prepInitSt (ExperimentResult a
expRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ExperimentResult a) (Maybe (ResultData a))
preparationResults)
  [ReplicationResult a]
repsDone <-
    if Bool
prepUpdated
      then do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) a. MonadIO m => ReplicationResult a -> DB m ()
deleteReplicationResult (ExperimentResult a
expRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ExperimentResult a) [ReplicationResult a]
evaluationResults)
        forall (m :: * -> *) a. Monad m => a -> m a
return []
      else forall (m :: * -> *) a. Monad m => a -> m a
return (ExperimentResult a
expRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ExperimentResult a) [ReplicationResult a]
evaluationResults)
  forall (m :: * -> *). MonadIO m => ReaderT SqlBackend m ()
transactionSave
  Maybe a
mEndSt <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (m :: * -> *) b. Monad m => Availability m b -> DB m b
mkTransientlyAvailable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (ResultData a) (Availability (ExpM a) (Maybe a))
endState) Maybe (ResultData a)
prepRes
  let initSt :: a
initSt = forall a. a -> Maybe a -> a
fromMaybe a
expInitSt Maybe a
mEndSt
  let initInpSt :: InputState a
initInpSt = forall a. a -> Maybe a -> a
fromMaybe (Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) (InputState a)
experimentsInitialInputState) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (ResultData a) (Maybe (InputState a))
endInputState forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (ResultData a)
prepRes)
  let runRepl :: Experiments a
-> ReplicationResult a
-> ReaderT
     SqlBackend
     (LoggingT (ResourceT (ExpM a)))
     (Bool, ReplicationResult a)
runRepl Experiments a
e ReplicationResult a
repRess = do
        (Bool, ReplicationResult a)
res <- forall a.
ExperimentDef a =>
Rands
-> Experiments a
-> Key Exp
-> CharPos
-> a
-> InitialInputState a
-> ReplicationResult a
-> DB (ExpM a) (Bool, ReplicationResult a)
runReplicationResult Rands
rands Experiments a
e Key Exp
expId (Int
expNr, Int
repetNr) a
initSt InputState a
initInpSt ReplicationResult a
repRess
        forall (m :: * -> *). MonadIO m => ReaderT SqlBackend m ()
transactionSave
        forall (m :: * -> *) a. Monad m => a -> m a
return (Bool, ReplicationResult a)
res
  [(Bool, ReplicationResult a)]
repRes <- forall (m :: * -> *) a.
MonadIO m =>
Experiments a
-> [ReplicationResult a] -> DB m [ReplicationResult a]
getRepRes Experiments a
exps [ReplicationResult a]
repsDone forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
MonadIO m =>
Experiments a
-> [ReplicationResult a] -> DB m [ReplicationResult a]
deleteTruncatedRepRes Experiments a
exps forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Experiments a
-> ReplicationResult a
-> ReaderT
     SqlBackend
     (LoggingT (ResourceT (ExpM a)))
     (Bool, ReplicationResult a)
runRepl Experiments a
exps)
  let updated :: Bool
updated = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a b. (a, b) -> a
fst [(Bool, ReplicationResult a)]
repRes
      res :: [ReplicationResult a]
res = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, ReplicationResult a)]
repRes
  forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
prepUpdated Bool -> Bool -> Bool
|| Bool
updated, forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ExperimentResult a) (Maybe (ResultData a))
preparationResults Maybe (ResultData a)
prepRes forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ExperimentResult a) [ReplicationResult a]
evaluationResults [ReplicationResult a]
res ExperimentResult a
expRes)
  where
    expResId :: Key ExpResult
expResId = ExperimentResult a
expRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ExperimentResult a) (Key ExpResult)
experimentResultKey
    deleteTruncatedRepRes :: (MonadIO m) => Experiments a -> [ReplicationResult a] -> DB m [ReplicationResult a]
    deleteTruncatedRepRes :: forall (m :: * -> *) a.
MonadIO m =>
Experiments a
-> [ReplicationResult a] -> DB m [ReplicationResult a]
deleteTruncatedRepRes Experiments a
exps' [ReplicationResult a]
xs
      | forall (t :: * -> *) a. Foldable t => t a -> Int
length [ReplicationResult a]
xs forall a. Ord a => a -> a -> Bool
> Int
len = do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) a. MonadIO m => ReplicationResult a -> DB m ()
deleteReplicationResult (forall a. Int -> [a] -> [a]
drop Int
len [ReplicationResult a]
xs)
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Int -> [a] -> [a]
take Int
len [ReplicationResult a]
xs)
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return [ReplicationResult a]
xs
      where
        len :: Int
len = Experiments a
exps' forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsSetup
experimentsSetup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Int -> f Int) -> ExpsSetup -> f ExpsSetup
expsSetupEvaluationReplications
    getRepRes :: (MonadIO m) => Experiments a -> [ReplicationResult a] -> DB m [ReplicationResult a]
    getRepRes :: forall (m :: * -> *) a.
MonadIO m =>
Experiments a
-> [ReplicationResult a] -> DB m [ReplicationResult a]
getRepRes Experiments a
exps' [ReplicationResult a]
repsDone = do
      $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Number of loaded replications: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ReplicationResult a]
repsDone)
      $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Number of new replications: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (forall (t :: * -> *) a. Foldable t => t a -> Int
length [forall (t :: * -> *) a. Foldable t => t a -> Int
length [ReplicationResult a]
repsDone forall a. Num a => a -> a -> a
+ Int
1 .. Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsSetup
experimentsSetup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Int -> f Int) -> ExpsSetup -> f ExpsSetup
expsSetupEvaluationReplications])
      ([ReplicationResult a]
repsDone forall a. [a] -> [a] -> [a]
++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
          [forall (t :: * -> *) a. Foldable t => t a -> Int
length [ReplicationResult a]
repsDone forall a. Num a => a -> a -> a
+ Int
1 .. Experiments a
exps' forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsSetup
experimentsSetup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Int -> f Int) -> ExpsSetup -> f ExpsSetup
expsSetupEvaluationReplications]
          (\Int
nr -> do
             Key RepResult
kRepRes <- forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert forall a b. (a -> b) -> a -> b
$ Key ExpResult
-> Int
-> Maybe (Key WarmUpResultData)
-> Maybe (Key RepResultData)
-> RepResult
RepResult (ExperimentResult a
expRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ExperimentResult a) (Key ExpResult)
experimentResultKey) Int
nr forall a. Maybe a
Nothing forall a. Maybe a
Nothing
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Key RepResult
-> Int
-> Maybe (ResultData a)
-> Maybe (ResultData a)
-> ReplicationResult a
ReplicationResult Key RepResult
kRepRes Int
nr forall a. Maybe a
Nothing forall a. Maybe a
Nothing)


runPreparation ::
     (ExperimentDef a)
  => Seed
  -> Experiments a
  -> Key Exp
  -> Key ExpResult
  -> (ExperimentNumber, RepetitionNumber)
  -> Bool
  -> a
  -> Maybe (ResultData a)
  -> DB (ExpM a) (Updated, Maybe (ResultData a))
runPreparation :: forall a.
ExperimentDef a =>
Seed
-> Experiments a
-> Key Exp
-> Key ExpResult
-> CharPos
-> Bool
-> a
-> Maybe (ResultData a)
-> DB (ExpM a) (Bool, Maybe (ResultData a))
runPreparation Seed
seed Experiments a
exps Key Exp
expId Key ExpResult
expResId (Int
expNr, Int
repetNr) Bool
prepDelNeeded a
prepInitSt Maybe (ResultData a)
mResData = do
  Gen RealWorld
g <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PrimMonad m => Seed -> m (Gen (PrimState m))
restore Seed
seed
  a
initSt <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. ExperimentDef a => Int -> Int -> GenIO -> a -> ExpM a a
beforePreparationHook Int
expNr Int
repetNr Gen RealWorld
g a
prepInitSt
  let len :: Int
len = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall (m :: * -> *) b. AvailabilityList m b -> Int
lengthAvailabilityList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (ResultData a) (AvailabilityList (ExpM a) Measure)
results) Maybe (ResultData a)
mResData
  Maybe (ResultData a)
mResData' <-
    if Int -> Bool
delNeeded Int
len
      then forall (m :: * -> *). MonadIO m => RepResultType -> DB m ()
deleteResultData (Key ExpResult -> RepResultType
Prep Key ExpResult
expResId) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      else forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ResultData a)
mResData
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int -> Bool
delNeeded Int
len) forall a b. (a -> b) -> a -> b
$ $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Deletion of preparation data needed. Len: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
len
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
runNeeded Int
len) forall a b. (a -> b) -> a -> b
$ $(logInfo) Text
"Preparation run is needed"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Int -> Bool
delNeeded Int
len) Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> Bool
runNeeded Int
len) Bool -> Bool -> Bool
&& Int
prepSteps forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ $(logInfo) Text
"preparation phase needs no change"
  if Int -> Bool
runNeeded Int
len
    then do
      (Bool, Maybe (ResultData a))
res <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> DB (ExpM a) (ResultData a)
new a
initSt) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ResultData a)
mResData' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> ResultData a -> DB (ExpM a) (Bool, Maybe (ResultData a))
run' Int
len
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. ExperimentDef a => a -> Int -> Int -> IO ()
afterPreparationHook a
initSt Int
expNr Int
repetNr
      forall (m :: * -> *) a. Monad m => a -> m a
return (Bool, Maybe (ResultData a))
res
    else forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Bool
delNeeded Int
len Bool -> Bool -> Bool
|| Int -> Bool
runNeeded Int
len, Maybe (ResultData a)
mResData')
  where
    delNeeded :: Int -> Bool
delNeeded Int
len = Bool
prepDelNeeded Bool -> Bool -> Bool
|| forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\ResultData a
_ -> Int
prepSteps forall a. Ord a => a -> a -> Bool
< Int
len) Maybe (ResultData a)
mResData
    runNeeded :: Int -> Bool
runNeeded Int
len = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int
prepSteps forall a. Ord a => a -> a -> Bool
> Int
0) (\ResultData a
_ -> Int
prepSteps forall a. Ord a => a -> a -> Bool
> Int
len Bool -> Bool -> Bool
|| (Int -> Bool
delNeeded Int
len Bool -> Bool -> Bool
&& Int
prepSteps forall a. Ord a => a -> a -> Bool
> Int
0)) Maybe (ResultData a)
mResData
    prepSteps :: Int
prepSteps = Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsSetup
experimentsSetup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Int -> f Int) -> ExpsSetup -> f ExpsSetup
expsSetupPreparationSteps
    maxSteps :: Maybe Int
maxSteps = Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsSetup
experimentsSetup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Maybe Int -> f (Maybe Int)) -> ExpsSetup -> f ExpsSetup
expsSetupEvaluationMaxStepsBetweenSaves
    initInpSt :: InputState a
initInpSt = Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) (InputState a)
experimentsInitialInputState
    new :: a -> DB (ExpM a) (ResultData a)
new a
initSt = forall a.
ExperimentDef a =>
Seed
-> RepResultType -> a -> InputState a -> DB (ExpM a) (ResultData a)
newResultData Seed
seed (Key ExpResult -> RepResultType
Prep Key ExpResult
expResId) a
initSt InputState a
initInpSt
    run' :: Int -> ResultData a -> DB (ExpM a) (Bool, Maybe (ResultData a))
run' Int
len ResultData a
rD = ((Int -> Bool
delNeeded Int
len Bool -> Bool -> Bool
||) forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a. a -> Maybe a
Just) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ExperimentDef a =>
Key Exp
-> Maybe Int
-> Int
-> RepResultType
-> ResultData a
-> DB (ExpM a) (Bool, ResultData a)
runResultData Key Exp
expId Maybe Int
maxSteps Int
prepSteps (Key ExpResult -> RepResultType
Prep Key ExpResult
expResId) ResultData a
rD


runReplicationResult ::
     (ExperimentDef a)
  => Rands
  -> Experiments a
  -> Key Exp
  -> (ExperimentNumber, RepetitionNumber)
  -> InitialState a
  -> InitialInputState a
  -> ReplicationResult a
  -> DB (ExpM a) (Updated, ReplicationResult a)
runReplicationResult :: forall a.
ExperimentDef a =>
Rands
-> Experiments a
-> Key Exp
-> CharPos
-> a
-> InitialInputState a
-> ReplicationResult a
-> DB (ExpM a) (Bool, ReplicationResult a)
runReplicationResult ([Seed]
_, [Seed]
wmUpRands, [Seed]
replRands) Experiments a
exps Key Exp
expId (Int
expNr, Int
repetNr) a
initSt InputState a
initInpSt ReplicationResult a
repRes = do
  let repliNr :: Int
repliNr = ReplicationResult a
repRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ReplicationResult a) Int
replicationNumber
  let randGenIdx :: Int
randGenIdx = (Int
repetNr forall a. Num a => a -> a -> a
- Int
1) forall a. Num a => a -> a -> a
* Int
replicats forall a. Num a => a -> a -> a
+ (Int
repliNr forall a. Num a => a -> a -> a
- Int
1)
  let wmUpRand :: Seed
wmUpRand = [Seed]
wmUpRands forall a. [a] -> Int -> a
!! Int
randGenIdx
  let repRand :: Seed
repRand = [Seed]
replRands forall a. [a] -> Int -> a
!! Int
randGenIdx
  $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Running replication " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
repliNr forall a. Semigroup a => a -> a -> a
<> Text
" for experiment repetition " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
repetNr
  (Bool
wmUpChange, Maybe (ResultData a)
mWmUp) <- forall a.
ExperimentDef a =>
Seed
-> Experiments a
-> Key Exp
-> Key RepResult
-> (Int, Int, Int)
-> a
-> InitialInputState a
-> Maybe (ResultData a)
-> DB (ExpM a) (Bool, Maybe (ResultData a))
runWarmUp Seed
wmUpRand Experiments a
exps Key Exp
expId (ReplicationResult a
repRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ReplicationResult a) (Key RepResult)
replicationResultKey) (Int
expNr, Int
repetNr, Int
repliNr) a
initSt InputState a
initInpSt (ReplicationResult a
repRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ReplicationResult a) (Maybe (ResultData a))
warmUpResults)
  a
initStEval <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return a
initSt) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe a
initSt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) b. Monad m => Availability m b -> DB m b
mkTransientlyAvailable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (ResultData a) (Availability (ExpM a) (Maybe a))
endState) Maybe (ResultData a)
mWmUp
  let initInpStEval :: InputState a
initInpStEval = forall a. a -> Maybe a -> a
fromMaybe InputState a
initInpSt (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (ResultData a) (Maybe (InputState a))
endInputState forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (ResultData a)
mWmUp)
  Maybe (ResultData a)
mEval <-
    if Bool
wmUpChange
      then forall (m :: * -> *). MonadIO m => RepResultType -> DB m ()
deleteResultData (Key RepResult -> RepResultType
Rep Key RepResult
repResId) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      else forall (m :: * -> *) a. Monad m => a -> m a
return (ReplicationResult a
repRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ReplicationResult a) (Maybe (ResultData a))
evalResults)
  (Bool
evalChange, Maybe (ResultData a)
mEval') <- forall a.
ExperimentDef a =>
Seed
-> Experiments a
-> Key Exp
-> Bool
-> Key RepResult
-> (Int, Int, Int)
-> a
-> InitialInputState a
-> Maybe (ResultData a)
-> DB (ExpM a) (Bool, Maybe (ResultData a))
runEval Seed
repRand Experiments a
exps Key Exp
expId Bool
wmUpChange (ReplicationResult a
repRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ReplicationResult a) (Key RepResult)
replicationResultKey) (Int
expNr, Int
repetNr, Int
repliNr) a
initStEval InputState a
initInpStEval Maybe (ResultData a)
mEval
  forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
wmUpChange Bool -> Bool -> Bool
|| Bool
evalChange, forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ReplicationResult a) (Maybe (ResultData a))
warmUpResults Maybe (ResultData a)
mWmUp forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ReplicationResult a) (Maybe (ResultData a))
evalResults Maybe (ResultData a)
mEval' ReplicationResult a
repRes)
  where
    !repResId :: Key RepResult
repResId = ReplicationResult a
repRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ReplicationResult a) (Key RepResult)
replicationResultKey
    !replicats :: Int
replicats = Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsSetup
experimentsSetup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Int -> f Int) -> ExpsSetup -> f ExpsSetup
expsSetupEvaluationReplications


runWarmUp ::
     (ExperimentDef a)
  => Seed
  -> Experiments a
  -> Key Exp
  -> Key RepResult
  -> (ExperimentNumber, RepetitionNumber, ReplicationNumber)
  -> InitialState a
  -> InitialInputState a
  -> Maybe (ResultData a)
  -> DB (ExpM a) (Updated, Maybe (ResultData a))
runWarmUp :: forall a.
ExperimentDef a =>
Seed
-> Experiments a
-> Key Exp
-> Key RepResult
-> (Int, Int, Int)
-> a
-> InitialInputState a
-> Maybe (ResultData a)
-> DB (ExpM a) (Bool, Maybe (ResultData a))
runWarmUp Seed
seed Experiments a
exps Key Exp
expId Key RepResult
repResId (Int
expNr, Int
repetNr, Int
repliNr) a
initSt InitialInputState a
initInpSt Maybe (ResultData a)
mResData = do
  !Gen RealWorld
g <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PrimMonad m => Seed -> m (Gen (PrimState m))
restore Seed
seed
  !a
initStWmUp <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
ExperimentDef a =>
Int -> Int -> Int -> GenIO -> a -> ExpM a a
beforeWarmUpHook Int
expNr Int
repetNr Int
repliNr Gen RealWorld
g a
initSt
  let len :: Int
len = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall (m :: * -> *) b. AvailabilityList m b -> Int
lengthAvailabilityList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (ResultData a) (AvailabilityList (ExpM a) Measure)
results) Maybe (ResultData a)
mResData
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int -> Bool
delNeeded Int
len) forall a b. (a -> b) -> a -> b
$ $(logInfo) Text
"Deletion of warm up data needed"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
runNeeded Int
len) forall a b. (a -> b) -> a -> b
$ $(logInfo) Text
"Warm up run is needed"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Int -> Bool
delNeeded Int
len) Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> Bool
runNeeded Int
len) Bool -> Bool -> Bool
&& Int
wmUpSteps forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ $(logInfo) Text
"Warm up phase needs no change"
  !Maybe (ResultData a)
mResData' <-
    if Int -> Bool
delNeeded Int
len
      then forall (m :: * -> *). MonadIO m => RepResultType -> DB m ()
deleteResultData (Key RepResult -> RepResultType
WarmUp Key RepResult
repResId) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      else forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ResultData a)
mResData
  if Int -> Bool
runNeeded Int
len
    then do
      !(Bool, Maybe (ResultData a))
res <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> DB (ExpM a) (ResultData a)
new a
initStWmUp) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ResultData a)
mResData' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> ResultData a -> DB (ExpM a) (Bool, Maybe (ResultData a))
run' Int
len
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. ExperimentDef a => a -> Int -> Int -> Int -> IO ()
afterWarmUpHook a
initSt Int
expNr Int
repetNr Int
repliNr
      forall (m :: * -> *) a. Monad m => a -> m a
return (Bool, Maybe (ResultData a))
res
    else do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
delNeeded Int
len) forall a b. (a -> b) -> a -> b
$ $(logInfo) Text
"Deleted warm up data."
      forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Bool
delNeeded Int
len, Maybe (ResultData a)
mResData')
  where
    delNeeded :: Int -> Bool
delNeeded Int
len = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\ResultData a
_ -> Int
wmUpSteps forall a. Ord a => a -> a -> Bool
< Int
len) Maybe (ResultData a)
mResData --  || maybe False ((>0) . lengthAvailabilityList) (mResData ^? traversed.results)
    runNeeded :: Int -> Bool
runNeeded Int
len = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int
wmUpSteps forall a. Ord a => a -> a -> Bool
> Int
0) (\ResultData a
_ -> Int
wmUpSteps forall a. Ord a => a -> a -> Bool
> Int
len Bool -> Bool -> Bool
|| (Int -> Bool
delNeeded Int
len Bool -> Bool -> Bool
&& Int
wmUpSteps forall a. Ord a => a -> a -> Bool
> Int
0)) Maybe (ResultData a)
mResData
    !wmUpSteps :: Int
wmUpSteps = Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsSetup
experimentsSetup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Int -> f Int) -> ExpsSetup -> f ExpsSetup
expsSetupEvaluationWarmUpSteps
    !maxSteps :: Maybe Int
maxSteps = Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsSetup
experimentsSetup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Maybe Int -> f (Maybe Int)) -> ExpsSetup -> f ExpsSetup
expsSetupEvaluationMaxStepsBetweenSaves
    new :: a -> DB (ExpM a) (ResultData a)
new !a
initStWmUp = forall a.
ExperimentDef a =>
Seed
-> RepResultType -> a -> InputState a -> DB (ExpM a) (ResultData a)
newResultData Seed
seed (Key RepResult -> RepResultType
WarmUp Key RepResult
repResId) a
initStWmUp InitialInputState a
initInpSt
    run' :: Int -> ResultData a -> DB (ExpM a) (Bool, Maybe (ResultData a))
run' !Int
len !ResultData a
rD = ((Int -> Bool
delNeeded Int
len Bool -> Bool -> Bool
||) forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a. a -> Maybe a
Just) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ExperimentDef a =>
Key Exp
-> Maybe Int
-> Int
-> RepResultType
-> ResultData a
-> DB (ExpM a) (Bool, ResultData a)
runResultData Key Exp
expId Maybe Int
maxSteps Int
wmUpSteps (Key RepResult -> RepResultType
WarmUp Key RepResult
repResId) ResultData a
rD


runEval ::
     (ExperimentDef a)
  => Seed
  -> Experiments a
  -> Key Exp
  -> Updated
  -> Key RepResult
  -> (ExperimentNumber, RepetitionNumber, ReplicationNumber)
  -> InitialState a
  -> InitialInputState a
  -> Maybe (ResultData a)
  -> DB (ExpM a) (Updated, Maybe (ResultData a))
runEval :: forall a.
ExperimentDef a =>
Seed
-> Experiments a
-> Key Exp
-> Bool
-> Key RepResult
-> (Int, Int, Int)
-> a
-> InitialInputState a
-> Maybe (ResultData a)
-> DB (ExpM a) (Bool, Maybe (ResultData a))
runEval Seed
seed Experiments a
exps Key Exp
expId Bool
warmUpUpdated Key RepResult
repResId (Int
expNr, Int
repetNr, Int
repliNr) a
initSt InitialInputState a
initInpSt Maybe (ResultData a)
mResData = do
  !Gen RealWorld
g <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PrimMonad m => Seed -> m (Gen (PrimState m))
restore Seed
seed
  !a
initStEval <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
ExperimentDef a =>
Int -> Int -> Int -> GenIO -> a -> ExpM a a
beforeEvaluationHook Int
expNr Int
repetNr Int
repliNr Gen RealWorld
g a
initSt
  let len :: Int
len = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall (m :: * -> *) b. AvailabilityList m b -> Int
lengthAvailabilityList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (ResultData a) (AvailabilityList (ExpM a) Measure)
results) Maybe (ResultData a)
mResData
  !Maybe (ResultData a)
mResData' <-
    if Int -> Bool
delNeeded Int
len
      then forall (m :: * -> *). MonadIO m => RepResultType -> DB m ()
deleteResultData (Key RepResult -> RepResultType
Rep Key RepResult
repResId) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      else forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ResultData a)
mResData
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int -> Bool
delNeeded Int
len) forall a b. (a -> b) -> a -> b
$ $(logInfo) Text
"Deletion of evaluation data needed"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
runNeeded Int
len) forall a b. (a -> b) -> a -> b
$ $(logInfo) Text
"Evaluation run is needed"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Int -> Bool
delNeeded Int
len) Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> Bool
runNeeded Int
len) Bool -> Bool -> Bool
&& Int
evalSteps forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ $(logInfo) Text
"Evaluation phase needs no change"
  if Int -> Bool
runNeeded Int
len
    then do
      $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"An evaluation run is needed for replication with ID " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (BackendKey SqlBackend -> Int64
unSqlBackendKey forall a b. (a -> b) -> a -> b
$ Key RepResult -> BackendKey SqlBackend
unRepResultKey Key RepResult
repResId)
      !(Bool, Maybe (ResultData a))
res <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> DB (ExpM a) (ResultData a)
new a
initStEval) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ResultData a)
mResData' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> ResultData a -> DB (ExpM a) (Bool, Maybe (ResultData a))
run' Int
len
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. ExperimentDef a => a -> Int -> Int -> Int -> IO ()
afterEvaluationHook a
initSt Int
expNr Int
repetNr Int
repliNr
      forall (m :: * -> *) a. Monad m => a -> m a
return (Bool, Maybe (ResultData a))
res
    else do
      $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"No evaluation run needed for replication with ID " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (BackendKey SqlBackend -> Int64
unSqlBackendKey forall a b. (a -> b) -> a -> b
$ Key RepResult -> BackendKey SqlBackend
unRepResultKey Key RepResult
repResId) forall a. Semigroup a => a -> a -> a
<> Text
". All needed data comes from the DB!"
      forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Bool
delNeeded Int
len, Maybe (ResultData a)
mResData')
  where
    delNeeded :: Int -> Bool
delNeeded Int
len = Bool
warmUpUpdated Bool -> Bool -> Bool
|| forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\ResultData a
_ -> Int
evalSteps forall a. Ord a => a -> a -> Bool
< Int
len) Maybe (ResultData a)
mResData
    runNeeded :: Int -> Bool
runNeeded Int
len = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int
evalSteps forall a. Ord a => a -> a -> Bool
> Int
0) (\ResultData a
_ -> Int
evalSteps forall a. Ord a => a -> a -> Bool
> Int
len  Bool -> Bool -> Bool
|| (Int -> Bool
delNeeded Int
len Bool -> Bool -> Bool
&& Int
evalSteps forall a. Ord a => a -> a -> Bool
> Int
0)) Maybe (ResultData a)
mResData
    !evalSteps :: Int
evalSteps = Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsSetup
experimentsSetup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Int -> f Int) -> ExpsSetup -> f ExpsSetup
expsSetupEvaluationSteps
    !maxSteps :: Maybe Int
maxSteps = Experiments a
exps forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiments a) ExpsSetup
experimentsSetup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Maybe Int -> f (Maybe Int)) -> ExpsSetup -> f ExpsSetup
expsSetupEvaluationMaxStepsBetweenSaves
    new :: a -> DB (ExpM a) (ResultData a)
new a
initStEval = forall a.
ExperimentDef a =>
Seed
-> RepResultType -> a -> InputState a -> DB (ExpM a) (ResultData a)
newResultData Seed
seed (Key RepResult -> RepResultType
Rep Key RepResult
repResId) a
initStEval InitialInputState a
initInpSt
    run' :: Int -> ResultData a -> DB (ExpM a) (Bool, Maybe (ResultData a))
run' !Int
len !ResultData a
rD = ((Int -> Bool
delNeeded Int
len Bool -> Bool -> Bool
||) forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a. a -> Maybe a
Just) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ExperimentDef a =>
Key Exp
-> Maybe Int
-> Int
-> RepResultType
-> ResultData a
-> DB (ExpM a) (Bool, ResultData a)
runResultData Key Exp
expId Maybe Int
maxSteps Int
evalSteps (Key RepResult -> RepResultType
Rep Key RepResult
repResId) ResultData a
rD


deleteReplicationResult :: (MonadIO m) => ReplicationResult a -> DB m ()
deleteReplicationResult :: forall (m :: * -> *) a. MonadIO m => ReplicationResult a -> DB m ()
deleteReplicationResult (ReplicationResult Key RepResult
repResId Int
_ Maybe (ResultData a)
_ Maybe (ResultData a)
_) =
  forall (m :: * -> *). MonadIO m => RepResultType -> DB m ()
deleteResultData (Key RepResult -> RepResultType
WarmUp Key RepResult
repResId) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  forall (m :: * -> *). MonadIO m => RepResultType -> DB m ()
deleteResultData (Key RepResult -> RepResultType
Rep Key RepResult
repResId) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
delete Key RepResult
repResId


deleteResultData :: (MonadIO m) => RepResultType -> DB m ()
deleteResultData :: forall (m :: * -> *). MonadIO m => RepResultType -> DB m ()
deleteResultData RepResultType
repResType = do
  case RepResultType
repResType of
    Prep Key ExpResult
expResId -> do
      forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update Key ExpResult
expResId [forall typ.
(typ ~ Maybe PrepResultDataId) =>
EntityField ExpResult typ
ExpResultPrepResultData forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. forall a. Maybe a
Nothing]
      Maybe ExpResult
exp <- forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key ExpResult
expResId
      forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
delete forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *).
Functor f =>
(Maybe PrepResultDataId -> f (Maybe PrepResultDataId))
-> ExpResult -> f ExpResult
expResultPrepResultData forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ExpResult
exp)
    WarmUp Key RepResult
repResId -> do
      forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update Key RepResult
repResId [forall typ.
(typ ~ Maybe (Key WarmUpResultData)) =>
EntityField RepResult typ
RepResultWarmUpResultData forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. forall a. Maybe a
Nothing]
      Maybe RepResult
repRes <- forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key RepResult
repResId
      forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
delete forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *).
Functor f =>
(Maybe (Key WarmUpResultData) -> f (Maybe (Key WarmUpResultData)))
-> RepResult -> f RepResult
repResultWarmUpResultData forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe RepResult
repRes)
    Rep Key RepResult
repResId -> do
      forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update Key RepResult
repResId [forall typ.
(typ ~ Maybe (Key RepResultData)) =>
EntityField RepResult typ
RepResultRepResultData forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. forall a. Maybe a
Nothing]
      Maybe RepResult
repRes <- forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key RepResult
repResId
      forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
delete forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *).
Functor f =>
(Maybe (Key RepResultData) -> f (Maybe (Key RepResultData)))
-> RepResult -> f RepResult
repResultRepResultData forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe RepResult
repRes)

foldM' :: (NFData a, Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldM' :: forall a (m :: * -> *) b.
(NFData a, Monad m) =>
(a -> b -> m a) -> a -> [b] -> m a
foldM' a -> b -> m a
_ !a
acc [] = forall (m :: * -> *) a. Monad m => a -> m a
return a
acc
foldM' a -> b -> m a
f !a
acc (b
x:[b]
xs) = do
  (forall a. NFData a => a -> a
force -> a
acc') <- a -> b -> m a
f a
acc b
x
  forall a (m :: * -> *) b.
(NFData a, Monad m) =>
(a -> b -> m a) -> a -> [b] -> m a
foldM' a -> b -> m a
f a
acc' [b]
xs


splitSizeMVar :: MVar Int
splitSizeMVar :: MVar Int
splitSizeMVar = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar Int
2000
{-# NOINLINE splitSizeMVar #-}

increaseSplitSize :: IO ()
increaseSplitSize :: IO ()
increaseSplitSize = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Int
splitSizeMVar (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min Int
128000 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*Int
2))

decreaseSplitSize :: IO ()
decreaseSplitSize :: IO ()
decreaseSplitSize = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Int
splitSizeMVar (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
max Int
500 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Integral a => a -> a -> a
`div` Int
2))

getSplitSize :: IO Int
getSplitSize :: IO Int
getSplitSize = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Int
5000 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar Int
splitSizeMVar


data RunData a =
  RunData
  -- GenIO, a, InputState a, [Input a], [Measure])
    { forall a. RunData a -> GenIO
dataRandG    :: !GenIO
    , forall a. RunData a -> a
dataState    :: !a
    , forall a. RunData a -> InputState a
dataInpState :: !(InputState a)
    , forall a. RunData a -> Vector (Input a)
dataInputs   :: !(V.Vector (Input a))
    , forall a. RunData a -> Vector Measure
dataMeasures :: !(V.Vector Measure)
    } deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (RunData a) x -> RunData a
forall a x. RunData a -> Rep (RunData a) x
$cto :: forall a x. Rep (RunData a) x -> RunData a
$cfrom :: forall a x. RunData a -> Rep (RunData a) x
Generic)

instance (ExperimentDef a) => NFData (RunData a) where
  rnf :: RunData a -> ()
rnf (RunData !GenIO
_ a
st InputState a
inpSt Vector (Input a)
inps Vector Measure
meas) = forall a. NFData a => a -> ()
rnf a
st seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf InputState a
inpSt seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Vector (Input a)
inps seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Vector Measure
meas

-- | We need to sepearte @runResultData@ into two functions, as a simple recursive structure causes a space leak if it is not in IO. See
-- https://stackoverflow.com/questions/41306593/memory-leak-in-recursive-io-function-pap
-- https://ro-che.info/articles/2017-01-10-nested-loop-space-leak
-- https://gitlab.haskell.org/ghc/ghc/-/issues/13080
runResultData :: (ExperimentDef a) => Key Exp -> Maybe Int -> Int -> RepResultType -> ResultData a -> DB (ExpM a) (Updated, ResultData a)
runResultData :: forall a.
ExperimentDef a =>
Key Exp
-> Maybe Int
-> Int
-> RepResultType
-> ResultData a
-> DB (ExpM a) (Bool, ResultData a)
runResultData !Key Exp
expId !Maybe Int
maxSteps !Int
len !RepResultType
repResType !ResultData a
resData = do
  (!Bool
done, !Bool
upd, !ResultData a
resData') <- forall a.
ExperimentDef a =>
Key Exp
-> Maybe Int
-> Int
-> RepResultType
-> ResultData a
-> DB (ExpM a) (Bool, Bool, ResultData a)
runResultData' Key Exp
expId Maybe Int
maxSteps Int
len RepResultType
repResType ResultData a
resData
  if Bool
done
    then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
upd, ResultData a
resData')
    else forall a.
ExperimentDef a =>
Key Exp
-> Maybe Int
-> Int
-> RepResultType
-> ResultData a
-> DB (ExpM a) (Bool, ResultData a)
runResultData Key Exp
expId Maybe Int
maxSteps Int
len RepResultType
repResType ResultData a
resData'
{-# NOINLINE runResultData #-}
{-# NOINLINE runResultData' #-}

-- | Wrapper due to GHC Bug. See @runResultData@.
runResultData' :: (ExperimentDef a) => Key Exp -> Maybe Int -> Int -> RepResultType -> ResultData a -> DB (ExpM a) (Bool, Updated, ResultData a)
runResultData' :: forall a.
ExperimentDef a =>
Key Exp
-> Maybe Int
-> Int
-> RepResultType
-> ResultData a
-> DB (ExpM a) (Bool, Bool, ResultData a)
runResultData' !Key Exp
expId !Maybe Int
maxSteps !Int
len !RepResultType
repResType !ResultData a
resData = do
  Availability (ExpM a) a
startStAvail <-
    (if Bool
isNew
       then forall (m :: * -> *) b.
Monad m =>
Availability m b -> DB m (Availability m b)
mkAvailable
       else forall (m :: * -> *) a. Monad m => a -> m a
return)
      (ResultData a
resData forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ResultData a) (Availability (ExpM a) a)
startState)
  a
st <- forall (m :: * -> *) b. Monad m => Availability m b -> DB m b
mkTransientlyAvailable (ResultData a
resData forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ResultData a) (Availability (ExpM a) (Maybe a))
endState) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) b. Monad m => Availability m b -> DB m b
mkTransientlyAvailable Availability (ExpM a) a
startStAvail) forall (m :: * -> *) a. Monad m => a -> m a
return
  let stInp :: InputState a
stInp = forall a. a -> Maybe a -> a
fromMaybe (ResultData a
resData forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ResultData a) (InputState a)
startInputState) (ResultData a
resData forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ResultData a) (Maybe (InputState a))
endInputState)
  let g :: Gen RealWorld
g = forall a. a -> Maybe a -> a
fromMaybe (ResultData a
resData forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ResultData a) GenIO
startRandGen) (ResultData a
resData forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ResultData a) (Maybe GenIO)
endRandGen)
  Int
splitPeriods <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getSplitSize) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
maxSteps
  let nrOfPeriodsToRun :: Int
nrOfPeriodsToRun = forall a. Ord a => a -> a -> a
min Int
splitPeriods (Int
len forall a. Num a => a -> a -> a
- Int
curLen)
      periodsToRun :: [Int]
periodsToRun = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
+ Int
curLen) [Int
1 .. Int
nrOfPeriodsToRun]
      printInfo :: Bool
printInfo = Int
splitPeriods forall a. Ord a => a -> a -> Bool
> Int
100 Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Int
p -> (Int
p forall a. Num a => a -> a -> a
- Int
1) forall a. Integral a => a -> a -> a
`mod` Int
100 forall a. Eq a => a -> a -> Bool
== Int
0) [Int]
periodsToRun
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
printInfo forall a b. (a -> b) -> a -> b
$ $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Number of steps already run is " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
curLen forall a. Semigroup a => a -> a -> a
<> Text
", thus still need to run " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Int
len forall a. Num a => a -> a -> a
- Int
curLen) forall a. Semigroup a => a -> a -> a
<> Text
" steps."
  let updated :: Bool
updated = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
periodsToRun)
  UTCTime
sTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let phase :: Phase
phase = ResultDataKey -> Phase
phaseFromResultDataKey (ResultData a
resData forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ResultData a) ResultDataKey
resultDataKey)
      phaseNr :: Int
phaseNr = forall a. Enum a => a -> Int
fromEnum Phase
phase
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
Unique record
-> record -> [Update record] -> ReaderT backend m (Entity record)
upsertBy (Key Exp -> Unique ExpProgress
UniqueExpProgress Key Exp
expId) (Key Exp -> Int -> Int -> ExpProgress
ExpProgress Key Exp
expId Int
phaseNr Int
curLen) [forall typ. (typ ~ Int) => EntityField ExpProgress typ
ExpProgressPhase forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Int
phaseNr, forall typ. (typ ~ Int) => EntityField ExpProgress typ
ExpProgressStep forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Int
curLen]
  !(RunData GenIO
g' a
st' InputState a
stInp' Vector (Input a)
inputs Vector Measure
measures) <- forall a (m :: * -> *) b.
(NFData a, Monad m) =>
(a -> b -> m a) -> a -> [b] -> m a
foldM' (forall a.
ExperimentDef a =>
Phase -> RunData a -> Int -> DB (ExpM a) (RunData a)
run Phase
phase) (forall a.
GenIO
-> a
-> InputState a
-> Vector (Input a)
-> Vector Measure
-> RunData a
RunData Gen RealWorld
g a
st InputState a
stInp forall a. Vector a
V.empty forall a. Vector a
V.empty) [Int]
periodsToRun
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
updated forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
Unique record
-> record -> [Update record] -> ReaderT backend m (Entity record)
upsertBy (Key Exp -> Unique ExpProgress
UniqueExpProgress Key Exp
expId) (Key Exp -> Int -> Int -> ExpProgress
ExpProgress Key Exp
expId Int
phaseNr (Int
curLen forall a. Num a => a -> a -> a
+ Int
nrOfPeriodsToRun)) [forall typ. (typ ~ Int) => EntityField ExpProgress typ
ExpProgressPhase forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Int
phaseNr, forall typ. (typ ~ Int) => EntityField ExpProgress typ
ExpProgressStep forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Int
curLen forall a. Num a => a -> a -> a
+ Int
nrOfPeriodsToRun]
  if Bool
updated
    then do
      Maybe UTCTime
eTime <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      UTCTime
sTime' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      !ResultData a
resData' <-
        Vector (Input a)
-> Vector Measure
-> ResultData a
-> ReaderT
     SqlBackend (LoggingT (ResourceT (ExpM a))) (ResultData a)
addInputValsAndMeasure (forall a. Vector a -> Vector a
V.reverse Vector (Input a)
inputs) (forall a. Vector a -> Vector a
V.reverse Vector Measure
measures) forall a b. (a -> b) -> a -> b
$ forall {a}. Bool -> (a -> a) -> a -> a
doIf Bool
isNew (forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ResultData a) UTCTime
startTime UTCTime
sTime) forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ResultData a) (Maybe (InputState a))
endInputState (forall a. a -> Maybe a
Just InputState a
stInp') forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ResultData a) (Availability (ExpM a) (Maybe a))
endState (forall (m :: * -> *) b. b -> Availability m b
Available forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
st') forall a b. (a -> b) -> a -> b
$
        forall {a}. Bool -> (a -> a) -> a -> a
doIf Bool
isNew (forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ResultData a) (Availability (ExpM a) a)
startState Availability (ExpM a) a
startStAvail) forall a b. (a -> b) -> a -> b
$ -- make available once for saving
        forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ResultData a) (Maybe GenIO)
endRandGen (forall a. a -> Maybe a
Just GenIO
g') forall a b. (a -> b) -> a -> b
$
        forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ResultData a) (Maybe UTCTime)
endTime Maybe UTCTime
eTime ResultData a
resData
      forall a.
ExperimentDef a =>
RepResultType -> ResultData a -> DB (ExpM a) ()
upd RepResultType
repResType ResultData a
resData'
      forall (m :: * -> *). MonadIO m => ReaderT SqlBackend m ()
transactionSave
      UTCTime
eTime' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      let runTime :: NominalDiffTime
runTime = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime (forall a. HasCallStack => Maybe a -> a
fromJust Maybe UTCTime
eTime) UTCTime
sTime
          saveTime :: NominalDiffTime
saveTime = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
eTime' UTCTime
sTime'
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe Int
maxSteps Bool -> Bool -> Bool
&& Int
nrOfPeriodsToRun forall a. Eq a => a -> a -> Bool
== Int
splitPeriods) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NominalDiffTime
runTime forall a. Ord a => a -> a -> Bool
< NominalDiffTime
60 forall a. Num a => a -> a -> a
* forall a. Ord a => a -> a -> a
max NominalDiffTime
5 NominalDiffTime
saveTime) IO ()
increaseSplitSize
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NominalDiffTime
runTime forall a. Ord a => a -> a -> Bool
> NominalDiffTime
120 forall a. Num a => a -> a -> a
* forall a. Ord a => a -> a -> a
max NominalDiffTime
5 NominalDiffTime
saveTime) IO ()
decreaseSplitSize
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
printInfo forall a b. (a -> b) -> a -> b
$ $(logInfo) forall a b. (a -> b) -> a -> b
$ Text
"Done and saved. Computation Time of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
periodsToRun) forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow NominalDiffTime
runTime forall a. Semigroup a => a -> a -> a
<> Text
". Saving Time: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow NominalDiffTime
saveTime
      if Int
len forall a. Num a => a -> a -> a
- Int
curLen forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
periodsToRun forall a. Ord a => a -> a -> Bool
> Int
0
        then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Bool
True, forall a. NFData a => a -> a
force ResultData a
resData') -- runResultData expId maxSteps len repResType (force resData')
        else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (Bool
True, Bool
True, forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ResultData a) (Availability (ExpM a) (Maybe a))
endState Availability (ExpM a) (Maybe a)
mkEndStateAvailableOnDemand forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ResultData a) (Availability (ExpM a) a)
startState Availability (ExpM a) a
mkStartStateAvailableOnDemand ResultData a
resData')
    else forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Bool
False, forall a. NFData a => a -> a
force forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ResultData a) (Availability (ExpM a) (Maybe a))
endState Availability (ExpM a) (Maybe a)
mkEndStateAvailableOnDemand forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set forall a. Lens' (ResultData a) (Availability (ExpM a) a)
startState Availability (ExpM a) a
mkStartStateAvailableOnDemand ResultData a
resData)
  where
    doIf :: Bool -> (a -> a) -> a -> a
doIf Bool
predicate ~a -> a
f
      | Bool
predicate = a -> a
f
      | Bool
otherwise = forall a. a -> a
id
    curLen :: Int
curLen = forall (m :: * -> *) b. AvailabilityList m b -> Int
lengthAvailabilityList (ResultData a
resData forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ResultData a) (AvailabilityList (ExpM a) Measure)
results)
    delInputs :: Bool
delInputs = forall (m :: * -> *) b. AvailabilityList m b -> Int
lengthAvailabilityList (ResultData a
resData forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ResultData a) (AvailabilityList (ExpM a) Measure)
results) forall a. Num a => a -> a -> a
- forall (m :: * -> *) b. AvailabilityList m b -> Int
lengthAvailabilityList (ResultData a
resData forall s a. s -> Getting a s a -> a
^. forall a.
Lens' (ResultData a) (AvailabilityList (ExpM a) (Input a))
inputValues) forall a. Ord a => a -> a -> Bool
> Int
0
    isNew :: Bool
isNew = Int
curLen forall a. Eq a => a -> a -> Bool
== Int
0
    mkStartStateAvailableOnDemand :: Availability (ExpM a) a
mkStartStateAvailableOnDemand =
      case ResultData a
resData forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ResultData a) ResultDataKey
resultDataKey of
        ResultDataPrep PrepResultDataId
key   -> forall (m :: * -> *) b. DB m b -> Availability m b
AvailableOnDemand forall a b. (a -> b) -> a -> b
$ forall a.
ExperimentDef a =>
Key Exp -> StartStateType -> DB (ExpM a) a
loadResDataStartState Key Exp
expId (PrepResultDataId -> StartStateType
StartStatePrep PrepResultDataId
key)
        ResultDataWarmUp Key WarmUpResultData
key -> forall (m :: * -> *) b. DB m b -> Availability m b
AvailableOnDemand forall a b. (a -> b) -> a -> b
$ forall a.
ExperimentDef a =>
Key Exp -> StartStateType -> DB (ExpM a) a
loadResDataStartState Key Exp
expId (Key WarmUpResultData -> StartStateType
StartStateWarmUp Key WarmUpResultData
key)
        ResultDataRep Key RepResultData
key    -> forall (m :: * -> *) b. DB m b -> Availability m b
AvailableOnDemand forall a b. (a -> b) -> a -> b
$ forall a.
ExperimentDef a =>
Key Exp -> StartStateType -> DB (ExpM a) a
loadResDataStartState Key Exp
expId (Key RepResultData -> StartStateType
StartStateRep Key RepResultData
key)
    mkEndStateAvailableOnDemand :: Availability (ExpM a) (Maybe a)
mkEndStateAvailableOnDemand =
      case ResultData a
resData forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ResultData a) ResultDataKey
resultDataKey of
        ResultDataPrep PrepResultDataId
key   -> forall (m :: * -> *) b. DB m b -> Availability m b
AvailableOnDemand forall a b. (a -> b) -> a -> b
$ forall a.
ExperimentDef a =>
Key Exp -> EndStateType -> DB (ExpM a) (Maybe a)
loadResDataEndState Key Exp
expId (PrepResultDataId -> EndStateType
EndStatePrep PrepResultDataId
key)
        ResultDataWarmUp Key WarmUpResultData
key -> forall (m :: * -> *) b. DB m b -> Availability m b
AvailableOnDemand forall a b. (a -> b) -> a -> b
$ forall a.
ExperimentDef a =>
Key Exp -> EndStateType -> DB (ExpM a) (Maybe a)
loadResDataEndState Key Exp
expId (Key WarmUpResultData -> EndStateType
EndStateWarmUp Key WarmUpResultData
key)
        ResultDataRep Key RepResultData
key    -> forall (m :: * -> *) b. DB m b -> Availability m b
AvailableOnDemand forall a b. (a -> b) -> a -> b
$ forall a.
ExperimentDef a =>
Key Exp -> EndStateType -> DB (ExpM a) (Maybe a)
loadResDataEndState Key Exp
expId (Key RepResultData -> EndStateType
EndStateRep Key RepResultData
key)
    addInputValsAndMeasure :: Vector (Input a)
-> Vector Measure
-> ResultData a
-> ReaderT
     SqlBackend (LoggingT (ResourceT (ExpM a))) (ResultData a)
addInputValsAndMeasure !Vector (Input a)
inputVals !Vector Measure
measures !ResultData a
resData' =
      let countResults' :: Int
countResults' = forall (m :: * -> *) b. AvailabilityList m b -> Int
lengthAvailabilityList (ResultData a
resData' forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ResultData a) (AvailabilityList (ExpM a) Measure)
results) forall a. Num a => a -> a -> a
+ forall a. Vector a -> Int
V.length Vector Measure
measures
          countInputValues' :: Int
countInputValues' = forall (m :: * -> *) b. AvailabilityList m b -> Int
lengthAvailabilityList (ResultData a
resData' forall s a. s -> Getting a s a -> a
^. forall a.
Lens' (ResultData a) (AvailabilityList (ExpM a) (Input a))
inputValues) forall a. Num a => a -> a -> a
+ forall a. Vector a -> Int
V.length Vector (Input a)
inputVals
          measuresList :: [Measure]
measuresList = forall a. Vector a -> [a]
V.toList Vector Measure
measures
          inputValsList :: [Input a]
inputValsList = forall a. Vector a -> [a]
V.toList Vector (Input a)
inputVals
       in case ResultData a
resData' forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ResultData a) ResultDataKey
resultDataKey of
            ResultDataPrep PrepResultDataId
key -> do
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
delInputs forall a b. (a -> b) -> a -> b
$ forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [forall typ. (typ ~ PrepResultDataId) => EntityField PrepInput typ
PrepInputPrepResultData forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. PrepResultDataId
key, forall typ. (typ ~ Int) => EntityField PrepInput typ
PrepInputPeriod forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>=. Int
curLen forall a. Num a => a -> a -> a
+ Int
1]
              [Key PrepInput]
inpKeys <- forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m [Key record]
insertMany forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (PrepResultDataId -> Int -> PrepInput
PrepInput PrepResultDataId
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (Input a) Int
inputValuePeriod) [Input a]
inputValsList
              forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m ()
insertMany_ forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Key PrepInput
k Input a
v -> Key PrepInput -> ConnectionString -> PrepInputValue
PrepInputValue Key PrepInput
k (Put -> ConnectionString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Serialize t => Putter t
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a1 a2.
Lens (Input a1) (Input a2) (InputValue a1) (InputValue a2)
inputValue forall a b. (a -> b) -> a -> b
$ Input a
v)) [Key PrepInput]
inpKeys [Input a]
inputValsList
              [Key PrepMeasure]
measureKeys <- forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m [Key record]
insertMany forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (PrepResultDataId -> Int -> PrepMeasure
PrepMeasure PrepResultDataId
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Measure Int
measurePeriod) forall a b. (a -> b) -> a -> b
$ [Measure]
measuresList
              forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m ()
insertMany_ forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Key PrepMeasure
k (Measure Int
_ [StepResult]
xs) -> forall a b. (a -> b) -> [a] -> [b]
map (\(StepResult Text
n Maybe Double
mX Double
y) -> Key PrepMeasure -> Text -> Maybe Double -> Double -> PrepResultStep
PrepResultStep Key PrepMeasure
k Text
n Maybe Double
mX Double
y) [StepResult]
xs) [Key PrepMeasure]
measureKeys [Measure]
measuresList
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. Lens' (ResultData a) (AvailabilityList (ExpM a) Measure)
results forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall (m :: * -> *) b.
(Int, AvailabilityListWhere -> ConduitT () b (DB m) ())
-> AvailabilityList m b
AvailableListOnDemand (Int
countResults', forall (m :: * -> *).
MonadIO m =>
PrepResultDataId
-> AvailabilityListWhere -> ConduitT () Measure (DB m) ()
loadPreparationMeasuresWhere PrepResultDataId
key) forall a b. (a -> b) -> a -> b
$ forall a.
Lens' (ResultData a) (AvailabilityList (ExpM a) (Input a))
inputValues forall s t a b. ASetter s t a b -> b -> s -> t
.~
                forall (m :: * -> *) b.
(Int, AvailabilityListWhere -> ConduitT () b (DB m) ())
-> AvailabilityList m b
AvailableListOnDemand (Int
countInputValues', forall (m :: * -> *) a.
(MonadIO m, ExperimentDef a) =>
PrepResultDataId
-> AvailabilityListWhere -> ConduitM () (Input a) (DB m) ()
loadPreparationInputWhere PrepResultDataId
key) forall a b. (a -> b) -> a -> b
$
                ResultData a
resData'
            ResultDataWarmUp Key WarmUpResultData
key -> do
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
delInputs forall a b. (a -> b) -> a -> b
$ forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [forall typ.
(typ ~ Key WarmUpResultData) =>
EntityField WarmUpInput typ
WarmUpInputRepResult forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key WarmUpResultData
key, forall typ. (typ ~ Int) => EntityField WarmUpInput typ
WarmUpInputPeriod forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>=. Int
curLen forall a. Num a => a -> a -> a
+ Int
1]
              [Key WarmUpInput]
inpKeys <- forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m [Key record]
insertMany forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Key WarmUpResultData -> Int -> WarmUpInput
WarmUpInput Key WarmUpResultData
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (Input a) Int
inputValuePeriod) [Input a]
inputValsList
              forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m ()
insertMany_ forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Key WarmUpInput
k Input a
v -> Key WarmUpInput -> ConnectionString -> WarmUpInputValue
WarmUpInputValue Key WarmUpInput
k (Put -> ConnectionString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Serialize t => Putter t
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a1 a2.
Lens (Input a1) (Input a2) (InputValue a1) (InputValue a2)
inputValue forall a b. (a -> b) -> a -> b
$ Input a
v)) [Key WarmUpInput]
inpKeys [Input a]
inputValsList
              [Key WarmUpMeasure]
measureKeys <- forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m [Key record]
insertMany forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Key WarmUpResultData -> Int -> WarmUpMeasure
WarmUpMeasure Key WarmUpResultData
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Measure Int
measurePeriod) [Measure]
measuresList
              forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m ()
insertMany_ forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Key WarmUpMeasure
k (Measure Int
_ [StepResult]
xs) -> forall a b. (a -> b) -> [a] -> [b]
map (\(StepResult Text
n Maybe Double
mX Double
y) -> Key WarmUpMeasure
-> Text -> Maybe Double -> Double -> WarmUpResultStep
WarmUpResultStep Key WarmUpMeasure
k Text
n Maybe Double
mX Double
y) [StepResult]
xs) [Key WarmUpMeasure]
measureKeys [Measure]
measuresList
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. Lens' (ResultData a) (AvailabilityList (ExpM a) Measure)
results forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall (m :: * -> *) b.
(Int, AvailabilityListWhere -> ConduitT () b (DB m) ())
-> AvailabilityList m b
AvailableListOnDemand (Int
countResults', forall (m :: * -> *).
MonadIO m =>
Key WarmUpResultData
-> AvailabilityListWhere -> ConduitM () Measure (DB m) ()
loadReplicationWarmUpMeasuresWhere Key WarmUpResultData
key) forall a b. (a -> b) -> a -> b
$ forall a.
Lens' (ResultData a) (AvailabilityList (ExpM a) (Input a))
inputValues forall s t a b. ASetter s t a b -> b -> s -> t
.~
                forall (m :: * -> *) b.
(Int, AvailabilityListWhere -> ConduitT () b (DB m) ())
-> AvailabilityList m b
AvailableListOnDemand (Int
countInputValues', forall a (m :: * -> *).
(ExperimentDef a, MonadIO m) =>
Key WarmUpResultData
-> AvailabilityListWhere -> ConduitT () (Input a) (DB m) ()
loadReplicationWarmUpInputWhere Key WarmUpResultData
key) forall a b. (a -> b) -> a -> b
$
                ResultData a
resData'
            ResultDataRep Key RepResultData
key -> do
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
delInputs forall a b. (a -> b) -> a -> b
$ forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [forall typ. (typ ~ Key RepResultData) => EntityField RepInput typ
RepInputRepResult forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key RepResultData
key, forall typ. (typ ~ Int) => EntityField RepInput typ
RepInputPeriod forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>=. Int
curLen forall a. Num a => a -> a -> a
+ Int
1]
              [Key RepInput]
inpKeys <- forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m [Key record]
insertMany forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Key RepResultData -> Int -> RepInput
RepInput Key RepResultData
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (Input a) Int
inputValuePeriod) [Input a]
inputValsList
              forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m ()
insertMany_ forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Key RepInput
k Input a
v -> Key RepInput -> ConnectionString -> RepInputValue
RepInputValue Key RepInput
k (Put -> ConnectionString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Serialize t => Putter t
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a1 a2.
Lens (Input a1) (Input a2) (InputValue a1) (InputValue a2)
inputValue forall a b. (a -> b) -> a -> b
$ Input a
v)) [Key RepInput]
inpKeys [Input a]
inputValsList
              [Key RepMeasure]
measureKeys <- forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m [Key record]
insertMany forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Key RepResultData -> Int -> RepMeasure
RepMeasure Key RepResultData
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Measure Int
measurePeriod) [Measure]
measuresList
              forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m ()
insertMany_ forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Key RepMeasure
k (Measure Int
_ [StepResult]
xs) -> forall a b. (a -> b) -> [a] -> [b]
map (\(StepResult Text
n Maybe Double
mX Double
y) -> Key RepMeasure -> Text -> Maybe Double -> Double -> RepResultStep
RepResultStep Key RepMeasure
k Text
n Maybe Double
mX Double
y) [StepResult]
xs) [Key RepMeasure]
measureKeys [Measure]
measuresList
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. Lens' (ResultData a) (AvailabilityList (ExpM a) Measure)
results forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall (m :: * -> *) b.
(Int, AvailabilityListWhere -> ConduitT () b (DB m) ())
-> AvailabilityList m b
AvailableListOnDemand (Int
countResults', forall (m :: * -> *).
MonadIO m =>
Key RepResultData
-> AvailabilityListWhere -> ConduitT () Measure (DB m) ()
loadReplicationMeasuresWhere Key RepResultData
key) forall a b. (a -> b) -> a -> b
$ forall a.
Lens' (ResultData a) (AvailabilityList (ExpM a) (Input a))
inputValues forall s t a b. ASetter s t a b -> b -> s -> t
.~
                forall (m :: * -> *) b.
(Int, AvailabilityListWhere -> ConduitT () b (DB m) ())
-> AvailabilityList m b
AvailableListOnDemand (Int
countInputValues', forall a (m :: * -> *).
(ExperimentDef a, MonadIO m) =>
Key RepResultData
-> AvailabilityListWhere -> ConduitT () (Input a) (DB m) ()
loadReplicationInputWhere Key RepResultData
key) forall a b. (a -> b) -> a -> b
$
                ResultData a
resData'
    upd :: (ExperimentDef a) => RepResultType -> ResultData a -> DB (ExpM a) ()
    upd :: forall a.
ExperimentDef a =>
RepResultType -> ResultData a -> DB (ExpM a) ()
upd Prep{} (ResultData (ResultDataPrep PrepResultDataId
k) UTCTime
sTime Maybe UTCTime
eTime GenIO
sG Maybe GenIO
eG !AvailabilityList (ExpM a) (Input a)
_ !AvailabilityList (ExpM a) Measure
_ Availability (ExpM a) a
sSt Availability (ExpM a) (Maybe a)
eSt InputState a
sInpSt Maybe (InputState a)
eInpSt) = do
      !ConnectionString
sGBS <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => GenIO -> m ConnectionString
fromRandGen GenIO
sG
      !Maybe ConnectionString
eGBS <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadIO m => GenIO -> m ConnectionString
fromRandGen) Maybe GenIO
eG
      forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update
        PrepResultDataId
k
        [ forall typ. (typ ~ UTCTime) => EntityField PrepResultData typ
PrepResultDataStartTime forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. UTCTime
sTime
        , forall typ. (typ ~ Maybe UTCTime) => EntityField PrepResultData typ
PrepResultDataEndTime forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Maybe UTCTime
eTime
        , forall typ.
(typ ~ ConnectionString) =>
EntityField PrepResultData typ
PrepResultDataStartRandGen forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. ConnectionString
sGBS
        , forall typ.
(typ ~ Maybe ConnectionString) =>
EntityField PrepResultData typ
PrepResultDataEndRandGen forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Maybe ConnectionString
eGBS
        , forall typ.
(typ ~ ConnectionString) =>
EntityField PrepResultData typ
PrepResultDataStartInputState forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Put -> ConnectionString
runPut (forall t. Serialize t => Putter t
put InputState a
sInpSt)
        , forall typ.
(typ ~ Maybe ConnectionString) =>
EntityField PrepResultData typ
PrepResultDataEndInputState forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Put -> ConnectionString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Serialize t => Putter t
put forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (InputState a)
eInpSt
        ]
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
curLen forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$ do
        ~Serializable a
serSt <- forall (m :: * -> *) b. Monad m => Availability m b -> DB m b
mkTransientlyAvailable Availability (ExpM a) a
sSt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ExperimentDef a => a -> ExpM a (Serializable a)
serialisable
        forall (m :: * -> *).
MonadIO m =>
StartStateType -> ConnectionString -> ReaderT SqlBackend m ()
setResDataStartState (PrepResultDataId -> StartStateType
StartStatePrep PrepResultDataId
k) (Put -> ConnectionString
runPut forall a b. (a -> b) -> a -> b
$ forall t. Serialize t => Putter t
put Serializable a
serSt)
      !Maybe (Serializable a)
serESt <- forall (m :: * -> *) b. Monad m => Availability m b -> DB m b
mkTransientlyAvailable Availability (ExpM a) (Maybe a)
eSt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. ExperimentDef a => a -> ExpM a (Serializable a)
serialisable
      forall (m :: * -> *).
MonadIO m =>
EndStateType -> Maybe ConnectionString -> ReaderT SqlBackend m ()
setResDataEndState (PrepResultDataId -> EndStateType
EndStatePrep PrepResultDataId
k) (Put -> ConnectionString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Serialize t => Putter t
put forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Serializable a)
serESt)
    upd WarmUp{} (ResultData (ResultDataWarmUp Key WarmUpResultData
k) UTCTime
sTime Maybe UTCTime
eTime GenIO
sG Maybe GenIO
eG !AvailabilityList (ExpM a) (Input a)
_ !AvailabilityList (ExpM a) Measure
_ Availability (ExpM a) a
sSt Availability (ExpM a) (Maybe a)
eSt InputState a
sInpSt Maybe (InputState a)
eInpSt) = do
      !ConnectionString
sGBS <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => GenIO -> m ConnectionString
fromRandGen GenIO
sG
      !Maybe ConnectionString
eGBS <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadIO m => GenIO -> m ConnectionString
fromRandGen) Maybe GenIO
eG
      forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update
        Key WarmUpResultData
k
        [ forall typ. (typ ~ UTCTime) => EntityField WarmUpResultData typ
WarmUpResultDataStartTime forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. UTCTime
sTime
        , forall typ.
(typ ~ Maybe UTCTime) =>
EntityField WarmUpResultData typ
WarmUpResultDataEndTime forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Maybe UTCTime
eTime
        , forall typ.
(typ ~ ConnectionString) =>
EntityField WarmUpResultData typ
WarmUpResultDataStartRandGen forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. ConnectionString
sGBS
        , forall typ.
(typ ~ Maybe ConnectionString) =>
EntityField WarmUpResultData typ
WarmUpResultDataEndRandGen forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Maybe ConnectionString
eGBS
        , forall typ.
(typ ~ ConnectionString) =>
EntityField WarmUpResultData typ
WarmUpResultDataStartInputState forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Put -> ConnectionString
runPut (forall t. Serialize t => Putter t
put InputState a
sInpSt)
        , forall typ.
(typ ~ Maybe ConnectionString) =>
EntityField WarmUpResultData typ
WarmUpResultDataEndInputState forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Put -> ConnectionString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Serialize t => Putter t
put forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (InputState a)
eInpSt
        ]
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
curLen forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$ do
        ~Serializable a
serSt <- forall (m :: * -> *) b. Monad m => Availability m b -> DB m b
mkTransientlyAvailable Availability (ExpM a) a
sSt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ExperimentDef a => a -> ExpM a (Serializable a)
serialisable
        forall (m :: * -> *).
MonadIO m =>
StartStateType -> ConnectionString -> ReaderT SqlBackend m ()
setResDataStartState (Key WarmUpResultData -> StartStateType
StartStateWarmUp Key WarmUpResultData
k) (Put -> ConnectionString
runPut forall a b. (a -> b) -> a -> b
$ forall t. Serialize t => Putter t
put Serializable a
serSt)
      !Maybe (Serializable a)
serESt <- forall (m :: * -> *) b. Monad m => Availability m b -> DB m b
mkTransientlyAvailable Availability (ExpM a) (Maybe a)
eSt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. ExperimentDef a => a -> ExpM a (Serializable a)
serialisable
      forall (m :: * -> *).
MonadIO m =>
EndStateType -> Maybe ConnectionString -> ReaderT SqlBackend m ()
setResDataEndState (Key WarmUpResultData -> EndStateType
EndStateWarmUp Key WarmUpResultData
k) (Put -> ConnectionString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Serialize t => Putter t
put forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Serializable a)
serESt)
    upd Rep{} (ResultData (ResultDataRep Key RepResultData
k) UTCTime
sTime Maybe UTCTime
eTime GenIO
sG Maybe GenIO
eG !AvailabilityList (ExpM a) (Input a)
_ !AvailabilityList (ExpM a) Measure
_ Availability (ExpM a) a
sSt Availability (ExpM a) (Maybe a)
eSt InputState a
sInpSt Maybe (InputState a)
eInpSt) = do
      !ConnectionString
sGBS <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => GenIO -> m ConnectionString
fromRandGen GenIO
sG
      !Maybe ConnectionString
eGBS <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadIO m => GenIO -> m ConnectionString
fromRandGen) Maybe GenIO
eG
      forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update
        Key RepResultData
k
        [ forall typ. (typ ~ UTCTime) => EntityField RepResultData typ
RepResultDataStartTime forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. UTCTime
sTime
        , forall typ. (typ ~ Maybe UTCTime) => EntityField RepResultData typ
RepResultDataEndTime forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Maybe UTCTime
eTime
        , forall typ.
(typ ~ ConnectionString) =>
EntityField RepResultData typ
RepResultDataStartRandGen forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. ConnectionString
sGBS
        , forall typ.
(typ ~ Maybe ConnectionString) =>
EntityField RepResultData typ
RepResultDataEndRandGen forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Maybe ConnectionString
eGBS
        , forall typ.
(typ ~ ConnectionString) =>
EntityField RepResultData typ
RepResultDataStartInputState forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Put -> ConnectionString
runPut (forall t. Serialize t => Putter t
put InputState a
sInpSt)
        , forall typ.
(typ ~ Maybe ConnectionString) =>
EntityField RepResultData typ
RepResultDataEndInputState forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Put -> ConnectionString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Serialize t => Putter t
put forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (InputState a)
eInpSt
        ]
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
curLen forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$ do
        ~Serializable a
serSt <- forall (m :: * -> *) b. Monad m => Availability m b -> DB m b
mkTransientlyAvailable Availability (ExpM a) a
sSt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ExperimentDef a => a -> ExpM a (Serializable a)
serialisable
        forall (m :: * -> *).
MonadIO m =>
StartStateType -> ConnectionString -> ReaderT SqlBackend m ()
setResDataStartState (Key RepResultData -> StartStateType
StartStateRep Key RepResultData
k) (Put -> ConnectionString
runPut forall a b. (a -> b) -> a -> b
$ forall t. Serialize t => Putter t
put Serializable a
serSt)
      !Maybe (Serializable a)
serESt <- forall (m :: * -> *) b. Monad m => Availability m b -> DB m b
mkTransientlyAvailable Availability (ExpM a) (Maybe a)
eSt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. ExperimentDef a => a -> ExpM a (Serializable a)
serialisable
      forall (m :: * -> *).
MonadIO m =>
EndStateType -> Maybe ConnectionString -> ReaderT SqlBackend m ()
setResDataEndState (Key RepResultData -> EndStateType
EndStateRep Key RepResultData
k) (Put -> ConnectionString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Serialize t => Putter t
put forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Serializable a)
serESt)
    upd RepResultType
_ ResultData a
_ = forall a. HasCallStack => String -> a
error String
"Unexpected update combination. This is a bug, please report it!"


run :: (ExperimentDef a) => Phase -> RunData a -> Int -> DB (ExpM a) (RunData a)
run :: forall a.
ExperimentDef a =>
Phase -> RunData a -> Int -> DB (ExpM a) (RunData a)
run Phase
ph (RunData GenIO
g a
st InputState a
stInp Vector (Input a)
inpVals Vector Measure
res) Int
period = do
  -- let (randGen, g') = split g
  (!InputValue a
inpVal', !InputState a
inpSt') <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$! forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$! forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$! forall a.
ExperimentDef a =>
GenIO
-> a -> InputState a -> Int -> ExpM a (InputValue a, InputState a)
generateInput GenIO
g a
st InputState a
stInp Int
period
  (![StepResult]
res', !a
st') <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$! forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$! forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$! forall a.
ExperimentDef a =>
Phase -> a -> InputValue a -> Int -> ExpM a ([StepResult], a)
runStep Phase
ph a
st InputValue a
inpVal' Int
period
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. NFData a => a -> a
force forall a b. (a -> b) -> a -> b
$! forall a.
GenIO
-> a
-> InputState a
-> Vector (Input a)
-> Vector Measure
-> RunData a
RunData GenIO
g a
st' InputState a
inpSt' (forall a. Int -> InputValue a -> Input a
Input Int
period InputValue a
inpVal' forall a. a -> Vector a -> Vector a
`V.cons` Vector (Input a)
inpVals) (Int -> [StepResult] -> Measure
Measure Int
period [StepResult]
res' forall a. a -> Vector a -> Vector a
`V.cons` Vector Measure
res)