experimenter 0.1.0.12 → 0.1.0.14

raw patch · 11 files changed

+319/−135 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−1
• LICENSE +28/−2
• config/models +28/−28
• experimenter.cabal +6/−5
• src/Experimenter.hs +1/−0
• src/Experimenter/Eval/Latex.hs +4/−4
• src/Experimenter/Eval/Table.hs +5/−2
• src/Experimenter/Experiment.hs +5/−1
• src/Experimenter/Load.hs +163/−0
• src/Experimenter/Models.hs +2/−1
• src/Experimenter/Run.hs +72/−91

@@ -1,6 +1,10 @@+ # Changelog for experimenter -Release 0.1.0.12 n 22.03.2021:+Release 0.1.0.14:+    - Vacuuming++Release 0.1.0.12 on 22.03.2021:     - Bug fix when decreasing number of evaluations  Release 0.1.0.10 on 15.03.2021:

@@ -1,3 +1,29 @@-Copyright Manuel Schneckenreither (c) 2020+BSD 3-Clause License -BSD3, see https://opensource.org/licenses/BSD-3-Clause+Copyright (c) 2021, Manuel+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -6,20 +6,20 @@     initialInputState ByteString  ExpsInfoParam-    exps ExpsId+    exps ExpsId OnDeleteCascade     name Text     value ByteString     UniqueExpsInfoParam exps name  ExpsMaster-    exps ExpsId+    exps ExpsId OnDeleteCascade     hostname Text     pid Int     lastAliveSign UTCTime     UniqueExpsMaster exps  ExpsSetup-    exps ExpsId+    exps ExpsId OnDeleteCascade     repetitions Int     preparationSteps Int     evaluationWarmUpSteps Int@@ -29,34 +29,34 @@     UniqueExpsSetup exps  Param-    exps ExpsId+    exps ExpsId OnDeleteCascade     name Text     minBound ByteString Maybe     maxBound ByteString Maybe     deriving Show Eq Ord  Exp         -- Adding "json" causes ToJSON and FromJSON instances to be derived.-    exps  ExpsId+    exps  ExpsId OnDeleteCascade     number Int     startTime UTCTime     endTime UTCTime Maybe     deriving Eq Ord  ExpExecutionLock-    exp ExpId+    exp ExpId OnDeleteCascade     hostname Text     pid Int     lastAliveSign UTCTime     UniqueExpExecutionLock exp  ExpProgress-    exp ExpId+    exp ExpId OnDeleteCascade     phase Int     step Int     UniqueExpProgress exp  ParamSetting-    exp ExpId+    exp ExpId OnDeleteCascade     name Text     value ByteString     skipPreparationPhase Bool@@ -64,7 +64,7 @@   ExpResult-    exp ExpId+    exp ExpId OnDeleteCascade     repetition Int     prepResultData                  PrepResultDataId Maybe @@ -79,39 +79,39 @@     endInputState                   ByteString Maybe  PrepStartStatePart             -- need to split big states into pieces-    resultData PrepResultDataId+    resultData PrepResultDataId OnDeleteCascade     number     Int     data       ByteString     UniquePrepStartStatePart resultData number  PrepEndStatePart-    resultData PrepResultDataId+    resultData PrepResultDataId OnDeleteCascade     number     Int     data       ByteString     UniquePrepEndStatePart resultData number  PrepInput-    prepResultData PrepResultDataId+    prepResultData PrepResultDataId OnDeleteCascade     period Int     UniquePrepInput prepResultData period  PrepInputValue-    prepInput PrepInputId+    prepInput PrepInputId OnDeleteCascade     value ByteString  PrepMeasure-    prepResultData PrepResultDataId+    prepResultData PrepResultDataId OnDeleteCascade     period Int     UniquePrepMeasure prepResultData period  PrepResultStep-    measure PrepMeasureId+    measure PrepMeasureId OnDeleteCascade     name Text     xValue  Double Maybe     yValue  Double  RepResult-    expResult ExpResultId+    expResult ExpResultId OnDeleteCascade     repNr Int     warmUpResultData WarmUpResultDataId Maybe     repResultData RepResultDataId Maybe@@ -128,13 +128,13 @@     endInputState                   ByteString Maybe  WarmUpStartStatePart             -- need to split big states into pieces-    resultData WarmUpResultDataId+    resultData WarmUpResultDataId OnDeleteCascade     number     Int     data       ByteString     UniqueWarmUpStartStatePart resultData number  WarmUpEndStatePart-    resultData WarmUpResultDataId+    resultData WarmUpResultDataId OnDeleteCascade     number     Int     data       ByteString     UniqueWarmUpEndStatePart resultData number@@ -151,54 +151,54 @@   RepStartStatePart             -- need to split big states into pieces-    resultData RepResultDataId+    resultData RepResultDataId OnDeleteCascade     number     Int     data       ByteString     UniqueRepStartStatePart resultData number  RepEndStatePart-    resultData RepResultDataId+    resultData RepResultDataId OnDeleteCascade     number     Int     data       ByteString     UniqueRepEndStatePart resultData number   WarmUpInput-    repResult WarmUpResultDataId+    repResult WarmUpResultDataId OnDeleteCascade     period Int     UniqueWarmUpInput repResult period  WarmUpInputValue-    warmUpInput WarmUpInputId+    warmUpInput WarmUpInputId OnDeleteCascade     value ByteString  WarmUpMeasure-    repResult WarmUpResultDataId+    repResult WarmUpResultDataId OnDeleteCascade     period Int     UniqueWarmUpMeasure repResult period  WarmUpResultStep-    measure WarmUpMeasureId+    measure WarmUpMeasureId OnDeleteCascade     name Text     xValue  Double Maybe     yValue  Double  RepInput-    repResult RepResultDataId+    repResult RepResultDataId OnDeleteCascade     period Int     UniqueRepInput repResult period  RepInputValue-    repInput RepInputId+    repInput RepInputId OnDeleteCascade     value ByteString  RepMeasure-    repResult RepResultDataId+    repResult RepResultDataId OnDeleteCascade     period Int     UniqueRepMeasure repResult period  RepResultStep-    measure RepMeasureId+    measure RepMeasureId OnDeleteCascade     name Text     xValue  Double Maybe     yValue  Double

