{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Experimenter.Load
( OnlyFinishedExperiments
, DatabaseSetting (..)
, loadExperimentsResultsM
, loadExperimentPrepEndStateIO
, loadExperimentPrepEndState
) 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 Control.Monad.Trans.Maybe
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 (catMaybes, fromJust, fromMaybe, isJust, isNothing)
import Data.Serialize hiding (get)
import qualified Data.Serialize as S
import qualified Data.Text as T
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.Random.MWC
import Text.Read (readMaybe)
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.Result.Query
import Experimenter.Setting
import Experimenter.StepResult
import Experimenter.Util
type OnlyFinishedExperiments = Bool
loadExperimentsResultsM ::
(ExperimentDef a)
=> OnlyFinishedExperiments
-> (ExpM a (Maybe (Experiments a)) -> IO (Maybe (Experiments a)))
-> DatabaseSetting
-> MkExperimentSetting a
-> InputState a
-> ExpM a a
-> Int64
-> IO (Maybe (Experiments a))
loadExperimentsResultsM :: forall a.
ExperimentDef a =>
OnlyFinishedExperiments
-> (ExpM a (Maybe (Experiments a)) -> IO (Maybe (Experiments a)))
-> DatabaseSetting
-> MkExperimentSetting a
-> InputState a
-> ExpM a a
-> Int64
-> IO (Maybe (Experiments a))
loadExperimentsResultsM OnlyFinishedExperiments
filtFin ExpM a (Maybe (Experiments a)) -> IO (Maybe (Experiments a))
runExpM DatabaseSetting
dbSetup MkExperimentSetting a
setup InputState a
initInpSt ExpM a a
mkInitSt Int64
key =
ExpM a (Maybe (Experiments a)) -> IO (Maybe (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
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
let sett :: ExperimentSetting
sett = MkExperimentSetting a
setup a
initSt
skipPrep :: Experiment a1 -> OnlyFinishedExperiments
skipPrep Experiment a1
exp' = forall (t :: * -> *) a.
Foldable t =>
(a -> OnlyFinishedExperiments) -> t a -> OnlyFinishedExperiments
any (forall s a. s -> Getting a s a -> a
^. forall a1 a2.
Lens
(ParameterSetting a1)
(ParameterSetting a2)
OnlyFinishedExperiments
OnlyFinishedExperiments
parameterSettingSkipPreparationPhase) (Experiment a1
exp' forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiment a) [ParameterSetting a]
parameterSetup)
isFinished :: Experiment a -> OnlyFinishedExperiments
isFinished Experiment a
exp' =
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Experiment a
exp' forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiment a) [ExperimentResult a]
experimentResults) forall a. Eq a => a -> a -> OnlyFinishedExperiments
== ExperimentSetting
sett forall s a. s -> Getting a s a -> a
^. Lens' ExperimentSetting Int
experimentRepetitions OnlyFinishedExperiments
-> OnlyFinishedExperiments -> OnlyFinishedExperiments
&&
(forall {a1}. Experiment a1 -> OnlyFinishedExperiments
skipPrep Experiment a
exp' OnlyFinishedExperiments
-> OnlyFinishedExperiments -> OnlyFinishedExperiments
|| forall (t :: * -> *) a.
Foldable t =>
(a -> OnlyFinishedExperiments) -> t a -> OnlyFinishedExperiments
all (\ExperimentResult a
expRes -> 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) (ExperimentResult a
expRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ExperimentResult a) (Maybe (ResultData a))
preparationResults) forall a. Eq a => a -> a -> OnlyFinishedExperiments
== ExperimentSetting
sett forall s a. s -> Getting a s a -> a
^. Lens' ExperimentSetting Int
preparationSteps) (Experiment a
exp' forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiment a) [ExperimentResult a]
experimentResults)) OnlyFinishedExperiments
-> OnlyFinishedExperiments -> OnlyFinishedExperiments
&&
forall (t :: * -> *) a.
Foldable t =>
(a -> OnlyFinishedExperiments) -> t a -> OnlyFinishedExperiments
all (\ExperimentResult a
expRes -> forall (t :: * -> *) a. Foldable t => t a -> Int
length (ExperimentResult a
expRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ExperimentResult a) [ReplicationResult a]
evaluationResults) forall a. Eq a => a -> a -> OnlyFinishedExperiments
== ExperimentSetting
sett forall s a. s -> Getting a s a -> a
^. Lens' ExperimentSetting Int
evaluationReplications) (Experiment a
exp' forall s a. s -> Getting a s a -> a
^. forall a. Lens' (Experiment a) [ExperimentResult a]
experimentResults) OnlyFinishedExperiments
-> OnlyFinishedExperiments -> OnlyFinishedExperiments
&&
forall (t :: * -> *) a.
Foldable t =>
(a -> OnlyFinishedExperiments) -> t a -> OnlyFinishedExperiments
all
(\ReplicationResult a
expRes -> 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) (ReplicationResult a
expRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ReplicationResult a) (Maybe (ResultData a))
warmUpResults) forall a. Eq a => a -> a -> OnlyFinishedExperiments
== ExperimentSetting
sett forall s a. s -> Getting a s a -> a
^. Lens' ExperimentSetting Int
evaluationWarmUpSteps)
(Experiment a
exp' forall s a. s -> Getting 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) OnlyFinishedExperiments
-> OnlyFinishedExperiments -> OnlyFinishedExperiments
&&
forall (t :: * -> *) a.
Foldable t =>
(a -> OnlyFinishedExperiments) -> t a -> OnlyFinishedExperiments
all
(\ReplicationResult a
expRes -> 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) (ReplicationResult a
expRes forall s a. s -> Getting a s a -> a
^. forall a. Lens' (ReplicationResult a) (Maybe (ResultData a))
evalResults) forall a. Eq a => a -> a -> OnlyFinishedExperiments
== ExperimentSetting
sett forall s a. s -> Getting a s a -> a
^. Lens' ExperimentSetting Int
evaluationSteps)
(Experiment a
exp' forall s a. s -> Getting 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)
filterFinished :: Experiments a -> Experiments a
filterFinished =
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over
forall a. Lens' (Experiments a) [Experiment a]
experiments
(if OnlyFinishedExperiments
filtFin
then forall a. (a -> OnlyFinishedExperiments) -> [a] -> [a]
filter Experiment a -> OnlyFinishedExperiments
isFinished
else forall a. a -> a
id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Experiments a -> Experiments a
filterFinished forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ExperimentDef a =>
ExperimentSetting
-> InputState a
-> a
-> Key Exps
-> DB (ExpM a) (Maybe (Experiments a))
loadExperimentsResults ExperimentSetting
sett InputState a
initInpSt a
initSt (forall record.
ToBackendKey SqlBackend record =>
Int64 -> Key record
toSqlKey Int64
key)
readValueSafe :: (Read a) => IO (Maybe a)
readValueSafe :: forall a. Read a => IO (Maybe a)
readValueSafe = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"Enter value: " forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
forall a. Read a => String -> Maybe a
readMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getLine
readListValueSafeName :: [(a, T.Text)] -> IO (Maybe a)
readListValueSafeName :: forall a. [(a, Text)] -> IO (Maybe a)
readListValueSafeName [(a, Text)]
xs = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Int
nr, (a
_, Text
n)) -> String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
nr forall a. Semigroup a => a -> a -> a
<> String
":\t " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
n) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0 :: Int) ..] [(a, Text)]
xs
Maybe Int
mNr <- forall a. Read a => IO (Maybe a)
readValueSafe
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
case Maybe Int
mNr of
Just Int
nr
| Int
nr forall a. Ord a => a -> a -> OnlyFinishedExperiments
>= Int
0 OnlyFinishedExperiments
-> OnlyFinishedExperiments -> OnlyFinishedExperiments
&& Int
nr forall a. Ord a => a -> a -> OnlyFinishedExperiments
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, Text)]
xs -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ [(a, Text)]
xs forall a. [a] -> Int -> a
!! Int
nr
Maybe Int
_ -> forall a. Maybe a
Nothing
hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b
hoistMaybe :: forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
loadExperimentPrepEndStateIO :: (ExpM a ~ IO, ExperimentDef a) => DatabaseSetting -> IO (Maybe a)
loadExperimentPrepEndStateIO :: forall a.
(ExpM a ~ IO, ExperimentDef a) =>
DatabaseSetting -> IO (Maybe a)
loadExperimentPrepEndStateIO = forall a.
ExperimentDef a =>
(ExpM a (Maybe a) -> IO (Maybe a))
-> DatabaseSetting -> IO (Maybe a)
loadExperimentPrepEndState forall a. a -> a
id
loadExperimentPrepEndState ::
forall a. (ExperimentDef a)
=> (ExpM a (Maybe a) -> IO (Maybe a))
-> DatabaseSetting
-> IO (Maybe a)
loadExperimentPrepEndState :: forall a.
ExperimentDef a =>
(ExpM a (Maybe a) -> IO (Maybe a))
-> DatabaseSetting -> IO (Maybe a)
loadExperimentPrepEndState ExpM a (Maybe a) -> IO (Maybe a)
runExpM DatabaseSetting
dbSetup =
ExpM a (Maybe a) -> IO (Maybe 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
$
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"From which experiment do you want to load the data? "
[Entity Exps]
exps <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [] []
let expsNames :: [(Key Exps, T.Text)]
expsNames :: [(Key Exps, Text)]
expsNames = forall a b. (a -> b) -> [a] -> [b]
map (forall record. Entity record -> Key record
entityKey forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *).
Functor f =>
(Text -> f Text) -> Exps -> f Exps
expsName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal) [Entity Exps]
exps
(Key Exps
expsKey :: Key Exps) <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [(a, Text)] -> IO (Maybe a)
readListValueSafeName [(Key Exps, Text)]
expsNames
[Entity Exp]
exp <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 Exps) => EntityField Exp typ
ExpExps forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Exps
expsKey] []
(Key Exp
expKey :: Key Exp) <-
if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Entity Exp]
exp forall a. Eq a => a -> a -> OnlyFinishedExperiments
== Int
1
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall record. Entity record -> Key record
entityKey forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [Entity Exp]
exp
else do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Which experiment number?"
let expNrs :: [(Key Exp, Text)]
expNrs = forall {a}. [(a, Text)] -> [(a, Text)]
sortOnSnd forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall record. Entity record -> Key record
entityKey forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. Show a => a -> Text
tshow forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *). Functor f => (Int -> f Int) -> Exp -> f Exp
expNumber) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal) [Entity Exp]
exp
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [(a, Text)] -> IO (Maybe a)
readListValueSafeName [(Key Exp, Text)]
expNrs
[Entity ExpResult]
reps <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 ExpResult typ
ExpResultExp forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Exp
expKey] []
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"And from which experiment repetition?"
let
repNames :: [(Key PrepResultData, T.Text)]
repNames :: [(PrepResultDataId, Text)]
repNames = forall {a}. [(a, Text)] -> [(a, Text)]
sortOnSnd forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a. HasCallStack => Maybe a -> a
fromJust) forall a b. (a -> b) -> a -> b
$ forall a. (a -> OnlyFinishedExperiments) -> [a] -> [a]
filter (forall a. Maybe a -> OnlyFinishedExperiments
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *).
Functor f =>
(Maybe PrepResultDataId -> f (Maybe PrepResultDataId))
-> ExpResult -> f ExpResult
expResultPrepResultData) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. Show a => a -> Text
tshow forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *).
Functor f =>
(Int -> f Int) -> ExpResult -> f ExpResult
expResultRepetition) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal) [Entity ExpResult]
reps
PrepResultDataId
rep <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [(a, Text)] -> IO (Maybe a)
readListValueSafeName [(PrepResultDataId, Text)]
repNames
let endStateType :: EndStateType
endStateType = PrepResultDataId -> EndStateType
EndStatePrep PrepResultDataId
rep
Maybe a
ma <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a.
ExperimentDef a =>
Key Exp -> EndStateType -> DB (ExpM a) (Maybe a)
loadResDataEndState Key Exp
expKey EndStateType
endStateType :: DB (ExpM a) (Maybe a))
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe Maybe a
ma
where sortOnSnd :: [(a, Text)] -> [(a, Text)]
sortOnSnd = 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) -> b
snd)