@@ -1,21 +1,21 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: 74babbc2a0932968985e7a2b1535fb195c4303a3485ec96ba414c071efdc6f9e+-- hash: 09483e763a09034ab405201665dd8f5879d6938c3109181575ec01111ea2b2bd  name:           experimenter-version:        0.1.0.12+version:        0.1.0.14 synopsis:       Perform scientific experiments stored in a DB, and generate reports. description:    Please see the README on GitHub at <https://github.com/schnecki/experimenter#readme> category:       Experiment homepage:       https://github.com/schnecki/experimenter#readme bug-reports:    https://github.com/schnecki/experimenter/issues author:         Manuel Schneckenreither-maintainer:     manuel.schneckenreither@uibk.ac.at-copyright:      2021 Manuel Schneckenreither+maintainer:     manuel.schneckenreither@student.uibk.ac.at+copyright:      2022 Manuel Schneckenreither license:        BSD3 license-file:   LICENSE build-type:     Simple@@ -52,6 +52,7 @@       Experimenter.Eval.Util       Experimenter.Experiment       Experimenter.Input+      Experimenter.Load       Experimenter.MasterSlave       Experimenter.Measure       Experimenter.Models

@@ -6,6 +6,7 @@ import           Experimenter.Eval         as E import           Experimenter.Experiment   as E import           Experimenter.Input        as E+import           Experimenter.Load         as E import           Experimenter.Measure      as E import           Experimenter.Models       as E import           Experimenter.Parameter    as E

@@ -34,8 +34,8 @@ import           Text.LaTeX.Packages.TabularX  import           Experimenter.Availability-import           Experimenter.DatabaseSetting import           Experimenter.DB+import           Experimenter.DatabaseSetting import           Experimenter.Eval.Table import           Experimenter.Eval.Type import           Experimenter.Eval.Util@@ -84,7 +84,7 @@   documentclass [] article   user <- liftIO getLoginName   author ("Username: " <> fromString user)-  title $ "Evaluation for ``" <> raw n <> "''"+  title $ "Evaluation for ``" <> raw (dereferLatex n) <> "''"   usepackage [utf8] inputenc   usepackage [] "fullpage"   usepackage [] "array"@@ -189,7 +189,7 @@  printTableWithName :: (MonadLogger m) => (StatsDef a, Table) -> LaTeXT m () printTableWithName (nm, tbl) = do-  paragraph (raw $ prettyStatsDef nm)+  paragraph (raw $ dereferLatex $ prettyStatsDef nm)   printTable tbl  @@ -298,7 +298,7 @@                     [ CellT n                     , CellL $ raw (dereferLatex $ tshow val) <>                       (case mBounds of-                         Nothing -> ""+                         Nothing               -> ""                          Just (minVal, maxVal) -> math (text " " `in_` autoParens (text (raw (dereferLatex $ tshow minVal)) <> ", " <> text (raw (dereferLatex $ tshow maxVal))))) <>                       (if drp                          then " [SkipPrepPhase]"

@@ -46,7 +46,10 @@   fromString = CellT . T.pack  dereferLatex :: T.Text -> T.Text-dereferLatex = protectText . T.replace "{" "\\{" . T.replace "}" "\\}" . T.replace "_" "\\_"+dereferLatex x = protectText $ foldl' (\x' (f, t) -> T.replace f t x') x list+  where+    list :: [(T.Text, T.Text)]+    list = [("{", "\\{"), ("}", "\\}"), ("_", "\\_"), ("_", "\\_"), ("%", "\\%"), ("^", "\\^"), ("~", "\\~"), ("$", "\\$")]  printTextwidthTable :: (MonadLogger m) => Table -> LaTeXT m () printTextwidthTable = printTableTabularX True@@ -64,7 +67,7 @@       where         content = hline <> printRow textbf header <> hline <> mconcat (map (printRow id) rows) <> hline         printRow :: (LaTeXC l) => (l -> l) -> Row -> l-        printRow _ (Row []) = mempty+        printRow _ (Row [])     = mempty         printRow f (Row (c:cs)) = foldl' (&) (f $ printCell c) (map (f . printCell) cs) <> lnbk         printCell :: (LaTeXC l) => Cell -> l         printCell (CellT txt) = raw (dereferLatex txt)

@@ -10,8 +10,8 @@  import           Control.DeepSeq import           Control.Monad.IO.Unlift-import           Data.Serialize          (Serialize) import           Data.Kind+import           Data.Serialize          (Serialize) import           System.Random.MWC  import           Experimenter.Parameter@@ -81,6 +81,10 @@   deserialisable = return    -- HOOKS++  -- | Function to call before starting the experiment, but after setting the parameters. E.g. one could recereate an ANN, if the structure may have changed with a parameter.+  beforeExperimentStartHook :: ExperimentNumber -> a -> ExpM a a+  beforeExperimentStartHook _ = return    -- | Function to call on the state before the preparation. This function is only executed if the preparation phase   -- exists (that is >0 preparation steps) and is started from period 0!

@@ -0,0 +1,163 @@+{-# 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 filtFin runExpM dbSetup setup initInpSt mkInitSt key =+  runExpM $ runDB dbSetup $ do+    initSt <- lift $ lift $ lift mkInitSt+    let sett = setup initSt+        skipPrep exp' = any (^. parameterSettingSkipPreparationPhase) (exp' ^. parameterSetup)+        isFinished exp' =+          length (exp' ^. experimentResults) == sett ^. experimentRepetitions && -- repetitions+          (skipPrep exp' || all (\expRes -> maybe 0 (lengthAvailabilityList . view results) (expRes ^. preparationResults) == sett ^. preparationSteps) (exp' ^. experimentResults)) && -- preparation length+          all (\expRes -> length (expRes ^. evaluationResults) == sett ^. evaluationReplications) (exp' ^. experimentResults) && -- replications+          all+            (\expRes -> maybe 0 (lengthAvailabilityList . view results) (expRes ^. warmUpResults) == sett ^. evaluationWarmUpSteps)+            (exp' ^. experimentResults . traversed . evaluationResults) && -- warm up length+          all+            (\expRes -> maybe 0 (lengthAvailabilityList . view results) (expRes ^. evalResults) == sett ^. evaluationSteps)+            (exp' ^. experimentResults . traversed . evaluationResults) -- eval length+        filterFinished =+          over+            experiments+            (if filtFin+               then filter isFinished+               else id)+    fmap filterFinished <$> loadExperimentsResults sett initInpSt initSt (toSqlKey key)+++readValueSafe :: (Read a) => IO (Maybe a)+readValueSafe = do+  liftIO $ putStr "Enter value: " >> hFlush stdout+  readMaybe <$> getLine+++readListValueSafeName :: [(a, T.Text)] -> IO (Maybe a)+readListValueSafeName xs = do+  mapM_ (\(nr, (_, n)) -> putStrLn $ show nr <> ":\t " <> T.unpack n) $ zip [(0 :: Int) ..] xs+  mNr <- readValueSafe+  return $+    case mNr of+      Just nr+        | nr >= 0 && nr < length xs -> Just $ fst $ xs !! nr+      _ -> Nothing+++-- | Convert a 'Maybe' computation to 'MaybeT'.+hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b+hoistMaybe = MaybeT . pure+++loadExperimentPrepEndStateIO :: (ExpM a ~ IO, ExperimentDef a) => DatabaseSetting -> IO (Maybe a)+loadExperimentPrepEndStateIO = loadExperimentPrepEndState id+++loadExperimentPrepEndState ::+     forall a. (ExperimentDef a)+  => (ExpM a (Maybe a) -> IO (Maybe a))+  -> DatabaseSetting+  -> IO (Maybe a)+loadExperimentPrepEndState runExpM dbSetup =+  runExpM $+  runDB dbSetup $+  runMaybeT $ do+    liftIO $ putStrLn "From which experiment do you want to load the data? "+    exps <- lift $ selectList [] []+    let expsNames :: [(Key Exps, T.Text)]+        expsNames = map (entityKey &&& (^. expsName) . entityVal) exps+    (expsKey :: Key Exps) <- MaybeT $ liftIO $ readListValueSafeName expsNames+    exp <- lift $ selectList [ExpExps ==. expsKey] []+    (expKey :: Key Exp) <-+      if length exp == 1+        then return $ entityKey $ head exp+        else do+          liftIO $ putStrLn "Which experiment number?"+          let expNrs = sortOnSnd $ map (entityKey &&& tshow . (^. expNumber) . entityVal) exp+          MaybeT $ liftIO $ readListValueSafeName expNrs+    reps <- lift $ selectList [ExpResultExp ==. expKey] []+    liftIO $ putStrLn "And from which experiment repetition?"++    let+      repNames :: [(Key PrepResultData, T.Text)]+      repNames = sortOnSnd $ map (first fromJust) $ filter (isJust . fst) $ map ((^. expResultPrepResultData) . entityVal &&& tshow . (^. expResultRepetition) . entityVal) reps+    rep <- MaybeT $ liftIO $ readListValueSafeName repNames+    let endStateType = EndStatePrep rep+    ma <- lift (loadResDataEndState expKey endStateType :: DB (ExpM a) (Maybe a))+    hoistMaybe ma+  where sortOnSnd = L.sortBy (compare `on` snd)

@@ -24,5 +24,6 @@ import           Database.Persist.TH  -share [mkPersist sqlSettings {mpsGenerateLenses = True}, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"]+share [mkPersist sqlSettings {mpsGenerateLenses = True}, -- mkDeleteCascade sqlSettings,+       mkMigrate "migrateAll"]   $(persistFileWith lowerCaseSettings "config/models")

@@ -19,30 +19,28 @@     , runExperiments     , runExperimentsM     , runExperimentsIO-    , loadExperimentsResultsM-    , loadStateAfterPreparation-    , loadStateAfterPreparation2+    -- , loadStateAfterPreparation+    -- , loadStateAfterPreparation2     ) where -import           Control.Arrow                (first, (&&&), (***))-import           Control.Arrow                (second)+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.Logger         (filterLogger, logDebug, logError, logInfo, runStdoutLoggingT) import           Control.Monad.Reader import qualified Data.ByteString              as B import           Data.Function                (on)-import           Data.Int                     (Int64) 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@@ -52,12 +50,13 @@ 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.DatabaseSetting import           Experimenter.DB+import           Experimenter.DatabaseSetting import           Experimenter.Experiment import           Experimenter.Input import           Experimenter.MasterSlave@@ -99,86 +98,67 @@     runStdoutLoggingT $ withPostgresqlPool (connectionString dbSetup) (parallelConnections dbSetup) $ liftSqlPersistMPool $ runMigration migrateAll >> indexCreation     runExpM $       runDB dbSetup $ do+        -- liftIO $ putStrLn "Running maintainance command: VACUUM"+        -- rawExecute "VACUUM" []+        liftIO $ vacuum dbSetup         initSt <- lift $ lift $ lift mkInitSt         $(logInfo) "Created initial state and will now check the DB for loading or creating experiments"         let expSetting = setup initSt         loadExperiments expSetting initInpSt initSt >>= checkUniqueParamNames >>= runExperimenter dbSetup expSetting initInpSt 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 bs _) = do+  let baseTxt = foldl' (\ts (from, to) -> map (T.strip . T.replace from to) ts) (T.splitOn " " $ E.decodeUtf8 bs) [("dbname=", "--dbname="), ("host=", "--host="), ("port=", "--port="), ("user=", "--username=")]+      txts = filter (not . T.isInfixOf "password=") baseTxt ++ ["-w"] -- Do *not* use full! ["-f" | full]+  runStdoutLoggingT $ $(logInfo) $ "Running: vacuumdb " <> T.intercalate " " txts+  callProcess "vacuumdb" (map T.unpack txts) -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)+  -- 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" -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 -type OnlyFinishedExperiments = Bool+-- 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) -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 filtFin runExpM dbSetup setup initInpSt mkInitSt key =-  runExpM $ runDB dbSetup $ do-    initSt <- lift $ lift $ lift mkInitSt-    let sett = setup initSt-        skipPrep exp' = any (^. parameterSettingSkipPreparationPhase) (exp' ^. parameterSetup)-        isFinished exp' =-          length (exp' ^. experimentResults) == sett ^. experimentRepetitions && -- repetitions-          (skipPrep exp' || all (\expRes -> maybe 0 (lengthAvailabilityList . view results) (expRes ^. preparationResults) == sett ^. preparationSteps) (exp' ^. experimentResults)) && -- preparation length-          all (\expRes -> length (expRes ^. evaluationResults) == sett ^. evaluationReplications) (exp' ^. experimentResults) && -- replications-          all-            (\expRes -> maybe 0 (lengthAvailabilityList . view results) (expRes ^. warmUpResults) == sett ^. evaluationWarmUpSteps)-            (exp' ^. experimentResults . traversed . evaluationResults) && -- warm up length-          all-            (\expRes -> maybe 0 (lengthAvailabilityList . view results) (expRes ^. evalResults) == sett ^. evaluationSteps)-            (exp' ^. experimentResults . traversed . evaluationResults) -- eval length-        filterFinished =-          over-            experiments-            (if filtFin-               then filter isFinished-               else id)-    fmap filterFinished <$> loadExperimentsResults sett initInpSt initSt (toSqlKey key) +-- 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 exps = do   let paramNames = map parameterName (view experimentsParameters exps)@@ -376,11 +356,11 @@         _       -> [ParameterSetting n vBs drp (toEnum dsgn)]  -- deleteExperiment :: (MonadIO m) => Experiment a -> DB m ()--- deleteExperiment (Experiment k _ _ _ _ expRes) = mapM_ deleteExperimentResult expRes >> deleteCascade k+-- deleteExperiment (Experiment k _ _ _ _ expRes) = mapM_ deleteExperimentResult expRes >> delete k   deleteExperimentResult :: (MonadIO m) => ExperimentResult a -> DB m ()-deleteExperimentResult (ExperimentResult k _ _ repls) = mapM_ deleteReplicationResult repls >> deleteCascade k+deleteExperimentResult (ExperimentResult k _ _ repls) = mapM_ deleteReplicationResult repls >> delete k   -- | Loads parameters of an experiment into all initial and end states of the given experiments variable.@@ -434,6 +414,7 @@           eTime <- return <$> liftIO getCurrentTime           update (exp ^. experimentKey) [ExpEndTime =. eTime]           delete lock+          liftIO $ vacuum dbSetup           return (updated, set experimentResults res $ set experimentEndTime eTime exp)         else delete lock >> return (updated, set experimentResults res exp)   where@@ -528,6 +509,7 @@   -> ExperimentResult a   -> DB (ExpM a) (Updated, ExperimentResult a) runExperimentResult skipPrep rands@(prepRands, _, _) exps expId expNr expRes = do+  expInitSt <- lift $ lift $ lift $ beforeExperimentStartHook expNr (exps ^. experimentsInitialState)   let repetNr = expRes ^. repetitionNumber   let prepSeed = prepRands !! (repetNr - 1)   (prepInitSt, delPrep) <-@@ -557,7 +539,6 @@       res = map snd repRes   return (prepUpdated || updated, set preparationResults prepRes $ set evaluationResults res expRes)   where-    expInitSt = exps ^. experimentsInitialState     expResId = expRes ^. experimentResultKey     deleteTruncatedRepRes :: (MonadIO m) => Experiments a -> [ReplicationResult a] -> DB m [ReplicationResult a]     deleteTruncatedRepRes exps' xs@@ -731,7 +712,7 @@ deleteReplicationResult (ReplicationResult repResId _ _ _) =   deleteResultData (WarmUp repResId) >>   deleteResultData (Rep repResId) >>-  deleteCascade repResId+  delete repResId   deleteResultData :: (MonadIO m) => RepResultType -> DB m ()@@ -740,15 +721,15 @@     Prep expResId -> do       update expResId [ExpResultPrepResultData =. Nothing]       exp <- get expResId-      sequence_ $ deleteCascade <$> (view expResultPrepResultData =<< exp)+      sequence_ $ delete <$> (view expResultPrepResultData =<< exp)     WarmUp repResId -> do       update repResId [RepResultWarmUpResultData =. Nothing]       repRes <- get repResId-      sequence_ $ deleteCascade <$> (view repResultWarmUpResultData =<< repRes)+      sequence_ $ delete <$> (view repResultWarmUpResultData =<< repRes)     Rep repResId -> do       update repResId [RepResultRepResultData =. Nothing]       repRes <- get repResId-      sequence_ $ deleteCascade <$> (view repResultRepResultData =<< repRes)+      sequence_ $ delete <$> (view repResultRepResultData =<< repRes)  foldM' :: (NFData a, Monad m) => (a -> b -> m a) -> a -> [b] -> m a foldM' _ !acc [] = return acc@@ -852,14 +833,14 @@     isNew = curLen == 0     mkStartStateAvailableOnDemand =       case resData ^. resultDataKey of-        ResultDataPrep key -> AvailableOnDemand $ loadResDataStartState expId (StartStatePrep key)+        ResultDataPrep key   -> AvailableOnDemand $ loadResDataStartState expId (StartStatePrep key)         ResultDataWarmUp key -> AvailableOnDemand $ loadResDataStartState expId (StartStateWarmUp key)-        ResultDataRep key -> AvailableOnDemand $ loadResDataStartState expId (StartStateRep key)+        ResultDataRep key    -> AvailableOnDemand $ loadResDataStartState expId (StartStateRep key)     mkEndStateAvailableOnDemand =       case resData ^. resultDataKey of-        ResultDataPrep key -> AvailableOnDemand $ loadResDataEndState expId (EndStatePrep key)+        ResultDataPrep key   -> AvailableOnDemand $ loadResDataEndState expId (EndStatePrep key)         ResultDataWarmUp key -> AvailableOnDemand $ loadResDataEndState expId (EndStateWarmUp key)-        ResultDataRep key -> AvailableOnDemand $ loadResDataEndState expId (EndStateRep key)+        ResultDataRep key    -> AvailableOnDemand $ loadResDataEndState expId (EndStateRep key)     addInputValsAndMeasure !inputVals !measures !resData' =       let countResults' = lengthAvailabilityList (resData' ^. results) + V.length measures           countInputValues' = lengthAvailabilityList (resData' ^. inputValues) + V.length inputVals@@ -867,7 +848,7 @@           inputValsList = V.toList inputVals        in case resData' ^. resultDataKey of             ResultDataPrep key -> do-              when delInputs $ deleteCascadeWhere [PrepInputPrepResultData ==. key, PrepInputPeriod >=. curLen + 1]+              when delInputs $ deleteWhere [PrepInputPrepResultData ==. key, PrepInputPeriod >=. curLen + 1]               inpKeys <- insertMany $ map (PrepInput key . view inputValuePeriod) inputValsList               insertMany_ $ zipWith (\k v -> PrepInputValue k (runPut . put . view inputValue $ v)) inpKeys inputValsList               measureKeys <- insertMany . map (PrepMeasure key . view measurePeriod) $ measuresList@@ -876,7 +857,7 @@                 AvailableListOnDemand (countInputValues', loadPreparationInputWhere key) $                 resData'             ResultDataWarmUp key -> do-              when delInputs $ deleteCascadeWhere [WarmUpInputRepResult ==. key, WarmUpInputPeriod >=. curLen + 1]+              when delInputs $ deleteWhere [WarmUpInputRepResult ==. key, WarmUpInputPeriod >=. curLen + 1]               inpKeys <- insertMany $ map (WarmUpInput key . view inputValuePeriod) inputValsList               insertMany_ $ zipWith (\k v -> WarmUpInputValue k (runPut . put . view inputValue $ v)) inpKeys inputValsList               measureKeys <- insertMany $ map (WarmUpMeasure key . view measurePeriod) measuresList@@ -885,7 +866,7 @@                 AvailableListOnDemand (countInputValues', loadReplicationWarmUpInputWhere key) $                 resData'             ResultDataRep key -> do-              when delInputs $ deleteCascadeWhere [RepInputRepResult ==. key, RepInputPeriod >=. curLen + 1]+              when delInputs $ deleteWhere [RepInputRepResult ==. key, RepInputPeriod >=. curLen + 1]               inpKeys <- insertMany $ map (RepInput key . view inputValuePeriod) inputValsList               insertMany_ $ zipWith (\k v -> RepInputValue k (runPut . put . view inputValue $ v)) inpKeys inputValsList               measureKeys <- insertMany $ map (RepMeasure key . view measurePeriod) measuresList